-- |
-- 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 Data.List(intersperse)

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

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

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

  | InvalidDependency [DepName]
    -- ^ Things that can't depend on each other

  | MultipleModParams Ident [Range]
    -- ^ Module parameters with the same name

  | InvalidFunctorImport (ImpName Name)
    -- ^ Can't import functors directly

  | UnexpectedNest Range PName
    -- ^ Nested modules were not supposed to appear here

  | ModuleKindMismatch Range (ImpName Name) ModKind ModKind
    -- ^ Exepcted one kind (first one) but found the other (second one)

    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
$cshowsPrec :: Int -> RenamerError -> ShowS
showsPrec :: Int -> RenamerError -> ShowS
$cshow :: RenamerError -> String
show :: RenamerError -> String
$cshowList :: [RenamerError] -> ShowS
showList :: [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
$cfrom :: forall x. RenamerError -> Rep RenamerError x
from :: forall x. RenamerError -> Rep RenamerError x
$cto :: forall x. Rep RenamerError x -> RenamerError
to :: forall x. Rep RenamerError x -> RenamerError
Generic, RenamerError -> ()
(RenamerError -> ()) -> NFData RenamerError
forall a. (a -> ()) -> NFData a
$crnf :: RenamerError -> ()
rnf :: RenamerError -> ()
NFData, RenamerError -> RenamerError -> Bool
(RenamerError -> RenamerError -> Bool)
-> (RenamerError -> RenamerError -> Bool) -> Eq RenamerError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RenamerError -> RenamerError -> Bool
== :: RenamerError -> RenamerError -> Bool
$c/= :: RenamerError -> RenamerError -> Bool
/= :: RenamerError -> RenamerError -> Bool
Eq, Eq RenamerError
Eq RenamerError =>
(RenamerError -> RenamerError -> Ordering)
-> (RenamerError -> RenamerError -> Bool)
-> (RenamerError -> RenamerError -> Bool)
-> (RenamerError -> RenamerError -> Bool)
-> (RenamerError -> RenamerError -> Bool)
-> (RenamerError -> RenamerError -> RenamerError)
-> (RenamerError -> RenamerError -> RenamerError)
-> Ord RenamerError
RenamerError -> RenamerError -> Bool
RenamerError -> RenamerError -> Ordering
RenamerError -> RenamerError -> RenamerError
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
$ccompare :: RenamerError -> RenamerError -> Ordering
compare :: RenamerError -> RenamerError -> Ordering
$c< :: RenamerError -> RenamerError -> Bool
< :: RenamerError -> RenamerError -> Bool
$c<= :: RenamerError -> RenamerError -> Bool
<= :: RenamerError -> RenamerError -> Bool
$c> :: RenamerError -> RenamerError -> Bool
> :: RenamerError -> RenamerError -> Bool
$c>= :: RenamerError -> RenamerError -> Bool
>= :: RenamerError -> RenamerError -> Bool
$cmax :: RenamerError -> RenamerError -> RenamerError
max :: RenamerError -> RenamerError -> RenamerError
$cmin :: RenamerError -> RenamerError -> RenamerError
min :: RenamerError -> RenamerError -> RenamerError
Ord)


{- | We use this to name dependencies.
In addition to normal names we have a way to refer to module parameters
and top-level module constraints, which have no explicit names -}
data DepName = NamedThing Name
               -- ^ Something with a name

             | ModPath ModPath
               -- ^ The module at this path

             | ModParamName Range Ident
               {- ^ Note that the range is important not just for error
                    reporting but to distinguish module parameters with
                    the same name (e.g., in nested functors) -}
             | 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
$c== :: DepName -> DepName -> Bool
== :: DepName -> DepName -> Bool
$c/= :: DepName -> DepName -> Bool
/= :: 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
$ccompare :: DepName -> DepName -> Ordering
compare :: DepName -> DepName -> Ordering
$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
>= :: DepName -> DepName -> Bool
$cmax :: DepName -> DepName -> DepName
max :: DepName -> DepName -> DepName
$cmin :: DepName -> DepName -> DepName
min :: DepName -> DepName -> 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
$cshowsPrec :: Int -> DepName -> ShowS
showsPrec :: Int -> DepName -> ShowS
$cshow :: DepName -> String
show :: DepName -> String
$cshowList :: [DepName] -> ShowS
showList :: [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
$cfrom :: forall x. DepName -> Rep DepName x
from :: forall x. DepName -> Rep DepName x
$cto :: forall x. Rep DepName x -> DepName
to :: forall x. Rep DepName x -> DepName
Generic,DepName -> ()
(DepName -> ()) -> NFData DepName
forall a. (a -> ()) -> NFData a
$crnf :: DepName -> ()
rnf :: DepName -> ()
NFData)

depNameLoc :: DepName -> Maybe Range
depNameLoc :: DepName -> Maybe Range
depNameLoc DepName
x =
  case DepName
x of
    NamedThing Name
n -> Range -> Maybe Range
forall a. a -> Maybe a
Just (Name -> Range
nameLoc Name
n)
    ConstratintAt Range
r -> Range -> Maybe Range
forall a. a -> Maybe a
Just Range
r
    ModParamName Range
r Ident
_ -> Range -> Maybe Range
forall a. a -> Maybe a
Just Range
r
    ModPath {} -> Maybe Range
forall a. Maybe a
Nothing


data ModKind = AFunctor | ASignature | AModule
    deriving (Int -> ModKind -> ShowS
[ModKind] -> ShowS
ModKind -> String
(Int -> ModKind -> ShowS)
-> (ModKind -> String) -> ([ModKind] -> ShowS) -> Show ModKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModKind -> ShowS
showsPrec :: Int -> ModKind -> ShowS
$cshow :: ModKind -> String
show :: ModKind -> String
$cshowList :: [ModKind] -> ShowS
showList :: [ModKind] -> ShowS
Show, (forall x. ModKind -> Rep ModKind x)
-> (forall x. Rep ModKind x -> ModKind) -> Generic ModKind
forall x. Rep ModKind x -> ModKind
forall x. ModKind -> Rep ModKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ModKind -> Rep ModKind x
from :: forall x. ModKind -> Rep ModKind x
$cto :: forall x. Rep ModKind x -> ModKind
to :: forall x. Rep ModKind x -> ModKind
Generic, ModKind -> ()
(ModKind -> ()) -> NFData ModKind
forall a. (a -> ()) -> NFData a
$crnf :: ModKind -> ()
rnf :: ModKind -> ()
NFData, ModKind -> ModKind -> Bool
(ModKind -> ModKind -> Bool)
-> (ModKind -> ModKind -> Bool) -> Eq ModKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModKind -> ModKind -> Bool
== :: ModKind -> ModKind -> Bool
$c/= :: ModKind -> ModKind -> Bool
/= :: ModKind -> ModKind -> Bool
Eq, Eq ModKind
Eq ModKind =>
(ModKind -> ModKind -> Ordering)
-> (ModKind -> ModKind -> Bool)
-> (ModKind -> ModKind -> Bool)
-> (ModKind -> ModKind -> Bool)
-> (ModKind -> ModKind -> Bool)
-> (ModKind -> ModKind -> ModKind)
-> (ModKind -> ModKind -> ModKind)
-> Ord ModKind
ModKind -> ModKind -> Bool
ModKind -> ModKind -> Ordering
ModKind -> ModKind -> ModKind
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
$ccompare :: ModKind -> ModKind -> Ordering
compare :: ModKind -> ModKind -> Ordering
$c< :: ModKind -> ModKind -> Bool
< :: ModKind -> ModKind -> Bool
$c<= :: ModKind -> ModKind -> Bool
<= :: ModKind -> ModKind -> Bool
$c> :: ModKind -> ModKind -> Bool
> :: ModKind -> ModKind -> Bool
$c>= :: ModKind -> ModKind -> Bool
>= :: ModKind -> ModKind -> Bool
$cmax :: ModKind -> ModKind -> ModKind
max :: ModKind -> ModKind -> ModKind
$cmin :: ModKind -> ModKind -> ModKind
min :: ModKind -> ModKind -> ModKind
Ord)

instance PP ModKind where
  ppPrec :: Int -> ModKind -> Doc
ppPrec Int
_ ModKind
e =
    case ModKind
e of
      ModKind
AFunctor   -> Doc
"a functor"
      ModKind
ASignature -> Doc
"an interface"
      ModKind
AModule    -> Doc
"a module"



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"
                    Namespace
NSConstructor -> Doc
"Constructor"

    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 {a}. IsString a => Namespace -> a
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 {a}. IsString a => Namespace -> a
sayNS Namespace
actual, Doc
"instead"
            ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
suggestion)
        where
        sayNS :: Namespace -> a
sayNS Namespace
ns = case Namespace
ns of
                     Namespace
NSValue  -> a
"value"
                     Namespace
NSConstructor -> a
"constructor"
                     Namespace
NSType   -> a
"type"
                     Namespace
NSModule -> a
"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
NSConstructor,Namespace
NSValue) ->
                [Doc
"Perhaps the constructor got shadowed?"]
            (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." ])

    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" Doc -> Doc -> Doc
<+> Doc
self Doc -> Doc -> Doc
<+>Doc
"dependency:")
         Int
4 ([Doc] -> Doc
vcat [ Doc
"•" Doc -> Doc -> Doc
<+> DepName -> Doc
forall a. PP a => a -> Doc
pp DepName
x Doc -> Doc -> Doc
<.>
                    case DepName -> Maybe Range
depNameLoc DepName
x of
                      Just Range
r -> Doc
", defined at" Doc -> Doc -> Doc
<+> Range -> Doc
ppR Range
r
                      Maybe Range
Nothing -> Doc
forall a. Monoid a => a
mempty
                 | 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)
            self :: Doc
self = case [DepName]
ds of
                     [DepName
_] -> Doc
"self"
                     [DepName]
_   -> Doc
"recursive"

    MultipleModParams Ident
x [Range]
rs ->
      Doc -> Int -> Doc -> Doc
hang (Doc
"[error] Multiple parameters with name" Doc -> Doc -> Doc
<+> Doc -> Doc
backticks (Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
x))
         Int
4 ([Doc] -> Doc
vcat [ Doc
"•" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r | Range
r <- [Range]
rs ])

    InvalidFunctorImport ImpName Name
x ->
      Doc -> Int -> Doc -> Doc
hang (Doc
"[error] Invalid import of functor" Doc -> Doc -> Doc
<+> Doc -> Doc
backticks (ImpName Name -> Doc
forall a. PP a => a -> Doc
pp ImpName Name
x))
        Int
4 Doc
"• Functors need to be instantiated before they can be imported."

    UnexpectedNest Range
s PName
x ->
      Doc -> Int -> Doc -> Doc
hang (Doc
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
s)
        Int
4 (Doc
"submodule" Doc -> Doc -> Doc
<+> Doc -> Doc
backticks (PName -> Doc
forall a. PP a => a -> Doc
pp PName
x) Doc -> Doc -> Doc
<+> Doc
"may not be defined here.")

    ModuleKindMismatch Range
r ImpName Name
x ModKind
expected ModKind
actual ->
      Doc -> Int -> Doc -> Doc
hang (Doc
"[error] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
r)
        Int
4 ([Doc] -> Doc
vcat [ Doc
"• Expected" Doc -> Doc -> Doc
<+> ModKind -> Doc
forall a. PP a => a -> Doc
pp ModKind
expected
                , Doc
"•" Doc -> Doc -> Doc
<+> Doc -> Doc
backticks (ImpName Name -> Doc
forall a. PP a => a -> Doc
pp ImpName Name
x) Doc -> Doc -> Doc
<+> Doc
"is" Doc -> Doc -> Doc
<+> ModKind -> Doc
forall a. PP a => a -> Doc
pp ModKind
actual
                ])


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
          Namespace
NSConstructor -> Doc
"constructor" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. PP a => a -> Doc
pp Name
n
      ModParamName Range
_r Ident
i -> Doc
"module parameter" Doc -> Doc -> Doc
<+> Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
i
      ModPath ModPath
mp ->
        case ModPath -> (ModName, [Ident])
modPathSplit ModPath
mp of
          (ModName
m,[]) -> Doc
"module" Doc -> Doc -> Doc
<+> ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
m
          (ModName
_,[Ident]
is) -> Doc
"submodule" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
"::" ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Doc
forall a. PP a => a -> Doc
pp [Ident]
is))



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

data RenamerWarning
  = SymbolShadowed PName Name [Name]
  | UnusedName Name
  | PrefixAssocChanged PrefixOp (Expr Name) (Located Name) Fixity (Expr 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
$cshowsPrec :: Int -> RenamerWarning -> ShowS
showsPrec :: Int -> RenamerWarning -> ShowS
$cshow :: RenamerWarning -> String
show :: RenamerWarning -> String
$cshowList :: [RenamerWarning] -> ShowS
showList :: [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
$cfrom :: forall x. RenamerWarning -> Rep RenamerWarning x
from :: forall x. RenamerWarning -> Rep RenamerWarning x
$cto :: forall x. Rep RenamerWarning x -> RenamerWarning
to :: forall x. Rep RenamerWarning x -> RenamerWarning
Generic, RenamerWarning -> ()
(RenamerWarning -> ()) -> NFData RenamerWarning
forall a. (a -> ()) -> NFData a
$crnf :: RenamerWarning -> ()
rnf :: 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 to show things
instance Ord RenamerWarning where
  compare :: RenamerWarning -> RenamerWarning -> Ordering
compare RenamerWarning
w1 RenamerWarning
w2 =
    case (RenamerWarning
w1, RenamerWarning
w2) of
      (SymbolShadowed PName
x Name
y [Name]
_, 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')
      (UnusedName Name
x, UnusedName Name
x') ->
        Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Name -> Position
byStart Name
x) (Name -> Position
byStart Name
x')
      (PrefixAssocChanged PrefixOp
_ Expr Name
_ Located Name
op Fixity
_ Expr Name
_, PrefixAssocChanged PrefixOp
_ Expr Name
_ Located Name
op' Fixity
_ Expr Name
_) ->
        Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Range -> Position
from (Range -> Position) -> Range -> Position
forall a b. (a -> b) -> a -> b
$ Located Name -> Range
forall a. Located a -> Range
srcRange Located Name
op) (Range -> Position
from (Range -> Position) -> Range -> Position
forall a b. (a -> b) -> a -> b
$ Located Name -> Range
forall a. Located a -> Range
srcRange Located Name
op')
      (RenamerWarning, RenamerWarning)
_ -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RenamerWarning -> Int
priority RenamerWarning
w1) (RenamerWarning -> Int
priority RenamerWarning
w2)

      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
      priority :: RenamerWarning -> Int
priority SymbolShadowed {}     = Int
0 :: Int
      priority UnusedName {}         = Int
1
      priority PrefixAssocChanged {} = Int
2

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 a. [a] -> 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)

  ppPrec Int
_ (PrefixAssocChanged PrefixOp
prefixOp Expr Name
x Located Name
infixOp Fixity
infixFixity Expr Name
y) =
    Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"[warning] at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located Name -> Range
forall a. Located a -> Range
srcRange Located Name
infixOp))
       Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep [ Doc -> Doc
backticks (Expr Name -> Doc
forall a. PP a => a -> Doc
pp Expr Name
old)
                , Doc
"is now parsed as"
                , Doc -> Doc
backticks (Expr Name -> Doc
forall a. PP a => a -> Doc
pp Expr Name
new) ]

    where
    old :: Expr Name
old = Expr Name -> Located Name -> Fixity -> Expr Name -> Expr Name
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix (PrefixOp -> Expr Name -> Expr Name
forall n. PrefixOp -> Expr n -> Expr n
EPrefix PrefixOp
prefixOp Expr Name
x) Located Name
infixOp Fixity
infixFixity Expr Name
y
    new :: Expr Name
new = PrefixOp -> Expr Name -> Expr Name
forall n. PrefixOp -> Expr n -> Expr n
EPrefix PrefixOp
prefixOp (Expr Name -> Located Name -> Fixity -> Expr Name -> Expr Name
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix Expr Name
x Located Name
infixOp Fixity
infixFixity Expr Name
y)