{- |
    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, runState, gets, modify
                                          , withState )
import           Data.Function            (on)
import           Data.List                (insertBy, intersect, nub, nubBy)
import qualified Data.Map  as Map         ( Map, empty, findWithDefault
                                          , fromList, insertWith, keys )
import           Data.Maybe               (isJust, isNothing)
import qualified Data.Set as Set          ( Set, empty, insert, member
                                          , singleton, toList, union)

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (ppPattern)

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

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

-- 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 -> SCState
initState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv

-- 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 -> 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 -> SCState
initState :: [KnownExtension]
-> ModuleIdent -> TCEnv -> NestEnv RenameInfo -> SCState
initState exts :: [KnownExtension]
exts m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv rEnv :: NestEnv RenameInfo
rEnv =
  [KnownExtension]
-> ModuleIdent
-> TCEnv
-> NestEnv RenameInfo
-> Integer
-> Integer
-> FuncDeps
-> Bool
-> [Message]
-> SCState
SCState [KnownExtension]
exts ModuleIdent
m TCEnv
tcEnv NestEnv RenameInfo
rEnv Integer
globalScopeId 1 FuncDeps
noFuncDeps Bool
False []

-- |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

-- |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
  = (QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [QualIdent] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS NestEnv RenameInfo
env ([QualIdent] -> NestEnv RenameInfo)
-> [QualIdent] -> NestEnv RenameInfo
forall a b. (a -> b) -> a -> b
$ (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m) [Ident]
fs
  where
    bindTS :: QualIdent -> NestEnv RenameInfo -> NestEnv RenameInfo
bindTS qf :: QualIdent
qf env' :: NestEnv RenameInfo
env'
      | [RenameInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RenameInfo] -> Bool) -> [RenameInfo] -> Bool
forall a b. (a -> b) -> a -> b
$ QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar QualIdent
qf NestEnv RenameInfo
env'
        = Bool
-> ModuleIdent
-> Ident
-> RenameInfo
-> NestEnv RenameInfo
-> NestEnv RenameInfo
bindGlobal Bool
tcc ModuleIdent
m (QualIdent -> Ident
unqualify QualIdent
qf) (QualIdent -> Int -> RenameInfo
GlobalVar QualIdent
qf (TypeExpr -> Int
typeArity TypeExpr
ty)) NestEnv RenameInfo
env'
      | Bool
otherwise = NestEnv RenameInfo
env'
bindFuncDecl _   _ _ env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env

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

-- |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 =
  (Ident -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Ident] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVar NestEnv RenameInfo
env ((Var a -> Ident) -> [Var a] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Var a -> Ident
forall a. Var a -> Ident
varIdent [Var a]
vs)
bindVarDecl _                           env :: NestEnv RenameInfo
env = NestEnv RenameInfo
env

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

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

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

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

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

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

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

checkInstanceDecl :: Decl () -> SCM (Decl ())
checkInstanceDecl :: Decl () -> StateT SCState Identity (Decl ())
checkInstanceDecl (InstanceDecl p :: SpanInfo
p cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl ()]
ds) = do
  ModuleIdent
m <- SCM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- SCM TCEnv
getTyConsEnv
  QualIdent -> [Ident] -> [Decl ()] -> SCM ()
forall a. QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods QualIdent
qcls (ModuleIdent -> QualIdent -> TCEnv -> [Ident]
clsMethods ModuleIdent
m QualIdent
qcls TCEnv
tcEnv) [Decl ()]
ds
  SpanInfo
-> Context -> QualIdent -> TypeExpr -> [Decl ()] -> Decl ()
forall a.
SpanInfo -> Context -> QualIdent -> TypeExpr -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p Context
cx QualIdent
qcls TypeExpr
ty ([Decl ()] -> Decl ())
-> SCM [Decl ()] -> StateT SCState Identity (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl ()] -> SCM [Decl ()]
checkTopDecls [Decl ()]
ds
checkInstanceDecl _ =
  String -> StateT SCState Identity (Decl ())
forall a. String -> a
internalError "SyntaxCheck.checkInstanceDecl: no instance declaration"

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

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

-- 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
$ Position -> Integer -> Message
errPrecedenceOutOfRange (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) Integer
i
  Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> StateT SCState Identity (Maybe Integer))
-> Maybe Integer -> StateT SCState Identity (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i

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

checkVar :: String -> Ident -> SCM Ident
checkVar :: String -> Ident -> StateT SCState Identity Ident
checkVar _what :: String
_what v :: Ident
v = do
  -- 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
$ Position -> Message
errToplevelPattern Position
p
                                       Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
forall a. Either a (Pattern ())
right
      where f' :: Ident
f'    = Ident -> Integer -> Ident
renameIdent Ident
f Integer
k
            infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
f) NestEnv RenameInfo
env
            left :: Either (Ident, Lhs ()) b
left  = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left  (Ident
f', SpanInfo -> Ident -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f' [Pattern ()]
ts)
            right :: Either a (Pattern ())
right = Pattern () -> Either a (Pattern ())
forall a b. b -> Either a b
Right (Pattern () -> Either a (Pattern ()))
-> Pattern () -> Either a (Pattern ())
forall a b. (a -> b) -> a -> b
$  -- 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
$ Position -> Message
errToplevelPattern Position
p
                                        Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Ident, Lhs ()) (Pattern ())
right
      where op' :: Ident
op'   = Ident -> Integer -> Ident
renameIdent Ident
op Integer
k
            infos :: [RenameInfo]
infos = QualIdent -> NestEnv RenameInfo -> [RenameInfo]
qualLookupVar (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
op) NestEnv RenameInfo
env
            left :: Either (Ident, Lhs ()) b
left  = (Ident, Lhs ()) -> Either (Ident, Lhs ()) b
forall a b. a -> Either a b
Left (Ident
op', SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi Pattern ()
t1 Ident
op' Pattern ()
t2)
            right :: Either (Ident, Lhs ()) (Pattern ())
right = Integer
-> NestEnv RenameInfo
-> (Pattern () -> Pattern ())
-> Pattern ()
-> Either (Ident, Lhs ()) (Pattern ())
forall a.
Integer
-> NestEnv RenameInfo
-> (Pattern a -> Pattern a)
-> Pattern a
-> Either (Ident, Lhs a) (Pattern a)
checkOpLhs Integer
k NestEnv RenameInfo
env (Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t1 (Ident -> QualIdent
qualify Ident
op)) Pattern ()
t2
            infixPattern :: Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern (InfixPattern _ a' :: ()
a' t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2') op2 :: QualIdent
op2 t3 :: Pattern ()
t3 =
              let t2'' :: Pattern ()
t2'' = Pattern () -> QualIdent -> Pattern () -> Pattern ()
infixPattern Pattern ()
t2' QualIdent
op2 Pattern ()
t3
                  sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2'')
              in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) ()
a' Pattern ()
t1' QualIdent
op1 Pattern ()
t2''
            infixPattern t1' :: Pattern ()
t1' op1 :: QualIdent
op1 t2' :: Pattern ()
t2' =
              let sp :: Span
sp = Span -> Span -> Span
combineSpans (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t1') (Pattern () -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan Pattern ()
t2')
              in SpanInfo
-> () -> Pattern () -> QualIdent -> Pattern () -> Pattern ()
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Span -> SpanInfo
fromSrcSpan Span
sp) () Pattern ()
t1' QualIdent
op1 Pattern ()
t2'
    ApLhs spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts -> do
      Either (Ident, Lhs ()) (Pattern ())
checked <- SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs SpanInfo
pspi Lhs ()
lhs
      case Either (Ident, Lhs ()) (Pattern ())
checked of
        Left (f' :: Ident
f', lhs' :: Lhs ()
lhs') -> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
 -> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ (Ident, Lhs ()) -> Either (Ident, Lhs ()) (Pattern ())
forall a b. a -> Either a b
Left (Ident
f', Lhs () -> Lhs ()
forall a. HasSpanInfo a => a -> a
updateEndPos (Lhs () -> Lhs ()) -> Lhs () -> Lhs ()
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi Lhs ()
lhs' [Pattern ()]
ts)
        r :: Either (Ident, Lhs ()) (Pattern ())
r               -> do Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> Message
errNonVariable "curried definition" Ident
f
                              Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Ident, Lhs ()) (Pattern ())
 -> SCM (Either (Ident, Lhs ()) (Pattern ())))
-> Either (Ident, Lhs ()) (Pattern ())
-> SCM (Either (Ident, Lhs ()) (Pattern ()))
forall a b. (a -> b) -> a -> b
$ Either (Ident, Lhs ()) (Pattern ())
r
        where (f :: Ident
f, _) = Lhs () -> (Ident, [Pattern ()])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs ()
lhs
  where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
pspi

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

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

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

checkDecls :: (Decl () -> RenameEnv -> RenameEnv) -> [Decl ()] -> SCM [Decl ()]
checkDecls :: (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDecls bindDecl :: Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl ds :: [Decl ()]
ds = do
  let dblVar :: Maybe Ident
dblVar = [Ident] -> Maybe Ident
forall a. Eq a => [a] -> Maybe a
findDouble [Ident]
bvs
  (Ident -> SCM ()) -> Maybe Ident -> SCM ()
forall a. (a -> SCM ()) -> Maybe a -> SCM ()
onJust (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errDuplicateDefinition) Maybe Ident
dblVar
  let mulTys :: [[Ident]]
mulTys = [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
tys
  ([Ident] -> SCM ()) -> [[Ident]] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> ([Ident] -> Message) -> [Ident] -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errDuplicateTypeSig) [[Ident]]
mulTys
  let missingTys :: [Ident]
missingTys = [Ident
v | ExternalDecl _ vs :: [Var ()]
vs <- [Decl ()]
ds, Var _ v :: Ident
v <- [Var ()]
vs, Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
tys]
  (Ident -> SCM ()) -> [Ident] -> SCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> SCM ()
report (Message -> SCM ()) -> (Ident -> Message) -> Ident -> SCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errNoTypeSig) [Ident]
missingTys
  if Maybe Ident -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Ident
dblVar Bool -> Bool -> Bool
&& [[Ident]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Ident]]
mulTys Bool -> Bool -> Bool
&& [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
missingTys
    then do
      (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
modifyRenameEnv ((NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ())
-> (NestEnv RenameInfo -> NestEnv RenameInfo) -> SCM ()
forall a b. (a -> b) -> a -> b
$ \env :: NestEnv RenameInfo
env -> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> NestEnv RenameInfo -> [Decl ()] -> NestEnv RenameInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
bindDecl NestEnv RenameInfo
env ([Decl ()]
tds [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
vds)
      (Decl () -> StateT SCState Identity (Decl ()))
-> [Decl ()] -> SCM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> Decl () -> StateT SCState Identity (Decl ())
checkDeclRhs [Ident]
bvs) [Decl ()]
ds
    else [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl ()]
ds -- 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
$ Position -> [(QualIdent, QualIdent)] -> Message
errInfixWithoutParens
    (Ident -> Position
forall a. HasPosition a => a -> Position
getPosition Ident
op) [(QualIdent, QualIdent)]
wrongCalls
  (Pattern () -> Ident -> Pattern () -> Lhs ())
-> Ident -> Pattern () -> Pattern () -> Lhs ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern () -> Ident -> Pattern () -> Lhs ()
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi) Ident
op (Pattern () -> Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ())
-> StateT SCState Identity (Pattern () -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t1 StateT SCState Identity (Pattern () -> Lhs ())
-> StateT SCState Identity (Pattern ()) -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p Pattern ()
t2
checkLhs p :: SpanInfo
p (ApLhs   spi :: SpanInfo
spi lhs :: Lhs ()
lhs ts :: [Pattern ()]
ts) =
  SpanInfo -> Lhs () -> [Pattern ()] -> Lhs ()
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi (Lhs () -> [Pattern ()] -> Lhs ())
-> SCM (Lhs ()) -> StateT SCState Identity ([Pattern ()] -> Lhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs SpanInfo
p Lhs ()
lhs StateT SCState Identity ([Pattern ()] -> Lhs ())
-> StateT SCState Identity [Pattern ()] -> SCM (Lhs ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern () -> StateT SCState Identity (Pattern ()))
-> [Pattern ()] -> StateT SCState Identity [Pattern ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern () -> StateT SCState Identity (Pattern ())
checkPattern SpanInfo
p) [Pattern ()]
ts

-- 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 (String -> StateT SCState Identity (Pattern ()))
-> String -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$
  "SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern  _ _ _ _ _) = String -> StateT SCState Identity (Pattern ())
forall a. String -> a
internalError (String -> StateT SCState Identity (Pattern ()))
-> String -> StateT SCState Identity (Pattern ())
forall a b. (a -> b) -> a -> b
$
  "SyntaxCheck.checkPattern: infix function pattern not defined"

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

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

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

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

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

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

checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())
checkExpr :: SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr _ (Literal       spi :: SpanInfo
spi a :: ()
a l :: Literal
l) = Expression () -> StateT SCState Identity (Expression ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression () -> StateT SCState Identity (Expression ()))
-> Expression () -> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ SpanInfo -> () -> Literal -> Expression ()
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
spi ()
a Literal
l
checkExpr _ (Variable      spi :: SpanInfo
spi a :: ()
a v :: QualIdent
v) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
v
checkExpr _ (Constructor   spi :: SpanInfo
spi a :: ()
a c :: QualIdent
c) = SpanInfo
-> () -> QualIdent -> StateT SCState Identity (Expression ())
forall a. SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable SpanInfo
spi ()
a QualIdent
c
checkExpr p :: SpanInfo
p (Paren         spi :: SpanInfo
spi   e :: Expression ()
e) = SpanInfo -> Expression () -> Expression ()
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
spi           (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Typed        spi :: SpanInfo
spi e :: Expression ()
e ty :: QualTypeExpr
ty) = (Expression () -> QualTypeExpr -> Expression ())
-> QualTypeExpr -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> QualTypeExpr -> Expression ()
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
ty (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Record     spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> QualIdent
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordExpr SpanInfo
p SpanInfo
spi QualIdent
c [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (RecordUpdate spi :: SpanInfo
spi e :: Expression ()
e fs :: [Field (Expression ())]
fs) = SpanInfo
-> SpanInfo
-> Expression ()
-> [Field (Expression ())]
-> StateT SCState Identity (Expression ())
checkRecordUpdExpr SpanInfo
p SpanInfo
spi Expression ()
e [Field (Expression ())]
fs
checkExpr p :: SpanInfo
p (Tuple        spi :: SpanInfo
spi   es :: [Expression ()]
es) = SpanInfo -> [Expression ()] -> Expression ()
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
spi ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (List         spi :: SpanInfo
spi a :: ()
a es :: [Expression ()]
es) = SpanInfo -> () -> [Expression ()] -> Expression ()
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
spi ()
a ([Expression ()] -> Expression ())
-> StateT SCState Identity [Expression ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression () -> StateT SCState Identity (Expression ()))
-> [Expression ()] -> StateT SCState Identity [Expression ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p) [Expression ()]
es
checkExpr p :: SpanInfo
p (ListCompr    spi :: SpanInfo
spi e :: Expression ()
e qs :: [Statement ()]
qs) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$ (Expression () -> [Statement ()] -> Expression ())
-> [Statement ()] -> Expression () -> Expression ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression () -> [Statement ()] -> Expression ()
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
spi) ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  -- 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 ds :: [Decl ()]
ds e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
inNestedScope (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> [Decl ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi ([Decl ()] -> Expression () -> Expression ())
-> SCM [Decl ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (Do                spi :: SpanInfo
spi sts :: [Statement ()]
sts e :: Expression ()
e) = StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a. SCM a -> SCM a
withLocalEnv (StateT SCState Identity (Expression ())
 -> StateT SCState Identity (Expression ()))
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> [Statement ()] -> Expression () -> Expression ()
forall a. SpanInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi ([Statement ()] -> Expression () -> Expression ())
-> StateT SCState Identity [Statement ()]
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement () -> StateT SCState Identity (Statement ()))
-> [Statement ()] -> StateT SCState Identity [Statement ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String
-> SpanInfo
-> Statement ()
-> StateT SCState Identity (Statement ())
checkStatement "do sequence" SpanInfo
p) [Statement ()]
sts StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e
checkExpr p :: SpanInfo
p (IfThenElse     spi :: SpanInfo
spi e1 :: Expression ()
e1 e2 :: Expression ()
e2 e3 :: Expression ()
e3) =
  SpanInfo
-> Expression () -> Expression () -> Expression () -> Expression ()
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
spi (Expression () -> Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT
     SCState Identity (Expression () -> Expression () -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e1 StateT
  SCState Identity (Expression () -> Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression () -> Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e2 StateT SCState Identity (Expression () -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e3
checkExpr p :: SpanInfo
p (Case          spi :: SpanInfo
spi ct :: CaseType
ct e :: Expression ()
e alts :: [Alt ()]
alts) =
  SpanInfo -> CaseType -> Expression () -> [Alt ()] -> Expression ()
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi CaseType
ct (Expression () -> [Alt ()] -> Expression ())
-> StateT SCState Identity (Expression ())
-> StateT SCState Identity ([Alt ()] -> Expression ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> Expression () -> StateT SCState Identity (Expression ())
checkExpr SpanInfo
p Expression ()
e StateT SCState Identity ([Alt ()] -> Expression ())
-> StateT SCState Identity [Alt ()]
-> StateT SCState Identity (Expression ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt () -> StateT SCState Identity (Alt ()))
-> [Alt ()] -> StateT SCState Identity [Alt ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt () -> StateT SCState Identity (Alt ())
checkAlt [Alt ()]
alts

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

checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable spi :: SpanInfo
spi a :: a
a v :: QualIdent
v
    -- anonymous free variable
  | Ident -> Bool
isAnonId (QualIdent -> Ident
unqualify QualIdent
v) = do
    Position -> SCM ()
checkAnonFreeVarsExtension (Position -> SCM ()) -> Position -> SCM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition QualIdent
v
    (\n :: Integer
n -> SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a (QualIdent -> Expression a) -> QualIdent -> Expression a
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> ModuleIdent)
-> (Ident -> Ident) -> QualIdent -> QualIdent
updQualIdent ModuleIdent -> ModuleIdent
forall a. a -> a
id ((Ident -> Integer -> Ident) -> Integer -> Ident -> Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ident -> Integer -> Ident
renameIdent Integer
n) QualIdent
v) (Integer -> Expression a) -> SCM Integer -> SCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SCM Integer
newId
    -- 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  ds :: [Decl ()]
ds) =
  SpanInfo -> [Decl ()] -> Statement ()
forall a. SpanInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi ([Decl ()] -> Statement ())
-> SCM [Decl ()] -> StateT SCState Identity (Statement ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SCM ()
incNesting SCM () -> SCM [Decl ()] -> SCM [Decl ()]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo)
-> [Decl ()] -> SCM [Decl ()]
checkDeclGroup Decl () -> NestEnv RenameInfo -> NestEnv RenameInfo
forall a. Decl a -> NestEnv RenameInfo -> NestEnv RenameInfo
bindVarDecl [Decl ()]
ds)

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

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

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

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

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

-- 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 -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([QualIdent] -> [QualIdent] -> [QualIdent])
-> [[QualIdent]] -> [QualIdent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [QualIdent] -> [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[QualIdent]]
css))
    (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ Position -> [QualIdent] -> Message
errNoCommonCons (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) [QualIdent]
ls

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

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

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

-- 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"

arity :: RenameInfo -> Int
arity :: RenameInfo -> Int
arity (Constr      _ n :: Int
n) = Int
n
arity (GlobalVar   _ n :: Int
n) = Int
n
arity (LocalVar    _ n :: Int
n) = Int
n
arity (RecordLabel _ _) = 1

-- Unlike expressions, constructor terms have no possibility to represent
-- over-applications in functional patterns. Therefore it is necessary to
-- transform them to nested function patterns using the prelude function
-- apply. E.g., the function pattern (id id 10) is transformed to
-- (apply (id id) 10).

genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl term :: Pattern ()
term []     = Pattern ()
term
genFuncPattAppl term :: Pattern ()
term (t :: Pattern ()
t:ts :: [Pattern ()]
ts)
   = SpanInfo -> () -> QualIdent -> [Pattern ()] -> Pattern ()
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo () QualIdent
qApplyId [Pattern () -> [Pattern ()] -> Pattern ()
genFuncPattAppl Pattern ()
term [Pattern ()]
ts, Pattern ()
t] -- TODO FIXME major problem

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

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

checkFuncPatsExtension :: Position -> SCM ()
checkFuncPatsExtension :: Position -> SCM ()
checkFuncPatsExtension p :: Position
p = Position -> String -> KnownExtension -> SCM ()
checkUsedExtension Position
p
  "Functional Patterns" KnownExtension
FunctionalPatterns

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

checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
checkUsedExtension pos :: Position
pos msg :: String
msg ext :: KnownExtension
ext = do
  Bool
enabled <- KnownExtension -> SCM Bool
hasExtension KnownExtension
ext
  Bool -> SCM () -> SCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (SCM () -> SCM ()) -> SCM () -> SCM ()
forall a b. (a -> b) -> a -> b
$ do
    Message -> SCM ()
report (Message -> SCM ()) -> Message -> SCM ()
forall a b. (a -> b) -> a -> b
$ Position -> String -> KnownExtension -> Message
errMissingLanguageExtension Position
pos String
msg KnownExtension
ext
    KnownExtension -> SCM ()
enableExtension KnownExtension
ext -- 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 -> Position -> Pattern a -> Message
errUnsupportedFPTerm :: String -> Position -> Pattern a -> Message
errUnsupportedFPTerm s :: String
s p :: Position
p pat :: Pattern a
pat = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
s
  Doc -> Doc -> Doc
<+> String -> Doc
text "patterns are not supported inside a functional pattern."
  Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
pat

errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern s :: String
s p :: Position
p pat :: Pattern a
pat = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Functional patterns are not supported inside a" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
<> Doc
dot
  Doc -> Doc -> Doc
$+$ Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
pat

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

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

errPrecedenceOutOfRange :: Position -> Integer -> Message
errPrecedenceOutOfRange :: Position -> Integer -> Message
errPrecedenceOutOfRange p :: Position
p i :: Integer
i = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Precedence out of range:", Integer -> String
forall a. Show a => a -> String
show Integer
i]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

errToplevelPattern :: Position -> Message
errToplevelPattern :: Position -> Message
errToplevelPattern p :: Position
p = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text
  "Pattern declaration not allowed at top-level"

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

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

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

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