Commit aae34edd authored by Finn Teegen's avatar Finn Teegen
Browse files

Merge remote-tracking branch 'upstream/master'

parents 02fd2b4f 372a9c4b
......@@ -59,7 +59,6 @@ Library
, Base.Messages
, Base.NestEnv
, Base.SCC
, Base.ScopeEnv
, Base.Subst
, Base.TopEnv
, Base.Types
......@@ -99,7 +98,7 @@ Library
, Imports
, Interfaces
, Modules
, ModuleSummary
, TokenStream
, Transformations
, Transformations.CaseCompletion
, Transformations.CurryToIL
......
{- |
Module : $Header$
Description : Construction and output of compiler messages
Copyright : (c) 2011 - 2016 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module defines several operations to construct and emit compiler
messages to the user.
-}
module Base.Messages
( -- * Output of user information
status, warn, putErrLn, putErrsLn
MonadIO (..), status, putMsg, putErrLn, putErrsLn
-- * program abortion
, abortWith, abortWithMessage, abortWithMessages
, internalError, errorMessage, errorMessages
, abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError
-- * creating messages
, Message, message, posMessage
, MonadIO (..)
) where
import Control.Monad (unless, when)
......@@ -15,23 +26,15 @@ import Data.List (sort)
import System.IO (hFlush, hPutStrLn, stderr, stdout)
import System.Exit (exitFailure)
import Curry.Base.Message ( Message, message, posMessage, ppMessage
, ppMessages, ppWarning, ppError)
import Curry.Base.Monad (CYIO, failMessages)
import Curry.Base.Pretty (text)
import Curry.Base.Message ( Message, message, posMessage, ppWarning
, ppMessages, ppError)
import Curry.Base.Pretty (Doc, text)
import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..))
-- |Print a status message, depending on the current verbosity
status :: MonadIO m => Options -> String -> m ()
status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)
-- TODO: bad code: Extend Curry monads (CYT / CYIO) to also track warnings
-- (see ticket 1246)
warn :: WarnOpts -> [Message] -> CYIO ()
warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
if wnWarnAsError opts
then failMessages (msgs ++ [message $ text "Failed due to -Werror"])
else liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
-- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m ()
putMsg msg = liftIO (putStrLn msg >> hFlush stdout)
......@@ -55,16 +58,21 @@ abortWithMessage msg = abortWithMessages [msg]
-- |Print a list of error messages on 'stderr' and abort the program
abortWithMessages :: [Message] -> IO a
abortWithMessages msgs = do
unless (null msgs) $ putErrLn (show $ ppMessages ppMessage $ sort msgs)
exitFailure
abortWithMessages msgs = printMessages ppError msgs >> exitFailure
-- |Print a list of warning messages on 'stderr' and abort the program
-- |if the -Werror option is set
warnOrAbort :: WarnOpts -> [Message] -> IO ()
warnOrAbort opts msgs = when (wnWarn opts && not (null msgs)) $ do
if wnWarnAsError opts
then abortWithMessages (msgs ++ [message $ text "Failed due to -Werror"])
else printMessages ppWarning msgs
-- |Print a list of messages on 'stderr'
printMessages :: (Message -> Doc) -> [Message] -> IO ()
printMessages msgType msgs
= unless (null msgs) $ putErrLn (show $ ppMessages msgType $ sort msgs)
-- |Raise an internal error
internalError :: String -> a
internalError msg = error $ "Internal error: " ++ msg
errorMessage :: Message -> a
errorMessage = error . show . ppError
errorMessages :: [Message] -> a
errorMessages = error . show . ppMessages ppError . sort
......@@ -18,8 +18,11 @@
module Base.NestEnv
( module Base.TopEnv
, NestEnv, bindNestEnv, qualBindNestEnv, lookupNestEnv, qualLookupNestEnv
, toplevelEnv, globalEnv, nestEnv, elemNestEnv
, NestEnv, emptyEnv, bindNestEnv, qualBindNestEnv
, lookupNestEnv, qualLookupNestEnv
, rebindNestEnv, qualRebindNestEnv
, unnestEnv, toplevelEnv, globalEnv, nestEnv, elemNestEnv
, qualModifyNestEnv, modifyNestEnv, localNestEnv, qualInLocalNestEnv
) where
import qualified Data.Map as Map
......@@ -40,9 +43,16 @@ instance Functor NestEnv where
globalEnv :: TopEnv a -> NestEnv a
globalEnv = GlobalEnv
emptyEnv :: NestEnv a
emptyEnv = globalEnv emptyTopEnv
nestEnv :: NestEnv a -> NestEnv a
nestEnv env = LocalEnv env Map.empty
unnestEnv :: NestEnv a -> NestEnv a
unnestEnv g@(GlobalEnv _) = g
unnestEnv (LocalEnv genv _) = genv
toplevelEnv :: NestEnv a -> TopEnv a
toplevelEnv (GlobalEnv env) = env
toplevelEnv (LocalEnv genv _) = toplevelEnv genv
......@@ -50,7 +60,7 @@ toplevelEnv (LocalEnv genv _) = toplevelEnv genv
bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv x y (GlobalEnv env) = GlobalEnv $ bindTopEnv x y env
bindNestEnv x y (LocalEnv genv env) = case Map.lookup x env of
Just _ -> internalError $ "NestEnv.bindNestEnv " ++ show x
Just _ -> internalError $ "NestEnv.bindNestEnv: " ++ show x ++ " is already bound"
Nothing -> LocalEnv genv $ Map.insert x y env
qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
......@@ -62,6 +72,19 @@ qualBindNestEnv x y (LocalEnv genv env)
Nothing -> LocalEnv genv $ Map.insert x' y env
where x' = unqualify x
-- Rebinds a value to a variable, failes if the variable was unbound before
rebindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
rebindNestEnv = qualRebindNestEnv . qualify
qualRebindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
qualRebindNestEnv x y (GlobalEnv env) = GlobalEnv $ qualRebindTopEnv x y env
qualRebindNestEnv x y (LocalEnv genv env)
| isQualified x = internalError $ "NestEnv.qualRebindNestEnv " ++ show x
| otherwise = case Map.lookup x' env of
Just _ -> LocalEnv genv $ Map.insert x' y env
Nothing -> LocalEnv (qualRebindNestEnv x y genv) env
where x' = unqualify x
lookupNestEnv :: Ident -> NestEnv a -> [a]
lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env
lookupNestEnv x (LocalEnv genv env) = case Map.lookup x env of
......@@ -75,3 +98,23 @@ qualLookupNestEnv x env
elemNestEnv :: Ident -> NestEnv a -> Bool
elemNestEnv x env = not (null (lookupNestEnv x env))
-- Applies a function to a value binding, does nothing if the variable is unbound
modifyNestEnv :: (a -> a) -> Ident -> NestEnv a -> NestEnv a
modifyNestEnv f = qualModifyNestEnv f . qualify
qualModifyNestEnv :: (a -> a) -> QualIdent -> NestEnv a -> NestEnv a
qualModifyNestEnv f x env = case qualLookupNestEnv x env of
[] -> env
y : _ -> qualRebindNestEnv x (f y) env
-- Returns the variables and values bound on the bottom (meaning non-top) scope
localNestEnv :: NestEnv a -> [(Ident, a)]
localNestEnv (GlobalEnv env) = localBindings env
localNestEnv (LocalEnv _ env) = Map.toList env
-- Returns wether the variable is bound on the bottom (meaning non-top) scope
qualInLocalNestEnv :: QualIdent -> NestEnv a -> Bool
qualInLocalNestEnv x (GlobalEnv env) = qualElemTopEnv x env
qualInLocalNestEnv x (LocalEnv _ env) = (not (isQualified x))
&& Map.member (unqualify x) env
......@@ -35,6 +35,7 @@ instance Eq (Node a b) where
instance Ord (Node b a) where
n1 `compare` n2 = key n1 `compare` key n2
-- |Computation of strongly connected components
scc :: Eq b => (a -> [b]) -- ^entities defined by node
-> (a -> [b]) -- ^entities used by node
-> [a] -- ^list of nodes
......
{- |ScopeEnv - provides functions and data types for dealing with nested
scope environments to store data from nested scopes
This module should be imported using "import qualified" to avoid name
clashes
November 2005,
Martin Engelke (men@informatik.uni-kiel.de)
-}
module Base.ScopeEnv
( Level, ScopeEnv
, new, insert, modify, lookup, level, lookupWithLevel, exists, beginScope
, endScope, endScopeUp, toLevelList, currentLevel
) where
import Prelude hiding (lookup)
import qualified Data.Map as Map
type Level = Int
type LevelMap a b = Map.Map a (b, Level)
-- |Data type for representing information in nested scopes.
data ScopeEnv a b = ScopeEnv Level (LevelMap a b) [LevelMap a b]
deriving Show
-- |Returns an empty scope environment
new :: Ord a => ScopeEnv a b
new = ScopeEnv 0 Map.empty []
-- |Inserts a value under a key into the environment of the current scope
insert :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b
insert k v = modifySE insertLev
where insertLev lev = Map.insert k (v, lev)
-- |Modifies the value of an existing key by applying the function 'fun'
-- in the environment of the current scope
modify :: Ord a => (b -> b) -> a -> ScopeEnv a b -> ScopeEnv a b
modify f k = modifySE modifyLev
where modifyLev _ = Map.adjust (\ (v, l) -> (f v, l)) k
-- |Looks up the value which is stored under a key from the environment of
-- the current scope
lookup :: Ord a => a -> ScopeEnv a b -> Maybe b
lookup k = fmap fst . lookupWithLevel k
-- Returns the level of the last insertion of a key
level :: Ord a => a -> ScopeEnv a b -> Level
level k = maybe (-1) snd . lookupWithLevel k
-- |Looks up the value and the level which is stored under a key from the
-- environment of the current scope
lookupWithLevel :: Ord a => a -> ScopeEnv a b -> Maybe (b, Level)
lookupWithLevel k = selectSE lookupLev
where lookupLev _ = Map.lookup k
-- Checks, whether a key exists in the environment of the current scope
exists :: Ord a => a -> ScopeEnv a b -> Bool
exists k = selectSE existsLev
where existsLev _ = Map.member k
-- Switches to the next scope (i.e. pushes the environment of the current
-- scope onto the top of an scope stack and increments the level counter)
beginScope :: Ord a => ScopeEnv a b -> ScopeEnv a b
beginScope (ScopeEnv lev top [] ) = ScopeEnv (lev + 1) top [top]
beginScope (ScopeEnv lev top (l:ls)) = ScopeEnv (lev + 1) top (l:l:ls)
-- Switches to the previous scope (i.e. pops the environment from the top
-- of the scope stack and decrements the level counter)
endScope :: Ord a => ScopeEnv a b -> ScopeEnv a b
endScope (ScopeEnv _ top [] ) = ScopeEnv 0 top []
endScope (ScopeEnv lev top (_:ls)) = ScopeEnv (lev - 1) top ls
-- Behaves like 'endScope' but additionally updates the environment of
-- the previous scope by updating all keys with the corresponding values
-- from the popped environment
endScopeUp :: Ord a => ScopeEnv a b -> ScopeEnv a b
endScopeUp (ScopeEnv _ top [] ) = ScopeEnv 0 top []
endScopeUp (ScopeEnv _ top (l:[]) ) = ScopeEnv 0 (integrate l top) []
endScopeUp (ScopeEnv lev top (l:l':ls)) = ScopeEnv (lev - 1) top
(integrate l l' : ls)
-- Return all (key, value) pairs from the environment of the current scope
-- which have been inserted in the current level
toLevelList :: Ord a => ScopeEnv a b -> [(a, b)]
toLevelList = selectSE toList
where toList lev local
= [ (k, v) | (k, (v, lev')) <- Map.toList local, lev' == lev ]
-- Return the current level
currentLevel :: Ord a => ScopeEnv a b -> Level
currentLevel = selectSE const
-- ---------------------------------------------------------------------------
-- Privates
-- ---------------------------------------------------------------------------
modifySE :: (Level -> LevelMap a b -> LevelMap a b)
-> ScopeEnv a b -> ScopeEnv a b
modifySE f (ScopeEnv _ top [] ) = ScopeEnv 0 (f 0 top) []
modifySE f (ScopeEnv lev top (l:ls)) = ScopeEnv lev top (f lev l : ls)
selectSE :: (Level -> LevelMap a b -> c) -> ScopeEnv a b -> c
selectSE f (ScopeEnv _ top [] ) = f 0 top
selectSE f (ScopeEnv lev _ (l:_)) = f lev l
integrate :: Ord a => LevelMap a b -> LevelMap a b -> LevelMap a b
integrate local = Map.mapWithKey update
where update k old@(_, l) = case Map.lookup k local of
Nothing -> old
Just (v', l')
| l == l' -> (v', l)
| otherwise -> old
......@@ -24,20 +24,27 @@ module Base.Subst
import qualified Data.Map as Map
data Subst a b = Subst Bool (Map.Map a b) deriving Show
-- |Data type for substitution
data Subst a b = Subst Bool (Map.Map a b)
deriving Show
idSubst :: Ord a => Subst a b
-- |Identity substitution
idSubst :: Subst a b
idSubst = Subst False Map.empty
substToList :: Ord v => Subst v e -> [(v, e)]
-- |Convert a substitution to a list of replacements
substToList :: Subst v e -> [(v, e)]
substToList (Subst _ sigma) = Map.toList sigma
-- |Create a substitution for a single replacement
singleSubst :: Ord v => v -> e -> Subst v e
singleSubst v e = bindSubst v e idSubst
-- |Extend a substitution with a single replacement
bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e
bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
-- |Remove a single replacement from a substitution
unbindSubst :: Ord v => v -> Subst v e -> Subst v e
unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma
......@@ -80,7 +87,8 @@ unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma
-- substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma)
-- where subst' = if comp then subst (Subst comp sigma) else id
compose :: (Ord v, Show v ,Show e) => Subst v e -> Subst v e -> Subst v e
-- |Compose two substitutions
compose :: Ord v => Subst v e -> Subst v e -> Subst v e
compose sigma sigma' =
composed (foldr (uncurry bindSubst) sigma' (substToList sigma))
where composed (Subst _ sigma'') = Subst True sigma''
......@@ -93,22 +101,26 @@ compose sigma sigma' =
-- module includes a class 'IntSubst' for substitution whose
-- domain are integer numbers.
-- |Apply a substitution to a variable
substVar' :: Ord v => (v -> e) -> (Subst v e -> e -> e)
-> Subst v e -> v -> e
substVar' var subst (Subst comp sigma) v =
maybe (var v) subst' (Map.lookup v sigma)
where subst' = if comp then subst (Subst comp sigma) else id
-- |Type class for terms where variables are represented as 'Int's
class IntSubst e where
-- |Construct a variable from an 'Int'
ivar :: Int -> e
-- |Apply a substitution to a term
isubst :: Subst Int e -> e -> e
-- |Apply a substitution to a term with variables represented as 'Int's
isubstVar :: IntSubst e => Subst Int e -> Int -> e
isubstVar = substVar' ivar isubst
-- The function 'restrictSubstTo' implements the restriction of a
-- |The function 'restrictSubstTo' implements the restriction of a
-- substitution to a given subset of its domain.
restrictSubstTo :: Ord v => [v] -> Subst v e -> Subst v e
restrictSubstTo vs (Subst comp sigma) =
foldr (uncurry bindSubst) (Subst comp Map.empty)
......
......@@ -43,7 +43,7 @@ module Base.TopEnv
, emptyTopEnv, predefTopEnv, importTopEnv, qualImportTopEnv
, bindTopEnv, qualBindTopEnv, rebindTopEnv
, qualRebindTopEnv, unbindTopEnv, qualUnbindTopEnv
, lookupTopEnv, qualLookupTopEnv
, lookupTopEnv, qualLookupTopEnv, qualElemTopEnv
, allImports, moduleImports, localBindings, allLocalBindings, allBindings
, allEntities
, getOrigName, reverseLookupByOrigName
......@@ -81,7 +81,7 @@ emptyTopEnv :: TopEnv a
emptyTopEnv = TopEnv Map.empty
-- |Insert an 'Entity' into a 'TopEnv' as a predefined 'Entity'
predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
predefTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
predefTopEnv k v (TopEnv env) = case Map.lookup k env of
Just _ -> internalError $ "TopEnv.predefTopEnv " ++ show k
Nothing -> TopEnv $ Map.insert k [(Import [], v)] env
......@@ -152,6 +152,9 @@ lookupTopEnv = qualLookupTopEnv . qualify
qualLookupTopEnv :: QualIdent -> TopEnv a -> [a]
qualLookupTopEnv x (TopEnv env) = map snd (entities x env)
qualElemTopEnv :: QualIdent -> TopEnv a -> Bool
qualElemTopEnv x env = not (null (qualLookupTopEnv x env))
allImports :: TopEnv a -> [(QualIdent, a)]
allImports (TopEnv env) =
[ (x, y) | (x, ys) <- Map.toList env, (Import _, y) <- ys ]
......
......@@ -29,12 +29,17 @@ module Checks.SyntaxCheck (syntaxCheck) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
-- <<<<<<< HEAD
import Control.Monad (unless, when)
import qualified Control.Monad.State as S ( State, runState, gets, modify
, withState )
import Data.List (insertBy, intersect, nub)
import Data.Maybe (isJust, isNothing)
import qualified Data.Set as Set (empty, insert, member)
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
......@@ -45,6 +50,7 @@ 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)
......@@ -96,13 +102,15 @@ data SCState = SCState
, renameEnv :: RenameEnv -- ^ Information store
, scopeId :: Integer -- ^ Identifier for the current scope
, nextId :: Integer -- ^ Next fresh identifier
, funcDeps :: FuncDeps -- ^ Stores data about functions dependencies
, typeClassesCheck :: Bool
, errors :: [Message] -- ^ Syntactic errors in the module
}
-- |Initial syntax check state
initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> SCState
initState exts m tcEnv rEnv = SCState exts m tcEnv rEnv globalScopeId 1 False []
initState exts m tcEnv rEnv =
SCState exts m tcEnv rEnv globalScopeId 1 noFuncDeps False []
-- |Identifier for global (top-level) declarations
globalScopeId :: Integer
......@@ -181,6 +189,10 @@ withLocalEnv act = do
inNestedScope :: SCM a -> SCM a
inNestedScope act = withLocalEnv (incNesting >> act)
-- |Modify the `FuncDeps'
modifyFuncDeps :: (FuncDeps -> FuncDeps) -> SCM ()
modifyFuncDeps f = S.modify $ \ s -> s { funcDeps = f $ funcDeps s }
-- |Report a syntax error
report :: Message -> SCM ()
report msg = S.modify $ \s -> s { errors = msg : errors s }
......@@ -189,6 +201,65 @@ report msg = S.modify $ \s -> s { errors = msg : errors s }
ok :: SCM ()
ok = 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
{ curGlobalFunc :: Maybe QualIdent
, globalDeps :: GlobalDeps
, funcPats :: [(QualIdent, QualIdent)]
}
type GlobalDeps = Map.Map QualIdent (Set.Set QualIdent)
-- |Initial state for FuncDeps
noFuncDeps :: FuncDeps
noFuncDeps = FuncDeps Nothing Map.empty []
-- |Perform an action inside a function, settìng `curGlobalFunc' to that function
inFunc :: Ident -> SCM a -> SCM a
inFunc i scm = do
m <- getModuleIdent
global <- isNothing <$> S.gets (curGlobalFunc . funcDeps)
when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Just (qualifyWith m i) }
res <- scm
when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Nothing }
return res
-- |Add a dependency to `curGlobalFunction'
addGlobalDep :: QualIdent -> SCM ()
addGlobalDep dep = do
maybeF <- S.gets (curGlobalFunc . funcDeps)
case maybeF of
Nothing -> internalError "SyntaxCheck.addFuncPat: no global function set"
Just f -> modifyFuncDeps $ \ fd -> fd
{ globalDeps = Map.insertWith (Set.union) f
(Set.singleton dep) (globalDeps fd) }
-- |Add a functional pattern to `curGlobalFunction'
addFuncPat :: QualIdent -> SCM ()
addFuncPat fp = do
maybeF <- S.gets (curGlobalFunc . funcDeps)
case maybeF of
Nothing -> internalError "SyntaxCheck.addFuncPat: no global function set"
Just f -> modifyFuncDeps $ \ fd -> fd { funcPats = (fp, f) : funcPats fd }
-- |Return dependencies of global functions
getGlobalDeps :: SCM GlobalDeps
getGlobalDeps = globalDeps <$> S.gets funcDeps
-- |Return used functional patterns
getFuncPats :: SCM [(QualIdent, QualIdent)]
getFuncPats = funcPats <$> S.gets 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
......@@ -376,12 +447,30 @@ checkModule (Module ps m es is ds) = do
cds' <- mapM (performTypeClassesCheck . checkClassDecl) cds
ids' <- mapM (performTypeClassesCheck . checkInstanceDecl) ids
let ds'' = updateClassAndInstanceDecls cds' ids' ds'
checkFuncPatDeps
exts <- getExtensions
return (Module ps m es is ds'', exts)
where tds = filter isTypeDecl ds
cds = filter isClassDecl ds
ids = filter isInstanceDecl ds
-- |Checks whether a function in a functional pattern contains cycles
-- |(depends on its own global function)
checkFuncPatDeps :: SCM ()
checkFuncPatDeps = do
fps <- getFuncPats
deps <- getGlobalDeps
let levels = scc (:[])
(\k -> Set.toList (Map.findWithDefault (Set.empty) k deps))
(Map.keys deps)
levelMap = Map.fromList [ (f, l) | (fs, l) <- zip levels [1 ..], f <- fs ]
level f = Map.findWithDefault (0 :: Int) f levelMap
mapM_ (checkFuncPatDep level) fps
checkFuncPatDep :: Ord a => (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
checkFuncPatDep level (fp, f) = unless (level fp < level f) $
report $ errFuncPatCyclic fp f
checkTopDecls :: [Decl ()] -> SCM [Decl ()]
checkTopDecls ds = do
m <- getModuleIdent
......@@ -445,8 +534,8 @@ checkDeclLhs (InfixDecl p fix' pr ops) =
InfixDecl p fix' <$> checkPrecedence p pr <*> mapM renameVar ops
checkDeclLhs (TypeSig p vs ty) =
(\vs' -> TypeSig p vs' ty) <$> mapM (checkVar "type signature") vs
checkDeclLhs (FunctionDecl p _ _ eqs) =
checkEquationsLhs p eqs
checkDeclLhs (FunctionDecl p _ f eqs) =
inFunc f $ checkEquationsLhs p eqs
checkDeclLhs (ForeignDecl p cc ie a f ty) =
(\f' -> ForeignDecl p cc ie a f' ty) <$> checkVar "foreign declaration" f
checkDeclLhs (ExternalDecl p vs) =
......@@ -574,7 +663,7 @@ checkDeclRhs _ (DataDecl p tc tvs cs) =
checkDeclRhs bvs (TypeSig p vs ty) =
(\vs' -> TypeSig p vs' ty) <$> mapM (checkLocalVar bvs) vs
checkDeclRhs _ (FunctionDecl a p f eqs) =
FunctionDecl a p f <$> mapM checkEquation eqs
FunctionDecl a p f <$> inFunc f (mapM checkEquation eqs)
checkDeclRhs _ (PatternDecl p t rhs) =
PatternDecl p t <$> checkRhs rhs
checkDeclRhs _ d = return d
......@@ -707,6 +796,7 @@ checkConstructorPattern p c ts = do
| otherwise = do
let n = arity r
checkFuncPatsExtension p
checkFuncPatCall r c
ts' <- mapM (checkPattern p) ts
mapM_ (checkFPTerm p) ts'
return $ if n' > n
......@@ -722,10 +812,10 @@ checkInfixPattern p t1 op t2 = do
env <- getRenameEnv
case qualLookupVar op env of
[Constr _ n] -> infixPattern op n
[_] -> funcPattern op
[r] -> funcPattern r op
rs -> case qualLookupVar (qualQualify m op) env of
[Constr _ n] -> infixPattern (qualQualify m op) n
[_] -> funcPattern (qualQualify m op)
[r] -> funcPattern r (qualQualify m op)
rs' -> do if (null rs && null rs')
then report $ errUndefinedData op
else report $ errAmbiguousData rs op
......@@ -735,8 +825,9 @@ checkInfixPattern p t1 op t2 = do
infixPattern qop n = do
when (n /= 2) $ report $ errWrongArity op n 2
flip (InfixPattern ()) qop <$> checkPattern p t1 <*> checkPattern p t2
funcPattern qop = do
funcPattern r qop = do