{-# LANGUAGE CPP #-}
module Checks.SyntaxCheck (syntaxCheck) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad (unless, when)
import qualified Control.Monad.State as S (State, gets, modify, runState,
withState)
import Data.Function (on)
import Data.List (insertBy, intersect, nub, nubBy)
import qualified Data.Map as Map (Map, empty, findWithDefault,
fromList, insertWith, keys)
import Data.Maybe (isJust, isNothing)
import qualified Data.Set as Set (Set, empty, insert, member,
singleton, toList, union)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
import Curry.Syntax
import Base.Expr
import Base.Messages (Message, internalError,
spanInfoMessage)
import Base.NestEnv
import Base.SCC (scc)
import Base.Utils (findDouble, findMultiples, (++!))
import Env.TypeConstructor (TCEnv, clsMethods, getOrigName)
import Env.Value (ValueEnv, ValueInfo (..),
qualLookupValueUnique)
syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module ()
-> ((Module (), [KnownExtension]), [Message])
syntaxCheck :: [KnownExtension]
-> TCEnv
-> ValueEnv
-> Module ()
-> ((Module (), [KnownExtension]), [Message])
syntaxCheck exts :: [KnownExtension]
exts tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv mdl :: Module ()
mdl@(Module _ _ _ m :: ModuleIdent
m _ _ ds :: [Decl ()]
ds) =
case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
cons of
[] -> case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples ([Ident]
ls [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
fs [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
cons [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
cs) of
[] -> SCM (Module (), [KnownExtension])
-> SCState -> ((Module (), [KnownExtension]), [Message])
forall a. SCM a -> SCState -> (a, [Message])
runSC (Module () -> SCM (Module (), [KnownExtension])
checkModule Module ()
mdl) SCState
state
iss :: [[Ident]]
iss -> ((Module ()
mdl, [KnownExtension]
exts), ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> [Ident] -> Message
errMultipleDeclarations ModuleIdent
m) [[Ident]]
iss)
css :: [[Ident]]
css -> ((Module ()
mdl, [KnownExtension]
exts), ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map [Ident] -> Message
errMultipleDataConstructor [[Ident]]
css)
where
tds :: [Decl ()]
tds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl ()]
ds
vds :: [Decl ()]
vds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl ()]
ds
cds :: [Decl ()]
cds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isClassDecl [Decl ()]
ds
cons :: [Ident]
cons = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
constrs [Decl ()]
tds
ls :: [Ident]
ls = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
recLabels [Decl ()]
tds
fs :: [Ident]
fs = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
vds
cs :: [Ident]
cs = ([Decl ()] -> [Ident]) -> [[Decl ()]] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
methods) [[Decl ()]
ds' | ClassDecl _ _ _ _ _ ds' :: [Decl ()]
ds' <- [Decl ()]
cds]
rEnv :: NestEnv RenameInfo
rEnv = TopEnv RenameInfo -> NestEnv RenameInfo
forall a. TopEnv a -> NestEnv a
globalEnv (TopEnv RenameInfo -> NestEnv RenameInfo)
-> TopEnv RenameInfo -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$ (ValueInfo -> RenameInfo) -> ValueEnv -> TopEnv RenameInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueInfo -> RenameInfo
renameInfo ValueEnv
vEnv
state :: SCState
state = [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> SCState
initState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv ValueEnv
vEnv
type SCM = S.State SCState
data SCState = SCState
{ SCState -> [KnownExtension]
extensions :: [KnownExtension]
, SCState -> ModuleIdent
moduleIdent :: ModuleIdent
, SCState -> TCEnv
tyConsEnv :: TCEnv
, SCState -> NestEnv RenameInfo
renameEnv :: RenameEnv
, SCState -> ValueEnv
valueEnv :: ValueEnv
, SCState -> Integer
scopeId :: Integer
, SCState -> Integer
nextId :: Integer
, SCState -> FuncDeps
funcDeps :: FuncDeps
, SCState -> Bool
typeClassesCheck :: Bool
, SCState -> [Message]
errors :: [Message]
}
initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> ValueEnv
-> SCState
initState :: [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> SCState
initState exts :: [KnownExtension]
exts m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv rEnv :: NestEnv RenameInfo
rEnv vEnv :: ValueEnv
vEnv =
[KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> Integer
-> Integer
-> FuncDeps
-> Bool
-> [Message]
-> SCState
SCState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv ValueEnv
vEnv Integer
globalScopeId 1 FuncDeps
noFuncDeps Bool
False []
globalScopeId :: Integer
globalScopeId :: Integer
globalScopeId = Ident -> Integer
idUnique (String -> Ident
mkIdent "")
runSC :: SCM a -> SCState -> (a, [Message])
runSC :: SCM a -> SCState -> (a, [Message])
runSC scm :: SCM a
scm s :: SCState
s = let (a :: a
a, s' :: SCState
s') = SCM a -> SCState -> (a, SCState)
forall s a. State s a -> s -> (a, s)
S.runState SCM a
scm SCState
s in (a
a, [Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ SCState -> [Message]
errors SCState
s')
hasExtension :: KnownExtension -> SCM Bool
hasExtension :: KnownExtension -> SCM Bool
hasExtension ext :: KnownExtension
ext = (SCState -> Bool) -> SCM Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem KnownExtension
ext ([KnownExtension] -> Bool)
-> (SCState -> [KnownExtension]) -> SCState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCState -> [KnownExtension]
extensions)
enableExtension :: KnownExtension -> SCM ()
enableExtension :: KnownExtension -> SCM ()
enableExtension e :: KnownExtension
e = (SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \s :: SCState
s -> SCState
s { extensions :: [KnownExtension]
extensions = KnownExtension
e KnownExtension -> [KnownExtension] -> [KnownExtension]
forall a. a -> [a] -> [a]
: SCState -> [KnownExtension]
extensions SCState
s }
getExtensions :: SCM [KnownExtension]
getExtensions :: SCM [KnownExtension]
getExtensions = (SCState -> [KnownExtension]) -> SCM [KnownExtension]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> [KnownExtension]
extensions
getModuleIdent :: SCM ModuleIdent
getModuleIdent :: SCM ModuleIdent
getModuleIdent = (SCState -> ModuleIdent) -> SCM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> ModuleIdent
moduleIdent
getTyConsEnv :: SCM TCEnv
getTyConsEnv :: SCM TCEnv
getTyConsEnv = (SCState -> TCEnv) -> SCM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> TCEnv
tyConsEnv
getRenameEnv :: SCM RenameEnv
getRenameEnv :: SCM (NestEnv RenameInfo)
getRenameEnv = (SCState -> NestEnv RenameInfo) -> SCM (NestEnv RenameInfo)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> NestEnv RenameInfo
renameEnv
getValueEnv :: SCM ValueEnv
getValueEnv :: SCM ValueEnv
getValueEnv = (SCState -> ValueEnv) -> SCM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> ValueEnv
valueEnv
modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM ()
modifyRenameEnv :: (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv f :: NestEnv RenameInfo -> NestEnv RenameInfo
f = (SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \s :: SCState
s -> SCState
s { renameEnv :: NestEnv RenameInfo
renameEnv = NestEnv RenameInfo -> NestEnv RenameInfo
f (NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$ SCState -> NestEnv RenameInfo
renameEnv SCState
s }
getScopeId :: SCM Integer
getScopeId :: SCM Integer
getScopeId = (SCState -> Integer) -> SCM Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> Integer
scopeId
newId :: SCM Integer
newId :: SCM Integer
newId = do
Integer
curId <- (SCState -> Integer) -> SCM Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> Integer
nextId
(SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \s :: SCState
s -> SCState
s { nextId :: Integer
nextId = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
curId }
Integer -> SCM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
curId
isTypeClassesCheck :: SCM Bool
isTypeClassesCheck :: SCM Bool
isTypeClassesCheck = (SCState -> Bool) -> SCM Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> Bool
typeClassesCheck
performTypeClassesCheck :: SCM a -> SCM a
performTypeClassesCheck :: SCM a -> SCM a
performTypeClassesCheck = SCM a -> SCM a
forall a. SCM a -> SCM a
inNestedScope (SCM a -> SCM a) -> (SCM a -> SCM a) -> SCM a -> SCM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(SCState -> SCState) -> SCM a -> SCM a
forall s a. (s -> s) -> State s a -> State s a
S.withState (\s :: SCState
s -> SCState
s { typeClassesCheck :: Bool
typeClassesCheck = Bool
True })
incNesting :: SCM ()
incNesting :: SCM ()
incNesting = do
Integer
newScopeId <- SCM Integer
newId
(SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \s :: SCState
s -> SCState
s { scopeId :: Integer
scopeId = Integer
newScopeId }
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv NestEnv RenameInfo -> NestEnv RenameInfo
forall a. NestEnv a -> NestEnv a
nestEnv
withLocalEnv :: SCM a -> SCM a
withLocalEnv :: SCM a -> SCM a
withLocalEnv act :: SCM a
act = do
NestEnv RenameInfo
oldEnv <- SCM (NestEnv RenameInfo)
getRenameEnv
a
res <- SCM a
act
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ NestEnv RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a b. a -> b -> a
const NestEnv RenameInfo
oldEnv
a -> SCM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
inNestedScope :: SCM a -> SCM a
inNestedScope :: SCM a -> SCM a
inNestedScope act :: SCM a
act = SCM a -> SCM a
forall a. SCM a -> SCM a
withLocalEnv (SCM ()
incNesting SCM () -> SCM a -> SCM a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SCM a
act)
modifyFuncDeps :: (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps :: (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps f :: FuncDeps -> FuncDeps
f = (SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ s :: SCState
s -> SCState
s { funcDeps :: FuncDeps
funcDeps = FuncDeps -> FuncDeps
f (FuncDeps -> FuncDeps) -> FuncDeps -> FuncDeps
forall a b. (a -> b) -> a -> b
$ SCState -> FuncDeps
funcDeps SCState
s }
report :: Message -> SCM ()
report :: Message -> SCM ()
report msg :: Message
msg = (SCState -> SCState) -> SCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SCState -> SCState) -> SCM ()) -> (SCState -> SCState) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \s :: SCState
s -> SCState
s { errors :: [Message]
errors = Message
msg Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: SCState -> [Message]
errors SCState
s }
ok :: SCM ()
ok :: SCM ()
ok = () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data FuncDeps = FuncDeps
{ FuncDeps -> Maybe QualIdent
curGlobalFunc :: Maybe QualIdent
, FuncDeps -> GlobalDeps
globalDeps :: GlobalDeps
, FuncDeps -> [(QualIdent, QualIdent)]
funcPats :: [(QualIdent, QualIdent)]
}
type GlobalDeps = Map.Map QualIdent (Set.Set QualIdent)
noFuncDeps :: FuncDeps
noFuncDeps :: FuncDeps
noFuncDeps = Maybe QualIdent
-> GlobalDeps -> [(QualIdent, QualIdent)] -> FuncDeps
FuncDeps Maybe QualIdent
forall a. Maybe a
Nothing GlobalDeps
forall k a. Map k a
Map.empty []
inFunc :: Ident -> SCM a -> SCM a
inFunc :: Ident -> SCM a -> SCM a
inFunc i :: Ident
i scm :: SCM a
scm = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
Bool
global <- Maybe QualIdent -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe QualIdent -> Bool)
-> StateT SCState Identity (Maybe QualIdent) -> SCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCState -> Maybe QualIdent)
-> StateT SCState Identity (Maybe QualIdent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (FuncDeps -> Maybe QualIdent
curGlobalFunc (FuncDeps -> Maybe QualIdent)
-> (SCState -> FuncDeps) -> SCState -> Maybe QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCState -> FuncDeps
funcDeps)
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
global (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps ((FuncDeps -> FuncDeps) -> SCM ())
-> (FuncDeps -> FuncDeps) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ fd :: FuncDeps
fd -> FuncDeps
fd { curGlobalFunc :: Maybe QualIdent
curGlobalFunc = QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
i) }
a
res <- SCM a
scm
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
global (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps ((FuncDeps -> FuncDeps) -> SCM ())
-> (FuncDeps -> FuncDeps) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ fd :: FuncDeps
fd -> FuncDeps
fd { curGlobalFunc :: Maybe QualIdent
curGlobalFunc = Maybe QualIdent
forall a. Maybe a
Nothing }
a -> SCM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
addGlobalDep :: QualIdent -> SCM ()
addGlobalDep :: QualIdent -> SCM ()
addGlobalDep dep :: QualIdent
dep = do
Maybe QualIdent
maybeF <- (SCState -> Maybe QualIdent)
-> StateT SCState Identity (Maybe QualIdent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (FuncDeps -> Maybe QualIdent
curGlobalFunc (FuncDeps -> Maybe QualIdent)
-> (SCState -> FuncDeps) -> SCState -> Maybe QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCState -> FuncDeps
funcDeps)
case Maybe QualIdent
maybeF of
Nothing -> String -> SCM ()
forall a. String -> a
internalError "SyntaxCheck.addFuncPat: no global function set"
Just f :: QualIdent
f -> (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps ((FuncDeps -> FuncDeps) -> SCM ())
-> (FuncDeps -> FuncDeps) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ fd :: FuncDeps
fd -> FuncDeps
fd
{ globalDeps :: GlobalDeps
globalDeps = (Set QualIdent -> Set QualIdent -> Set QualIdent)
-> QualIdent -> Set QualIdent -> GlobalDeps -> GlobalDeps
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set QualIdent -> Set QualIdent -> Set QualIdent
forall a. Ord a => Set a -> Set a -> Set a
Set.union QualIdent
f
(QualIdent -> Set QualIdent
forall a. a -> Set a
Set.singleton QualIdent
dep) (FuncDeps -> GlobalDeps
globalDeps FuncDeps
fd) }
addFuncPat :: QualIdent -> SCM ()
addFuncPat :: QualIdent -> SCM ()
addFuncPat fp :: QualIdent
fp = do
Maybe QualIdent
maybeF <- (SCState -> Maybe QualIdent)
-> StateT SCState Identity (Maybe QualIdent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (FuncDeps -> Maybe QualIdent
curGlobalFunc (FuncDeps -> Maybe QualIdent)
-> (SCState -> FuncDeps) -> SCState -> Maybe QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCState -> FuncDeps
funcDeps)
case Maybe QualIdent
maybeF of
Nothing -> String -> SCM ()
forall a. String -> a
internalError "SyntaxCheck.addFuncPat: no global function set"
Just f :: QualIdent
f -> (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps ((FuncDeps -> FuncDeps) -> SCM ())
-> (FuncDeps -> FuncDeps) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ fd :: FuncDeps
fd -> FuncDeps
fd { funcPats :: [(QualIdent, QualIdent)]
funcPats = (QualIdent
fp, QualIdent
f) (QualIdent, QualIdent)
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. a -> [a] -> [a]
: FuncDeps -> [(QualIdent, QualIdent)]
funcPats FuncDeps
fd }
getGlobalDeps :: SCM GlobalDeps
getGlobalDeps :: SCM GlobalDeps
getGlobalDeps = FuncDeps -> GlobalDeps
globalDeps (FuncDeps -> GlobalDeps)
-> StateT SCState Identity FuncDeps -> SCM GlobalDeps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCState -> FuncDeps) -> StateT SCState Identity FuncDeps
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> FuncDeps
funcDeps
getFuncPats :: SCM [(QualIdent, QualIdent)]
getFuncPats :: SCM [(QualIdent, QualIdent)]
getFuncPats = FuncDeps -> [(QualIdent, QualIdent)]
funcPats (FuncDeps -> [(QualIdent, QualIdent)])
-> StateT SCState Identity FuncDeps -> SCM [(QualIdent, QualIdent)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCState -> FuncDeps) -> StateT SCState Identity FuncDeps
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> FuncDeps
funcDeps
type RenameEnv = NestEnv RenameInfo
data RenameInfo
= Constr QualIdent Int
| RecordLabel QualIdent [QualIdent]
| GlobalVar QualIdent Int
| LocalVar Ident Int
deriving (RenameInfo -> RenameInfo -> Bool
(RenameInfo -> RenameInfo -> Bool)
-> (RenameInfo -> RenameInfo -> Bool) -> Eq RenameInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenameInfo -> RenameInfo -> Bool
$c/= :: RenameInfo -> RenameInfo -> Bool
== :: RenameInfo -> RenameInfo -> Bool
$c== :: RenameInfo -> RenameInfo -> Bool
Eq, Int -> RenameInfo -> ShowS
[RenameInfo] -> ShowS
RenameInfo -> String
(Int -> RenameInfo -> ShowS)
-> (RenameInfo -> String)
-> ([RenameInfo] -> ShowS)
-> Show RenameInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenameInfo] -> ShowS
$cshowList :: [RenameInfo] -> ShowS
show :: RenameInfo -> String
$cshow :: RenameInfo -> String
showsPrec :: Int -> RenameInfo -> ShowS
$cshowsPrec :: Int -> RenameInfo -> ShowS
Show)
ppRenameInfo :: RenameInfo -> Doc
ppRenameInfo :: RenameInfo -> Doc
ppRenameInfo (Constr qn :: QualIdent
qn _) = String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
ppRenameInfo (RecordLabel qn :: QualIdent
qn _) = String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
ppRenameInfo (GlobalVar qn :: QualIdent
qn _) = String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
ppRenameInfo (LocalVar n :: Ident
n _) = String -> Doc
text (Ident -> String
escName Ident
n)
renameInfo :: ValueInfo -> RenameInfo
renameInfo :: ValueInfo -> RenameInfo
renameInfo (DataConstructor qid :: QualIdent
qid a :: Int
a _ _) = QualIdent -> Int -> RenameInfo
Constr QualIdent
qid Int
a
renameInfo (NewtypeConstructor qid :: QualIdent
qid _ _) = QualIdent -> Int -> RenameInfo
Constr QualIdent
qid 1
renameInfo (Value qid :: QualIdent
qid _ a :: Int
a _) = QualIdent -> Int -> RenameInfo
GlobalVar QualIdent
qid Int
a
renameInfo (Label qid :: QualIdent
qid cs :: [QualIdent]
cs _) = QualIdent -> [QualIdent] -> RenameInfo
RecordLabel QualIdent
qid [QualIdent]
cs
bindGlobal :: Bool -> ModuleIdent -> Ident -> RenameInfo -> RenameEnv
-> RenameEnv
bindGlobal :: Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal tcc :: Bool
tcc m :: ModuleIdent
m c :: Ident
c r :: RenameInfo
r
| Bool -> Bool
not Bool
tcc = Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
c RenameInfo
r (NestEnv RenameInfo -> NestEnv RenameInfo)
-> (NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. QualIdent -> a -> NestEnv a -> NestEnv a
qualBindNestEnv (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c) RenameInfo
r
| Bool
otherwise = NestEnv RenameInfo -> NestEnv RenameInfo
forall a. a -> a
id
bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv
bindLocal :: Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
bindLocal = Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv
bindTypeDecl :: Decl a -> SCM ()
bindTypeDecl :: Decl a -> SCM ()
bindTypeDecl (DataDecl _ _ _ cs :: [ConstrDecl]
cs _) =
(ConstrDecl -> SCM ()) -> [ConstrDecl] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ConstrDecl -> SCM ()
bindConstr [ConstrDecl]
cs SCM () -> SCM () -> SCM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ConstrDecl] -> SCM ()
bindRecordLabels [ConstrDecl]
cs
bindTypeDecl (NewtypeDecl _ _ _ nc :: NewConstrDecl
nc _) = NewConstrDecl -> SCM ()
bindNewConstr NewConstrDecl
nc
bindTypeDecl _ = SCM ()
ok
bindConstr :: ConstrDecl -> SCM ()
bindConstr :: ConstrDecl -> SCM ()
bindConstr (ConstrDecl _ c :: Ident
c tys :: [TypeExpr]
tys) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
c (QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c) (Int -> RenameInfo) -> Int -> RenameInfo
forall a b. (a -> b) -> a -> b
$ [TypeExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeExpr]
tys)
bindConstr (ConOpDecl _ _ op :: Ident
op _) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
op (QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
op) 2)
bindConstr (RecordDecl _ c :: Ident
c fs :: [FieldDecl]
fs) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
c (QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c) ([Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
labels))
where labels :: [Ident]
labels = [Ident
l | FieldDecl _ ls :: [Ident]
ls _ <- [FieldDecl]
fs, Ident
l <- [Ident]
ls]
bindNewConstr :: NewConstrDecl -> SCM ()
bindNewConstr :: NewConstrDecl -> SCM ()
bindNewConstr (NewConstrDecl _ c :: Ident
c _) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
c (QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c) 1)
bindNewConstr (NewRecordDecl _ c :: Ident
c (l :: Ident
l, _)) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(Ident, [Ident]) -> SCM ()
bindRecordLabel (Ident
l, [Ident
c])
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
c (QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c) 1)
bindRecordLabels :: [ConstrDecl] -> SCM ()
bindRecordLabels :: [ConstrDecl] -> SCM ()
bindRecordLabels cs :: [ConstrDecl]
cs =
((Ident, [Ident]) -> SCM ()) -> [(Ident, [Ident])] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ident, [Ident]) -> SCM ()
bindRecordLabel [(Ident
l, Ident -> [Ident]
constr Ident
l) | Ident
l <- [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ((ConstrDecl -> [Ident]) -> [ConstrDecl] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstrDecl -> [Ident]
recordLabels [ConstrDecl]
cs)]
where constr :: Ident -> [Ident]
constr l :: Ident
l = [ConstrDecl -> Ident
constrId ConstrDecl
c | ConstrDecl
c <- [ConstrDecl]
cs, Ident
l Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ConstrDecl -> [Ident]
recordLabels ConstrDecl
c]
bindRecordLabel :: (Ident, [Ident]) -> SCM ()
bindRecordLabel :: (Ident, [Ident]) -> SCM ()
bindRecordLabel (l :: Ident
l, cs :: [Ident]
cs) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
Bool
new <- [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RenameInfo] -> Bool)
-> (NestEnv RenameInfo -> [RenameInfo])
-> NestEnv RenameInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar Ident
l (NestEnv RenameInfo -> Bool)
-> SCM (NestEnv RenameInfo) -> SCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM (NestEnv RenameInfo)
getRenameEnv
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
new (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ Ident -> Message
errDuplicateDefinition Ident
l
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
False ModuleIdent
m Ident
l (RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$
QualIdent -> [QualIdent] -> RenameInfo
RecordLabel (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
l) ((Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m) [Ident]
cs)
bindFuncDecl :: Bool -> ModuleIdent -> Decl a -> RenameEnv -> RenameEnv
bindFuncDecl :: Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindFuncDecl _ _ (FunctionDecl _ _ _ []) _
= String -> NestEnv RenameInfo
forall a. String -> a
internalError "SyntaxCheck.bindFuncDecl: no equations"
bindFuncDecl tcc :: Bool
tcc m :: ModuleIdent
m (FunctionDecl _ _ f :: Ident
f (eq :: Equation a
eq:_)) env :: NestEnv RenameInfo
env
= let arty :: Int
arty = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int) -> [Pattern a] -> Int
forall a b. (a -> b) -> a -> b
$ (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs Equation a
eq
in Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
tcc ModuleIdent
m Ident
f (QualIdent -> Int -> RenameInfo
GlobalVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) Int
arty) NestEnv RenameInfo
env
bindFuncDecl tcc :: Bool
tcc m :: ModuleIdent
m (TypeSig _ fs :: [Ident]
fs (QualTypeExpr _ _ ty :: TypeExpr
ty)) env :: NestEnv RenameInfo
env
= (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> (Ident -> QualIdent)
-> Ident
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m) NestEnv RenameInfo
env [Ident]
fs
where
bindTS :: QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS qf :: QualIdent
qf env' :: NestEnv RenameInfo
env'
| [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RenameInfo] -> Bool) -> [RenameInfo] -> Bool
forall a b. (a -> b) -> a -> b
$ QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
qf NestEnv RenameInfo
env'
= Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
tcc ModuleIdent
m (QualIdent -> Ident
unqualify QualIdent
qf) (QualIdent -> Int -> RenameInfo
GlobalVar QualIdent
qf (TypeExpr -> Int
typeArity TypeExpr
ty)) NestEnv RenameInfo
env'
| Bool
otherwise = NestEnv RenameInfo
env'
bindFuncDecl _ _ _ env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env
bindClassDecl :: Decl a -> SCM ()
bindClassDecl :: Decl a -> SCM ()
bindClassDecl (ClassDecl _ _ _ _ _ ds :: [Decl a]
ds) = (Decl a -> SCM ()) -> [Decl a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl a -> SCM ()
forall a. Decl a -> SCM ()
bindClassMethod [Decl a]
ds
bindClassDecl _ = SCM ()
ok
bindClassMethod :: Decl a -> SCM ()
bindClassMethod :: Decl a -> SCM ()
bindClassMethod ts :: Decl a
ts@(TypeSig _ _ _) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall a.
Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindFuncDecl Bool
False ModuleIdent
m Decl a
ts
bindClassMethod _ = SCM ()
ok
bindVarDecl :: Decl a -> RenameEnv -> RenameEnv
bindVarDecl :: Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl (FunctionDecl _ _ f :: Ident
f eqs :: [Equation a]
eqs) env :: NestEnv RenameInfo
env
| [Equation a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation a]
eqs = String -> NestEnv RenameInfo
forall a. String -> a
internalError "SyntaxCheck.bindVarDecl: no equations"
| Bool
otherwise = let arty :: Int
arty = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int) -> [Pattern a] -> Int
forall a b. (a -> b) -> a -> b
$ (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs (Equation a -> (Ident, [Pattern a]))
-> Equation a -> (Ident, [Pattern a])
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs
in Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
bindLocal (Ident -> Ident
unRenameIdent Ident
f) (Ident -> Int -> RenameInfo
LocalVar Ident
f Int
arty) NestEnv RenameInfo
env
bindVarDecl (PatternDecl _ t :: Pattern a
t _) env :: NestEnv RenameInfo
env = (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar NestEnv RenameInfo
env (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t)
bindVarDecl (FreeDecl _ vs :: [Var a]
vs) env :: NestEnv RenameInfo
env = (Var a -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Var a] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> (Var a -> Ident)
-> Var a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var a -> Ident
forall a. Var a -> Ident
varIdent) NestEnv RenameInfo
env [Var a]
vs
bindVarDecl _ env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env
bindVar :: Ident -> RenameEnv -> RenameEnv
bindVar :: Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar v :: Ident
v | Ident -> Bool
isAnonId Ident
v = NestEnv RenameInfo -> NestEnv RenameInfo
forall a. a -> a
id
| Bool
otherwise = Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
bindLocal (Ident -> Ident
unRenameIdent Ident
v) (Ident -> Int -> RenameInfo
LocalVar Ident
v 0)
lookupVar :: Ident -> RenameEnv -> [RenameInfo]
lookupVar :: Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar v :: Ident
v env :: NestEnv RenameInfo
env = Ident -> NestEnv RenameInfo -> [RenameInfo]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
v NestEnv RenameInfo
env [RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [RenameInfo]
lookupTupleConstr Ident
v
qualLookupVar :: QualIdent -> RenameEnv -> [RenameInfo]
qualLookupVar :: QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar v :: QualIdent
v env :: NestEnv RenameInfo
env = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
forall a. QualIdent -> NestEnv a -> [a]
qualLookupNestEnv QualIdent
v NestEnv RenameInfo
env
[RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupListCons QualIdent
v NestEnv RenameInfo
env
[RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [RenameInfo]
lookupTupleConstr (QualIdent -> Ident
unqualify QualIdent
v)
lookupTupleConstr :: Ident -> [RenameInfo]
lookupTupleConstr :: Ident -> [RenameInfo]
lookupTupleConstr v :: Ident
v
| Ident -> Bool
isTupleId Ident
v = let a :: Int
a = Ident -> Int
tupleArity Ident
v
in [QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Int -> Ident
tupleId Int
a) Int
a]
| Bool
otherwise = []
qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
qualLookupListCons :: QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupListCons v :: QualIdent
v env :: NestEnv RenameInfo
env
| QualIdent
v QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent Ident
consId
= QualIdent -> NestEnv RenameInfo -> [RenameInfo]
forall a. QualIdent -> NestEnv a -> [a]
qualLookupNestEnv (Ident -> QualIdent
qualify (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
qidIdent QualIdent
v) NestEnv RenameInfo
env
| Bool
otherwise
= []
checkModule :: Module () -> SCM (Module (), [KnownExtension])
checkModule :: Module () -> SCM (Module (), [KnownExtension])
checkModule (Module spi :: SpanInfo
spi li :: LayoutInfo
li ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl ()]
ds) = do
(Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
bindTypeDecl [Decl ()]
tds
(Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
bindClassDecl [Decl ()]
cds
[Decl ()]
ds' <- [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
[Decl ()]
cds' <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. SCM a -> SCM a
performTypeClassesCheck (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ()))
-> (Decl () -> StateT SCState Identity (Decl ()))
-> Decl ()
-> StateT SCState Identity (Decl ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl () -> StateT SCState Identity (Decl ())
checkClassDecl) [Decl ()]
cds
[Decl ()]
ids' <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. SCM a -> SCM a
performTypeClassesCheck (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ()))
-> (Decl () -> StateT SCState Identity (Decl ()))
-> Decl ()
-> StateT SCState Identity (Decl ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl () -> StateT SCState Identity (Decl ())
checkInstanceDecl) [Decl ()]
ids
let ds'' :: [Decl ()]
ds'' = [Decl ()] -> [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl ()]
cds' [Decl ()]
ids' [Decl ()]
ds'
SCM ()
checkFuncPatDeps
[KnownExtension]
exts <- SCM [KnownExtension]
getExtensions
(Module (), [KnownExtension]) -> SCM (Module (), [KnownExtension])
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl ()]
-> Module ()
forall a.
SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi LayoutInfo
li [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is [Decl ()]
ds'', [KnownExtension]
exts)
where tds :: [Decl ()]
tds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl ()]
ds
cds :: [Decl ()]
cds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isClassDecl [Decl ()]
ds
ids :: [Decl ()]
ids = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isInstanceDecl [Decl ()]
ds
checkFuncPatDeps :: SCM ()
checkFuncPatDeps :: SCM ()
checkFuncPatDeps = do
[(QualIdent, QualIdent)]
fps <- SCM [(QualIdent, QualIdent)]
getFuncPats
GlobalDeps
deps <- SCM GlobalDeps
getGlobalDeps
let levels :: [[QualIdent]]
levels = (QualIdent -> [QualIdent])
-> (QualIdent -> [QualIdent]) -> [QualIdent] -> [[QualIdent]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc (QualIdent -> [QualIdent] -> [QualIdent]
forall a. a -> [a] -> [a]
:[])
(\k :: QualIdent
k -> Set QualIdent -> [QualIdent]
forall a. Set a -> [a]
Set.toList (Set QualIdent -> QualIdent -> GlobalDeps -> Set QualIdent
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set QualIdent
forall a. Set a
Set.empty QualIdent
k GlobalDeps
deps))
(GlobalDeps -> [QualIdent]
forall k a. Map k a -> [k]
Map.keys GlobalDeps
deps)
levelMap :: Map QualIdent Int
levelMap = [(QualIdent, Int)] -> Map QualIdent Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (QualIdent
f, Int
l) | (fs :: [QualIdent]
fs, l :: Int
l) <- [[QualIdent]] -> [Int] -> [([QualIdent], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[QualIdent]]
levels [1 ..], QualIdent
f <- [QualIdent]
fs ]
level :: QualIdent -> Int
level f :: QualIdent
f = Int -> QualIdent -> Map QualIdent Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (0 :: Int) QualIdent
f Map QualIdent Int
levelMap
((QualIdent, QualIdent) -> SCM ())
-> [(QualIdent, QualIdent)] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((QualIdent -> Int) -> (QualIdent, QualIdent) -> SCM ()
forall a.
Ord a =>
(QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep QualIdent -> Int
level) [(QualIdent, QualIdent)]
fps
checkFuncPatDep :: Ord a => (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep :: (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep level :: QualIdent -> a
level (fp :: QualIdent
fp, f :: QualIdent
f) = Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QualIdent -> a
level QualIdent
fp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< QualIdent -> a
level QualIdent
f) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$
Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent -> Message
errFuncPatCyclic QualIdent
fp QualIdent
f
checkTopDecls :: [Decl ()] -> SCM [Decl ()]
checkTopDecls :: [Decl ()] -> SCM [Decl ()]
checkTopDecls ds :: [Decl ()]
ds = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
Bool
tcc <- SCM Bool
isTypeClassesCheck
(Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup (Bool
-> ModuleIdent
-> Decl ()
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall a.
Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindFuncDecl Bool
tcc ModuleIdent
m) [Decl ()]
ds
checkClassDecl :: Decl () -> SCM (Decl ())
checkClassDecl :: Decl () -> StateT SCState Identity (Decl ())
checkClassDecl (ClassDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl ()]
ds) = do
QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods (Ident -> QualIdent
qualify Ident
cls) ((Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
methods [Decl ()]
ds) [Decl ()]
ds
SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl ()] -> Decl ()
forall a.
SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p LayoutInfo
li Context
cx Ident
cls Ident
tv ([Decl ()] -> Decl ())
-> SCM [Decl ()] -> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
checkClassDecl _ =
String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkClassDecl: no class declaration"
checkInstanceDecl :: Decl () -> SCM (Decl ())
checkInstanceDecl :: Decl () -> StateT SCState Identity (Decl ())
checkInstanceDecl (InstanceDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl ()]
ds) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- SCM ValueEnv
getValueEnv
TCEnv
tcEnv <- SCM TCEnv
getTyConsEnv
let clsMthds :: [Ident]
clsMthds = ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods ModuleIdent
m QualIdent
qcls TCEnv
tcEnv
let orig :: QualIdent
orig = ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m QualIdent
qcls TCEnv
tcEnv
let mthds :: [Ident]
mthds =
if ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
m QualIdent
orig
then [Ident]
clsMthds
else (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (QualIdent -> ModuleIdent -> ValueEnv -> Ident -> Bool
isFromCls QualIdent
orig ModuleIdent
m ValueEnv
vEnv) [Ident]
clsMthds
QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods QualIdent
qcls [Ident]
mthds [Decl ()]
ds
(Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
checkAmbiguousMethod [Decl ()]
ds
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl ()]
-> Decl ()
forall a.
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl a]
-> Decl a
InstanceDecl SpanInfo
p LayoutInfo
li Context
cx QualIdent
qcls TypeExpr
ty ([Decl ()] -> Decl ())
-> SCM [Decl ()] -> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
where
isFromCls :: QualIdent -> ModuleIdent -> ValueEnv -> Ident -> Bool
isFromCls orig :: QualIdent
orig m :: ModuleIdent
m vEnv :: ValueEnv
vEnv f :: Ident
f = case ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique ModuleIdent
m (Ident -> QualIdent
qualify Ident
f) ValueEnv
vEnv of
[Value _ (Just cls :: QualIdent
cls) _ _]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
orig -> Bool
True
_ -> Bool
False
checkInstanceDecl _ =
String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkInstanceDecl: no instance declaration"
checkAmbiguousMethod :: Decl a -> SCM ()
checkAmbiguousMethod :: Decl a -> SCM ()
checkAmbiguousMethod (FunctionDecl _ _ f :: Ident
f _) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
NestEnv RenameInfo
rename <- SCM (NestEnv RenameInfo)
getRenameEnv
case Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar Ident
f NestEnv RenameInfo
rename of
rs1 :: [RenameInfo]
rs1@(_:_:_) -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) NestEnv RenameInfo
rename of
[] -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs1 (Ident -> QualIdent
qualify Ident
f)
rs2 :: [RenameInfo]
rs2@(_:_:_) -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs2 (Ident -> QualIdent
qualify Ident
f)
_ -> () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAmbiguousMethod _ =
String -> SCM ()
forall a. String -> a
internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration"
checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods qcls :: QualIdent
qcls ms :: [Ident]
ms ds :: [Decl a]
ds =
(Ident -> SCM ()) -> [Ident] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> Message
errUndefinedMethod QualIdent
qcls) ([Ident] -> SCM ()) -> [Ident] -> SCM ()
forall a b. (a -> b) -> a -> b
$ (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
ms) [Ident]
fs
where fs :: [Ident]
fs = [Ident
f | FunctionDecl _ _ f :: Ident
f _ <- [Decl a]
ds]
updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [] [] ds :: [Decl a]
ds = [Decl a]
ds
updateClassAndInstanceDecls (c :: Decl a
c:cs :: [Decl a]
cs) is :: [Decl a]
is (ClassDecl _ _ _ _ _ _:ds :: [Decl a]
ds) =
Decl a
c Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls cs :: [Decl a]
cs (i :: Decl a
i:is :: [Decl a]
is) (InstanceDecl _ _ _ _ _ _:ds :: [Decl a]
ds) =
Decl a
i Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls cs :: [Decl a]
cs is :: [Decl a]
is (d :: Decl a
d:ds :: [Decl a]
ds) =
Decl a
d Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls _ _ _ =
String -> [Decl a]
forall a. String -> a
internalError "SyntaxCheck.updateClassAndInstanceDecls"
checkDeclGroup :: (Decl () -> RenameEnv -> RenameEnv) -> [Decl ()] -> SCM [Decl ()]
checkDeclGroup :: (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup bindDecl :: Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl ds :: [Decl ()]
ds = do
[Decl ()]
checkedLhs <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs ([Decl ()] -> SCM [Decl ()]) -> [Decl ()] -> SCM [Decl ()]
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> [Decl ()]
forall a. [Decl a] -> [Decl a]
sortFuncDecls [Decl ()]
ds
[Decl ()] -> SCM [Decl ()]
forall a. [Decl a] -> SCM [Decl a]
joinEquations [Decl ()]
checkedLhs SCM [Decl ()] -> ([Decl ()] -> SCM [Decl ()]) -> SCM [Decl ()]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDecls Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl
checkDeclLhs :: Decl () -> SCM (Decl ())
checkDeclLhs :: Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs (InfixDecl p :: SpanInfo
p fix' :: Infix
fix' pr :: Maybe Integer
pr ops :: [Ident]
ops) =
SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl ()
forall a. SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl a
InfixDecl SpanInfo
p Infix
fix' (Maybe Integer -> [Ident] -> Decl ())
-> StateT SCState Identity (Maybe Integer)
-> StateT SCState Identity ([Ident] -> Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
checkPrecedence SpanInfo
p Maybe Integer
pr StateT SCState Identity ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT SCState Identity Ident
renameVar [Ident]
ops
checkDeclLhs (TypeSig p :: SpanInfo
p vs :: [Ident]
vs ty :: QualTypeExpr
ty) =
(\vs' :: [Ident]
vs' -> SpanInfo -> [Ident] -> QualTypeExpr -> Decl ()
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident]
vs' QualTypeExpr
ty) ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Ident -> StateT SCState Identity Ident
checkVar "type signature") [Ident]
vs
checkDeclLhs (FunctionDecl p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation ()]
eqs) =
Ident
-> StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. Ident -> SCM a -> SCM a
inFunc Ident
f (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ()))
-> StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [Equation ()] -> StateT SCState Identity (Decl ())
checkEquationsLhs SpanInfo
p [Equation ()]
eqs
checkDeclLhs (ExternalDecl p :: SpanInfo
p vs :: [Var ()]
vs) =
SpanInfo -> [Var ()] -> Decl ()
forall a. SpanInfo -> [Var a] -> Decl a
ExternalDecl SpanInfo
p ([Var ()] -> Decl ())
-> StateT SCState Identity [Var ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var () -> StateT SCState Identity (Var ()))
-> [Var ()] -> StateT SCState Identity [Var ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Var () -> StateT SCState Identity (Var ())
forall a. String -> Var a -> SCM (Var a)
checkVar' "external declaration") [Var ()]
vs
checkDeclLhs (PatternDecl p :: SpanInfo
p t :: Pattern ()
t rhs :: Rhs ()
rhs) =
(\t' :: Pattern ()
t' -> SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern ()
t' Rhs ()
rhs) (Pattern () -> Decl ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkDeclLhs (FreeDecl p :: SpanInfo
p vs :: [Var ()]
vs) =
SpanInfo -> [Var ()] -> Decl ()
forall a. SpanInfo -> [Var a] -> Decl a
FreeDecl SpanInfo
p ([Var ()] -> Decl ())
-> StateT SCState Identity [Var ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var () -> StateT SCState Identity (Var ()))
-> [Var ()] -> StateT SCState Identity [Var ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Var () -> StateT SCState Identity (Var ())
forall a. String -> Var a -> SCM (Var a)
checkVar' "free variables declaration") [Var ()]
vs
checkDeclLhs d :: Decl ()
d = Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
d
checkPrecedence :: SpanInfo -> Maybe Precedence -> SCM (Maybe Precedence)
checkPrecedence :: SpanInfo
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
checkPrecedence _ Nothing = Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
checkPrecedence p :: SpanInfo
p (Just i :: Integer
i) = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 9) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report
(Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Integer -> Message
errPrecedenceOutOfRange SpanInfo
p Integer
i
Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> StateT SCState Identity (Maybe Integer))
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
checkVar' :: String -> Var a -> SCM (Var a)
checkVar' :: String -> Var a -> SCM (Var a)
checkVar' what :: String
what (Var a :: a
a v :: Ident
v) = a -> Ident -> Var a
forall a. a -> Ident -> Var a
Var a
a (Ident -> Var a) -> StateT SCState Identity Ident -> SCM (Var a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> StateT SCState Identity Ident
checkVar String
what Ident
v
checkVar :: String -> Ident -> SCM Ident
checkVar :: String -> Ident -> StateT SCState Identity Ident
checkVar _what :: String
_what v :: Ident
v = do
Ident -> StateT SCState Identity Ident
renameVar Ident
v
renameVar :: Ident -> SCM Ident
renameVar :: Ident -> StateT SCState Identity Ident
renameVar v :: Ident
v = Ident -> Integer -> Ident
renameIdent Ident
v (Integer -> Ident) -> SCM Integer -> StateT SCState Identity Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
getScopeId
checkEquationsLhs :: SpanInfo -> [Equation ()] -> SCM (Decl ())
checkEquationsLhs :: SpanInfo -> [Equation ()] -> StateT SCState Identity (Decl ())
checkEquationsLhs p :: SpanInfo
p [Equation p' :: SpanInfo
p' lhs :: Lhs ()
lhs rhs :: Rhs ()
rhs] = do
Either (Ident, Lhs ()) (Pattern ())
lhs' <- SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs SpanInfo
p' Lhs ()
lhs
case Either (Ident, Lhs ()) (Pattern ())
lhs' of
Left l :: (Ident, Lhs ())
l -> Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl () -> StateT SCState Identity (Decl ()))
-> Decl () -> StateT SCState Identity (Decl ())
forall a b. (a -> b) -> a -> b
$ (Ident, Lhs ()) -> Decl ()
funDecl' (Ident, Lhs ())
l
Right r :: Pattern ()
r -> Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs (SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p' Pattern ()
r Rhs ()
rhs)
where funDecl' :: (Ident, Lhs ()) -> Decl ()
funDecl' (f :: Ident
f, lhs' :: Lhs ()
lhs') = SpanInfo -> () -> Ident -> [Equation ()] -> Decl ()
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p () Ident
f [SpanInfo -> Lhs () -> Rhs () -> Equation ()
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p' Lhs ()
lhs' Rhs ()
rhs]
checkEquationsLhs _ _ = String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkEquationsLhs"
checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs pspi :: SpanInfo
pspi toplhs :: Lhs ()
toplhs = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
Integer
k <- SCM Integer
getScopeId
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case Lhs ()
toplhs of
FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern ()]
ts
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
f NestEnv RenameInfo
env -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
| Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
globalScopeId -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall a. Either a (Pattern ())
right
| [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
infos -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
| Bool
otherwise -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Message
errToplevelPattern SpanInfo
pspi
Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall a. Either a (Pattern ())
right
where f' :: Ident
f' = Ident -> Integer -> Ident
renameIdent Ident
f Integer
k
infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) NestEnv RenameInfo
env
left :: Either (Ident, Lhs ()) b
left = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left (Ident
f', SpanInfo -> Ident -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f' [Pattern ()]
ts)
right :: Either a (Pattern ())
right = Pattern () -> Either a (Pattern ())
forall a b. b -> Either a b
Right (Pattern () -> Either a (Pattern ()))
-> Pattern () -> Either a (Pattern ())
forall a b. (a -> b) -> a -> b
$
Pattern () -> Pattern ()
forall a. HasSpanInfo a => a -> a
updateEndPos (Pattern () -> Pattern ()) -> Pattern () -> Pattern ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () (Ident -> QualIdent
qualify Ident
f) [Pattern ()]
ts
OpLhs spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: Ident
op t2 :: Pattern ()
t2
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
op NestEnv RenameInfo
env -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
| Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
globalScopeId -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
right
| [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
infos -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
| Bool
otherwise -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Message
errToplevelPattern SpanInfo
pspi
Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
right
where op' :: Ident
op' = Ident -> Integer -> Ident
renameIdent Ident
op Integer
k
infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
op) NestEnv RenameInfo
env
left :: Either (Ident, Lhs ()) b
left = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left (Ident
op', SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi Pattern ()
t1 Ident
op' Pattern ()
t2)
right :: Either (Ident, Lhs ()) (Pattern ())
right = Integer
-> NestEnv RenameInfo
-> (Pattern () -> Pattern ())
-> Pattern ()
-> Either (Ident, Lhs ()) (Pattern ())
forall a.
Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs Integer
k NestEnv RenameInfo
env (Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t1 (Ident -> QualIdent
qualify Ident
op)) Pattern ()
t2
infixPattern :: Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern (InfixPattern _ a' :: ()
a' t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2') op2 :: QualIdent
op2 t3 :: Pattern ()
t3 =
let t2'' :: Pattern ()
t2'' = Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t2' QualIdent
op2 Pattern ()
t3
sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2'')
in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) ()
a' Pattern ()
t1' QualIdent
op1 Pattern ()
t2''
infixPattern t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2' =
let sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2')
in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) () Pattern ()
t1' QualIdent
op1 Pattern ()
t2'
ApLhs spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts -> do
Either (Ident, Lhs ()) (Pattern ())
checked <- SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs SpanInfo
pspi Lhs ()
lhs
case Either (Ident, Lhs ()) (Pattern ())
checked of
Left (f' :: Ident
f', lhs' :: Lhs ()
lhs') -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ (Ident, Lhs ()) -> Either (Ident, Lhs ()) (Pattern ())
forall a b. a -> Either a b
Left (Ident
f', Lhs () -> Lhs ()
forall a. HasSpanInfo a => a -> a
updateEndPos (Lhs () -> Lhs ()) -> Lhs () -> Lhs ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi Lhs ()
lhs' [Pattern ()]
ts)
r :: Either (Ident, Lhs ()) (Pattern ())
r -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> Message
errNonVariable "curried definition" Ident
f
Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ Either (Ident, Lhs ()) (Pattern ())
r
where (f :: Ident
f, _) = Lhs () -> (Ident, [Pattern ()])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs ()
lhs
checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a)
-> Pattern a -> Either (Ident, Lhs a) (Pattern a)
checkOpLhs :: Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs k :: Integer
k env :: NestEnv RenameInfo
env f :: Pattern a -> Pattern a
f (InfixPattern spi :: SpanInfo
spi a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2)
| Maybe ModuleIdent -> Bool
forall a. Maybe a -> Bool
isJust Maybe ModuleIdent
m Bool -> Bool -> Bool
|| Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
op' NestEnv RenameInfo
env
= Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
forall a.
Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs Integer
k NestEnv RenameInfo
env (Pattern a -> Pattern a
f (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi a
a Pattern a
t1 QualIdent
op) Pattern a
t2
| Bool
otherwise
= (Ident, Lhs a) -> Either (Ident, Lhs a) (Pattern a)
forall a b. a -> Either a b
Left (Ident
op'', SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs (Pattern a -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo Pattern a
t1') Pattern a
t1' Ident
op'' Pattern a
t2)
where (m :: Maybe ModuleIdent
m,op' :: Ident
op') = (QualIdent -> Maybe ModuleIdent
qidModule QualIdent
op, QualIdent -> Ident
qidIdent QualIdent
op)
op'' :: Ident
op'' = Ident -> Integer -> Ident
renameIdent Ident
op' Integer
k
t1' :: Pattern a
t1' = Pattern a -> Pattern a
f Pattern a
t1
checkOpLhs _ _ f :: Pattern a -> Pattern a
f t :: Pattern a
t = Pattern a -> Either (Ident, Lhs a) (Pattern a)
forall a b. b -> Either a b
Right (Pattern a -> Pattern a
f Pattern a
t)
joinEquations :: [Decl a] -> SCM [Decl a]
joinEquations :: [Decl a] -> SCM [Decl a]
joinEquations [] = [Decl a] -> SCM [Decl a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
joinEquations (FunctionDecl a :: SpanInfo
a p :: a
p f :: Ident
f eqs :: [Equation a]
eqs : FunctionDecl _ _ f' :: Ident
f' [eq :: Equation a
eq] : ds :: [Decl a]
ds)
| Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
f' = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Equation a -> Int
forall a. Equation a -> Int
getArity ([Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Equation a -> Int
forall a. Equation a -> Int
getArity Equation a
eq) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [Ident] -> Message
errDifferentArity [Ident
f, Ident
f']
[Decl a] -> SCM [Decl a]
forall a. [Decl a] -> SCM [Decl a]
joinEquations (Decl a -> Decl a
forall a. HasSpanInfo a => a -> a
updateEndPos (SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
a a
p Ident
f ([Equation a]
eqs [Equation a] -> [Equation a] -> [Equation a]
forall a. [a] -> [a] -> [a]
++ [Equation a
eq])) Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a]
ds)
where getArity :: Equation a -> Int
getArity = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int)
-> (Equation a -> [Pattern a]) -> Equation a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Equation a -> (Ident, [Pattern a]))
-> Equation a
-> [Pattern a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs
joinEquations (d :: Decl a
d : ds :: [Decl a]
ds) = (Decl a
d Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:) ([Decl a] -> [Decl a]) -> SCM [Decl a] -> SCM [Decl a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> SCM [Decl a]
forall a. [Decl a] -> SCM [Decl a]
joinEquations [Decl a]
ds
checkDecls :: (Decl () -> RenameEnv -> RenameEnv) -> [Decl ()] -> SCM [Decl ()]
checkDecls :: (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDecls bindDecl :: Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl ds :: [Decl ()]
ds = do
let dblVar :: Maybe Ident
dblVar = [Ident] -> Maybe Ident
forall a. Eq a => [a] -> Maybe a
findDouble [Ident]
bvs
(Ident -> SCM ()) -> Maybe Ident -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errDuplicateDefinition) Maybe Ident
dblVar
let mulTys :: [[Ident]]
mulTys = [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
tys
([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateTypeSig) [[Ident]]
mulTys
let missingTys :: [Ident]
missingTys = [Ident
v | ExternalDecl _ vs :: [Var ()]
vs <- [Decl ()]
ds, Var _ v :: Ident
v <- [Var ()]
vs, Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
tys]
(Ident -> SCM ()) -> [Ident] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errNoTypeSig) [Ident]
missingTys
if Maybe Ident -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Ident
dblVar Bool -> Bool -> Bool
&& [[Ident]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Ident]]
mulTys Bool -> Bool -> Bool
&& [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
missingTys
then do
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \env :: NestEnv RenameInfo
env -> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Decl ()] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl NestEnv RenameInfo
env ([Decl ()]
tds [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
vds)
(Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> Decl () -> StateT SCState Identity (Decl ())
checkDeclRhs [Ident]
bvs) [Decl ()]
ds
else [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl ()]
ds
where vds :: [Decl ()]
vds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl ()]
ds
tds :: [Decl ()]
tds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeSig [Decl ()]
ds
bvs :: [Ident]
bvs = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
vds
tys :: [Ident]
tys = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
tds
onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok
checkDeclRhs :: [Ident] -> Decl () -> SCM (Decl ())
checkDeclRhs :: [Ident] -> Decl () -> StateT SCState Identity (Decl ())
checkDeclRhs _ (DataDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) =
([ConstrDecl] -> [QualIdent] -> Decl ())
-> [QualIdent] -> [ConstrDecl] -> Decl ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl ()
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs) [QualIdent]
clss ([ConstrDecl] -> Decl ())
-> StateT SCState Identity [ConstrDecl]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConstrDecl -> StateT SCState Identity ConstrDecl)
-> [ConstrDecl] -> StateT SCState Identity [ConstrDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT SCState Identity ConstrDecl
checkDeclLabels [ConstrDecl]
cs
checkDeclRhs bvs :: [Ident]
bvs (TypeSig p :: SpanInfo
p vs :: [Ident]
vs ty :: QualTypeExpr
ty) =
(\vs' :: [Ident]
vs' -> SpanInfo -> [Ident] -> QualTypeExpr -> Decl ()
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident]
vs' QualTypeExpr
ty) ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> Ident -> StateT SCState Identity Ident
checkLocalVar [Ident]
bvs) [Ident]
vs
checkDeclRhs _ (FunctionDecl a :: SpanInfo
a p :: ()
p f :: Ident
f eqs :: [Equation ()]
eqs) =
SpanInfo -> () -> Ident -> [Equation ()] -> Decl ()
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
a ()
p Ident
f ([Equation ()] -> Decl ())
-> StateT SCState Identity [Equation ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident
-> StateT SCState Identity [Equation ()]
-> StateT SCState Identity [Equation ()]
forall a. Ident -> SCM a -> SCM a
inFunc Ident
f ((Equation () -> StateT SCState Identity (Equation ()))
-> [Equation ()] -> StateT SCState Identity [Equation ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation () -> StateT SCState Identity (Equation ())
checkEquation [Equation ()]
eqs)
checkDeclRhs _ (PatternDecl p :: SpanInfo
p t :: Pattern ()
t rhs :: Rhs ()
rhs) =
SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern ()
t (Rhs () -> Decl ())
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs
checkDeclRhs _ d :: Decl ()
d = Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
d
checkDeclLabels :: ConstrDecl -> SCM ConstrDecl
checkDeclLabels :: ConstrDecl -> StateT SCState Identity ConstrDecl
checkDeclLabels rd :: ConstrDecl
rd@(RecordDecl _ _ fs :: [FieldDecl]
fs) = do
(QualIdent -> SCM ()) -> Maybe QualIdent -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QualIdent -> Message
errDuplicateLabel "declaration")
([QualIdent] -> Maybe QualIdent
forall a. Eq a => [a] -> Maybe a
findDouble ([QualIdent] -> Maybe QualIdent) -> [QualIdent] -> Maybe QualIdent
forall a b. (a -> b) -> a -> b
$ (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> QualIdent
qualify [Ident]
labels)
ConstrDecl -> StateT SCState Identity ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDecl
rd
where
onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok
labels :: [Ident]
labels = [Ident
l | FieldDecl _ ls :: [Ident]
ls _ <- [FieldDecl]
fs, Ident
l <- [Ident]
ls]
checkDeclLabels d :: ConstrDecl
d = ConstrDecl -> StateT SCState Identity ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDecl
d
checkLocalVar :: [Ident] -> Ident -> SCM Ident
checkLocalVar :: [Ident] -> Ident -> StateT SCState Identity Ident
checkLocalVar bvs :: [Ident]
bvs v :: Ident
v = do
Bool
tcc <- SCM Bool
isTypeClassesCheck
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
bvs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tcc) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ Ident -> Message
errNoBody Ident
v
Ident -> StateT SCState Identity Ident
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
v
checkEquation :: Equation () -> SCM (Equation ())
checkEquation :: Equation () -> StateT SCState Identity (Equation ())
checkEquation (Equation p :: SpanInfo
p lhs :: Lhs ()
lhs rhs :: Rhs ()
rhs) = StateT SCState Identity (Equation ())
-> StateT SCState Identity (Equation ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Equation ())
-> StateT SCState Identity (Equation ()))
-> StateT SCState Identity (Equation ())
-> StateT SCState Identity (Equation ())
forall a b. (a -> b) -> a -> b
$ do
Lhs ()
lhs' <- SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs SpanInfo
p Lhs ()
lhs SCM (Lhs ()) -> (Lhs () -> SCM (Lhs ())) -> SCM (Lhs ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Lhs () -> SCM (Lhs ())
forall t. QuantExpr t => Bool -> t -> SCM t
addBoundVariables Bool
False
Rhs ()
rhs' <- Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs
Equation () -> StateT SCState Identity (Equation ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Equation () -> StateT SCState Identity (Equation ()))
-> Equation () -> StateT SCState Identity (Equation ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs () -> Rhs () -> Equation ()
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs ()
lhs' Rhs ()
rhs'
checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs p :: SpanInfo
p (FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern ()]
ts) = SpanInfo -> Ident -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f ([Pattern ()] -> Lhs ())
-> StateT SCState Identity [Pattern ()] -> SCM (Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkLhs p :: SpanInfo
p (OpLhs spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: Ident
op t2 :: Pattern ()
t2) = do
let wrongCalls :: [(QualIdent, QualIdent)]
wrongCalls = (Pattern () -> [(QualIdent, QualIdent)])
-> [Pattern ()] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern () -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just (QualIdent -> Maybe QualIdent) -> QualIdent -> Maybe QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
op)) [Pattern ()
t1,Pattern ()
t2]
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(QualIdent, QualIdent)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(QualIdent, QualIdent)]
wrongCalls) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens
SpanInfo
spi [(QualIdent, QualIdent)]
wrongCalls
(Pattern () -> Ident -> Pattern () -> Lhs ())
-> Ident -> Pattern () -> Pattern () -> Lhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi) Ident
op (Pattern () -> Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1 StateT SCState Identity (Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ()) -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
checkLhs p :: SpanInfo
p (ApLhs spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts) =
SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi (Lhs () -> [Pattern ()] -> Lhs ())
-> SCM (Lhs ()) -> StateT SCState Identity ([Pattern ()] -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs SpanInfo
p Lhs ()
lhs StateT SCState Identity ([Pattern ()] -> Lhs ())
-> StateT SCState Identity [Pattern ()] -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern _ (LiteralPattern _ _ _) = []
checkParenPattern _ (NegativePattern _ _ _) = []
checkParenPattern _ (VariablePattern _ _ _) = []
checkParenPattern _ (ConstructorPattern _ _ _ cs :: [Pattern a]
cs) =
(Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
cs
checkParenPattern o :: Maybe QualIdent
o (InfixPattern _ _ t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) =
[(QualIdent, QualIdent)]
-> (QualIdent -> [(QualIdent, QualIdent)])
-> Maybe QualIdent
-> [(QualIdent, QualIdent)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\c :: QualIdent
c -> [(QualIdent
c, QualIdent
op)]) Maybe QualIdent
o
[(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t1 [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t2
checkParenPattern _ (ParenPattern _ t :: Pattern a
t) =
Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t
checkParenPattern _ (RecordPattern _ _ _ fs :: [Field (Pattern a)]
fs) =
(Field (Pattern a) -> [(QualIdent, QualIdent)])
-> [Field (Pattern a)] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Field _ _ t :: Pattern a
t) -> Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t) [Field (Pattern a)]
fs
checkParenPattern _ (TuplePattern _ ts :: [Pattern a]
ts) =
(Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern _ (ListPattern _ _ ts :: [Pattern a]
ts) =
(Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern o :: Maybe QualIdent
o (AsPattern _ _ t :: Pattern a
t) =
Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
o Pattern a
t
checkParenPattern o :: Maybe QualIdent
o (LazyPattern _ t :: Pattern a
t) =
Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
o Pattern a
t
checkParenPattern _ (FunctionPattern _ _ _ ts :: [Pattern a]
ts) =
(Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern o :: Maybe QualIdent
o (InfixFuncPattern _ _ t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) =
[(QualIdent, QualIdent)]
-> (QualIdent -> [(QualIdent, QualIdent)])
-> Maybe QualIdent
-> [(QualIdent, QualIdent)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\c :: QualIdent
c -> [(QualIdent
c, QualIdent
op)]) Maybe QualIdent
o
[(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t1 [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t2
checkPattern :: SpanInfo -> Pattern () -> SCM (Pattern ())
checkPattern :: SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern _ (LiteralPattern spi :: SpanInfo
spi a :: ()
a l :: Literal
l) =
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Pattern ()
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
spi ()
a Literal
l
checkPattern _ (NegativePattern spi :: SpanInfo
spi a :: ()
a l :: Literal
l) =
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Pattern ()
forall a. SpanInfo -> a -> Literal -> Pattern a
NegativePattern SpanInfo
spi ()
a Literal
l
checkPattern p :: SpanInfo
p (VariablePattern spi :: SpanInfo
spi a :: ()
a v :: Ident
v)
| Ident -> Bool
isAnonId Ident
v = SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi ()
a (Ident -> Pattern ())
-> (Integer -> Ident) -> Integer -> Pattern ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Integer -> Ident
renameIdent Ident
v (Integer -> Pattern ())
-> SCM Integer -> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
newId
| Bool
otherwise = SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern SpanInfo
p SpanInfo
spi (Ident -> QualIdent
qualify Ident
v) []
checkPattern p :: SpanInfo
p (ConstructorPattern spi :: SpanInfo
spi _ c :: QualIdent
c ts :: [Pattern ()]
ts) =
SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern SpanInfo
p SpanInfo
spi QualIdent
c [Pattern ()]
ts
checkPattern p :: SpanInfo
p (InfixPattern spi :: SpanInfo
spi _ t1 :: Pattern ()
t1 op :: QualIdent
op t2 :: Pattern ()
t2) =
SpanInfo
-> SpanInfo
-> Pattern ()
-> QualIdent
-> Pattern ()
-> StateT SCState Identity (Pattern ())
checkInfixPattern SpanInfo
p SpanInfo
spi Pattern ()
t1 QualIdent
op Pattern ()
t2
checkPattern p :: SpanInfo
p (ParenPattern spi :: SpanInfo
spi t :: Pattern ()
t) =
SpanInfo -> Pattern () -> Pattern ()
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
spi (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkPattern p :: SpanInfo
p (RecordPattern spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Pattern ())]
fs) =
SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Pattern ())]
-> StateT SCState Identity (Pattern ())
checkRecordPattern SpanInfo
p SpanInfo
spi QualIdent
c [Field (Pattern ())]
fs
checkPattern p :: SpanInfo
p (TuplePattern spi :: SpanInfo
spi ts :: [Pattern ()]
ts) =
SpanInfo -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
spi ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkPattern p :: SpanInfo
p (ListPattern spi :: SpanInfo
spi a :: ()
a ts :: [Pattern ()]
ts) =
SpanInfo -> () -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
spi ()
a ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkPattern p :: SpanInfo
p (AsPattern spi :: SpanInfo
spi v :: Ident
v t :: Pattern ()
t) =
SpanInfo -> Ident -> Pattern () -> Pattern ()
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
spi (Ident -> Pattern () -> Pattern ())
-> StateT SCState Identity Ident
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> StateT SCState Identity Ident
checkVar "@ pattern" Ident
v StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkPattern p :: SpanInfo
p (LazyPattern spi :: SpanInfo
spi t :: Pattern ()
t) = do
Pattern ()
t' <- SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
String -> SpanInfo -> Pattern () -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm "lazy pattern" SpanInfo
p Pattern ()
t'
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo -> Pattern () -> Pattern ()
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
spi Pattern ()
t')
checkPattern _ (FunctionPattern _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError
"SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern _ _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError
"SyntaxCheck.checkPattern: infix function pattern not defined"
checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()]
-> SCM (Pattern ())
checkConstructorPattern :: SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern p :: SpanInfo
p spi :: SpanInfo
spi c :: QualIdent
c ts :: [Pattern ()]
ts = do
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
Integer
k <- SCM Integer
getScopeId
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
[Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons QualIdent
c Int
n
[r :: RenameInfo
r] -> RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun RenameInfo
r Integer
k
rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) NestEnv RenameInfo
env of
[Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) Int
n
[r :: RenameInfo
r] -> RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun RenameInfo
r Integer
k
[]
| [Pattern ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern ()]
ts Bool -> Bool -> Bool
&& Bool -> Bool
not (QualIdent -> Bool
isQualified QualIdent
c) ->
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi () (Ident -> Pattern ()) -> Ident -> Pattern ()
forall a b. (a -> b) -> a -> b
$ Ident -> Integer -> Ident
renameIdent (QualIdent -> Ident
unqualify QualIdent
c) Integer
k
| [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs -> do
[Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
c
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
c [Pattern ()]
ts'
_ -> do [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
c
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
c [Pattern ()]
ts'
where
n' :: Int
n' = [Pattern ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern ()]
ts
processCons :: QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons qc :: QualIdent
qc n :: Int
n = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n') (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Int -> Int -> Message
errWrongArity QualIdent
c Int
n Int
n'
SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
qc ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
processVarFun :: RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun r :: RenameInfo
r k :: Integer
k
| [Pattern ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern ()]
ts Bool -> Bool -> Bool
&& Bool -> Bool
not (QualIdent -> Bool
isQualified QualIdent
c)
= Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi () (Ident -> Pattern ()) -> Ident -> Pattern ()
forall a b. (a -> b) -> a -> b
$ Ident -> Integer -> Ident
renameIdent (QualIdent -> Ident
unqualify QualIdent
c) Integer
k
| Bool
otherwise = do
SpanInfo -> SCM ()
checkFuncPatsExtension SpanInfo
p
RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall RenameInfo
r QualIdent
c
[Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
(Pattern () -> SCM ()) -> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern () -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern ()]
ts'
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi () (RenameInfo -> QualIdent
qualVarIdent RenameInfo
r) [Pattern ()]
ts'
checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern ()
-> SCM (Pattern ())
checkInfixPattern :: SpanInfo
-> SpanInfo
-> Pattern ()
-> QualIdent
-> Pattern ()
-> StateT SCState Identity (Pattern ())
checkInfixPattern p :: SpanInfo
p spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: QualIdent
op t2 :: Pattern ()
t2 = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
op NestEnv RenameInfo
env of
[Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern QualIdent
op Int
n
[r :: RenameInfo
r] -> RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern RenameInfo
r QualIdent
op
rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op) NestEnv RenameInfo
env of
[Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op) Int
n
[r :: RenameInfo
r] -> RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern RenameInfo
r (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op)
rs' :: [RenameInfo]
rs' -> do if [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs'
then Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
op
else Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
op
(Pattern () -> QualIdent -> Pattern () -> Pattern ())
-> QualIdent -> Pattern () -> Pattern () -> Pattern ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi ()) QualIdent
op (Pattern () -> Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1
StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
where
infixPattern :: QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern qop :: QualIdent
qop n :: Int
n = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 2) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Int -> Int -> Message
errWrongArity QualIdent
op Int
n 2
(Pattern () -> QualIdent -> Pattern () -> Pattern ())
-> QualIdent -> Pattern () -> Pattern () -> Pattern ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi ()) QualIdent
qop (Pattern () -> Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1 StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
funcPattern :: RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern r :: RenameInfo
r qop :: QualIdent
qop = do
SpanInfo -> SCM ()
checkFuncPatsExtension SpanInfo
p
RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall RenameInfo
r QualIdent
qop
[Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()
t1,Pattern ()
t2]
let [t1' :: Pattern ()
t1',t2' :: Pattern ()
t2'] = [Pattern ()]
ts'
(Pattern () -> SCM ()) -> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern () -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern ()]
ts'
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
spi () Pattern ()
t1' QualIdent
qop Pattern ()
t2'
checkRecordPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Pattern ())]
-> SCM (Pattern ())
checkRecordPattern :: SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Pattern ())]
-> StateT SCState Identity (Pattern ())
checkRecordPattern p :: SpanInfo
p spi :: SpanInfo
spi c :: QualIdent
c fs :: [Field (Pattern ())]
fs = do
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
[Constr c' :: QualIdent
c' _] -> Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
c') [Field (Pattern ())]
fs
rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) NestEnv RenameInfo
env of
[Constr c' :: QualIdent
c' _] -> Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
c') [Field (Pattern ())]
fs
rs' :: [RenameInfo]
rs' -> if [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs'
then do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
c
Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat Maybe QualIdent
forall a. Maybe a
Nothing [Field (Pattern ())]
fs
else do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
c
Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat Maybe QualIdent
forall a. Maybe a
Nothing [Field (Pattern ())]
fs
where
processRecPat :: Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat mcon :: Maybe QualIdent
mcon fields :: [Field (Pattern ())]
fields = do
[Field (Pattern ())]
fs' <- (Field (Pattern ())
-> StateT SCState Identity (Field (Pattern ())))
-> [Field (Pattern ())]
-> StateT SCState Identity [Field (Pattern ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Pattern () -> StateT SCState Identity (Pattern ()))
-> Field (Pattern ())
-> StateT SCState Identity (Field (Pattern ()))
forall a. (a -> SCM a) -> Field a -> SCM (Field a)
checkField (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p)) [Field (Pattern ())]
fields
String
-> SpanInfo -> Maybe QualIdent -> [Field (Pattern ())] -> SCM ()
forall a.
String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels "pattern" SpanInfo
p Maybe QualIdent
mcon [Field (Pattern ())]
fs'
Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Field (Pattern ())] -> Pattern ()
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
spi () QualIdent
c [Field (Pattern ())]
fs'
checkFuncPatCall :: RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall :: RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall r :: RenameInfo
r f :: QualIdent
f = case RenameInfo
r of
GlobalVar dep :: QualIdent
dep _ -> do
QualIdent -> SCM ()
addGlobalDep QualIdent
dep
QualIdent -> SCM ()
addFuncPat (QualIdent
dep QualIdent -> QualIdent -> QualIdent
forall a b. (HasPosition a, HasPosition b) => a -> b -> a
@> QualIdent
f)
_ -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errFuncPatNotGlobal QualIdent
f
checkRhs :: Rhs () -> SCM (Rhs ())
checkRhs :: Rhs () -> StateT SCState Identity (Rhs ())
checkRhs (SimpleRhs spi :: SpanInfo
spi li :: LayoutInfo
li e :: Expression ()
e ds :: [Decl ()]
ds) = StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ()))
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a b. (a -> b) -> a -> b
$
(Expression () -> [Decl ()] -> Rhs ())
-> [Decl ()] -> Expression () -> Rhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> LayoutInfo -> Expression () -> [Decl ()] -> Rhs ()
forall a.
SpanInfo -> LayoutInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
spi LayoutInfo
li) ([Decl ()] -> Expression () -> Rhs ())
-> SCM [Decl ()]
-> StateT SCState Identity (Expression () -> Rhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity (Expression () -> Rhs ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Rhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
e
checkRhs (GuardedRhs spi :: SpanInfo
spi li :: LayoutInfo
li es :: [CondExpr ()]
es ds :: [Decl ()]
ds) = StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ()))
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a b. (a -> b) -> a -> b
$
([CondExpr ()] -> [Decl ()] -> Rhs ())
-> [Decl ()] -> [CondExpr ()] -> Rhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> LayoutInfo -> [CondExpr ()] -> [Decl ()] -> Rhs ()
forall a.
SpanInfo -> LayoutInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi LayoutInfo
li) ([Decl ()] -> [CondExpr ()] -> Rhs ())
-> SCM [Decl ()]
-> StateT SCState Identity ([CondExpr ()] -> Rhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity ([CondExpr ()] -> Rhs ())
-> StateT SCState Identity [CondExpr ()]
-> StateT SCState Identity (Rhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
(CondExpr () -> StateT SCState Identity (CondExpr ()))
-> [CondExpr ()] -> StateT SCState Identity [CondExpr ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CondExpr () -> StateT SCState Identity (CondExpr ())
checkCondExpr [CondExpr ()]
es
checkCondExpr :: CondExpr () -> SCM (CondExpr ())
checkCondExpr :: CondExpr () -> StateT SCState Identity (CondExpr ())
checkCondExpr (CondExpr spi :: SpanInfo
spi g :: Expression ()
g e :: Expression ()
e) = SpanInfo -> Expression () -> Expression () -> CondExpr ()
forall a. SpanInfo -> Expression a -> Expression a -> CondExpr a
CondExpr SpanInfo
spi (Expression () -> Expression () -> CondExpr ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> CondExpr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
g StateT SCState Identity (Expression () -> CondExpr ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (CondExpr ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
e
checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())
checkExpr :: SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr _ (Literal spi :: SpanInfo
spi a :: ()
a l :: Literal
l) = Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Expression ()
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
spi ()
a Literal
l
checkExpr _ (Variable spi :: SpanInfo
spi a :: ()
a v :: QualIdent
v) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
v
checkExpr _ (Constructor spi :: SpanInfo
spi a :: ()
a c :: QualIdent
c) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
c
checkExpr p :: SpanInfo
p (Paren spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
spi (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Typed spi :: SpanInfo
spi e :: Expression ()
e ty :: QualTypeExpr
ty) = (Expression () -> QualTypeExpr -> Expression ())
-> QualTypeExpr -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> QualTypeExpr -> Expression ()
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
ty (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Record spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordExpr SpanInfo
p SpanInfo
spi QualIdent
c [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (RecordUpdate spi :: SpanInfo
spi e :: Expression ()
e fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> Expression ()
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordUpdExpr SpanInfo
p SpanInfo
spi Expression ()
e [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (Tuple spi :: SpanInfo
spi es :: [Expression ()]
es) = SpanInfo -> [Expression ()] -> Expression ()
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
spi ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (List spi :: SpanInfo
spi a :: ()
a es :: [Expression ()]
es) = SpanInfo -> () -> [Expression ()] -> Expression ()
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
spi ()
a ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (ListCompr spi :: SpanInfo
spi e :: Expression ()
e qs :: [Statement ()]
qs) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ (Expression () -> [Statement ()] -> Expression ())
-> [Statement ()] -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> [Statement ()] -> Expression ()
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
spi) ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Statement () -> StateT SCState Identity (Statement ()))
-> [Statement ()] -> StateT SCState Identity [Statement ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement "list comprehension" SpanInfo
p) [Statement ()]
qs StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (EnumFrom spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
EnumFrom SpanInfo
spi (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (EnumFromThen spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromThen SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (EnumFromTo spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromTo SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (EnumFromThenTo spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2 e3 :: Expression ()
e3) =
SpanInfo
-> Expression () -> Expression () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
EnumFromThenTo SpanInfo
spi (Expression () -> Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
SCState Identity (Expression () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
SCState Identity (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e3
checkExpr p :: SpanInfo
p (UnaryMinus spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Apply spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (InfixApply spi :: SpanInfo
spi e1 :: Expression ()
e1 op :: InfixOp ()
op e2 :: Expression ()
e2) =
SpanInfo
-> Expression () -> InfixOp () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi (Expression () -> InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
SCState Identity (InfixOp () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
SCState Identity (InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (LeftSection spi :: SpanInfo
spi e :: Expression ()
e op :: InfixOp ()
op) =
SpanInfo -> Expression () -> InfixOp () -> Expression ()
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi (Expression () -> InfixOp () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (InfixOp () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity (InfixOp () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op
checkExpr p :: SpanInfo
p (RightSection spi :: SpanInfo
spi op :: InfixOp ()
op e :: Expression ()
e) =
SpanInfo -> InfixOp () -> Expression () -> Expression ()
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi (InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Lambda spi :: SpanInfo
spi ts :: [Pattern ()]
ts e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> SpanInfo
-> [Pattern ()]
-> Expression ()
-> StateT SCState Identity (Expression ())
checkLambda SpanInfo
p SpanInfo
spi [Pattern ()]
ts Expression ()
e
checkExpr p :: SpanInfo
p (Let spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl ()]
ds e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
SpanInfo
-> LayoutInfo -> [Decl ()] -> Expression () -> Expression ()
forall a.
SpanInfo -> LayoutInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi LayoutInfo
li ([Decl ()] -> Expression () -> Expression ())
-> SCM [Decl ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Do spi :: SpanInfo
spi li :: LayoutInfo
li sts :: [Statement ()]
sts e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
SpanInfo
-> LayoutInfo -> [Statement ()] -> Expression () -> Expression ()
forall a.
SpanInfo
-> LayoutInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi LayoutInfo
li ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement () -> StateT SCState Identity (Statement ()))
-> [Statement ()] -> StateT SCState Identity [Statement ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement "do sequence" SpanInfo
p) [Statement ()]
sts StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (IfThenElse spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2 e3 :: Expression ()
e3) =
SpanInfo
-> Expression () -> Expression () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
spi (Expression () -> Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
SCState Identity (Expression () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
SCState Identity (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e3
checkExpr p :: SpanInfo
p (Case spi :: SpanInfo
spi li :: LayoutInfo
li ct :: CaseType
ct e :: Expression ()
e alts :: [Alt ()]
alts) =
SpanInfo
-> LayoutInfo
-> CaseType
-> Expression ()
-> [Alt ()]
-> Expression ()
forall a.
SpanInfo
-> LayoutInfo
-> CaseType
-> Expression a
-> [Alt a]
-> Expression a
Case SpanInfo
spi LayoutInfo
li CaseType
ct (Expression () -> [Alt ()] -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity ([Alt ()] -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity ([Alt ()] -> Expression ())
-> StateT SCState Identity [Alt ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt () -> StateT SCState Identity (Alt ()))
-> [Alt ()] -> StateT SCState Identity [Alt ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt () -> StateT SCState Identity (Alt ())
checkAlt [Alt ()]
alts
checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression ()
-> SCM (Expression ())
checkLambda :: SpanInfo
-> SpanInfo
-> [Pattern ()]
-> Expression ()
-> StateT SCState Identity (Expression ())
checkLambda p :: SpanInfo
p spi :: SpanInfo
spi ts :: [Pattern ()]
ts e :: Expression ()
e = case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples ([Pattern ()] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bvNoAnon [Pattern ()]
ts) of
[] -> do
[Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "lambda expression" SpanInfo
p) [Pattern ()]
ts
SpanInfo -> [Pattern ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern ()]
ts' (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
errVars :: [[Ident]]
errVars -> do
([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateVariables) [[Ident]]
errVars
let nubTs :: [Pattern ()]
nubTs = (Pattern () -> Pattern () -> Bool) -> [Pattern ()] -> [Pattern ()]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\t1 :: Pattern ()
t1 t2 :: Pattern ()
t2 -> (Bool -> Bool
not (Bool -> Bool) -> ([Ident] -> Bool) -> [Ident] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (([Ident] -> [Ident] -> [Ident])
-> (Pattern () -> [Ident]) -> Pattern () -> Pattern () -> [Ident]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [Ident] -> [Ident] -> [Ident]
forall a. Eq a => [a] -> [a] -> [a]
intersect Pattern () -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bvNoAnon Pattern ()
t1 Pattern ()
t2)) [Pattern ()]
ts
(Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "lambda expression" SpanInfo
p) [Pattern ()]
nubTs
SpanInfo -> [Pattern ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern ()]
ts (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
where
bvNoAnon :: e -> [Ident]
bvNoAnon t :: e
t = (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Ident -> Bool) -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Bool
isAnonId) ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ e -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv e
t
checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable spi :: SpanInfo
spi a :: a
a v :: QualIdent
v
| Ident -> Bool
isAnonId (QualIdent -> Ident
unqualify QualIdent
v) = do
SpanInfo -> SCM ()
checkAnonFreeVarsExtension (SpanInfo -> SCM ()) -> SpanInfo -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo QualIdent
v
(\n :: Integer
n -> SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a (QualIdent -> Expression a) -> QualIdent -> Expression a
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> ModuleIdent)
-> (Ident -> Ident) -> QualIdent -> QualIdent
updQualIdent ModuleIdent -> ModuleIdent
forall a. a -> a
id (Ident -> Integer -> Ident
`renameIdent` Integer
n) QualIdent
v) (Integer -> Expression a) -> SCM Integer -> SCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
newId
| Bool
otherwise = do
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
v NestEnv RenameInfo
env of
[] -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedVariable QualIdent
v
Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v
[Constr _ _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
spi a
a QualIdent
v
[GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (Expression a) -> SCM (Expression a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v)
[LocalVar v' :: Ident
v' _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a
(QualIdent -> Expression a) -> QualIdent -> Expression a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify
(Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> Ident -> Ident
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> a
spanInfoLike Ident
v' (QualIdent -> Ident
qidIdent QualIdent
v)
[RecordLabel _ _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v
rs :: [RenameInfo]
rs -> do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
v) NestEnv RenameInfo
env of
[] -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs QualIdent
v
Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v
[Constr _ _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
spi a
a QualIdent
v
[GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (Expression a) -> SCM (Expression a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v)
[LocalVar v' :: Ident
v' _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a
(QualIdent -> Expression a) -> QualIdent -> Expression a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify
(Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> Ident -> Ident
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> a
spanInfoLike Ident
v' (QualIdent -> Ident
qidIdent QualIdent
v)
[RecordLabel _ _] -> Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v
rs' :: [RenameInfo]
rs' -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs' QualIdent
v
Expression a -> SCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> SCM (Expression a))
-> Expression a -> SCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
v
checkRecordExpr :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Expression ())]
-> SCM (Expression ())
checkRecordExpr :: SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordExpr _ spi :: SpanInfo
spi c :: QualIdent
c [] = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
[Constr _ _] -> Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> QualIdent -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi () QualIdent
c []
rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) NestEnv RenameInfo
env of
[Constr _ _] -> Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> QualIdent -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi () QualIdent
c []
rs' :: [RenameInfo]
rs' -> if [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs'
then do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
c
Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> QualIdent -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi () QualIdent
c []
else do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
c
Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> QualIdent -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi () QualIdent
c []
checkRecordExpr p :: SpanInfo
p spi :: SpanInfo
spi c :: QualIdent
c fs :: [Field (Expression ())]
fs =
SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p (SpanInfo
-> Expression () -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo -> Expression a -> [Field (Expression a)] -> Expression a
RecordUpdate SpanInfo
spi (SpanInfo -> () -> QualIdent -> Expression ()
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor (QualIdent -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo QualIdent
c) () QualIdent
c)
[Field (Expression ())]
fs)
checkRecordUpdExpr :: SpanInfo -> SpanInfo -> Expression ()
-> [Field (Expression ())] -> SCM (Expression ())
checkRecordUpdExpr :: SpanInfo
-> SpanInfo
-> Expression ()
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordUpdExpr p :: SpanInfo
p spi :: SpanInfo
spi e :: Expression ()
e fs :: [Field (Expression ())]
fs = do
Expression ()
e' <- SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
[Field (Expression ())]
fs' <- (Field (Expression ())
-> StateT SCState Identity (Field (Expression ())))
-> [Field (Expression ())]
-> StateT SCState Identity [Field (Expression ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expression () -> StateT SCState Identity (Expression ()))
-> Field (Expression ())
-> StateT SCState Identity (Field (Expression ()))
forall a. (a -> SCM a) -> Field a -> SCM (Field a)
checkField (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p)) [Field (Expression ())]
fs
case Expression ()
e' of
Constructor _ a :: ()
a c :: QualIdent
c -> do String
-> SpanInfo -> Maybe QualIdent -> [Field (Expression ())] -> SCM ()
forall a.
String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels "construction" SpanInfo
p (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
c) [Field (Expression ())]
fs'
Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> QualIdent -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi ()
a QualIdent
c [Field (Expression ())]
fs'
_ -> do String
-> SpanInfo -> Maybe QualIdent -> [Field (Expression ())] -> SCM ()
forall a.
String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels "update" SpanInfo
p Maybe QualIdent
forall a. Maybe a
Nothing [Field (Expression ())]
fs'
Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression () -> [Field (Expression ())] -> Expression ()
forall a.
SpanInfo -> Expression a -> [Field (Expression a)] -> Expression a
RecordUpdate SpanInfo
spi Expression ()
e' [Field (Expression ())]
fs'
checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ())
checkStatement :: String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement _ p :: SpanInfo
p (StmtExpr spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Statement ()
forall a. SpanInfo -> Expression a -> Statement a
StmtExpr SpanInfo
spi (Expression () -> Statement ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkStatement s :: String
s p :: SpanInfo
p (StmtBind spi :: SpanInfo
spi t :: Pattern ()
t e :: Expression ()
e) =
(Pattern () -> Expression () -> Statement ())
-> Expression () -> Pattern () -> Statement ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern () -> Expression () -> Statement ()
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
spi) (Expression () -> Pattern () -> Statement ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Pattern () -> Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity (Pattern () -> Statement ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SCM ()
incNesting SCM ()
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern String
s SpanInfo
p Pattern ()
t)
checkStatement _ _ (StmtDecl spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl ()]
ds) =
SpanInfo -> LayoutInfo -> [Decl ()] -> Statement ()
forall a. SpanInfo -> LayoutInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi LayoutInfo
li ([Decl ()] -> Statement ())
-> SCM [Decl ()] -> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCM ()
incNesting SCM () -> SCM [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds)
bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ())
bindPattern :: String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern s :: String
s p :: SpanInfo
p t :: Pattern ()
t = do
Pattern ()
t' <- SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
String -> SpanInfo -> Pattern () -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern ()
t'
Bool -> Pattern () -> StateT SCState Identity (Pattern ())
forall t. QuantExpr t => Bool -> t -> SCM t
addBoundVariables Bool
True Pattern ()
t'
banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm _ _ (LiteralPattern _ _ _) = SCM ()
ok
banFPTerm _ _ (NegativePattern _ _ _) = SCM ()
ok
banFPTerm _ _ (VariablePattern _ _ _) = SCM ()
ok
banFPTerm s :: String
s p :: SpanInfo
p (ConstructorPattern _ _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (InfixPattern _ _ t1 :: Pattern a
t1 _ t2 :: Pattern a
t2) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a
t1, Pattern a
t2]
banFPTerm s :: String
s p :: SpanInfo
p (ParenPattern _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p (RecordPattern _ _ _ fs :: [Field (Pattern a)]
fs) = (Field (Pattern a) -> SCM ()) -> [Field (Pattern a)] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Field (Pattern a) -> SCM ()
forall a. Field (Pattern a) -> SCM ()
banFPTermField [Field (Pattern a)]
fs
where banFPTermField :: Field (Pattern a) -> SCM ()
banFPTermField (Field _ _ x :: Pattern a
x) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
x
banFPTerm s :: String
s p :: SpanInfo
p (TuplePattern _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (ListPattern _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (AsPattern _ _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p (LazyPattern _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p pat :: Pattern a
pat@(FunctionPattern _ _ _ _)
= Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern String
s SpanInfo
p Pattern a
pat
banFPTerm s :: String
s p :: SpanInfo
p pat :: Pattern a
pat@(InfixFuncPattern _ _ _ _ _)
= Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern String
s SpanInfo
p Pattern a
pat
checkOp :: InfixOp a -> SCM (InfixOp a)
checkOp :: InfixOp a -> SCM (InfixOp a)
checkOp op :: InfixOp a
op = do
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
v NestEnv RenameInfo
env of
[] -> Message -> SCM ()
report (QualIdent -> Message
errUndefinedVariable QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
[Constr _ _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixConstr a
a QualIdent
v
[GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a QualIdent
v)
[LocalVar v' :: Ident
v' _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a (QualIdent -> InfixOp a) -> QualIdent -> InfixOp a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
v'
rs :: [RenameInfo]
rs -> do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
v) NestEnv RenameInfo
env of
[] -> Message -> SCM ()
report ([RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
[Constr _ _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixConstr a
a QualIdent
v
[GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a QualIdent
v)
[LocalVar v' :: Ident
v' _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a (QualIdent -> InfixOp a) -> QualIdent -> InfixOp a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
v'
rs' :: [RenameInfo]
rs' -> Message -> SCM ()
report ([RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs' QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
where v :: QualIdent
v = InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op
a :: a
a = InfixOp a -> a
forall a. InfixOp a -> a
opAnnotation InfixOp a
op
checkAlt :: Alt () -> SCM (Alt ())
checkAlt :: Alt () -> StateT SCState Identity (Alt ())
checkAlt (Alt spi :: SpanInfo
spi t :: Pattern ()
t rhs :: Rhs ()
rhs) = StateT SCState Identity (Alt ())
-> StateT SCState Identity (Alt ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Alt ())
-> StateT SCState Identity (Alt ()))
-> StateT SCState Identity (Alt ())
-> StateT SCState Identity (Alt ())
forall a b. (a -> b) -> a -> b
$
SpanInfo -> Pattern () -> Rhs () -> Alt ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
spi (Pattern () -> Rhs () -> Alt ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Rhs () -> Alt ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "case expression" SpanInfo
spi Pattern ()
t StateT SCState Identity (Rhs () -> Alt ())
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Alt ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs
addBoundVariables :: (QuantExpr t) => Bool -> t -> SCM t
addBoundVariables :: Bool -> t -> SCM t
addBoundVariables checkDuplicates :: Bool
checkDuplicates ts :: t
ts = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkDuplicates (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ ([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateVariables)
([Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
bvs)
(NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ env :: NestEnv RenameInfo
env -> (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar NestEnv RenameInfo
env ([Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub [Ident]
bvs)
t -> SCM t
forall (m :: * -> *) a. Monad m => a -> m a
return t
ts
where bvs :: [Ident]
bvs = t -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv t
ts
checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels what :: String
what p :: SpanInfo
p c :: Maybe QualIdent
c fs :: [Field a]
fs = do
(QualIdent -> StateT SCState Identity [QualIdent])
-> [QualIdent] -> StateT SCState Identity [[QualIdent]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualIdent -> StateT SCState Identity [QualIdent]
checkFieldLabel [QualIdent]
ls' StateT SCState Identity [[QualIdent]]
-> ([[QualIdent]] -> SCM ()) -> SCM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo
-> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM ()
checkLabels SpanInfo
p Maybe QualIdent
c [QualIdent]
ls'
(QualIdent -> SCM ()) -> Maybe QualIdent -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QualIdent -> Message
errDuplicateLabel String
what) ([QualIdent] -> Maybe QualIdent
forall a. Eq a => [a] -> Maybe a
findDouble [QualIdent]
ls)
where ls :: [QualIdent]
ls = [QualIdent
l | Field _ l :: QualIdent
l _ <- [Field a]
fs]
ls' :: [QualIdent]
ls' = [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a]
nub [QualIdent]
ls
onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok
checkFieldLabel :: QualIdent -> SCM [QualIdent]
checkFieldLabel :: QualIdent -> StateT SCState Identity [QualIdent]
checkFieldLabel l :: QualIdent
l = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
l NestEnv RenameInfo
env of
[RecordLabel _ cs :: [QualIdent]
cs] -> [QualIdent] -> StateT SCState Identity [QualIdent]
forall (t :: * -> *) a.
Foldable t =>
t a -> StateT SCState Identity (t a)
processLabel [QualIdent]
cs
rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
l) NestEnv RenameInfo
env of
[RecordLabel _ cs :: [QualIdent]
cs] -> [QualIdent] -> StateT SCState Identity [QualIdent]
forall (t :: * -> *) a.
Foldable t =>
t a -> StateT SCState Identity (t a)
processLabel [QualIdent]
cs
rs' :: [RenameInfo]
rs' -> if ([RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs')
then do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedLabel QualIdent
l
[QualIdent] -> StateT SCState Identity [QualIdent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$
[RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
l)
[QualIdent] -> StateT SCState Identity [QualIdent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
processLabel :: t a -> StateT SCState Identity (t a)
processLabel cs' :: t a
cs' = do
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
cs') (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedLabel QualIdent
l
t a -> StateT SCState Identity (t a)
forall (m :: * -> *) a. Monad m => a -> m a
return t a
cs'
checkLabels :: SpanInfo -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]]
-> SCM ()
checkLabels :: SpanInfo
-> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM ()
checkLabels _ (Just c :: QualIdent
c) ls :: [QualIdent]
ls css :: [[QualIdent]]
css = do
NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
[Constr c' :: QualIdent
c' _] -> (QualIdent -> SCM ()) -> [QualIdent] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> QualIdent -> Message
errNoLabel QualIdent
c)
[QualIdent
l | (l :: QualIdent
l, cs :: [QualIdent]
cs) <- [QualIdent] -> [[QualIdent]] -> [(QualIdent, [QualIdent])]
forall a b. [a] -> [b] -> [(a, b)]
zip [QualIdent]
ls [[QualIdent]]
css, QualIdent
c' QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [QualIdent]
cs]
_ -> String -> SCM ()
forall a. String -> a
internalError (String -> SCM ()) -> String -> SCM ()
forall a b. (a -> b) -> a -> b
$
"Checks.SyntaxCheck.checkLabels: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c
checkLabels p :: SpanInfo
p Nothing ls :: [QualIdent]
ls css :: [[QualIdent]]
css
| Bool -> Bool
not ([QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([QualIdent] -> [QualIdent] -> [QualIdent])
-> [[QualIdent]] -> [QualIdent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [QualIdent] -> [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[QualIdent]]
css)) Bool -> Bool -> Bool
||
([QualIdent] -> Bool) -> [[QualIdent]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QualIdent]]
css = SCM ()
ok
| Bool
otherwise = Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [QualIdent] -> Message
errNoCommonCons SpanInfo
p [QualIdent]
ls
checkField :: (a -> SCM a) -> Field a -> SCM (Field a)
checkField :: (a -> SCM a) -> Field a -> SCM (Field a)
checkField check :: a -> SCM a
check (Field p :: SpanInfo
p l :: QualIdent
l x :: a
x) = SpanInfo -> QualIdent -> a -> Field a
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
l (a -> Field a) -> SCM a -> SCM (Field a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> SCM a
check a
x
constrs :: Decl a -> [Ident]
constrs :: Decl a -> [Ident]
constrs (DataDecl _ _ _ cs :: [ConstrDecl]
cs _) = (ConstrDecl -> Ident) -> [ConstrDecl] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ConstrDecl -> Ident
constrId [ConstrDecl]
cs
constrs (NewtypeDecl _ _ _ nc :: NewConstrDecl
nc _) = [NewConstrDecl -> Ident
nconstrId NewConstrDecl
nc]
constrs _ = []
vars :: Decl a -> [Ident]
vars :: Decl a -> [Ident]
vars (TypeSig _ fs :: [Ident]
fs _) = [Ident]
fs
vars (FunctionDecl _ _ f :: Ident
f _) = [Ident
f]
vars (ExternalDecl _ vs :: [Var a]
vs) = [Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
vs
vars (PatternDecl _ t :: Pattern a
t _) = Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t
vars (FreeDecl _ vs :: [Var a]
vs) = [Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
vs
vars _ = []
recLabels :: Decl a -> [Ident]
recLabels :: Decl a -> [Ident]
recLabels (DataDecl _ _ _ cs :: [ConstrDecl]
cs _) = (ConstrDecl -> [Ident]) -> [ConstrDecl] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstrDecl -> [Ident]
recordLabels [ConstrDecl]
cs
recLabels (NewtypeDecl _ _ _ nc :: NewConstrDecl
nc _) = NewConstrDecl -> [Ident]
nrecordLabels NewConstrDecl
nc
recLabels _ = []
sortFuncDecls :: [Decl a] -> [Decl a]
sortFuncDecls :: [Decl a] -> [Decl a]
sortFuncDecls = Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
forall a. Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
forall a. Set a
Set.empty []
where
sortFD :: Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD _ res :: [Decl a]
res [] = [Decl a] -> [Decl a]
forall a. [a] -> [a]
reverse [Decl a]
res
sortFD env :: Set Ident
env res :: [Decl a]
res (decl :: Decl a
decl : decls' :: [Decl a]
decls') = case Decl a
decl of
FunctionDecl _ _ ident :: Ident
ident _
| Ident
ident Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
env
-> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
env ((Decl a -> Decl a -> Ordering) -> Decl a -> [Decl a] -> [Decl a]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy Decl a -> Decl a -> Ordering
forall a. Decl a -> Decl a -> Ordering
cmpFuncDecl Decl a
decl [Decl a]
res) [Decl a]
decls'
| Bool
otherwise
-> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Ident
ident Set Ident
env) (Decl a
declDecl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:[Decl a]
res) [Decl a]
decls'
_ -> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
env (Decl a
declDecl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:[Decl a]
res) [Decl a]
decls'
cmpFuncDecl :: Decl a -> Decl a -> Ordering
cmpFuncDecl :: Decl a -> Decl a -> Ordering
cmpFuncDecl (FunctionDecl _ _ id1 :: Ident
id1 _) (FunctionDecl _ _ id2 :: Ident
id2 _)
| Ident
id1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
id2 = Ordering
EQ
| Bool
otherwise = Ordering
GT
cmpFuncDecl _ _ = Ordering
GT
isDataConstr :: Ident -> RenameEnv -> Bool
isDataConstr :: Ident -> NestEnv RenameInfo -> Bool
isDataConstr v :: Ident
v = (RenameInfo -> Bool) -> [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenameInfo -> Bool
isConstr ([RenameInfo] -> Bool)
-> (NestEnv RenameInfo -> [RenameInfo])
-> NestEnv RenameInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar Ident
v (NestEnv RenameInfo -> [RenameInfo])
-> (NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo
-> [RenameInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEnv RenameInfo -> NestEnv RenameInfo
forall a. TopEnv a -> NestEnv a
globalEnv (TopEnv RenameInfo -> NestEnv RenameInfo)
-> (NestEnv RenameInfo -> TopEnv RenameInfo)
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestEnv RenameInfo -> TopEnv RenameInfo
forall a. NestEnv a -> TopEnv a
toplevelEnv
isConstr :: RenameInfo -> Bool
isConstr :: RenameInfo -> Bool
isConstr (Constr _ _) = Bool
True
isConstr (GlobalVar _ _) = Bool
False
isConstr (LocalVar _ _) = Bool
False
isConstr (RecordLabel _ _) = Bool
False
isLabel :: RenameInfo -> Bool
isLabel :: RenameInfo -> Bool
isLabel (Constr _ _) = Bool
False
isLabel (GlobalVar _ _) = Bool
False
isLabel (LocalVar _ _) = Bool
False
isLabel (RecordLabel _ _) = Bool
True
qualVarIdent :: RenameInfo -> QualIdent
qualVarIdent :: RenameInfo -> QualIdent
qualVarIdent (GlobalVar v :: QualIdent
v _) = QualIdent
v
qualVarIdent (LocalVar v :: Ident
v _) = Ident -> QualIdent
qualify Ident
v
qualVarIdent _ = String -> QualIdent
forall a. String -> a
internalError "SyntaxCheck.qualVarIdent: no variable"
checkFPTerm :: SpanInfo -> Pattern a -> SCM ()
checkFPTerm :: SpanInfo -> Pattern a -> SCM ()
checkFPTerm _ (LiteralPattern _ _ _) = SCM ()
ok
checkFPTerm _ (NegativePattern _ _ _) = SCM ()
ok
checkFPTerm _ (VariablePattern _ _ _) = SCM ()
ok
checkFPTerm p :: SpanInfo
p (ConstructorPattern _ _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (InfixPattern _ _ t1 :: Pattern a
t1 _ t2 :: Pattern a
t2) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a
t1, Pattern a
t2]
checkFPTerm p :: SpanInfo
p (ParenPattern _ t :: Pattern a
t) = SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p (TuplePattern _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (ListPattern _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (AsPattern _ _ t :: Pattern a
t) = SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p t :: Pattern a
t@(LazyPattern _ _) =
Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm "Lazy" SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p (RecordPattern _ _ _ fs :: [Field (Pattern a)]
fs) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p)
[ Pattern a
t | Field _ _ t :: Pattern a
t <- [Field (Pattern a)]
fs ]
checkFPTerm _ (FunctionPattern _ _ _ _) = SCM ()
ok
checkFPTerm _ (InfixFuncPattern _ _ _ _ _) = SCM ()
ok
checkFuncPatsExtension :: SpanInfo -> SCM ()
checkFuncPatsExtension :: SpanInfo -> SCM ()
checkFuncPatsExtension spi :: SpanInfo
spi = SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension SpanInfo
spi
"Functional Patterns" KnownExtension
FunctionalPatterns
checkAnonFreeVarsExtension :: SpanInfo -> SCM ()
checkAnonFreeVarsExtension :: SpanInfo -> SCM ()
checkAnonFreeVarsExtension spi :: SpanInfo
spi = SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension SpanInfo
spi
"Anonymous free variables" KnownExtension
AnonFreeVars
checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension spi :: SpanInfo
spi msg :: String
msg ext :: KnownExtension
ext = do
Bool
enabled <- KnownExtension -> SCM Bool
hasExtension KnownExtension
ext
Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ do
Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension SpanInfo
spi String
msg KnownExtension
ext
KnownExtension -> SCM ()
enableExtension KnownExtension
ext
typeArity :: TypeExpr -> Int
typeArity :: TypeExpr -> Int
typeArity (ArrowType _ _ t2 :: TypeExpr
t2) = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TypeExpr -> Int
typeArity TypeExpr
t2
typeArity _ = 0
getFlatLhs :: Equation a -> (Ident, [Pattern a])
getFlatLhs :: Equation a -> (Ident, [Pattern a])
getFlatLhs (Equation _ lhs :: Lhs a
lhs _) = Lhs a -> (Ident, [Pattern a])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs a
lhs
opAnnotation :: InfixOp a -> a
opAnnotation :: InfixOp a -> a
opAnnotation (InfixOp a :: a
a _) = a
a
opAnnotation (InfixConstr a :: a
a _) = a
a
errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm s :: String
s spi :: SpanInfo
spi pat :: Pattern a
pat = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
s
Doc -> Doc -> Doc
<+> String -> Doc
text "patterns are not supported inside a functional pattern."
Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
pat
errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern s :: String
s spi :: SpanInfo
spi pat :: Pattern a
pat = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Functional patterns are not supported inside a" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc
dot
Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
pat
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal f :: QualIdent
f = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Function", QualIdent -> String
escQualName QualIdent
f, "in functional pattern is not global"]
errFuncPatCyclic :: QualIdent -> QualIdent -> Message
errFuncPatCyclic :: QualIdent -> QualIdent -> Message
errFuncPatCyclic fp :: QualIdent
fp f :: QualIdent
f = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
fp (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[ "Function", Ident -> String
escName (Ident -> String) -> Ident -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
unqualify QualIdent
fp, "used in functional pattern depends on"
, Ident -> String
escName (Ident -> String) -> Ident -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
unqualify QualIdent
f, " causing a cyclic dependency"]
errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message
errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message
errPrecedenceOutOfRange spi :: SpanInfo
spi i :: Integer
i = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Precedence out of range:", Integer -> String
forall a. Show a => a -> String
show Integer
i]
errUndefinedVariable :: QualIdent -> Message
errUndefinedVariable :: QualIdent -> Message
errUndefinedVariable v :: QualIdent
v = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[QualIdent -> String
escQualName QualIdent
v, "is undefined"]
errUndefinedData :: QualIdent -> Message
errUndefinedData :: QualIdent -> Message
errUndefinedData c :: QualIdent
c = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Undefined data constructor", QualIdent -> String
escQualName QualIdent
c]
errUndefinedLabel :: QualIdent -> Message
errUndefinedLabel :: QualIdent -> Message
errUndefinedLabel l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Undefined record label", QualIdent -> String
escQualName QualIdent
l]
errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod qcls :: QualIdent
qcls f :: Ident
f = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[Ident -> String
escName Ident
f, "is not a (visible) method of class", QualIdent -> String
escQualName QualIdent
qcls]
errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent rs :: [RenameInfo]
rs qn :: QualIdent
qn | (RenameInfo -> Bool) -> [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenameInfo -> Bool
isConstr [RenameInfo]
rs = [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
qn
| (RenameInfo -> Bool) -> [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenameInfo -> Bool
isLabel [RenameInfo]
rs = [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel [RenameInfo]
rs QualIdent
qn
| Bool
otherwise = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "variable" [RenameInfo]
rs QualIdent
qn
errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
errAmbiguousData = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "data constructor"
errAmbiguousLabel :: [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel :: [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "field label"
errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous what :: String
what rs :: [RenameInfo]
rs qn :: QualIdent
qn = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
qn
(Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Ambiguous" Doc -> Doc -> Doc
<+> String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
Doc -> Doc -> Doc
$+$ String -> Doc
text "It could refer to:"
Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((RenameInfo -> Doc) -> [RenameInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RenameInfo -> Doc
ppRenameInfo [RenameInfo]
rs))
errDuplicateDefinition :: Ident -> Message
errDuplicateDefinition :: Ident -> Message
errDuplicateDefinition v :: Ident
v = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["More than one definition for", Ident -> String
escName Ident
v]
errDuplicateVariables :: [Ident] -> Message
errDuplicateVariables :: [Ident] -> Message
errDuplicateVariables [] = String -> Message
forall a. String -> a
internalError
"SyntaxCheck.errDuplicateVariables: empty list"
errDuplicateVariables (v :: Ident
v:vs :: [Ident]
vs) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text (Ident -> String
escName Ident
v) Doc -> Doc -> Doc
<+> String -> Doc
text "occurs more than one in pattern at:" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
vIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
vs)))
errMultipleDataConstructor :: [Ident] -> Message
errMultipleDataConstructor :: [Ident] -> Message
errMultipleDataConstructor [] = String -> Message
forall a. String -> a
internalError
"SyntaxCheck.errMultipleDataDeclaration: empty list"
errMultipleDataConstructor (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Multiple definitions for data/record constructor" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
i)
Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))
errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message
errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message
errMultipleDeclarations _ [] = String -> Message
forall a. String -> a
internalError
"SyntaxCheck.errMultipleDeclarations: empty list"
errMultipleDeclarations m :: ModuleIdent
m (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Multiple declarations of" Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
i))
Doc -> Doc -> Doc
$+$ String -> Doc
text "Declared at:" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))
errDuplicateTypeSig :: [Ident] -> Message
errDuplicateTypeSig :: [Ident] -> Message
errDuplicateTypeSig [] = String -> Message
forall a. String -> a
internalError
"SyntaxCheck.errDuplicateTypeSig: empty list"
errDuplicateTypeSig (v :: Ident
v:vs :: [Ident]
vs) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "More than one type signature for" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
v)
Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
vIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
vs)))
errDuplicateLabel :: String -> QualIdent -> Message
errDuplicateLabel :: String -> QualIdent -> Message
errDuplicateLabel what :: String
what l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Field label", QualIdent -> String
escQualName QualIdent
l, "occurs more than once in record", String
what]
errNonVariable :: String -> Ident -> Message
errNonVariable :: String -> Ident -> Message
errNonVariable what :: String
what c :: Ident
c = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Data constructor", Ident -> String
escName Ident
c, "in left hand side of", String
what]
errNoBody :: Ident -> Message
errNoBody :: Ident -> Message
errNoBody v :: Ident
v = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ["No body for", Ident -> String
escName Ident
v]
errNoCommonCons :: SpanInfo -> [QualIdent] -> Message
errNoCommonCons :: SpanInfo -> [QualIdent] -> Message
errNoCommonCons spi :: SpanInfo
spi ls :: [QualIdent]
ls = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "No constructor has all of these fields:"
Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((QualIdent -> Doc) -> [QualIdent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (QualIdent -> String) -> QualIdent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> String
escQualName) [QualIdent]
ls))
errNoLabel :: QualIdent -> QualIdent -> Message
errNoLabel :: QualIdent -> QualIdent -> Message
errNoLabel c :: QualIdent
c l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[QualIdent -> String
escQualName QualIdent
l, "is not a field label of constructor", QualIdent -> String
escQualName QualIdent
c]
errNoTypeSig :: Ident -> Message
errNoTypeSig :: Ident -> Message
errNoTypeSig f :: Ident
f = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["No type signature for external function", Ident -> String
escName Ident
f]
errToplevelPattern :: SpanInfo -> Message
errToplevelPattern :: SpanInfo -> Message
errToplevelPattern spi :: SpanInfo
spi = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text
"Pattern declaration not allowed at top-level"
errDifferentArity :: [Ident] -> Message
errDifferentArity :: [Ident] -> Message
errDifferentArity [] = String -> Message
forall a. String -> a
internalError
"SyntaxCheck.errDifferentArity: empty list"
errDifferentArity (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Equations for" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
i) Doc -> Doc -> Doc
<+> String -> Doc
text "have different arities"
Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))
errWrongArity :: QualIdent -> Int -> Int -> Message
errWrongArity :: QualIdent -> Int -> Int -> Message
errWrongArity c :: QualIdent
c arity' :: Int
arity' argc :: Int
argc = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Data constructor", QualIdent -> String
escQualName QualIdent
c, "expects", Int -> String
forall a. (Eq a, Num a, Show a) => a -> String
arguments Int
arity'])
Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> String -> Doc
text "but is applied to" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
argc)
where arguments :: a -> String
arguments 0 = "no arguments"
arguments 1 = "1 argument"
arguments n :: a
n = a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " arguments"
errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension spi :: SpanInfo
spi what :: String
what ext :: KnownExtension
ext = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text "are not supported in standard Curry." Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 (String -> Doc
text "Use flag or -X" Doc -> Doc -> Doc
<+> String -> Doc
text (KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext)
Doc -> Doc -> Doc
<+> String -> Doc
text "to enable this extension.")
errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens spi :: SpanInfo
spi calls :: [(QualIdent, QualIdent)]
calls = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Missing parens in infix patterns:" Doc -> Doc -> Doc
$+$
[Doc] -> Doc
vcat (((QualIdent, QualIdent) -> Doc)
-> [(QualIdent, QualIdent)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent, QualIdent) -> Doc
showCall [(QualIdent, QualIdent)]
calls)
where
showCall :: (QualIdent, QualIdent) -> Doc
showCall (q1 :: QualIdent
q1, q2 :: QualIdent
q2) = QualIdent -> Doc
showWithPos QualIdent
q1 Doc -> Doc -> Doc
<+> String -> Doc
text "calls" Doc -> Doc -> Doc
<+> QualIdent -> Doc
showWithPos QualIdent
q2
showWithPos :: QualIdent -> Doc
showWithPos q :: QualIdent
q = String -> Doc
text (QualIdent -> String
qualName QualIdent
q)
Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Position -> String
showLine (Position -> String) -> Position -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition QualIdent
q)