-- |
-- Module      :  Cryptol.ModuleSystem.Renamer
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# Language DeriveGeneric, DeriveAnyClass #-}
{-# Language OverloadedStrings #-}
module Cryptol.ModuleSystem.Renamer.Error where

import Cryptol.ModuleSystem.Name
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.Selector(ppNestedSels)
import Cryptol.Utils.PP

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat

-- Errors ----------------------------------------------------------------------

data RenamerError
  = MultipleSyms (Located PName) [Name]
    -- ^ Multiple imported symbols contain this name

  | UnboundName Namespace (Located PName)
    -- ^ Some name not bound to any definition

  | OverlappingSyms [Name]
    -- ^ An environment has produced multiple overlapping symbols

  | WrongNamespace Namespace Namespace (Located PName)
    -- ^ expected, actual.
    -- When a name is missing from the expected namespace, but exists in another

  | FixityError (Located Name) Fixity (Located Name) Fixity
    -- ^ When the fixity of two operators conflict

  | InvalidConstraint (Type PName)
    -- ^ When it's not possible to produce a Prop from a Type.

  | MalformedBuiltin (Type PName) PName
    -- ^ When a builtin type/type-function is used incorrectly.

  | BoundReservedType PName (Maybe Range) Doc
    -- ^ When a builtin type is named in a binder.

  | OverlappingRecordUpdate (Located [Selector]) (Located [Selector])
    -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@)

  | InvalidDependency [DepName]
    deriving (Int -> RenamerError -> ShowS
[RenamerError] -> ShowS
RenamerError -> String
(Int -> RenamerError -> ShowS)
-> (RenamerError -> String)
-> ([RenamerError] -> ShowS)
-> Show RenamerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenamerError] -> ShowS
$cshowList :: [RenamerError] -> ShowS
show :: RenamerError -> String
$cshow :: RenamerError -> String
showsPrec :: Int -> RenamerError -> ShowS
$cshowsPrec :: Int -> RenamerError -> ShowS
Show, (forall x. RenamerError -> Rep RenamerError x)
-> (forall x. Rep RenamerError x -> RenamerError)
-> Generic RenamerError
forall x. Rep RenamerError x -> RenamerError
forall x. RenamerError -> Rep RenamerError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RenamerError x -> RenamerError
$cfrom :: forall x. RenamerError -> Rep RenamerError x
Generic, RenamerError -> ()
(RenamerError -> ()) -> NFData RenamerError
forall a. (a -> ()) -> NFData a
rnf :: RenamerError -> ()
$crnf :: RenamerError -> ()
NFData)


-- We use this because parameter constrstaints have no names
data DepName = NamedThing Name
             | ConstratintAt Range -- ^ identifed by location in source
               deriving (DepName -> DepName -> Bool
(DepName -> DepName -> Bool)
-> (DepName -> DepName -> Bool) -> Eq DepName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DepName -> DepName -> Bool
$c/= :: DepName -> DepName -> Bool
== :: DepName -> DepName -> Bool
$c== :: DepName -> DepName -> Bool
Eq,Eq DepName
Eq DepName
-> (DepName -> DepName -> Ordering)
-> (DepName -> DepName -> Bool)
-> (DepName -> DepName -> Bool)
-> (DepName -> DepName -> Bool)
-> (DepName -> DepName -> Bool)
-> (DepName -> DepName -> DepName)
-> (DepName -> DepName -> DepName)
-> Ord DepName
DepName -> DepName -> Bool
DepName -> DepName -> Ordering
DepName -> DepName -> DepName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DepName -> DepName -> DepName
$cmin :: DepName -> DepName -> DepName
max :: DepName -> DepName -> DepName
$cmax :: DepName -> DepName -> DepName
>= :: DepName -> DepName -> Bool
$c>= :: DepName -> DepName -> Bool
> :: DepName -> DepName -> Bool
$c> :: DepName -> DepName -> Bool
<= :: DepName -> DepName -> Bool
$c<= :: DepName -> DepName -> Bool
< :: DepName -> DepName -> Bool
$c< :: DepName -> DepName -> Bool
compare :: DepName -> DepName -> Ordering
$ccompare :: DepName -> DepName -> Ordering
$cp1Ord :: Eq DepName
Ord,Int -> DepName -> ShowS
[DepName] -> ShowS
DepName -> String
(Int -> DepName -> ShowS)
-> (DepName -> String) -> ([DepName] -> ShowS) -> Show DepName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DepName] -> ShowS
$cshowList :: [DepName] -> ShowS
show :: DepName -> String
$cshow :: DepName -> String
showsPrec :: Int -> DepName -> ShowS
$cshowsPrec :: Int -> DepName -> ShowS
Show,(forall x. DepName -> Rep DepName x)
-> (forall x. Rep DepName x -> DepName) -> Generic DepName
forall x. Rep DepName x -> DepName
forall x. DepName -> Rep DepName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DepName x -> DepName
$cfrom :: forall x. DepName -> Rep DepName x
Generic,DepName -> ()
(DepName -> ()) -> NFData DepName
forall a. (a -> ()) -> NFData a
rnf :: DepName -> ()
$crnf :: DepName -> ()
NFData)

depNameLoc :: DepName -> Range
depNameLoc :: DepName -> Range
depNameLoc DepName
x =
  case DepName
x of
    NamedThing Name
n -> Name -> Range
nameLoc Name
n
    ConstratintAt Range
r -> Range
r
  


instance PP RenamerError where
  ppPrec :: Int -> RenamerError -> Doc
ppPrec Int
_ RenamerError
e = case RenamerError
e of

    MultipleSyms Located PName
lqn [Name]
qns ->
      Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
lqn))
         Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc
text String
"Multiple definitions for symbol:" Doc -> Doc -> Doc
<+> PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
forall a. Located a -> a
thing Located PName
lqn))
          Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
ppLocName [Name]
qns)

    UnboundName Namespace
ns Located PName
lqn ->
      Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
lqn))
         Int
4 (Doc
something Doc -> Doc -> Doc
<+> Doc
"not in scope:" Doc -> Doc -> Doc
<+> PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
forall a. Located a -> a
thing Located PName
lqn))
      where
      something :: Doc
something = case Namespace
ns of
                    Namespace
NSValue   -> Doc
"Value"
                    Namespace
NSType    -> Doc
"Type"
                    Namespace
NSModule  -> Doc
"Module"

    OverlappingSyms [Name]
qns ->
      Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[error]")
         Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Overlapping symbols defined:"
          Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
ppLocName [Name]
qns)

    WrongNamespace Namespace
expected Namespace
actual Located PName
lqn ->
      Doc -> Int -> Doc -> Doc
hang (Doc
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
lqn ))
         Int
4 ([Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
            [ Doc
"Expected a", Namespace -> Doc
forall p. IsString p => Namespace -> p
sayNS Namespace
expected, Doc
"named", Doc -> Doc
quotes (PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
forall a. Located a -> a
thing Located PName
lqn))
            , Doc
"but found a", Namespace -> Doc
forall p. IsString p => Namespace -> p
sayNS Namespace
actual, Doc
"instead"
            ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
suggestion)
        where
        sayNS :: Namespace -> p
sayNS Namespace
ns = case Namespace
ns of
                     Namespace
NSValue  -> p
"value"
                     Namespace
NSType   -> p
"type"
                     Namespace
NSModule -> p
"module"
        suggestion :: [Doc]
suggestion =
          case (Namespace
expected,Namespace
actual) of

            (Namespace
NSValue,Namespace
NSType) ->
                [Doc
"Did you mean `(" Doc -> Doc -> Doc
<.> PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
forall a. Located a -> a
thing Located PName
lqn) Doc -> Doc -> Doc
<.> String -> Doc
textString
")?"]
            (Namespace, Namespace)
_ -> []

    FixityError Located Name
o1 Fixity
f1 Located Name
o2 Fixity
f2 ->
      Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located Name -> Range
forall a. Located a -> Range
srcRange Located Name
o1) Doc -> Doc -> Doc
<+> String -> Doc
text String
"and" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located Name -> Range
forall a. Located a -> Range
srcRange Located Name
o2))
         Int
4 ([Doc] -> Doc
vsep [ String -> Doc
text String
"The fixities of"
                 , Int -> Doc -> Doc
indent Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
                   [ Doc
"•" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp (Located Name -> Name
forall a. Located a -> a
thing Located Name
o1) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Fixity -> Doc
forall a. PP a => a -> Doc
pp Fixity
f1)
                   , Doc
"•" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp (Located Name -> Name
forall a. Located a -> a
thing Located Name
o2) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Fixity -> Doc
forall a. PP a => a -> Doc
pp Fixity
f2) ]
                 , String -> Doc
text String
"are not compatible."
                 , String -> Doc
text String
"You may use explicit parentheses to disambiguate." ])

    InvalidConstraint Type PName
ty ->
      Doc -> Int -> Doc -> Doc
hang ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [String -> Doc
text String
"[error]"] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc] -> (Range -> [Doc]) -> Maybe Range -> [Doc]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Range
r -> [String -> Doc
text String
"at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r]) (Type PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Type PName
ty))
         Int
4 ([Doc] -> Doc
fsep [ Type PName -> Doc
forall a. PP a => a -> Doc
pp Type PName
ty, String -> Doc
text String
"is not a valid constraint" ])

    MalformedBuiltin Type PName
ty PName
pn ->
      Doc -> Int -> Doc -> Doc
hang ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [String -> Doc
text String
"[error]"] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc] -> (Range -> [Doc]) -> Maybe Range -> [Doc]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Range
r -> [String -> Doc
text String
"at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r]) (Type PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Type PName
ty))
         Int
4 ([Doc] -> Doc
fsep [ String -> Doc
text String
"invalid use of built-in type", PName -> Doc
forall a. PP a => a -> Doc
pp PName
pn
                 , String -> Doc
text String
"in type", Type PName -> Doc
forall a. PP a => a -> Doc
pp Type PName
ty ])

    BoundReservedType PName
n Maybe Range
loc Doc
src ->
      Doc -> Int -> Doc -> Doc
hang ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [String -> Doc
text String
"[error]"] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc] -> (Range -> [Doc]) -> Maybe Range -> [Doc]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Range
r -> [String -> Doc
text String
"at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r]) Maybe Range
loc)
         Int
4 ([Doc] -> Doc
fsep [ String -> Doc
text String
"built-in type", Doc -> Doc
quotes (PName -> Doc
forall a. PP a => a -> Doc
pp PName
n), String -> Doc
text String
"shadowed in", Doc
src ])

    OverlappingRecordUpdate Located [Selector]
xs Located [Selector]
ys ->
      Doc -> Int -> Doc -> Doc
hang Doc
"[error] Overlapping record updates:"
         Int
4 ([Doc] -> Doc
vcat [ Located [Selector] -> Doc
ppLab Located [Selector]
xs, Located [Selector] -> Doc
ppLab Located [Selector]
ys ])
      where
      ppLab :: Located [Selector] -> Doc
ppLab Located [Selector]
as = [Selector] -> Doc
ppNestedSels (Located [Selector] -> [Selector]
forall a. Located a -> a
thing Located [Selector]
as) Doc -> Doc -> Doc
<+> Doc
"at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located [Selector] -> Range
forall a. Located a -> Range
srcRange Located [Selector]
as)

    InvalidDependency [DepName]
ds ->
      Doc -> Int -> Doc -> Doc
hang Doc
"[error] Invalid recursive dependency:"
         Int
4 ([Doc] -> Doc
vcat [ Doc
"•" Doc -> Doc -> Doc
<+> DepName -> Doc
forall a. PP a => a -> Doc
pp DepName
x Doc -> Doc -> Doc
<.> Doc
", defined at" Doc -> Doc -> Doc
<+> Range -> Doc
ppR (DepName -> Range
depNameLoc DepName
x)
                 | DepName
x <- [DepName]
ds ])
      where ppR :: Range -> Doc
ppR Range
r = Position -> Doc
forall a. PP a => a -> Doc
pp (Range -> Position
from Range
r) Doc -> Doc -> Doc
<.> Doc
"--" Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp (Range -> Position
to Range
r)

instance PP DepName where
  ppPrec :: Int -> DepName -> Doc
ppPrec Int
_ DepName
d =
    case DepName
d of
      ConstratintAt Range
r -> Doc
"constraint at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r
      NamedThing Name
n ->
        case Name -> Namespace
nameNamespace Name
n of
          Namespace
NSModule -> Doc
"submodule" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp Name
n
          Namespace
NSType   -> Doc
"type" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp Name
n
          Namespace
NSValue  -> Name -> Doc
forall a. PP a => a -> Doc
pp Name
n



-- Warnings --------------------------------------------------------------------

data RenamerWarning
  = SymbolShadowed PName Name [Name]
  | UnusedName Name
    deriving (Int -> RenamerWarning -> ShowS
[RenamerWarning] -> ShowS
RenamerWarning -> String
(Int -> RenamerWarning -> ShowS)
-> (RenamerWarning -> String)
-> ([RenamerWarning] -> ShowS)
-> Show RenamerWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenamerWarning] -> ShowS
$cshowList :: [RenamerWarning] -> ShowS
show :: RenamerWarning -> String
$cshow :: RenamerWarning -> String
showsPrec :: Int -> RenamerWarning -> ShowS
$cshowsPrec :: Int -> RenamerWarning -> ShowS
Show, (forall x. RenamerWarning -> Rep RenamerWarning x)
-> (forall x. Rep RenamerWarning x -> RenamerWarning)
-> Generic RenamerWarning
forall x. Rep RenamerWarning x -> RenamerWarning
forall x. RenamerWarning -> Rep RenamerWarning x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RenamerWarning x -> RenamerWarning
$cfrom :: forall x. RenamerWarning -> Rep RenamerWarning x
Generic, RenamerWarning -> ()
(RenamerWarning -> ()) -> NFData RenamerWarning
forall a. (a -> ()) -> NFData a
rnf :: RenamerWarning -> ()
$crnf :: RenamerWarning -> ()
NFData)

instance Eq RenamerWarning where
  RenamerWarning
x == :: RenamerWarning -> RenamerWarning -> Bool
== RenamerWarning
y = RenamerWarning -> RenamerWarning -> Ordering
forall a. Ord a => a -> a -> Ordering
compare RenamerWarning
x RenamerWarning
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- used to determine in what order ot show things
instance Ord RenamerWarning where
  compare :: RenamerWarning -> RenamerWarning -> Ordering
compare RenamerWarning
w1 RenamerWarning
w2 =
    case RenamerWarning
w1 of
      SymbolShadowed PName
x Name
y [Name]
_ ->
        case RenamerWarning
w2 of
          SymbolShadowed PName
x' Name
y' [Name]
_ -> (Position, PName) -> (Position, PName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Name -> Position
byStart Name
y,PName
x) (Name -> Position
byStart Name
y',PName
x')
          RenamerWarning
_                      -> Ordering
LT
      UnusedName Name
x ->
        case RenamerWarning
w2 of
          UnusedName Name
y -> Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Name -> Position
byStart Name
x) (Name -> Position
byStart Name
y)
          RenamerWarning
_            -> Ordering
GT

      where
      byStart :: Name -> Position
byStart = Range -> Position
from (Range -> Position) -> (Name -> Range) -> Name -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Range
nameLoc


instance PP RenamerWarning where
  ppPrec :: Int -> RenamerWarning -> Doc
ppPrec Int
_ (SymbolShadowed PName
k Name
x [Name]
os) =
    Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[warning] at" Doc -> Doc -> Doc
<+> Doc
loc)
       Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep [ Doc
"This binding for" Doc -> Doc -> Doc
<+> Doc -> Doc
backticks (PName -> Doc
forall a. PP a => a -> Doc
pp PName
k)
                , Doc
"shadows the existing binding" Doc -> Doc -> Doc
<.> Doc
plural
                , String -> Doc
text String
"at" ]
        Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Range -> Doc
forall a. PP a => a -> Doc
pp (Range -> Doc) -> (Name -> Range) -> Name -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Range
nameLoc) [Name]
os)

    where
    plural :: Doc
plural | [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Char -> Doc
char Char
's'
           | Bool
otherwise     = Doc
forall a. Monoid a => a
mempty

    loc :: Doc
loc = Range -> Doc
forall a. PP a => a -> Doc
pp (Name -> Range
nameLoc Name
x)

  ppPrec Int
_ (UnusedName Name
x) =
    Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[warning] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Name -> Range
nameLoc Name
x))
       Int
4 (String -> Doc
text String
"Unused name:" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp Name
x)