{- |
    Module      :  $Header$
    Description :  Syntax checks
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                                   Martin Engelke
                                   Björn Peemöller
                       2015        Jan Tikovsky
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   After the type declarations have been checked, the compiler performs
   a syntax check on the remaining declarations. This check disambiguates
   nullary data constructors and variables which -- in contrast to Haskell --
   is not possible on purely syntactic criteria. In addition, this pass checks
   for undefined as well as ambiguous variables and constructors. In order to
   allow lifting of local definitions in later phases, all local variables are
   renamed by adding a key identifying their scope. Therefore, all variables
   defined in the same scope share the same key so that multiple definitions
   can be recognized. Finally, all (adjacent) equations of a function are
   merged into a single definition.
-}
{-# LANGUAGE CPP #-}
module Checks.SyntaxCheck (syntaxCheck) where

#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif

import           Control.Monad       (unless, when)
import qualified Control.Monad.State as S (State, gets, modify, runState,
                                           withState)
import           Data.Function       (on)
import           Data.List           (insertBy, intersect, nub, nubBy)
import qualified Data.Map            as Map (Map, empty, findWithDefault,
                                             fromList, insertWith, keys)
import           Data.Maybe          (isJust, isNothing)
import qualified Data.Set            as Set (Set, empty, insert, member,
                                             singleton, toList, union)

import           Curry.Base.Ident
import           Curry.Base.Position
import           Curry.Base.Pretty
import           Curry.Base.Span
import           Curry.Base.SpanInfo
import           Curry.Syntax

import           Base.Expr
import           Base.Messages       (Message, internalError,
                                      spanInfoMessage)
import           Base.NestEnv
import           Base.SCC            (scc)
import           Base.Utils          (findDouble, findMultiples, (++!))

import           Env.TypeConstructor (TCEnv, clsMethods, getOrigName)
import           Env.Value           (ValueEnv, ValueInfo (..),
                                      qualLookupValueUnique)


-- The syntax checking proceeds as follows. First, the compiler extracts
-- information about all imported values and data constructors from the
-- imported (type) environments. Next, the data constructors defined in
-- the current module are entered into this environment. After this,
-- all record labels are entered into the environment. If a record
-- identifier is already assigned to a constructor, then an error will be
-- generated. Class methods defined in the current module are entered into
-- the environment, too. Finally, all declarations are checked within the
-- resulting environment. In addition, this process will also rename the
-- local variables.

-- TODO: use SpanInfos for errors and then stop passing down SpanInfo from the decls to the checks

syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module ()
            -> ((Module (), [KnownExtension]), [Message])
syntaxCheck :: [KnownExtension]
-> TCEnv
-> ValueEnv
-> Module ()
-> ((Module (), [KnownExtension]), [Message])
syntaxCheck exts :: [KnownExtension]
exts tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv mdl :: Module ()
mdl@(Module _ _ _ m :: ModuleIdent
m _ _ ds :: [Decl ()]
ds) =
  case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
cons of
    []  -> case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples ([Ident]
ls [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
fs [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
cons [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
cs) of
             []  -> SCM (Module (), [KnownExtension])
-> SCState -> ((Module (), [KnownExtension]), [Message])
forall a. SCM a -> SCState -> (a, [Message])
runSC (Module () -> SCM (Module (), [KnownExtension])
checkModule Module ()
mdl) SCState
state
             iss :: [[Ident]]
iss -> ((Module ()
mdl, [KnownExtension]
exts), ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> [Ident] -> Message
errMultipleDeclarations ModuleIdent
m) [[Ident]]
iss)
    css :: [[Ident]]
css -> ((Module ()
mdl, [KnownExtension]
exts), ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map [Ident] -> Message
errMultipleDataConstructor [[Ident]]
css)
  where
    tds :: [Decl ()]
tds   = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl ()]
ds
    vds :: [Decl ()]
vds   = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl ()]
ds
    cds :: [Decl ()]
cds   = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isClassDecl [Decl ()]
ds
    cons :: [Ident]
cons  = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
constrs [Decl ()]
tds
    ls :: [Ident]
ls    = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
recLabels [Decl ()]
tds
    fs :: [Ident]
fs    = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
vds
    cs :: [Ident]
cs    = ([Decl ()] -> [Ident]) -> [[Decl ()]] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
methods) [[Decl ()]
ds' | ClassDecl _ _ _ _ _ ds' :: [Decl ()]
ds' <- [Decl ()]
cds]
    rEnv :: NestEnv RenameInfo
rEnv  = TopEnv RenameInfo -> NestEnv RenameInfo
forall a. TopEnv a -> NestEnv a
globalEnv (TopEnv RenameInfo -> NestEnv RenameInfo)
-> TopEnv RenameInfo -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$ (ValueInfo -> RenameInfo) -> ValueEnv -> TopEnv RenameInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueInfo -> RenameInfo
renameInfo ValueEnv
vEnv
    state :: SCState
state = [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> SCState
initState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv ValueEnv
vEnv

-- A global state transformer is used for generating fresh integer keys with
-- which the variables are renamed.
-- The state tracks the identifier of the current scope 'scopeId' as well as
-- the next fresh identifier, which is used for introducing new scopes as well
-- as renaming literals and underscore to disambiguate them.

-- |Syntax check monad
type SCM = S.State SCState

-- |Internal state of the syntax check
data SCState = SCState
  { SCState -> [KnownExtension]
extensions       :: [KnownExtension] -- ^ Enabled language extensions
  , SCState -> ModuleIdent
moduleIdent      :: ModuleIdent      -- ^ 'ModuleIdent' of the current module
  , SCState -> TCEnv
tyConsEnv        :: TCEnv
  , SCState -> NestEnv RenameInfo
renameEnv        :: RenameEnv        -- ^ Information store
  , SCState -> ValueEnv
valueEnv         :: ValueEnv         -- ^ To check instance method visibility
  , SCState -> Integer
scopeId          :: Integer          -- ^ Identifier for the current scope
  , SCState -> Integer
nextId           :: Integer          -- ^ Next fresh identifier
  , SCState -> FuncDeps
funcDeps         :: FuncDeps         -- ^ Stores data about functions dependencies
  , SCState -> Bool
typeClassesCheck :: Bool
  , SCState -> [Message]
errors           :: [Message]        -- ^ Syntactic errors in the module
  }

-- |Initial syntax check state
initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> ValueEnv
          -> SCState
initState :: [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> SCState
initState exts :: [KnownExtension]
exts m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv rEnv :: NestEnv RenameInfo
rEnv vEnv :: ValueEnv
vEnv =
  [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> ValueEnv
-> Integer
-> Integer
-> FuncDeps
-> Bool
-> [Message]
-> SCState
SCState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv ValueEnv
vEnv Integer
globalScopeId 1 FuncDeps
noFuncDeps Bool
False []

-- |Identifier for global (top-level) declarations
globalScopeId :: Integer
globalScopeId :: Integer
globalScopeId = Ident -> Integer
idUnique (String -> Ident
mkIdent "")

-- |Run the syntax check monad
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')

-- |Check for an enabled extension
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)

-- |Enable an additional 'Extension' to avoid redundant complaints about
-- missing 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 }

-- |Retrieve all enabled extensions
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

-- |Retrieve the 'ModuleIdent' of the current module
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

-- |Retrieve the 'TCEnv'
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

-- |Retrieve the 'RenameEnv'
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

-- |Retrieve the 'ValueEnv'
getValueEnv :: SCM ValueEnv
getValueEnv :: SCM ValueEnv
getValueEnv = (SCState -> ValueEnv) -> SCM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SCState -> ValueEnv
valueEnv

-- |Modify the '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 }

-- |Retrieve the current scope identifier
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

-- |Create a new identifier and return it
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

-- |Checks whether a type classes check is running
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

-- |Performs a type classes check in a nested scope
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 })

-- |Increase the nesting of the 'RenameEnv' to introduce a new local scope.
-- This also increases the scope identifier.
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

-- |Perform an action in a nested scope (by creating a nested 'RenameEnv')
-- and discard the nested 'RenameEnv' afterwards
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)

-- |Modify the `FuncDeps'
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 a syntax error
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 }

-- |Everything is checked
ok :: SCM ()
ok :: SCM ()
ok = () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- FuncDeps contains information to deal with dependencies between functions.
-- This is used for checking whether functional patterns are cyclic.
-- curGlobalFunc contains the identifier of the global function that is
-- currently being checked, if any.
-- data X = X
-- f = let g = lookup 42 in g [1,2,3]
-- While `X' is being checked `curGlobalFunc' should be `Nothing',
-- while `lookup' is being checked is should be `f's identifier.
-- globalDeps collects all dependencies (other functions) of global functions
-- funcPats collects all functional patterns and the global function they're
-- used in
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)

-- |Initial state for FuncDeps
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 []

-- |Perform an action inside a function, settìng `curGlobalFunc' to that function
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

-- |Add a dependency to `curGlobalFunction'
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) }

-- |Add a functional pattern to `curGlobalFunction'
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 }

-- |Return dependencies of global functions
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

-- |Return used functional patterns
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


-- A nested environment is used for recording information about the data
-- constructors and variables in the module. For every data constructor
-- its arity is saved. This is used for checking that all constructor
-- applications in patterns are saturated. For local variables the
-- environment records the new name of the variable after renaming.
-- Global variables are recorded with qualified identifiers in order
-- to distinguish multiply declared entities.

-- Currently, records must explicitly be declared together with their labels.
-- When constructing or updating a record, it is necessary to compute
-- all its labels using just one of them. Thus for each label
-- the record identifier and all its labels are entered into the environment

-- Note: the function 'qualLookupVar' has been extended to allow the usage of
-- the qualified list constructor (prelude.:).

type RenameEnv = NestEnv RenameInfo

data RenameInfo
  -- |Arity of data constructor
  = Constr      QualIdent Int
  -- |Constructors of a record label
  | RecordLabel QualIdent [QualIdent]
  -- |Arity of global function
  | GlobalVar   QualIdent Int
  -- |Arity of local function
  | 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)

-- Since record types are currently translated into data types, it is necessary
-- to ensure that all identifiers for records and constructors are different.
-- Furthermore, it is not allowed to declare a label more than once.

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

-- ------------------------------------------------------------------------------

-- |Bind type constructor information and record label information
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)

-- ------------------------------------------------------------------------------

-- |Bind a global function declaration in the 'RenameEnv'
bindFuncDecl :: Bool -> ModuleIdent -> Decl a -> RenameEnv -> RenameEnv
bindFuncDecl :: Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindFuncDecl _   _ (FunctionDecl _ _ _ []) _
  = String -> NestEnv RenameInfo
forall a. String -> a
internalError "SyntaxCheck.bindFuncDecl: no equations"
bindFuncDecl tcc :: Bool
tcc m :: ModuleIdent
m (FunctionDecl _ _ f :: Ident
f (eq :: Equation a
eq:_)) env :: NestEnv RenameInfo
env
  = let arty :: Int
arty = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int) -> [Pattern a] -> Int
forall a b. (a -> b) -> a -> b
$ (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs Equation a
eq
    in  Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
tcc ModuleIdent
m Ident
f (QualIdent -> Int -> RenameInfo
GlobalVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) Int
arty) NestEnv RenameInfo
env
bindFuncDecl tcc :: Bool
tcc m :: ModuleIdent
m (TypeSig _ fs :: [Ident]
fs (QualTypeExpr _ _ ty :: TypeExpr
ty)) env :: NestEnv RenameInfo
env
  = (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> (Ident -> QualIdent)
-> Ident
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m) NestEnv RenameInfo
env [Ident]
fs
  where
    bindTS :: QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS qf :: QualIdent
qf env' :: NestEnv RenameInfo
env'
      | [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RenameInfo] -> Bool) -> [RenameInfo] -> Bool
forall a b. (a -> b) -> a -> b
$ QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
qf NestEnv RenameInfo
env'
        = Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
tcc ModuleIdent
m (QualIdent -> Ident
unqualify QualIdent
qf) (QualIdent -> Int -> RenameInfo
GlobalVar QualIdent
qf (TypeExpr -> Int
typeArity TypeExpr
ty)) NestEnv RenameInfo
env'
      | Bool
otherwise = NestEnv RenameInfo
env'
bindFuncDecl _   _ _ env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env

-- ------------------------------------------------------------------------------

-- |Bind type class information, i.e. class methods
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

-- ------------------------------------------------------------------------------

-- |Bind a local declaration (function, variables) in the 'RenameEnv'
bindVarDecl :: Decl a -> RenameEnv -> RenameEnv
bindVarDecl :: Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl (FunctionDecl    _ _ f :: Ident
f eqs :: [Equation a]
eqs) env :: NestEnv RenameInfo
env
  | [Equation a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation a]
eqs  = String -> NestEnv RenameInfo
forall a. String -> a
internalError "SyntaxCheck.bindVarDecl: no equations"
  | Bool
otherwise = let arty :: Int
arty = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int) -> [Pattern a] -> Int
forall a b. (a -> b) -> a -> b
$ (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs (Equation a -> (Ident, [Pattern a]))
-> Equation a -> (Ident, [Pattern a])
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs
                in  Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
bindLocal (Ident -> Ident
unRenameIdent Ident
f) (Ident -> Int -> RenameInfo
LocalVar Ident
f Int
arty) NestEnv RenameInfo
env
bindVarDecl (PatternDecl         _ t :: Pattern a
t _) env :: NestEnv RenameInfo
env = (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar NestEnv RenameInfo
env (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t)
bindVarDecl (FreeDecl             _ vs :: [Var a]
vs) env :: NestEnv RenameInfo
env = (Var a -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Var a] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> (Var a -> Ident)
-> Var a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var a -> Ident
forall a. Var a -> Ident
varIdent) NestEnv RenameInfo
env [Var a]
vs
bindVarDecl _                           env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env

bindVar :: Ident -> RenameEnv -> RenameEnv
bindVar :: Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar v :: Ident
v | Ident -> Bool
isAnonId Ident
v = NestEnv RenameInfo -> NestEnv RenameInfo
forall a. a -> a
id
          | Bool
otherwise  = Ident -> RenameInfo -> NestEnv RenameInfo -> NestEnv RenameInfo
bindLocal (Ident -> Ident
unRenameIdent Ident
v) (Ident -> Int -> RenameInfo
LocalVar Ident
v 0)

lookupVar :: Ident -> RenameEnv -> [RenameInfo]
lookupVar :: Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar v :: Ident
v env :: NestEnv RenameInfo
env = Ident -> NestEnv RenameInfo -> [RenameInfo]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
v NestEnv RenameInfo
env [RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [RenameInfo]
lookupTupleConstr Ident
v

qualLookupVar :: QualIdent -> RenameEnv -> [RenameInfo]
qualLookupVar :: QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar v :: QualIdent
v env :: NestEnv RenameInfo
env =  QualIdent -> NestEnv RenameInfo -> [RenameInfo]
forall a. QualIdent -> NestEnv a -> [a]
qualLookupNestEnv QualIdent
v NestEnv RenameInfo
env
                   [RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupListCons QualIdent
v NestEnv RenameInfo
env
                   [RenameInfo] -> [RenameInfo] -> [RenameInfo]
forall a. [a] -> [a] -> [a]
++! Ident -> [RenameInfo]
lookupTupleConstr (QualIdent -> Ident
unqualify QualIdent
v)

lookupTupleConstr :: Ident -> [RenameInfo]
lookupTupleConstr :: Ident -> [RenameInfo]
lookupTupleConstr v :: Ident
v
  | Ident -> Bool
isTupleId Ident
v = let a :: Int
a = Ident -> Int
tupleArity Ident
v
                  in  [QualIdent -> Int -> RenameInfo
Constr (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Int -> Ident
tupleId Int
a) Int
a]
  | Bool
otherwise   = []

qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
qualLookupListCons :: QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupListCons v :: QualIdent
v env :: NestEnv RenameInfo
env
  | QualIdent
v QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent Ident
consId
  = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
forall a. QualIdent -> NestEnv a -> [a]
qualLookupNestEnv (Ident -> QualIdent
qualify (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
qidIdent QualIdent
v) NestEnv RenameInfo
env
  | Bool
otherwise
  = []

-- When a module is checked, the global declaration group is checked. The
-- resulting renaming environment can be discarded. The same is true for
-- a goal. Note that all declarations in the goal must be considered as
-- local declarations. Class and instance declarations define their own scope,
-- thus defined functions will be renamed as well. For class and instance
-- declarations several checks have to be disabled (for instance, type
-- signatures without corresponding function declaration are allowed in class
-- declarations), while some have to be performed extra (for instance, no
-- other functions than specified by the type signatures within a class
-- declaration are allowed to be declared).

checkModule :: Module () -> SCM (Module (), [KnownExtension])
checkModule :: Module () -> SCM (Module (), [KnownExtension])
checkModule (Module spi :: SpanInfo
spi li :: LayoutInfo
li ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl ()]
ds) = do
  (Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
bindTypeDecl [Decl ()]
tds
  (Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
bindClassDecl [Decl ()]
cds
  [Decl ()]
ds' <- [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
  [Decl ()]
cds' <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. SCM a -> SCM a
performTypeClassesCheck (StateT SCState Identity (Decl ())
 -> StateT SCState Identity (Decl ()))
-> (Decl () -> StateT SCState Identity (Decl ()))
-> Decl ()
-> StateT SCState Identity (Decl ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl () -> StateT SCState Identity (Decl ())
checkClassDecl) [Decl ()]
cds
  [Decl ()]
ids' <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. SCM a -> SCM a
performTypeClassesCheck (StateT SCState Identity (Decl ())
 -> StateT SCState Identity (Decl ()))
-> (Decl () -> StateT SCState Identity (Decl ()))
-> Decl ()
-> StateT SCState Identity (Decl ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl () -> StateT SCState Identity (Decl ())
checkInstanceDecl) [Decl ()]
ids
  let ds'' :: [Decl ()]
ds'' = [Decl ()] -> [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl ()]
cds' [Decl ()]
ids' [Decl ()]
ds'
  SCM ()
checkFuncPatDeps
  [KnownExtension]
exts <- SCM [KnownExtension]
getExtensions
  (Module (), [KnownExtension]) -> SCM (Module (), [KnownExtension])
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl ()]
-> Module ()
forall a.
SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi LayoutInfo
li [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is [Decl ()]
ds'', [KnownExtension]
exts)
  where tds :: [Decl ()]
tds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl ()]
ds
        cds :: [Decl ()]
cds = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isClassDecl [Decl ()]
ds
        ids :: [Decl ()]
ids = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isInstanceDecl [Decl ()]
ds

-- |Checks whether a function in a functional pattern contains cycles
-- |(depends on its own global function)
checkFuncPatDeps :: SCM ()
checkFuncPatDeps :: SCM ()
checkFuncPatDeps = do
  [(QualIdent, QualIdent)]
fps  <- SCM [(QualIdent, QualIdent)]
getFuncPats
  GlobalDeps
deps <- SCM GlobalDeps
getGlobalDeps
  let levels :: [[QualIdent]]
levels   = (QualIdent -> [QualIdent])
-> (QualIdent -> [QualIdent]) -> [QualIdent] -> [[QualIdent]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc (QualIdent -> [QualIdent] -> [QualIdent]
forall a. a -> [a] -> [a]
:[])
                     (\k :: QualIdent
k -> Set QualIdent -> [QualIdent]
forall a. Set a -> [a]
Set.toList (Set QualIdent -> QualIdent -> GlobalDeps -> Set QualIdent
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set QualIdent
forall a. Set a
Set.empty QualIdent
k GlobalDeps
deps))
                     (GlobalDeps -> [QualIdent]
forall k a. Map k a -> [k]
Map.keys GlobalDeps
deps)
      levelMap :: Map QualIdent Int
levelMap = [(QualIdent, Int)] -> Map QualIdent Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (QualIdent
f, Int
l) | (fs :: [QualIdent]
fs, l :: Int
l) <- [[QualIdent]] -> [Int] -> [([QualIdent], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[QualIdent]]
levels [1 ..], QualIdent
f <- [QualIdent]
fs ]
      level :: QualIdent -> Int
level f :: QualIdent
f  = Int -> QualIdent -> Map QualIdent Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (0 :: Int) QualIdent
f Map QualIdent Int
levelMap
  ((QualIdent, QualIdent) -> SCM ())
-> [(QualIdent, QualIdent)] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((QualIdent -> Int) -> (QualIdent, QualIdent) -> SCM ()
forall a.
Ord a =>
(QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep QualIdent -> Int
level) [(QualIdent, QualIdent)]
fps

checkFuncPatDep :: Ord a => (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep :: (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep level :: QualIdent -> a
level (fp :: QualIdent
fp, f :: QualIdent
f) = Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QualIdent -> a
level QualIdent
fp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< QualIdent -> a
level QualIdent
f) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$
  Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent -> Message
errFuncPatCyclic QualIdent
fp QualIdent
f

checkTopDecls :: [Decl ()] -> SCM [Decl ()]
checkTopDecls :: [Decl ()] -> SCM [Decl ()]
checkTopDecls ds :: [Decl ()]
ds = do
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  Bool
tcc <- SCM Bool
isTypeClassesCheck
  (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup (Bool
-> ModuleIdent
-> Decl ()
-> NestEnv RenameInfo
-> NestEnv RenameInfo
forall a.
Bool
-> ModuleIdent
-> Decl a
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindFuncDecl Bool
tcc ModuleIdent
m) [Decl ()]
ds

checkClassDecl :: Decl () -> SCM (Decl ())
checkClassDecl :: Decl () -> StateT SCState Identity (Decl ())
checkClassDecl (ClassDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl ()]
ds) = do
  QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods (Ident -> QualIdent
qualify Ident
cls) ((Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
methods [Decl ()]
ds) [Decl ()]
ds
  SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl ()] -> Decl ()
forall a.
SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p LayoutInfo
li Context
cx Ident
cls Ident
tv ([Decl ()] -> Decl ())
-> SCM [Decl ()] -> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
checkClassDecl _ =
  String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkClassDecl: no class declaration"

checkInstanceDecl :: Decl () -> SCM (Decl ())
checkInstanceDecl :: Decl () -> StateT SCState Identity (Decl ())
checkInstanceDecl (InstanceDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl ()]
ds) = do
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- SCM ValueEnv
getValueEnv
  TCEnv
tcEnv <- SCM TCEnv
getTyConsEnv
  let clsMthds :: [Ident]
clsMthds = ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods ModuleIdent
m QualIdent
qcls TCEnv
tcEnv
  let orig :: QualIdent
orig = ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m QualIdent
qcls TCEnv
tcEnv
  let mthds :: [Ident]
mthds =
        if ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
m QualIdent
orig
          then [Ident]
clsMthds
          else (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (QualIdent -> ModuleIdent -> ValueEnv -> Ident -> Bool
isFromCls QualIdent
orig ModuleIdent
m ValueEnv
vEnv) [Ident]
clsMthds
  QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods QualIdent
qcls [Ident]
mthds [Decl ()]
ds
  (Decl () -> SCM ()) -> [Decl ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl () -> SCM ()
forall a. Decl a -> SCM ()
checkAmbiguousMethod [Decl ()]
ds
  SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl ()]
-> Decl ()
forall a.
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl a]
-> Decl a
InstanceDecl SpanInfo
p LayoutInfo
li Context
cx QualIdent
qcls TypeExpr
ty ([Decl ()] -> Decl ())
-> SCM [Decl ()] -> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
  where
    isFromCls :: QualIdent -> ModuleIdent -> ValueEnv -> Ident -> Bool
isFromCls orig :: QualIdent
orig m :: ModuleIdent
m vEnv :: ValueEnv
vEnv f :: Ident
f = case ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique ModuleIdent
m (Ident -> QualIdent
qualify Ident
f) ValueEnv
vEnv of
      [Value _ (Just cls :: QualIdent
cls) _ _]
        | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
orig -> Bool
True
      _               -> Bool
False

checkInstanceDecl _ =
  String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkInstanceDecl: no instance declaration"

checkAmbiguousMethod :: Decl a -> SCM ()
checkAmbiguousMethod :: Decl a -> SCM ()
checkAmbiguousMethod (FunctionDecl _ _ f :: Ident
f _) = do
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  NestEnv RenameInfo
rename <- SCM (NestEnv RenameInfo)
getRenameEnv
  case Ident -> NestEnv RenameInfo -> [RenameInfo]
lookupVar Ident
f NestEnv RenameInfo
rename of
    rs1 :: [RenameInfo]
rs1@(_:_:_) -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) NestEnv RenameInfo
rename of
      []          -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs1 (Ident -> QualIdent
qualify Ident
f)
      rs2 :: [RenameInfo]
rs2@(_:_:_) -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs2 (Ident -> QualIdent
qualify Ident
f)
      _           -> () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _           -> () -> SCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAmbiguousMethod _ =
  String -> SCM ()
forall a. String -> a
internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration"

checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods qcls :: QualIdent
qcls ms :: [Ident]
ms ds :: [Decl a]
ds =
  (Ident -> SCM ()) -> [Ident] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> Message
errUndefinedMethod QualIdent
qcls) ([Ident] -> SCM ()) -> [Ident] -> SCM ()
forall a b. (a -> b) -> a -> b
$ (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
ms) [Ident]
fs
  where fs :: [Ident]
fs = [Ident
f | FunctionDecl _ _ f :: Ident
f _ <- [Decl a]
ds]

updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [] [] ds :: [Decl a]
ds = [Decl a]
ds
updateClassAndInstanceDecls (c :: Decl a
c:cs :: [Decl a]
cs) is :: [Decl a]
is (ClassDecl _ _ _ _ _ _:ds :: [Decl a]
ds) =
  Decl a
c Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls cs :: [Decl a]
cs (i :: Decl a
i:is :: [Decl a]
is) (InstanceDecl _ _ _ _ _ _:ds :: [Decl a]
ds) =
  Decl a
i Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls cs :: [Decl a]
cs is :: [Decl a]
is (d :: Decl a
d:ds :: [Decl a]
ds) =
  Decl a
d Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
forall a. [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]
updateClassAndInstanceDecls [Decl a]
cs [Decl a]
is [Decl a]
ds
updateClassAndInstanceDecls _ _ _ =
  String -> [Decl a]
forall a. String -> a
internalError "SyntaxCheck.updateClassAndInstanceDecls"

-- Each declaration group opens a new scope and uses a distinct key
-- for renaming the variables in this scope. In a declaration group,
-- first the left hand sides of all declarations are checked, next the
-- compiler checks that there is a definition for every type signature
-- and evaluation annotation in this group. Finally, the right hand sides
-- are checked and adjacent equations for the same function are merged
-- into a single definition.

-- The function 'checkDeclLhs' also handles the case where a pattern
-- declaration is recognized as a function declaration by the parser.
-- This happens, e.g., for the declaration
--      where Just x = y
-- because the parser cannot distinguish nullary constructors and functions.
-- Note that pattern declarations are not allowed on the top-level.

checkDeclGroup :: (Decl () -> RenameEnv -> RenameEnv) -> [Decl ()] -> SCM [Decl ()]
checkDeclGroup :: (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup bindDecl :: Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl ds :: [Decl ()]
ds = do
  [Decl ()]
checkedLhs <- (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs ([Decl ()] -> SCM [Decl ()]) -> [Decl ()] -> SCM [Decl ()]
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> [Decl ()]
forall a. [Decl a] -> [Decl a]
sortFuncDecls [Decl ()]
ds
  [Decl ()] -> SCM [Decl ()]
forall a. [Decl a] -> SCM [Decl a]
joinEquations [Decl ()]
checkedLhs SCM [Decl ()] -> ([Decl ()] -> SCM [Decl ()]) -> SCM [Decl ()]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDecls Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl

checkDeclLhs :: Decl () -> SCM (Decl ())
checkDeclLhs :: Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs (InfixDecl    p :: SpanInfo
p fix' :: Infix
fix' pr :: Maybe Integer
pr ops :: [Ident]
ops) =
  SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl ()
forall a. SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl a
InfixDecl SpanInfo
p Infix
fix' (Maybe Integer -> [Ident] -> Decl ())
-> StateT SCState Identity (Maybe Integer)
-> StateT SCState Identity ([Ident] -> Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
checkPrecedence SpanInfo
p Maybe Integer
pr StateT SCState Identity ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT SCState Identity Ident
renameVar [Ident]
ops
checkDeclLhs (TypeSig            p :: SpanInfo
p vs :: [Ident]
vs ty :: QualTypeExpr
ty) =
  (\vs' :: [Ident]
vs' -> SpanInfo -> [Ident] -> QualTypeExpr -> Decl ()
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident]
vs' QualTypeExpr
ty) ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Ident -> StateT SCState Identity Ident
checkVar "type signature") [Ident]
vs
checkDeclLhs (FunctionDecl     p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation ()]
eqs) =
  Ident
-> StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a. Ident -> SCM a -> SCM a
inFunc Ident
f (StateT SCState Identity (Decl ())
 -> StateT SCState Identity (Decl ()))
-> StateT SCState Identity (Decl ())
-> StateT SCState Identity (Decl ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [Equation ()] -> StateT SCState Identity (Decl ())
checkEquationsLhs SpanInfo
p [Equation ()]
eqs
checkDeclLhs (ExternalDecl          p :: SpanInfo
p vs :: [Var ()]
vs) =
  SpanInfo -> [Var ()] -> Decl ()
forall a. SpanInfo -> [Var a] -> Decl a
ExternalDecl SpanInfo
p ([Var ()] -> Decl ())
-> StateT SCState Identity [Var ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var () -> StateT SCState Identity (Var ()))
-> [Var ()] -> StateT SCState Identity [Var ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Var () -> StateT SCState Identity (Var ())
forall a. String -> Var a -> SCM (Var a)
checkVar' "external declaration") [Var ()]
vs
checkDeclLhs (PatternDecl        p :: SpanInfo
p t :: Pattern ()
t rhs :: Rhs ()
rhs) =
  (\t' :: Pattern ()
t' -> SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern ()
t' Rhs ()
rhs) (Pattern () -> Decl ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkDeclLhs (FreeDecl              p :: SpanInfo
p vs :: [Var ()]
vs) =
  SpanInfo -> [Var ()] -> Decl ()
forall a. SpanInfo -> [Var a] -> Decl a
FreeDecl SpanInfo
p ([Var ()] -> Decl ())
-> StateT SCState Identity [Var ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var () -> StateT SCState Identity (Var ()))
-> [Var ()] -> StateT SCState Identity [Var ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Var () -> StateT SCState Identity (Var ())
forall a. String -> Var a -> SCM (Var a)
checkVar' "free variables declaration") [Var ()]
vs
checkDeclLhs d :: Decl ()
d                            = Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
d

checkPrecedence :: SpanInfo -> Maybe Precedence -> SCM (Maybe Precedence)
checkPrecedence :: SpanInfo
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
checkPrecedence _ Nothing  = Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
checkPrecedence p :: SpanInfo
p (Just i :: Integer
i) = do
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 9) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report
                            (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Integer -> Message
errPrecedenceOutOfRange SpanInfo
p Integer
i
  Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> StateT SCState Identity (Maybe Integer))
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i

checkVar' :: String -> Var a -> SCM (Var a)
checkVar' :: String -> Var a -> SCM (Var a)
checkVar' what :: String
what (Var a :: a
a v :: Ident
v) = a -> Ident -> Var a
forall a. a -> Ident -> Var a
Var a
a (Ident -> Var a) -> StateT SCState Identity Ident -> SCM (Var a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> StateT SCState Identity Ident
checkVar String
what Ident
v

checkVar :: String -> Ident -> SCM Ident
checkVar :: String -> Ident -> StateT SCState Identity Ident
checkVar _what :: String
_what v :: Ident
v = do
  -- isDC <- S.gets (isDataConstr v . renameEnv)
  -- when isDC $ report $ nonVariable what v -- TODO Why is this disabled?
  Ident -> StateT SCState Identity Ident
renameVar Ident
v

renameVar :: Ident -> SCM Ident
renameVar :: Ident -> StateT SCState Identity Ident
renameVar v :: Ident
v = Ident -> Integer -> Ident
renameIdent Ident
v (Integer -> Ident) -> SCM Integer -> StateT SCState Identity Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
getScopeId

checkEquationsLhs :: SpanInfo -> [Equation ()] -> SCM (Decl ())
checkEquationsLhs :: SpanInfo -> [Equation ()] -> StateT SCState Identity (Decl ())
checkEquationsLhs p :: SpanInfo
p [Equation p' :: SpanInfo
p' lhs :: Lhs ()
lhs rhs :: Rhs ()
rhs] = do
  Either (Ident, Lhs ()) (Pattern ())
lhs' <- SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs SpanInfo
p' Lhs ()
lhs
  case Either (Ident, Lhs ()) (Pattern ())
lhs' of
    Left  l :: (Ident, Lhs ())
l -> Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl () -> StateT SCState Identity (Decl ()))
-> Decl () -> StateT SCState Identity (Decl ())
forall a b. (a -> b) -> a -> b
$ (Ident, Lhs ()) -> Decl ()
funDecl' (Ident, Lhs ())
l
    Right r :: Pattern ()
r -> Decl () -> StateT SCState Identity (Decl ())
checkDeclLhs (SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p' Pattern ()
r Rhs ()
rhs)
  where funDecl' :: (Ident, Lhs ()) -> Decl ()
funDecl' (f :: Ident
f, lhs' :: Lhs ()
lhs') = SpanInfo -> () -> Ident -> [Equation ()] -> Decl ()
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p () Ident
f [SpanInfo -> Lhs () -> Rhs () -> Equation ()
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p' Lhs ()
lhs' Rhs ()
rhs]
checkEquationsLhs _ _ = String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkEquationsLhs"

checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs pspi :: SpanInfo
pspi toplhs :: Lhs ()
toplhs = do
  ModuleIdent
m   <- SCM ModuleIdent
getModuleIdent
  Integer
k   <- SCM Integer
getScopeId
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  case Lhs ()
toplhs of
    FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern ()]
ts
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
f NestEnv RenameInfo
env -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
      | Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
globalScopeId       -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall a. Either a (Pattern ())
right
      | [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
infos               -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
      | Bool
otherwise                -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Message
errToplevelPattern SpanInfo
pspi
                                       Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall a. Either a (Pattern ())
right
      where f' :: Ident
f'    = Ident -> Integer -> Ident
renameIdent Ident
f Integer
k
            infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) NestEnv RenameInfo
env
            left :: Either (Ident, Lhs ()) b
left  = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left  (Ident
f', SpanInfo -> Ident -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f' [Pattern ()]
ts)
            right :: Either a (Pattern ())
right = Pattern () -> Either a (Pattern ())
forall a b. b -> Either a b
Right (Pattern () -> Either a (Pattern ()))
-> Pattern () -> Either a (Pattern ())
forall a b. (a -> b) -> a -> b
$  -- use start from the parsed FunLhs and compute end
              Pattern () -> Pattern ()
forall a. HasSpanInfo a => a -> a
updateEndPos (Pattern () -> Pattern ()) -> Pattern () -> Pattern ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () (Ident -> QualIdent
qualify Ident
f) [Pattern ()]
ts
    OpLhs spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: Ident
op t2 :: Pattern ()
t2
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
op NestEnv RenameInfo
env -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
      | Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
globalScopeId        -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
right
      | [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
infos                -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall b. Either (Ident, Lhs ()) b
left
      | Bool
otherwise                 -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Message
errToplevelPattern SpanInfo
pspi
                                        Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
right
      where op' :: Ident
op'   = Ident -> Integer -> Ident
renameIdent Ident
op Integer
k
            infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
op) NestEnv RenameInfo
env
            left :: Either (Ident, Lhs ()) b
left  = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left (Ident
op', SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi Pattern ()
t1 Ident
op' Pattern ()
t2)
            right :: Either (Ident, Lhs ()) (Pattern ())
right = Integer
-> NestEnv RenameInfo
-> (Pattern () -> Pattern ())
-> Pattern ()
-> Either (Ident, Lhs ()) (Pattern ())
forall a.
Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs Integer
k NestEnv RenameInfo
env (Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t1 (Ident -> QualIdent
qualify Ident
op)) Pattern ()
t2
            infixPattern :: Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern (InfixPattern _ a' :: ()
a' t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2') op2 :: QualIdent
op2 t3 :: Pattern ()
t3 =
              let t2'' :: Pattern ()
t2'' = Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t2' QualIdent
op2 Pattern ()
t3
                  sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2'')
              in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) ()
a' Pattern ()
t1' QualIdent
op1 Pattern ()
t2''
            infixPattern t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2' =
              let sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2')
              in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) () Pattern ()
t1' QualIdent
op1 Pattern ()
t2'
    ApLhs spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts -> do
      Either (Ident, Lhs ()) (Pattern ())
checked <- SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs SpanInfo
pspi Lhs ()
lhs
      case Either (Ident, Lhs ()) (Pattern ())
checked of
        Left (f' :: Ident
f', lhs' :: Lhs ()
lhs') -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
 -> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ (Ident, Lhs ()) -> Either (Ident, Lhs ()) (Pattern ())
forall a b. a -> Either a b
Left (Ident
f', Lhs () -> Lhs ()
forall a. HasSpanInfo a => a -> a
updateEndPos (Lhs () -> Lhs ()) -> Lhs () -> Lhs ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi Lhs ()
lhs' [Pattern ()]
ts)
        r :: Either (Ident, Lhs ()) (Pattern ())
r               -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> Message
errNonVariable "curried definition" Ident
f
                              Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
 -> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ Either (Ident, Lhs ()) (Pattern ())
r
        where (f :: Ident
f, _) = Lhs () -> (Ident, [Pattern ()])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs ()
lhs

checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a)
           -> Pattern a -> Either (Ident, Lhs a) (Pattern a)
checkOpLhs :: Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs k :: Integer
k env :: NestEnv RenameInfo
env f :: Pattern a -> Pattern a
f (InfixPattern spi :: SpanInfo
spi a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2)
  | Maybe ModuleIdent -> Bool
forall a. Maybe a -> Bool
isJust Maybe ModuleIdent
m Bool -> Bool -> Bool
|| Ident -> NestEnv RenameInfo -> Bool
isDataConstr Ident
op' NestEnv RenameInfo
env
  = Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
forall a.
Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs Integer
k NestEnv RenameInfo
env (Pattern a -> Pattern a
f (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi a
a Pattern a
t1 QualIdent
op) Pattern a
t2
  | Bool
otherwise
  = (Ident, Lhs a) -> Either (Ident, Lhs a) (Pattern a)
forall a b. a -> Either a b
Left (Ident
op'', SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs (Pattern a -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo Pattern a
t1') Pattern a
t1' Ident
op'' Pattern a
t2)
  where (m :: Maybe ModuleIdent
m,op' :: Ident
op') = (QualIdent -> Maybe ModuleIdent
qidModule QualIdent
op, QualIdent -> Ident
qidIdent QualIdent
op)
        op'' :: Ident
op''    = Ident -> Integer -> Ident
renameIdent Ident
op' Integer
k
        t1' :: Pattern a
t1'     = Pattern a -> Pattern a
f Pattern a
t1
checkOpLhs _ _ f :: Pattern a -> Pattern a
f t :: Pattern a
t = Pattern a -> Either (Ident, Lhs a) (Pattern a)
forall a b. b -> Either a b
Right (Pattern a -> Pattern a
f Pattern a
t)

-- -- ---------------------------------------------------------------------------

joinEquations :: [Decl a] -> SCM [Decl a]
joinEquations :: [Decl a] -> SCM [Decl a]
joinEquations [] = [Decl a] -> SCM [Decl a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
joinEquations (FunctionDecl a :: SpanInfo
a p :: a
p f :: Ident
f eqs :: [Equation a]
eqs : FunctionDecl _ _ f' :: Ident
f' [eq :: Equation a
eq] : ds :: [Decl a]
ds)
  | Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
f' = do
    Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Equation a -> Int
forall a. Equation a -> Int
getArity ([Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Equation a -> Int
forall a. Equation a -> Int
getArity Equation a
eq) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [Ident] -> Message
errDifferentArity [Ident
f, Ident
f']
    [Decl a] -> SCM [Decl a]
forall a. [Decl a] -> SCM [Decl a]
joinEquations (Decl a -> Decl a
forall a. HasSpanInfo a => a -> a
updateEndPos (SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
a a
p Ident
f ([Equation a]
eqs [Equation a] -> [Equation a] -> [Equation a]
forall a. [a] -> [a] -> [a]
++ [Equation a
eq])) Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a]
ds)
  where getArity :: Equation a -> Int
getArity = [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Pattern a] -> Int)
-> (Equation a -> [Pattern a]) -> Equation a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Equation a -> (Ident, [Pattern a]))
-> Equation a
-> [Pattern a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Equation a -> (Ident, [Pattern a])
forall a. Equation a -> (Ident, [Pattern a])
getFlatLhs
joinEquations (d :: Decl a
d : ds :: [Decl a]
ds) = (Decl a
d Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:) ([Decl a] -> [Decl a]) -> SCM [Decl a] -> SCM [Decl a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> SCM [Decl a]
forall a. [Decl a] -> SCM [Decl a]
joinEquations [Decl a]
ds

checkDecls :: (Decl () -> RenameEnv -> RenameEnv) -> [Decl ()] -> SCM [Decl ()]
checkDecls :: (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDecls bindDecl :: Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl ds :: [Decl ()]
ds = do
  let dblVar :: Maybe Ident
dblVar = [Ident] -> Maybe Ident
forall a. Eq a => [a] -> Maybe a
findDouble [Ident]
bvs
  (Ident -> SCM ()) -> Maybe Ident -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errDuplicateDefinition) Maybe Ident
dblVar
  let mulTys :: [[Ident]]
mulTys = [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
tys
  ([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateTypeSig) [[Ident]]
mulTys
  let missingTys :: [Ident]
missingTys = [Ident
v | ExternalDecl _ vs :: [Var ()]
vs <- [Decl ()]
ds, Var _ v :: Ident
v <- [Var ()]
vs, Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
tys]
  (Ident -> SCM ()) -> [Ident] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errNoTypeSig) [Ident]
missingTys
  if Maybe Ident -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Ident
dblVar Bool -> Bool -> Bool
&& [[Ident]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Ident]]
mulTys Bool -> Bool -> Bool
&& [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
missingTys
    then do
      (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \env :: NestEnv RenameInfo
env -> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Decl ()] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl NestEnv RenameInfo
env ([Decl ()]
tds [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
vds)
      (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> Decl () -> StateT SCState Identity (Decl ())
checkDeclRhs [Ident]
bvs) [Decl ()]
ds
    else [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl ()]
ds -- skip further checking
  where vds :: [Decl ()]
vds    = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl ()]
ds
        tds :: [Decl ()]
tds    = (Decl () -> Bool) -> [Decl ()] -> [Decl ()]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl () -> Bool
forall a. Decl a -> Bool
isTypeSig [Decl ()]
ds
        bvs :: [Ident]
bvs    = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
vds
        tys :: [Ident]
tys    = (Decl () -> [Ident]) -> [Decl ()] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl () -> [Ident]
forall a. Decl a -> [Ident]
vars [Decl ()]
tds
        onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok

-- -- ---------------------------------------------------------------------------

checkDeclRhs :: [Ident] -> Decl () -> SCM (Decl ())
checkDeclRhs :: [Ident] -> Decl () -> StateT SCState Identity (Decl ())
checkDeclRhs _   (DataDecl   p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) =
  ([ConstrDecl] -> [QualIdent] -> Decl ())
-> [QualIdent] -> [ConstrDecl] -> Decl ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl ()
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs) [QualIdent]
clss ([ConstrDecl] -> Decl ())
-> StateT SCState Identity [ConstrDecl]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConstrDecl -> StateT SCState Identity ConstrDecl)
-> [ConstrDecl] -> StateT SCState Identity [ConstrDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT SCState Identity ConstrDecl
checkDeclLabels [ConstrDecl]
cs
checkDeclRhs bvs :: [Ident]
bvs (TypeSig        p :: SpanInfo
p vs :: [Ident]
vs ty :: QualTypeExpr
ty) =
  (\vs' :: [Ident]
vs' -> SpanInfo -> [Ident] -> QualTypeExpr -> Decl ()
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident]
vs' QualTypeExpr
ty) ([Ident] -> Decl ())
-> StateT SCState Identity [Ident]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> StateT SCState Identity Ident)
-> [Ident] -> StateT SCState Identity [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> Ident -> StateT SCState Identity Ident
checkLocalVar [Ident]
bvs) [Ident]
vs
checkDeclRhs _   (FunctionDecl a :: SpanInfo
a p :: ()
p f :: Ident
f eqs :: [Equation ()]
eqs) =
  SpanInfo -> () -> Ident -> [Equation ()] -> Decl ()
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
a ()
p Ident
f ([Equation ()] -> Decl ())
-> StateT SCState Identity [Equation ()]
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident
-> StateT SCState Identity [Equation ()]
-> StateT SCState Identity [Equation ()]
forall a. Ident -> SCM a -> SCM a
inFunc Ident
f ((Equation () -> StateT SCState Identity (Equation ()))
-> [Equation ()] -> StateT SCState Identity [Equation ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation () -> StateT SCState Identity (Equation ())
checkEquation [Equation ()]
eqs)
checkDeclRhs _   (PatternDecl    p :: SpanInfo
p t :: Pattern ()
t rhs :: Rhs ()
rhs) =
  SpanInfo -> Pattern () -> Rhs () -> Decl ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern ()
t (Rhs () -> Decl ())
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs
checkDeclRhs _   d :: Decl ()
d                        = Decl () -> StateT SCState Identity (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
d

checkDeclLabels :: ConstrDecl -> SCM ConstrDecl
checkDeclLabels :: ConstrDecl -> StateT SCState Identity ConstrDecl
checkDeclLabels rd :: ConstrDecl
rd@(RecordDecl _ _ fs :: [FieldDecl]
fs) = do
  (QualIdent -> SCM ()) -> Maybe QualIdent -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QualIdent -> Message
errDuplicateLabel "declaration")
         ([QualIdent] -> Maybe QualIdent
forall a. Eq a => [a] -> Maybe a
findDouble ([QualIdent] -> Maybe QualIdent) -> [QualIdent] -> Maybe QualIdent
forall a b. (a -> b) -> a -> b
$ (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> QualIdent
qualify [Ident]
labels)
  ConstrDecl -> StateT SCState Identity ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDecl
rd
  where
    onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok
    labels :: [Ident]
labels = [Ident
l | FieldDecl _ ls :: [Ident]
ls _ <- [FieldDecl]
fs, Ident
l <- [Ident]
ls]
checkDeclLabels d :: ConstrDecl
d = ConstrDecl -> StateT SCState Identity ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDecl
d

checkLocalVar :: [Ident] -> Ident -> SCM Ident
checkLocalVar :: [Ident] -> Ident -> StateT SCState Identity Ident
checkLocalVar bvs :: [Ident]
bvs v :: Ident
v = do
  Bool
tcc <- SCM Bool
isTypeClassesCheck
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
bvs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tcc) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ Ident -> Message
errNoBody Ident
v
  Ident -> StateT SCState Identity Ident
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
v

checkEquation :: Equation () -> SCM (Equation ())
checkEquation :: Equation () -> StateT SCState Identity (Equation ())
checkEquation (Equation p :: SpanInfo
p lhs :: Lhs ()
lhs rhs :: Rhs ()
rhs) = StateT SCState Identity (Equation ())
-> StateT SCState Identity (Equation ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Equation ())
 -> StateT SCState Identity (Equation ()))
-> StateT SCState Identity (Equation ())
-> StateT SCState Identity (Equation ())
forall a b. (a -> b) -> a -> b
$ do
  Lhs ()
lhs' <- SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs SpanInfo
p Lhs ()
lhs SCM (Lhs ()) -> (Lhs () -> SCM (Lhs ())) -> SCM (Lhs ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Lhs () -> SCM (Lhs ())
forall t. QuantExpr t => Bool -> t -> SCM t
addBoundVariables Bool
False
  Rhs ()
rhs' <- Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs
  Equation () -> StateT SCState Identity (Equation ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Equation () -> StateT SCState Identity (Equation ()))
-> Equation () -> StateT SCState Identity (Equation ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs () -> Rhs () -> Equation ()
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs ()
lhs' Rhs ()
rhs'

checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs p :: SpanInfo
p (FunLhs    spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern ()]
ts) = SpanInfo -> Ident -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f ([Pattern ()] -> Lhs ())
-> StateT SCState Identity [Pattern ()] -> SCM (Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkLhs p :: SpanInfo
p (OpLhs spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: Ident
op t2 :: Pattern ()
t2) = do
  let wrongCalls :: [(QualIdent, QualIdent)]
wrongCalls = (Pattern () -> [(QualIdent, QualIdent)])
-> [Pattern ()] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern () -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just (QualIdent -> Maybe QualIdent) -> QualIdent -> Maybe QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
op)) [Pattern ()
t1,Pattern ()
t2]
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(QualIdent, QualIdent)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(QualIdent, QualIdent)]
wrongCalls) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens
    SpanInfo
spi [(QualIdent, QualIdent)]
wrongCalls
  (Pattern () -> Ident -> Pattern () -> Lhs ())
-> Ident -> Pattern () -> Pattern () -> Lhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi) Ident
op (Pattern () -> Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1 StateT SCState Identity (Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ()) -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
checkLhs p :: SpanInfo
p (ApLhs   spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts) =
  SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi (Lhs () -> [Pattern ()] -> Lhs ())
-> SCM (Lhs ()) -> StateT SCState Identity ([Pattern ()] -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs SpanInfo
p Lhs ()
lhs StateT SCState Identity ([Pattern ()] -> Lhs ())
-> StateT SCState Identity [Pattern ()] -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts

-- checkParen
-- @param Aufrufende InfixFunktion
-- @param Pattern
-- @return Liste mit fehlerhaften Funktionsaufrufen

checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern _ (LiteralPattern          _ _ _) = []
checkParenPattern _ (NegativePattern         _ _ _) = []
checkParenPattern _ (VariablePattern         _ _ _) = []
checkParenPattern _ (ConstructorPattern   _ _ _ cs :: [Pattern a]
cs) =
  (Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
cs
checkParenPattern o :: Maybe QualIdent
o (InfixPattern     _ _ t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) =
  [(QualIdent, QualIdent)]
-> (QualIdent -> [(QualIdent, QualIdent)])
-> Maybe QualIdent
-> [(QualIdent, QualIdent)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\c :: QualIdent
c -> [(QualIdent
c, QualIdent
op)]) Maybe QualIdent
o
  [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t1 [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t2
checkParenPattern _ (ParenPattern              _ t :: Pattern a
t) =
  Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t
checkParenPattern _ (RecordPattern        _ _ _ fs :: [Field (Pattern a)]
fs) =
  (Field (Pattern a) -> [(QualIdent, QualIdent)])
-> [Field (Pattern a)] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Field _ _ t :: Pattern a
t) -> Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t) [Field (Pattern a)]
fs
checkParenPattern _ (TuplePattern             _ ts :: [Pattern a]
ts) =
  (Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern _ (ListPattern            _ _ ts :: [Pattern a]
ts) =
  (Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern o :: Maybe QualIdent
o (AsPattern               _ _ t :: Pattern a
t) =
  Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
o Pattern a
t
checkParenPattern o :: Maybe QualIdent
o (LazyPattern               _ t :: Pattern a
t) =
  Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
o Pattern a
t
checkParenPattern _ (FunctionPattern      _ _ _ ts :: [Pattern a]
ts) =
  (Pattern a -> [(QualIdent, QualIdent)])
-> [Pattern a] -> [(QualIdent, QualIdent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing) [Pattern a]
ts
checkParenPattern o :: Maybe QualIdent
o (InfixFuncPattern _ _ t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) =
  [(QualIdent, QualIdent)]
-> (QualIdent -> [(QualIdent, QualIdent)])
-> Maybe QualIdent
-> [(QualIdent, QualIdent)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\c :: QualIdent
c -> [(QualIdent
c, QualIdent
op)]) Maybe QualIdent
o
  [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t1 [(QualIdent, QualIdent)]
-> [(QualIdent, QualIdent)] -> [(QualIdent, QualIdent)]
forall a. [a] -> [a] -> [a]
++ Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
forall a. Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern Maybe QualIdent
forall a. Maybe a
Nothing Pattern a
t2

checkPattern :: SpanInfo -> Pattern () -> SCM (Pattern ())
checkPattern :: SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern _ (LiteralPattern        spi :: SpanInfo
spi a :: ()
a l :: Literal
l) =
  Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Pattern ()
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
spi ()
a Literal
l
checkPattern _ (NegativePattern       spi :: SpanInfo
spi a :: ()
a l :: Literal
l) =
  Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Pattern ()
forall a. SpanInfo -> a -> Literal -> Pattern a
NegativePattern SpanInfo
spi ()
a Literal
l
checkPattern p :: SpanInfo
p (VariablePattern       spi :: SpanInfo
spi a :: ()
a v :: Ident
v)
  | Ident -> Bool
isAnonId Ident
v = SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi ()
a (Ident -> Pattern ())
-> (Integer -> Ident) -> Integer -> Pattern ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Integer -> Ident
renameIdent Ident
v (Integer -> Pattern ())
-> SCM Integer -> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
newId
  | Bool
otherwise  = SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern SpanInfo
p SpanInfo
spi (Ident -> QualIdent
qualify Ident
v) []
checkPattern p :: SpanInfo
p (ConstructorPattern spi :: SpanInfo
spi _ c :: QualIdent
c ts :: [Pattern ()]
ts) =
  SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern SpanInfo
p SpanInfo
spi QualIdent
c [Pattern ()]
ts
checkPattern p :: SpanInfo
p (InfixPattern   spi :: SpanInfo
spi _ t1 :: Pattern ()
t1 op :: QualIdent
op t2 :: Pattern ()
t2) =
  SpanInfo
-> SpanInfo
-> Pattern ()
-> QualIdent
-> Pattern ()
-> StateT SCState Identity (Pattern ())
checkInfixPattern SpanInfo
p SpanInfo
spi Pattern ()
t1 QualIdent
op Pattern ()
t2
checkPattern p :: SpanInfo
p (ParenPattern            spi :: SpanInfo
spi t :: Pattern ()
t) =
  SpanInfo -> Pattern () -> Pattern ()
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
spi (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkPattern p :: SpanInfo
p (RecordPattern      spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Pattern ())]
fs) =
  SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Pattern ())]
-> StateT SCState Identity (Pattern ())
checkRecordPattern SpanInfo
p SpanInfo
spi QualIdent
c [Field (Pattern ())]
fs
checkPattern p :: SpanInfo
p (TuplePattern           spi :: SpanInfo
spi ts :: [Pattern ()]
ts) =
  SpanInfo -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
spi ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkPattern p :: SpanInfo
p (ListPattern          spi :: SpanInfo
spi a :: ()
a ts :: [Pattern ()]
ts) =
  SpanInfo -> () -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
spi ()
a ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
checkPattern p :: SpanInfo
p (AsPattern             spi :: SpanInfo
spi v :: Ident
v t :: Pattern ()
t) =
  SpanInfo -> Ident -> Pattern () -> Pattern ()
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
spi (Ident -> Pattern () -> Pattern ())
-> StateT SCState Identity Ident
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ident -> StateT SCState Identity Ident
checkVar "@ pattern" Ident
v StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
checkPattern p :: SpanInfo
p (LazyPattern             spi :: SpanInfo
spi t :: Pattern ()
t) = do
  Pattern ()
t' <- SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
  String -> SpanInfo -> Pattern () -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm "lazy pattern" SpanInfo
p Pattern ()
t'
  Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo -> Pattern () -> Pattern ()
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
spi Pattern ()
t')
checkPattern _ (FunctionPattern     _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError
  "SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern  _ _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError
  "SyntaxCheck.checkPattern: infix function pattern not defined"

checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()]
                        -> SCM (Pattern ())
checkConstructorPattern :: SpanInfo
-> SpanInfo
-> QualIdent
-> [Pattern ()]
-> StateT SCState Identity (Pattern ())
checkConstructorPattern p :: SpanInfo
p spi :: SpanInfo
spi c :: QualIdent
c ts :: [Pattern ()]
ts = do
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  Integer
k <- SCM Integer
getScopeId
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
    [Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons QualIdent
c Int
n
    [r :: RenameInfo
r]          -> RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun RenameInfo
r Integer
k
    rs :: [RenameInfo]
rs -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) NestEnv RenameInfo
env of
      [Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) Int
n
      [r :: RenameInfo
r]          -> RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun RenameInfo
r Integer
k
      []
        | [Pattern ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern ()]
ts Bool -> Bool -> Bool
&& Bool -> Bool
not (QualIdent -> Bool
isQualified QualIdent
c) ->
            Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi () (Ident -> Pattern ()) -> Ident -> Pattern ()
forall a b. (a -> b) -> a -> b
$ Ident -> Integer -> Ident
renameIdent (QualIdent -> Ident
unqualify QualIdent
c) Integer
k
        | [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs -> do
            [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
            Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
c
            Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
c [Pattern ()]
ts'
      _ -> do [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
              Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
c
              Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
c [Pattern ()]
ts'
  where
  n' :: Int
n' = [Pattern ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern ()]
ts
  processCons :: QualIdent -> Int -> StateT SCState Identity (Pattern ())
processCons qc :: QualIdent
qc n :: Int
n = do
    Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n') (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Int -> Int -> Message
errWrongArity QualIdent
c Int
n Int
n'
    SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi () QualIdent
qc ([Pattern ()] -> Pattern ())
-> StateT SCState Identity [Pattern ()]
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
  processVarFun :: RenameInfo -> Integer -> StateT SCState Identity (Pattern ())
processVarFun r :: RenameInfo
r k :: Integer
k
    | [Pattern ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern ()]
ts Bool -> Bool -> Bool
&& Bool -> Bool
not (QualIdent -> Bool
isQualified QualIdent
c)
    = Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi () (Ident -> Pattern ()) -> Ident -> Pattern ()
forall a b. (a -> b) -> a -> b
$ Ident -> Integer -> Ident
renameIdent (QualIdent -> Ident
unqualify QualIdent
c) Integer
k -- (varIdent r) k
    | Bool
otherwise = do
      SpanInfo -> SCM ()
checkFuncPatsExtension SpanInfo
p
      RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall RenameInfo
r QualIdent
c
      [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts
      (Pattern () -> SCM ()) -> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern () -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern ()]
ts'
      Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi () (RenameInfo -> QualIdent
qualVarIdent RenameInfo
r) [Pattern ()]
ts'

checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern ()
                  -> SCM (Pattern ())
checkInfixPattern :: SpanInfo
-> SpanInfo
-> Pattern ()
-> QualIdent
-> Pattern ()
-> StateT SCState Identity (Pattern ())
checkInfixPattern p :: SpanInfo
p spi :: SpanInfo
spi t1 :: Pattern ()
t1 op :: QualIdent
op t2 :: Pattern ()
t2 = do
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
op NestEnv RenameInfo
env of
    [Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern QualIdent
op Int
n
    [r :: RenameInfo
r]          -> RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern RenameInfo
r QualIdent
op
    rs :: [RenameInfo]
rs           -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op) NestEnv RenameInfo
env of
      [Constr _ n :: Int
n] -> QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op) Int
n
      [r :: RenameInfo
r]          -> RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern RenameInfo
r (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op)
      rs' :: [RenameInfo]
rs'          -> do if [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs'
                            then Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
op
                            else Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
op
                         (Pattern () -> QualIdent -> Pattern () -> Pattern ())
-> QualIdent -> Pattern () -> Pattern () -> Pattern ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi ()) QualIdent
op (Pattern () -> Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1
                                                  StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
  where
  infixPattern :: QualIdent -> Int -> StateT SCState Identity (Pattern ())
infixPattern qop :: QualIdent
qop n :: Int
n = do
    Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 2) (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Int -> Int -> Message
errWrongArity QualIdent
op Int
n 2
    (Pattern () -> QualIdent -> Pattern () -> Pattern ())
-> QualIdent -> Pattern () -> Pattern () -> Pattern ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi ()) QualIdent
qop (Pattern () -> Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Pattern ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1 StateT SCState Identity (Pattern () -> Pattern ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
  funcPattern :: RenameInfo -> QualIdent -> StateT SCState Identity (Pattern ())
funcPattern r :: RenameInfo
r qop :: QualIdent
qop = do
    SpanInfo -> SCM ()
checkFuncPatsExtension SpanInfo
p
    RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall RenameInfo
r QualIdent
qop
    [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()
t1,Pattern ()
t2]
    let [t1' :: Pattern ()
t1',t2' :: Pattern ()
t2'] = [Pattern ()]
ts'
    (Pattern () -> SCM ()) -> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern () -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern ()]
ts'
    Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
spi () Pattern ()
t1' QualIdent
qop Pattern ()
t2'

checkRecordPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Pattern ())]
                   -> SCM (Pattern ())
checkRecordPattern :: SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Pattern ())]
-> StateT SCState Identity (Pattern ())
checkRecordPattern p :: SpanInfo
p spi :: SpanInfo
spi c :: QualIdent
c fs :: [Field (Pattern ())]
fs = do
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  ModuleIdent
m   <- SCM ModuleIdent
getModuleIdent
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
    [Constr c' :: QualIdent
c' _] -> Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
c') [Field (Pattern ())]
fs
    rs :: [RenameInfo]
rs            -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) NestEnv RenameInfo
env of
      [Constr c' :: QualIdent
c' _] -> Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
c') [Field (Pattern ())]
fs
      rs' :: [RenameInfo]
rs'           -> if [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs'
                          then do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedData QualIdent
c
                                  Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat Maybe QualIdent
forall a. Maybe a
Nothing [Field (Pattern ())]
fs
                          else do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
c
                                  Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat Maybe QualIdent
forall a. Maybe a
Nothing [Field (Pattern ())]
fs
  where
  processRecPat :: Maybe QualIdent
-> [Field (Pattern ())] -> StateT SCState Identity (Pattern ())
processRecPat mcon :: Maybe QualIdent
mcon fields :: [Field (Pattern ())]
fields = do
    [Field (Pattern ())]
fs' <- (Field (Pattern ())
 -> StateT SCState Identity (Field (Pattern ())))
-> [Field (Pattern ())]
-> StateT SCState Identity [Field (Pattern ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Pattern () -> StateT SCState Identity (Pattern ()))
-> Field (Pattern ())
-> StateT SCState Identity (Field (Pattern ()))
forall a. (a -> SCM a) -> Field a -> SCM (Field a)
checkField (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p)) [Field (Pattern ())]
fields
    String
-> SpanInfo -> Maybe QualIdent -> [Field (Pattern ())] -> SCM ()
forall a.
String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels "pattern" SpanInfo
p Maybe QualIdent
mcon [Field (Pattern ())]
fs'
    Pattern () -> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern () -> StateT SCState Identity (Pattern ()))
-> Pattern () -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> QualIdent -> [Field (Pattern ())] -> Pattern ()
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
spi () QualIdent
c [Field (Pattern ())]
fs'

checkFuncPatCall :: RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall :: RenameInfo -> QualIdent -> SCM ()
checkFuncPatCall r :: RenameInfo
r f :: QualIdent
f = case RenameInfo
r of
  GlobalVar dep :: QualIdent
dep _ -> do
    QualIdent -> SCM ()
addGlobalDep QualIdent
dep
    QualIdent -> SCM ()
addFuncPat (QualIdent
dep QualIdent -> QualIdent -> QualIdent
forall a b. (HasPosition a, HasPosition b) => a -> b -> a
@> QualIdent
f)
  _           -> Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errFuncPatNotGlobal QualIdent
f

-- Note: process decls first
checkRhs :: Rhs () -> SCM (Rhs ())
checkRhs :: Rhs () -> StateT SCState Identity (Rhs ())
checkRhs (SimpleRhs spi :: SpanInfo
spi li :: LayoutInfo
li e :: Expression ()
e ds :: [Decl ()]
ds) = StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Rhs ())
 -> StateT SCState Identity (Rhs ()))
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a b. (a -> b) -> a -> b
$
  (Expression () -> [Decl ()] -> Rhs ())
-> [Decl ()] -> Expression () -> Rhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> LayoutInfo -> Expression () -> [Decl ()] -> Rhs ()
forall a.
SpanInfo -> LayoutInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
spi LayoutInfo
li) ([Decl ()] -> Expression () -> Rhs ())
-> SCM [Decl ()]
-> StateT SCState Identity (Expression () -> Rhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity (Expression () -> Rhs ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Rhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
e
checkRhs (GuardedRhs spi :: SpanInfo
spi li :: LayoutInfo
li es :: [CondExpr ()]
es ds :: [Decl ()]
ds) = StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Rhs ())
 -> StateT SCState Identity (Rhs ()))
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Rhs ())
forall a b. (a -> b) -> a -> b
$
  ([CondExpr ()] -> [Decl ()] -> Rhs ())
-> [Decl ()] -> [CondExpr ()] -> Rhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> LayoutInfo -> [CondExpr ()] -> [Decl ()] -> Rhs ()
forall a.
SpanInfo -> LayoutInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi LayoutInfo
li) ([Decl ()] -> [CondExpr ()] -> Rhs ())
-> SCM [Decl ()]
-> StateT SCState Identity ([CondExpr ()] -> Rhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity ([CondExpr ()] -> Rhs ())
-> StateT SCState Identity [CondExpr ()]
-> StateT SCState Identity (Rhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    (CondExpr () -> StateT SCState Identity (CondExpr ()))
-> [CondExpr ()] -> StateT SCState Identity [CondExpr ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CondExpr () -> StateT SCState Identity (CondExpr ())
checkCondExpr [CondExpr ()]
es

checkCondExpr :: CondExpr () -> SCM (CondExpr ())
checkCondExpr :: CondExpr () -> StateT SCState Identity (CondExpr ())
checkCondExpr (CondExpr spi :: SpanInfo
spi g :: Expression ()
g e :: Expression ()
e) =  SpanInfo -> Expression () -> Expression () -> CondExpr ()
forall a. SpanInfo -> Expression a -> Expression a -> CondExpr a
CondExpr SpanInfo
spi (Expression () -> Expression () -> CondExpr ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> CondExpr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
g StateT SCState Identity (Expression () -> CondExpr ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (CondExpr ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
spi Expression ()
e

checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())
checkExpr :: SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr _ (Literal       spi :: SpanInfo
spi a :: ()
a l :: Literal
l) = Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Expression ()
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
spi ()
a Literal
l
checkExpr _ (Variable      spi :: SpanInfo
spi a :: ()
a v :: QualIdent
v) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
v
checkExpr _ (Constructor   spi :: SpanInfo
spi a :: ()
a c :: QualIdent
c) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
c
checkExpr p :: SpanInfo
p (Paren         spi :: SpanInfo
spi   e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
spi           (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Typed        spi :: SpanInfo
spi e :: Expression ()
e ty :: QualTypeExpr
ty) = (Expression () -> QualTypeExpr -> Expression ())
-> QualTypeExpr -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> QualTypeExpr -> Expression ()
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
ty (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Record     spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordExpr SpanInfo
p SpanInfo
spi QualIdent
c [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (RecordUpdate spi :: SpanInfo
spi e :: Expression ()
e fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> Expression ()
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordUpdExpr SpanInfo
p SpanInfo
spi Expression ()
e [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (Tuple        spi :: SpanInfo
spi   es :: [Expression ()]
es) = SpanInfo -> [Expression ()] -> Expression ()
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
spi ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (List         spi :: SpanInfo
spi a :: ()
a es :: [Expression ()]
es) = SpanInfo -> () -> [Expression ()] -> Expression ()
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
spi ()
a ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (ListCompr    spi :: SpanInfo
spi e :: Expression ()
e qs :: [Statement ()]
qs) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ (Expression () -> [Statement ()] -> Expression ())
-> [Statement ()] -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> [Statement ()] -> Expression ()
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
spi) ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  -- Note: must be flipped to insert qs into RenameEnv first
  (Statement () -> StateT SCState Identity (Statement ()))
-> [Statement ()] -> StateT SCState Identity [Statement ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement "list comprehension" SpanInfo
p) [Statement ()]
qs StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (EnumFrom              spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
EnumFrom SpanInfo
spi (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (EnumFromThen      spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
  SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromThen SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (EnumFromTo        spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
  SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromTo SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (EnumFromThenTo spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2 e3 :: Expression ()
e3) =
  SpanInfo
-> Expression () -> Expression () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
EnumFromThenTo SpanInfo
spi (Expression () -> Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
     SCState Identity (Expression () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
  SCState Identity (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e3
checkExpr p :: SpanInfo
p (UnaryMinus            spi :: SpanInfo
spi e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Apply             spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2) =
  SpanInfo -> Expression () -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (InfixApply     spi :: SpanInfo
spi e1 :: Expression ()
e1 op :: InfixOp ()
op e2 :: Expression ()
e2) =
  SpanInfo
-> Expression () -> InfixOp () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi (Expression () -> InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
     SCState Identity (InfixOp () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
  SCState Identity (InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2
checkExpr p :: SpanInfo
p (LeftSection        spi :: SpanInfo
spi e :: Expression ()
e op :: InfixOp ()
op) =
  SpanInfo -> Expression () -> InfixOp () -> Expression ()
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi (Expression () -> InfixOp () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (InfixOp () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity (InfixOp () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op
checkExpr p :: SpanInfo
p (RightSection       spi :: SpanInfo
spi op :: InfixOp ()
op e :: Expression ()
e) =
  SpanInfo -> InfixOp () -> Expression () -> Expression ()
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi (InfixOp () -> Expression () -> Expression ())
-> StateT SCState Identity (InfixOp ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InfixOp () -> StateT SCState Identity (InfixOp ())
forall a. InfixOp a -> SCM (InfixOp a)
checkOp InfixOp ()
op StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Lambda             spi :: SpanInfo
spi ts :: [Pattern ()]
ts e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> SpanInfo
-> [Pattern ()]
-> Expression ()
-> StateT SCState Identity (Expression ())
checkLambda SpanInfo
p SpanInfo
spi [Pattern ()]
ts Expression ()
e
checkExpr p :: SpanInfo
p (Let             spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl ()]
ds e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
  SpanInfo
-> LayoutInfo -> [Decl ()] -> Expression () -> Expression ()
forall a.
SpanInfo -> LayoutInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi LayoutInfo
li ([Decl ()] -> Expression () -> Expression ())
-> SCM [Decl ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Do             spi :: SpanInfo
spi li :: LayoutInfo
li sts :: [Statement ()]
sts e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
  SpanInfo
-> LayoutInfo -> [Statement ()] -> Expression () -> Expression ()
forall a.
SpanInfo
-> LayoutInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi LayoutInfo
li ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement () -> StateT SCState Identity (Statement ()))
-> [Statement ()] -> StateT SCState Identity [Statement ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement "do sequence" SpanInfo
p) [Statement ()]
sts StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (IfThenElse     spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2 e3 :: Expression ()
e3) =
  SpanInfo
-> Expression () -> Expression () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
spi (Expression () -> Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
     SCState Identity (Expression () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
  SCState Identity (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e3
checkExpr p :: SpanInfo
p (Case       spi :: SpanInfo
spi li :: LayoutInfo
li ct :: CaseType
ct e :: Expression ()
e alts :: [Alt ()]
alts) =
  SpanInfo
-> LayoutInfo
-> CaseType
-> Expression ()
-> [Alt ()]
-> Expression ()
forall a.
SpanInfo
-> LayoutInfo
-> CaseType
-> Expression a
-> [Alt a]
-> Expression a
Case SpanInfo
spi LayoutInfo
li CaseType
ct (Expression () -> [Alt ()] -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity ([Alt ()] -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity ([Alt ()] -> Expression ())
-> StateT SCState Identity [Alt ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt () -> StateT SCState Identity (Alt ()))
-> [Alt ()] -> StateT SCState Identity [Alt ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt () -> StateT SCState Identity (Alt ())
checkAlt [Alt ()]
alts

checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression ()
            -> SCM (Expression ())
checkLambda :: SpanInfo
-> SpanInfo
-> [Pattern ()]
-> Expression ()
-> StateT SCState Identity (Expression ())
checkLambda p :: SpanInfo
p spi :: SpanInfo
spi ts :: [Pattern ()]
ts e :: Expression ()
e = case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples ([Pattern ()] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bvNoAnon [Pattern ()]
ts) of
  []      -> do
    [Pattern ()]
ts' <- (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "lambda expression" SpanInfo
p) [Pattern ()]
ts
    SpanInfo -> [Pattern ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern ()]
ts' (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
  errVars :: [[Ident]]
errVars -> do
    ([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateVariables) [[Ident]]
errVars
    let nubTs :: [Pattern ()]
nubTs = (Pattern () -> Pattern () -> Bool) -> [Pattern ()] -> [Pattern ()]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\t1 :: Pattern ()
t1 t2 :: Pattern ()
t2 -> (Bool -> Bool
not (Bool -> Bool) -> ([Ident] -> Bool) -> [Ident] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (([Ident] -> [Ident] -> [Ident])
-> (Pattern () -> [Ident]) -> Pattern () -> Pattern () -> [Ident]
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [Ident] -> [Ident] -> [Ident]
forall a. Eq a => [a] -> [a] -> [a]
intersect Pattern () -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bvNoAnon Pattern ()
t1 Pattern ()
t2)) [Pattern ()]
ts
    (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "lambda expression" SpanInfo
p) [Pattern ()]
nubTs
    SpanInfo -> [Pattern ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern ()]
ts (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
  where
    bvNoAnon :: e -> [Ident]
bvNoAnon t :: e
t = (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Ident -> Bool) -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Bool
isAnonId) ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ e -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv e
t

checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable spi :: SpanInfo
spi a :: a
a v :: QualIdent
v
    -- anonymous free variable
  | Ident -> Bool
isAnonId (QualIdent -> Ident
unqualify QualIdent
v) = do
    SpanInfo -> SCM ()
checkAnonFreeVarsExtension (SpanInfo -> SCM ()) -> SpanInfo -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo QualIdent
v
    (\n :: Integer
n -> SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a (QualIdent -> Expression a) -> QualIdent -> Expression a
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> ModuleIdent)
-> (Ident -> Ident) -> QualIdent -> QualIdent
updQualIdent ModuleIdent -> ModuleIdent
forall a. a -> a
id (Ident -> Integer -> Ident
`renameIdent` Integer
n) QualIdent
v) (Integer -> Expression a) -> SCM Integer -> SCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
newId
    -- return $ Variable v
    -- normal variable
  | 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'

-- * Because patterns or decls eventually introduce new variables, the
--   scope has to be nested one level.
-- * Because statements are processed list-wise, inNestedEnv can not be
--   used as this nesting must be visible to following statements.
checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ())
checkStatement :: String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement _ p :: SpanInfo
p (StmtExpr spi :: SpanInfo
spi     e :: Expression ()
e) = SpanInfo -> Expression () -> Statement ()
forall a. SpanInfo -> Expression a -> Statement a
StmtExpr SpanInfo
spi (Expression () -> Statement ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkStatement s :: String
s p :: SpanInfo
p (StmtBind spi :: SpanInfo
spi   t :: Pattern ()
t e :: Expression ()
e) =
  (Pattern () -> Expression () -> Statement ())
-> Expression () -> Pattern () -> Statement ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern () -> Expression () -> Statement ()
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
spi) (Expression () -> Pattern () -> Statement ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Pattern () -> Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity (Pattern () -> Statement ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SCM ()
incNesting SCM ()
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern String
s SpanInfo
p Pattern ()
t)
checkStatement _ _ (StmtDecl spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl ()]
ds) =
  SpanInfo -> LayoutInfo -> [Decl ()] -> Statement ()
forall a. SpanInfo -> LayoutInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi LayoutInfo
li ([Decl ()] -> Statement ())
-> SCM [Decl ()] -> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCM ()
incNesting SCM () -> SCM [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds)

bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ())
bindPattern :: String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern s :: String
s p :: SpanInfo
p t :: Pattern ()
t = do
  Pattern ()
t' <- SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t
  String -> SpanInfo -> Pattern () -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern ()
t'
  Bool -> Pattern () -> StateT SCState Identity (Pattern ())
forall t. QuantExpr t => Bool -> t -> SCM t
addBoundVariables Bool
True Pattern ()
t'

banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm _ _ (LiteralPattern           _ _ _) = SCM ()
ok
banFPTerm _ _ (NegativePattern          _ _ _) = SCM ()
ok
banFPTerm _ _ (VariablePattern          _ _ _) = SCM ()
ok
banFPTerm s :: String
s p :: SpanInfo
p (ConstructorPattern    _ _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (InfixPattern       _ _ t1 :: Pattern a
t1 _ t2 :: Pattern a
t2) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a
t1, Pattern a
t2]
banFPTerm s :: String
s p :: SpanInfo
p (ParenPattern               _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p (RecordPattern         _ _ _ fs :: [Field (Pattern a)]
fs) = (Field (Pattern a) -> SCM ()) -> [Field (Pattern a)] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Field (Pattern a) -> SCM ()
forall a. Field (Pattern a) -> SCM ()
banFPTermField [Field (Pattern a)]
fs
  where banFPTermField :: Field (Pattern a) -> SCM ()
banFPTermField (Field _ _ x :: Pattern a
x) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
x
banFPTerm s :: String
s p :: SpanInfo
p (TuplePattern              _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (ListPattern             _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p) [Pattern a]
ts
banFPTerm s :: String
s p :: SpanInfo
p (AsPattern                _ _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p (LazyPattern                _ t :: Pattern a
t) = String -> SpanInfo -> Pattern a -> SCM ()
forall a. String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm String
s SpanInfo
p Pattern a
t
banFPTerm s :: String
s p :: SpanInfo
p pat :: Pattern a
pat@(FunctionPattern    _ _ _ _)
 = Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern String
s SpanInfo
p Pattern a
pat
banFPTerm s :: String
s p :: SpanInfo
p pat :: Pattern a
pat@(InfixFuncPattern _ _ _ _ _)
 = Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern String
s SpanInfo
p Pattern a
pat

checkOp :: InfixOp a -> SCM (InfixOp a)
checkOp :: InfixOp a -> SCM (InfixOp a)
checkOp op :: InfixOp a
op = do
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
v NestEnv RenameInfo
env of
    []              -> Message -> SCM ()
report (QualIdent -> Message
errUndefinedVariable QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
    [Constr _ _]    -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixConstr a
a QualIdent
v
    [GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a QualIdent
v)
    [LocalVar v' :: Ident
v' _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a (QualIdent -> InfixOp a) -> QualIdent -> InfixOp a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
v'
    rs :: [RenameInfo]
rs              -> do
      ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
      case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
v) NestEnv RenameInfo
env of
        []              -> Message -> SCM ()
report ([RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
        [Constr _ _]    -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixConstr a
a QualIdent
v
        [GlobalVar f :: QualIdent
f _] -> QualIdent -> SCM ()
addGlobalDep QualIdent
f SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a QualIdent
v)
        [LocalVar v' :: Ident
v' _] -> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (InfixOp a -> SCM (InfixOp a)) -> InfixOp a -> SCM (InfixOp a)
forall a b. (a -> b) -> a -> b
$ a -> QualIdent -> InfixOp a
forall a. a -> QualIdent -> InfixOp a
InfixOp a
a (QualIdent -> InfixOp a) -> QualIdent -> InfixOp a
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
v'
        rs' :: [RenameInfo]
rs'             -> Message -> SCM ()
report ([RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs' QualIdent
v) SCM () -> SCM (InfixOp a) -> SCM (InfixOp a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InfixOp a -> SCM (InfixOp a)
forall (m :: * -> *) a. Monad m => a -> m a
return InfixOp a
op
  where v :: QualIdent
v = InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op
        a :: a
a = InfixOp a -> a
forall a. InfixOp a -> a
opAnnotation InfixOp a
op

checkAlt :: Alt () -> SCM (Alt ())
checkAlt :: Alt () -> StateT SCState Identity (Alt ())
checkAlt (Alt spi :: SpanInfo
spi t :: Pattern ()
t rhs :: Rhs ()
rhs) = StateT SCState Identity (Alt ())
-> StateT SCState Identity (Alt ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Alt ())
 -> StateT SCState Identity (Alt ()))
-> StateT SCState Identity (Alt ())
-> StateT SCState Identity (Alt ())
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> Pattern () -> Rhs () -> Alt ()
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
spi (Pattern () -> Rhs () -> Alt ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Rhs () -> Alt ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
bindPattern "case expression" SpanInfo
spi Pattern ()
t StateT SCState Identity (Rhs () -> Alt ())
-> StateT SCState Identity (Rhs ())
-> StateT SCState Identity (Alt ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs () -> StateT SCState Identity (Rhs ())
checkRhs Rhs ()
rhs

addBoundVariables :: (QuantExpr t) => Bool -> t -> SCM t
addBoundVariables :: Bool -> t -> SCM t
addBoundVariables checkDuplicates :: Bool
checkDuplicates ts :: t
ts = do
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkDuplicates (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ ([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateVariables)
                               ([Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
bvs)
  (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \ env :: NestEnv RenameInfo
env -> (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar NestEnv RenameInfo
env ([Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub [Ident]
bvs)
  t -> SCM t
forall (m :: * -> *) a. Monad m => a -> m a
return t
ts
  where bvs :: [Ident]
bvs = t -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv t
ts

-- For record patterns and expressions the compiler checks that all field
-- labels belong to the pattern or expression's constructor. For record
-- update expressions, the compiler checks that there is at least one
-- constructor which has all the specified field labels. In addition, the
-- compiler always checks that no field label occurs twice. Field labels
-- are always looked up in the global environment since they cannot be
-- shadowed by local variables (cf.\ Sect.~3.15.1 of the revised
-- Haskell'98 report~\cite{PeytonJones03:Haskell}).

checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels what :: String
what p :: SpanInfo
p c :: Maybe QualIdent
c fs :: [Field a]
fs = do
  (QualIdent -> StateT SCState Identity [QualIdent])
-> [QualIdent] -> StateT SCState Identity [[QualIdent]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualIdent -> StateT SCState Identity [QualIdent]
checkFieldLabel [QualIdent]
ls' StateT SCState Identity [[QualIdent]]
-> ([[QualIdent]] -> SCM ()) -> SCM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo
-> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM ()
checkLabels SpanInfo
p Maybe QualIdent
c [QualIdent]
ls'
  (QualIdent -> SCM ()) -> Maybe QualIdent -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QualIdent -> Message
errDuplicateLabel String
what) ([QualIdent] -> Maybe QualIdent
forall a. Eq a => [a] -> Maybe a
findDouble [QualIdent]
ls)
  where ls :: [QualIdent]
ls  = [QualIdent
l | Field _ l :: QualIdent
l _ <- [Field a]
fs]
        ls' :: [QualIdent]
ls' = [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a]
nub [QualIdent]
ls
        onJust :: (a -> SCM ()) -> Maybe a -> SCM ()
onJust = SCM () -> (a -> SCM ()) -> Maybe a -> SCM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SCM ()
ok

checkFieldLabel :: QualIdent -> SCM [QualIdent]
checkFieldLabel :: QualIdent -> StateT SCState Identity [QualIdent]
checkFieldLabel l :: QualIdent
l = do
  ModuleIdent
m   <- SCM ModuleIdent
getModuleIdent
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
l NestEnv RenameInfo
env of
    [RecordLabel _ cs :: [QualIdent]
cs] -> [QualIdent] -> StateT SCState Identity [QualIdent]
forall (t :: * -> *) a.
Foldable t =>
t a -> StateT SCState Identity (t a)
processLabel [QualIdent]
cs
    rs :: [RenameInfo]
rs                 -> case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
l) NestEnv RenameInfo
env of
      [RecordLabel _ cs :: [QualIdent]
cs] -> [QualIdent] -> StateT SCState Identity [QualIdent]
forall (t :: * -> *) a.
Foldable t =>
t a -> StateT SCState Identity (t a)
processLabel [QualIdent]
cs
      rs' :: [RenameInfo]
rs'                -> if ([RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs Bool -> Bool -> Bool
&& [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenameInfo]
rs')
                               then do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedLabel QualIdent
l
                                       [QualIdent] -> StateT SCState Identity [QualIdent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                               else do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$
                                         [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent [RenameInfo]
rs (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
l)
                                       [QualIdent] -> StateT SCState Identity [QualIdent]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
  processLabel :: t a -> StateT SCState Identity (t a)
processLabel cs' :: t a
cs' = do
    Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
cs') (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errUndefinedLabel QualIdent
l
    t a -> StateT SCState Identity (t a)
forall (m :: * -> *) a. Monad m => a -> m a
return t a
cs'

checkLabels :: SpanInfo -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]]
            -> SCM ()
checkLabels :: SpanInfo
-> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM ()
checkLabels _ (Just c :: QualIdent
c) ls :: [QualIdent]
ls css :: [[QualIdent]]
css = do
  NestEnv RenameInfo
env <- SCM (NestEnv RenameInfo)
getRenameEnv
  case QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
c NestEnv RenameInfo
env of
    [Constr c' :: QualIdent
c' _] -> (QualIdent -> SCM ()) -> [QualIdent] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ())
-> (QualIdent -> Message) -> QualIdent -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> QualIdent -> Message
errNoLabel QualIdent
c)
                           [QualIdent
l | (l :: QualIdent
l, cs :: [QualIdent]
cs) <- [QualIdent] -> [[QualIdent]] -> [(QualIdent, [QualIdent])]
forall a b. [a] -> [b] -> [(a, b)]
zip [QualIdent]
ls [[QualIdent]]
css, QualIdent
c' QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [QualIdent]
cs]
    _             -> String -> SCM ()
forall a. String -> a
internalError (String -> SCM ()) -> String -> SCM ()
forall a b. (a -> b) -> a -> b
$
                       "Checks.SyntaxCheck.checkLabels: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c
checkLabels p :: SpanInfo
p Nothing ls :: [QualIdent]
ls css :: [[QualIdent]]
css
  | Bool -> Bool
not ([QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([QualIdent] -> [QualIdent] -> [QualIdent])
-> [[QualIdent]] -> [QualIdent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [QualIdent] -> [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[QualIdent]]
css)) Bool -> Bool -> Bool
||
    ([QualIdent] -> Bool) -> [[QualIdent]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QualIdent]]
css = SCM ()
ok
  | Bool
otherwise    = Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [QualIdent] -> Message
errNoCommonCons SpanInfo
p [QualIdent]
ls

checkField :: (a -> SCM a) -> Field a -> SCM (Field a)
checkField :: (a -> SCM a) -> Field a -> SCM (Field a)
checkField check :: a -> SCM a
check (Field p :: SpanInfo
p l :: QualIdent
l x :: a
x) = SpanInfo -> QualIdent -> a -> Field a
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
l (a -> Field a) -> SCM a -> SCM (Field a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> SCM a
check a
x

-- ---------------------------------------------------------------------------
-- Auxiliary definitions
-- ---------------------------------------------------------------------------

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 _                        = []

-- Since the compiler expects all rules of the same function to be together,
-- it is necessary to sort the list of declarations.

sortFuncDecls :: [Decl a] -> [Decl a]
sortFuncDecls :: [Decl a] -> [Decl a]
sortFuncDecls = Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
forall a. Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
forall a. Set a
Set.empty []
 where
 sortFD :: Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD _   res :: [Decl a]
res []              = [Decl a] -> [Decl a]
forall a. [a] -> [a]
reverse [Decl a]
res
 sortFD env :: Set Ident
env res :: [Decl a]
res (decl :: Decl a
decl : decls' :: [Decl a]
decls') = case Decl a
decl of
   FunctionDecl _ _ ident :: Ident
ident _
    | Ident
ident Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
env
    -> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
env ((Decl a -> Decl a -> Ordering) -> Decl a -> [Decl a] -> [Decl a]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy Decl a -> Decl a -> Ordering
forall a. Decl a -> Decl a -> Ordering
cmpFuncDecl Decl a
decl [Decl a]
res) [Decl a]
decls'
    | Bool
otherwise
    -> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Ident
ident Set Ident
env) (Decl a
declDecl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:[Decl a]
res) [Decl a]
decls'
   _    -> Set Ident -> [Decl a] -> [Decl a] -> [Decl a]
sortFD Set Ident
env (Decl a
declDecl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
:[Decl a]
res) [Decl a]
decls'

cmpFuncDecl :: Decl a -> Decl a -> Ordering
cmpFuncDecl :: Decl a -> Decl a -> Ordering
cmpFuncDecl (FunctionDecl _ _ id1 :: Ident
id1 _) (FunctionDecl _ _ id2 :: Ident
id2 _)
   | Ident
id1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
id2 = Ordering
EQ
   | Bool
otherwise  = Ordering
GT
cmpFuncDecl _ _ = Ordering
GT

-- Due to the lack of a capitalization convention in Curry, it is
-- possible that an identifier may ambiguously refer to a data
-- constructor and a function provided that both are imported from some
-- other module. When checking whether an identifier denotes a
-- constructor there are two options with regard to ambiguous
-- identifiers:
--   * Handle the identifier as a data constructor if at least one of
--     the imported names is a data constructor.
--   * Handle the identifier as a data constructor only if all imported
--     entities are data constructors.
-- We choose the first possibility here because in the second case a
-- redefinition of a constructor can magically become possible if a
-- function with the same name is imported. It seems better to warn
-- the user about the fact that the identifier is ambiguous.

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

-- varIdent :: RenameInfo -> Ident
-- varIdent (GlobalVar _ v) = unqualify v
-- varIdent (LocalVar  _ v) = v
-- varIdent _ = internalError "SyntaxCheck.varIdent: no variable"

qualVarIdent :: RenameInfo -> QualIdent
qualVarIdent :: RenameInfo -> QualIdent
qualVarIdent (GlobalVar v :: QualIdent
v _) = QualIdent
v
qualVarIdent (LocalVar  v :: Ident
v _) = Ident -> QualIdent
qualify Ident
v
qualVarIdent _ = String -> QualIdent
forall a. String -> a
internalError "SyntaxCheck.qualVarIdent: no variable"

checkFPTerm :: SpanInfo -> Pattern a -> SCM ()
checkFPTerm :: SpanInfo -> Pattern a -> SCM ()
checkFPTerm _ (LiteralPattern        _ _ _) = SCM ()
ok
checkFPTerm _ (NegativePattern       _ _ _) = SCM ()
ok
checkFPTerm _ (VariablePattern       _ _ _) = SCM ()
ok
checkFPTerm p :: SpanInfo
p (ConstructorPattern _ _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (InfixPattern    _ _ t1 :: Pattern a
t1 _ t2 :: Pattern a
t2) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a
t1, Pattern a
t2]
checkFPTerm p :: SpanInfo
p (ParenPattern            _ t :: Pattern a
t) = SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p (TuplePattern           _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (ListPattern          _ _ ts :: [Pattern a]
ts) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p) [Pattern a]
ts
checkFPTerm p :: SpanInfo
p (AsPattern             _ _ t :: Pattern a
t) = SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p t :: Pattern a
t@(LazyPattern           _ _) =
  Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> SpanInfo -> Pattern a -> Message
forall a. String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm "Lazy" SpanInfo
p Pattern a
t
checkFPTerm p :: SpanInfo
p (RecordPattern      _ _ _ fs :: [Field (Pattern a)]
fs) = (Pattern a -> SCM ()) -> [Pattern a] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanInfo -> Pattern a -> SCM ()
forall a. SpanInfo -> Pattern a -> SCM ()
checkFPTerm SpanInfo
p)
                                            [ Pattern a
t | Field _ _ t :: Pattern a
t <- [Field (Pattern a)]
fs ]
checkFPTerm _ (FunctionPattern     _ _ _ _) = SCM ()
ok -- do not check again
checkFPTerm _ (InfixFuncPattern  _ _ _ _ _) = SCM ()
ok -- do not check again

-- ---------------------------------------------------------------------------
-- Miscellaneous functions
-- ---------------------------------------------------------------------------

checkFuncPatsExtension :: SpanInfo -> SCM ()
checkFuncPatsExtension :: SpanInfo -> SCM ()
checkFuncPatsExtension spi :: SpanInfo
spi = SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension SpanInfo
spi
  "Functional Patterns" KnownExtension
FunctionalPatterns

checkAnonFreeVarsExtension :: SpanInfo -> SCM ()
checkAnonFreeVarsExtension :: SpanInfo -> SCM ()
checkAnonFreeVarsExtension spi :: SpanInfo
spi = SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension SpanInfo
spi
  "Anonymous free variables" KnownExtension
AnonFreeVars

checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()
checkUsedExtension spi :: SpanInfo
spi msg :: String
msg ext :: KnownExtension
ext = do
  Bool
enabled <- KnownExtension -> SCM Bool
hasExtension KnownExtension
ext
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ do
    Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension SpanInfo
spi String
msg KnownExtension
ext
    KnownExtension -> SCM ()
enableExtension KnownExtension
ext -- to avoid multiple warnings

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

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFPTerm s :: String
s spi :: SpanInfo
spi pat :: Pattern a
pat = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
s
  Doc -> Doc -> Doc
<+> String -> Doc
text "patterns are not supported inside a functional pattern."
  Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
pat

errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message
errUnsupportedFuncPattern s :: String
s spi :: SpanInfo
spi pat :: Pattern a
pat = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Functional patterns are not supported inside a" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc
dot
  Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
pat

errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal f :: QualIdent
f = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Function", QualIdent -> String
escQualName QualIdent
f, "in functional pattern is not global"]

errFuncPatCyclic :: QualIdent -> QualIdent -> Message
errFuncPatCyclic :: QualIdent -> QualIdent -> Message
errFuncPatCyclic fp :: QualIdent
fp f :: QualIdent
f = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
fp (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Function", Ident -> String
escName (Ident -> String) -> Ident -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
unqualify QualIdent
fp, "used in functional pattern depends on"
  , Ident -> String
escName (Ident -> String) -> Ident -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
unqualify QualIdent
f, " causing a cyclic dependency"]

errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message
errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message
errPrecedenceOutOfRange spi :: SpanInfo
spi i :: Integer
i = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Precedence out of range:", Integer -> String
forall a. Show a => a -> String
show Integer
i]

errUndefinedVariable :: QualIdent -> Message
errUndefinedVariable :: QualIdent -> Message
errUndefinedVariable v :: QualIdent
v = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [QualIdent -> String
escQualName QualIdent
v, "is undefined"]

errUndefinedData :: QualIdent -> Message
errUndefinedData :: QualIdent -> Message
errUndefinedData c :: QualIdent
c = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Undefined data constructor", QualIdent -> String
escQualName QualIdent
c]

errUndefinedLabel :: QualIdent -> Message
errUndefinedLabel :: QualIdent -> Message
errUndefinedLabel l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$  [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Undefined record label", QualIdent -> String
escQualName QualIdent
l]

errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod qcls :: QualIdent
qcls f :: Ident
f = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [Ident -> String
escName Ident
f, "is not a (visible) method of class", QualIdent -> String
escQualName QualIdent
qcls]

errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
errAmbiguousIdent rs :: [RenameInfo]
rs qn :: QualIdent
qn | (RenameInfo -> Bool) -> [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenameInfo -> Bool
isConstr [RenameInfo]
rs = [RenameInfo] -> QualIdent -> Message
errAmbiguousData [RenameInfo]
rs QualIdent
qn
                        | (RenameInfo -> Bool) -> [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenameInfo -> Bool
isLabel  [RenameInfo]
rs = [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel [RenameInfo]
rs QualIdent
qn
                        | Bool
otherwise       = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "variable" [RenameInfo]
rs QualIdent
qn

errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
errAmbiguousData = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "data constructor"

errAmbiguousLabel :: [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel :: [RenameInfo] -> QualIdent -> Message
errAmbiguousLabel = String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous "field label"

errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
errAmbiguous what :: String
what rs :: [RenameInfo]
rs qn :: QualIdent
qn = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
qn
  (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$   String -> Doc
text "Ambiguous" Doc -> Doc -> Doc
<+> String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
  Doc -> Doc -> Doc
$+$ String -> Doc
text "It could refer to:"
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((RenameInfo -> Doc) -> [RenameInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RenameInfo -> Doc
ppRenameInfo [RenameInfo]
rs))

errDuplicateDefinition :: Ident -> Message
errDuplicateDefinition :: Ident -> Message
errDuplicateDefinition v :: Ident
v = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["More than one definition for", Ident -> String
escName Ident
v]

errDuplicateVariables :: [Ident] -> Message
errDuplicateVariables :: [Ident] -> Message
errDuplicateVariables [] = String -> Message
forall a. String -> a
internalError
  "SyntaxCheck.errDuplicateVariables: empty list"
errDuplicateVariables (v :: Ident
v:vs :: [Ident]
vs) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text (Ident -> String
escName Ident
v) Doc -> Doc -> Doc
<+> String -> Doc
text "occurs more than one in pattern at:" Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
vIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
vs)))

errMultipleDataConstructor :: [Ident] -> Message
errMultipleDataConstructor :: [Ident] -> Message
errMultipleDataConstructor [] = String -> Message
forall a. String -> a
internalError
  "SyntaxCheck.errMultipleDataDeclaration: empty list"
errMultipleDataConstructor (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Multiple definitions for data/record constructor" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
i)
  Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))

errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message
errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message
errMultipleDeclarations _ [] = String -> Message
forall a. String -> a
internalError
  "SyntaxCheck.errMultipleDeclarations: empty list"
errMultipleDeclarations m :: ModuleIdent
m (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Multiple declarations of" Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
i))
  Doc -> Doc -> Doc
$+$ String -> Doc
text "Declared at:" Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))

errDuplicateTypeSig :: [Ident] -> Message
errDuplicateTypeSig :: [Ident] -> Message
errDuplicateTypeSig [] = String -> Message
forall a. String -> a
internalError
  "SyntaxCheck.errDuplicateTypeSig: empty list"
errDuplicateTypeSig (v :: Ident
v:vs :: [Ident]
vs) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "More than one type signature for" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
v)
  Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
vIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
vs)))

errDuplicateLabel :: String -> QualIdent -> Message
errDuplicateLabel :: String -> QualIdent -> Message
errDuplicateLabel what :: String
what l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Field label", QualIdent -> String
escQualName QualIdent
l, "occurs more than once in record", String
what]

errNonVariable :: String -> Ident -> Message
errNonVariable :: String -> Ident -> Message
errNonVariable what :: String
what c :: Ident
c = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Data constructor", Ident -> String
escName Ident
c, "in left hand side of", String
what]

errNoBody :: Ident -> Message
errNoBody :: Ident -> Message
errNoBody v :: Ident
v = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$  [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ["No body for", Ident -> String
escName Ident
v]

errNoCommonCons :: SpanInfo -> [QualIdent] -> Message
errNoCommonCons :: SpanInfo -> [QualIdent] -> Message
errNoCommonCons spi :: SpanInfo
spi ls :: [QualIdent]
ls = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "No constructor has all of these fields:"
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((QualIdent -> Doc) -> [QualIdent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (QualIdent -> String) -> QualIdent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> String
escQualName) [QualIdent]
ls))

errNoLabel :: QualIdent -> QualIdent -> Message
errNoLabel :: QualIdent -> QualIdent -> Message
errNoLabel c :: QualIdent
c l :: QualIdent
l = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
l (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [QualIdent -> String
escQualName QualIdent
l, "is not a field label of constructor", QualIdent -> String
escQualName QualIdent
c]

errNoTypeSig :: Ident -> Message
errNoTypeSig :: Ident -> Message
errNoTypeSig f :: Ident
f = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["No type signature for external function", Ident -> String
escName Ident
f]

errToplevelPattern :: SpanInfo -> Message
errToplevelPattern :: SpanInfo -> Message
errToplevelPattern spi :: SpanInfo
spi = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text
  "Pattern declaration not allowed at top-level"

errDifferentArity :: [Ident] -> Message
errDifferentArity :: [Ident] -> Message
errDifferentArity [] = String -> Message
forall a. String -> a
internalError
  "SyntaxCheck.errDifferentArity: empty list"
errDifferentArity (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Equations for" Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
i) Doc -> Doc -> Doc
<+> String -> Doc
text "have different arities"
  Doc -> Doc -> Doc
<+> String -> Doc
text "at:" Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))

errWrongArity :: QualIdent -> Int -> Int -> Message
errWrongArity :: QualIdent -> Int -> Int -> Message
errWrongArity c :: QualIdent
c arity' :: Int
arity' argc :: Int
argc = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Data constructor", QualIdent -> String
escQualName QualIdent
c, "expects", Int -> String
forall a. (Eq a, Num a, Show a) => a -> String
arguments Int
arity'])
  Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> String -> Doc
text "but is applied to" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
argc)
  where arguments :: a -> String
arguments 0 = "no arguments"
        arguments 1 = "1 argument"
        arguments n :: a
n = a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " arguments"

errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message
errMissingLanguageExtension spi :: SpanInfo
spi what :: String
what ext :: KnownExtension
ext = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text "are not supported in standard Curry." Doc -> Doc -> Doc
$+$
  Int -> Doc -> Doc
nest 2 (String -> Doc
text "Use flag or -X" Doc -> Doc -> Doc
<+> String -> Doc
text (KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext)
          Doc -> Doc -> Doc
<+> String -> Doc
text "to enable this extension.")

errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens spi :: SpanInfo
spi calls :: [(QualIdent, QualIdent)]
calls = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Missing parens in infix patterns:" Doc -> Doc -> Doc
$+$
  [Doc] -> Doc
vcat (((QualIdent, QualIdent) -> Doc)
-> [(QualIdent, QualIdent)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent, QualIdent) -> Doc
showCall [(QualIdent, QualIdent)]
calls)
  where
  showCall :: (QualIdent, QualIdent) -> Doc
showCall (q1 :: QualIdent
q1, q2 :: QualIdent
q2) = QualIdent -> Doc
showWithPos QualIdent
q1 Doc -> Doc -> Doc
<+> String -> Doc
text "calls" Doc -> Doc -> Doc
<+> QualIdent -> Doc
showWithPos QualIdent
q2
  showWithPos :: QualIdent -> Doc
showWithPos q :: QualIdent
q =  String -> Doc
text (QualIdent -> String
qualName QualIdent
q)
               Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Position -> String
showLine (Position -> String) -> Position -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition QualIdent
q)