{-# 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, runState, gets, modify
, 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 Curry.Syntax.Pretty (ppPattern)
import Base.Expr
import Base.Messages (Message, posMessage, internalError)
import Base.NestEnv
import Base.SCC (scc)
import Base.Utils ((++!), findDouble, findMultiples)
import Env.TypeConstructor (TCEnv, clsMethods)
import Env.Value (ValueEnv, ValueInfo (..))
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 -> SCState
initState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv
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 -> Integer
scopeId :: Integer
, SCState -> Integer
nextId :: Integer
, SCState -> FuncDeps
funcDeps :: FuncDeps
, SCState -> Bool
typeClassesCheck :: Bool
, SCState -> [Message]
errors :: [Message]
}
initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> SCState
initState :: [KnownExtension]
-> ModuleIdent -> TCEnv -> NestEnv RenameInfo -> SCState
initState exts :: [KnownExtension]
exts m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv rEnv :: NestEnv RenameInfo
rEnv =
[KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> Integer
-> Integer
-> FuncDeps
-> Bool
-> [Message]
-> SCState
SCState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv 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
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
= (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [QualIdent] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS NestEnv RenameInfo
env ([QualIdent] -> NestEnv RenameInfo)
-> [QualIdent] -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$ (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m) [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 =
(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 ((Var a -> Ident) -> [Var a] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Var a -> Ident
forall a. Var a -> Ident
varIdent [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 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
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl ()]
-> Module ()
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [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 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 -> Context -> Ident -> Ident -> [Decl ()] -> Decl ()
forall a.
SpanInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p 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 cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl ()]
ds) = do
ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- SCM TCEnv
getTyConsEnv
QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods QualIdent
qcls (ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods ModuleIdent
m QualIdent
qcls TCEnv
tcEnv) [Decl ()]
ds
SpanInfo
-> Context -> QualIdent -> TypeExpr -> [Decl ()] -> Decl ()
forall a.
SpanInfo -> Context -> QualIdent -> TypeExpr -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p 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
checkInstanceDecl _ =
String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkInstanceDecl: no instance 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
$ Position -> Integer -> Message
errPrecedenceOutOfRange (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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
$ Position -> Message
errToplevelPattern Position
p
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
$ Position -> Message
errToplevelPattern Position
p
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
where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
pspi
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
$ Position -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens
(Ident -> Position
forall a. HasPosition a => a -> Position
getPosition Ident
op) [(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 (String -> StateT SCState Identity (Pattern ()))
-> String -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$
"SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern _ _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError (String -> StateT SCState Identity (Pattern ()))
-> String -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$
"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
let n :: Int
n = RenameInfo -> Int
arity RenameInfo
r
Position -> SCM ()
checkFuncPatsExtension (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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
$ if Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
then let (ts1 :: [Pattern ()]
ts1, ts2 :: [Pattern ()]
ts2) = Int -> [Pattern ()] -> ([Pattern ()], [Pattern ()])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [Pattern ()]
ts'
in Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl
(SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi () (RenameInfo -> QualIdent
qualVarIdent RenameInfo
r) [Pattern ()]
ts1) [Pattern ()]
ts2
else 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
Position -> SCM ()
checkFuncPatsExtension (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 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 -> Expression () -> [Decl ()] -> Rhs ()
forall a. SpanInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
spi) ([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 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 -> [CondExpr ()] -> [Decl ()] -> Rhs ()
forall a. SpanInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi) ([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 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 -> [Decl ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi ([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 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 -> [Statement ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Statement a] -> Expression a -> Expression a
Do 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 "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 ct :: CaseType
ct e :: Expression ()
e alts :: [Alt ()]
alts) =
SpanInfo -> CaseType -> Expression () -> [Alt ()] -> Expression ()
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi 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
Position -> SCM ()
checkAnonFreeVarsExtension (Position -> SCM ()) -> Position -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition 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) -> Integer -> Ident -> Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 ds :: [Decl ()]
ds) =
SpanInfo -> [Decl ()] -> Statement ()
forall a. SpanInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi ([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 -> Position -> Pattern a -> Message
forall a. String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern String
s (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 -> Position -> Pattern a -> Message
forall a. String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern String
s (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([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))
(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
$ Position -> [QualIdent] -> Message
errNoCommonCons (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 decls :: [Decl a]
decls = 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 [] [Decl a]
decls
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"
arity :: RenameInfo -> Int
arity :: RenameInfo -> Int
arity (Constr _ n :: Int
n) = Int
n
arity (GlobalVar _ n :: Int
n) = Int
n
arity (LocalVar _ n :: Int
n) = Int
n
arity (RecordLabel _ _) = 1
genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl term :: Pattern ()
term [] = Pattern ()
term
genFuncPattAppl term :: Pattern ()
term (t :: Pattern ()
t:ts :: [Pattern ()]
ts)
= SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo () QualIdent
qApplyId [Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl Pattern ()
term [Pattern ()]
ts, Pattern ()
t]
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 -> Position -> Pattern a -> Message
forall a. String -> Position -> Pattern a -> Message
errUnsupportedFPTerm "Lazy" (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 :: Position -> SCM ()
checkFuncPatsExtension :: Position -> SCM ()
checkFuncPatsExtension p :: Position
p = Position -> String -> KnownExtension -> SCM ()
checkUsedExtension Position
p
"Functional Patterns" KnownExtension
FunctionalPatterns
checkAnonFreeVarsExtension :: Position -> SCM ()
checkAnonFreeVarsExtension :: Position -> SCM ()
checkAnonFreeVarsExtension p :: Position
p = Position -> String -> KnownExtension -> SCM ()
checkUsedExtension Position
p
"Anonymous free variables" KnownExtension
AnonFreeVars
checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
checkUsedExtension pos :: Position
pos 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
$ Position -> String -> KnownExtension -> Message
errMissingLanguageExtension Position
pos 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 -> Position -> Pattern a -> Message
errUnsupportedFPTerm :: String -> Position -> Pattern a -> Message
errUnsupportedFPTerm s :: String
s p :: Position
p pat :: Pattern a
pat = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
pat
errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern s :: String
s p :: Position
p pat :: Pattern a
pat = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
pat
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal f :: QualIdent
f = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: Position -> Integer -> Message
errPrecedenceOutOfRange :: Position -> Integer -> Message
errPrecedenceOutOfRange p :: Position
p i :: Integer
i = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: Position -> [QualIdent] -> Message
errNoCommonCons :: Position -> [QualIdent] -> Message
errNoCommonCons p :: Position
p ls :: [QualIdent]
ls = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: Position -> Message
errToplevelPattern :: Position -> Message
errToplevelPattern p :: Position
p = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: Position -> String -> KnownExtension -> Message
errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message
errMissingLanguageExtension p :: Position
p what :: String
what ext :: KnownExtension
ext = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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 :: Position -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens :: Position -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens p :: Position
p calls :: [(QualIdent, QualIdent)]
calls = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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)