Skip to content

GitLab

Commit a35f0d57 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

small refactorings

parent 0763bae0
Expand all Hide whitespace changes
Inline Side-by-side
src/Checks.hs
View file @ a35f0d57
......@@ -39,22 +39,17 @@ instance Monad CheckStatus where
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
-- In addition, nullary type constructors and type variables are
-- disambiguated in the declarations; the environment remains unchanged.
kindCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the syntax check.
-- |Check for a correct syntax.
-- In addition, nullary data constructors and variables are
-- disambiguated in the declarations; the environment remains unchanged.
syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds')
......@@ -62,7 +57,18 @@ syntaxCheck opts env (Module m es is ds)
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
-- |Apply the type check.
-- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the
-- relative precedences; the operator precedence environment is updated.
precCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the correct typing of the module.
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
......@@ -72,5 +78,4 @@ typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEn
-- |Check for warnings.
warnCheck :: CompilerEnv -> Module -> [Message]
warnCheck env (Module _ _ is ds)
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
warnCheck env mdl = WC.warnCheck (valueEnv env) mdl
src/Checks/PrecCheck.lhs
View file @ a35f0d57
......@@ -30,7 +30,8 @@ of the operators involved.
> import Base.Messages (Message, toMessage)
> import Base.Utils (findDouble)
> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
> , qualLookupP)
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> ([Decl], PEnv, [Message])
> precCheck m pEnv decls = runPCM (checkDecls decls) initState
......@@ -58,14 +59,14 @@ The Prec check monad.
> getPrecEnv :: PCM PEnv
> getPrecEnv = S.gets precEnv
> withPrecEnv :: (PEnv -> PEnv) -> PCM ()
> withPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
> modifyPrecEnv :: (PEnv -> PEnv) -> PCM ()
> modifyPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
> withLocalPrecEnv :: PCM a -> PCM a
> withLocalPrecEnv act = do
> oldEnv <- getPrecEnv
> res <- act
> withPrecEnv $ const oldEnv
> modifyPrecEnv $ const oldEnv
> return res
> report :: Message -> PCM ()
......@@ -83,10 +84,10 @@ imported precedence environment.
> bindPrecs ds = case findDouble opFixDecls of
> Just op -> report $ errDuplicatePrecedence op
> Nothing -> case filter (`notElem` bvs) opFixDecls of
> op : _ -> report $ errUndefinedOperator op
> op : _ -> report $ errUndefinedOperator op
> [] -> do
> m <- getModuleIdent
> withPrecEnv $ \ env -> foldr (bindPrec m) env fixDs
> modifyPrecEnv $ \ env -> foldr (bindPrec m) env fixDs
> where
> (fixDs, nonFixDs) = partition isInfixDecl ds
> opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops]
......@@ -137,12 +138,11 @@ interface.
> liftM2 (Equation p) (checkLhs lhs) (checkRhs rhs)
> checkLhs :: Lhs -> PCM Lhs
> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
> checkLhs (OpLhs t1 op t2) =
> liftM2 (\u1 u2 -> OpLhs u1 op u2) t1' t2'
> where t1' = (checkConstrTerm t1 >>= checkOpL op)
> t2' = (checkConstrTerm t2 >>= checkOpR op)
> checkLhs (ApLhs lhs ts) =
> liftM2 (flip OpLhs op) (checkConstrTerm t1 >>= checkOpL op)
> (checkConstrTerm t2 >>= checkOpR op)
> checkLhs (ApLhs lhs ts) =
> liftM2 ApLhs (checkLhs lhs) (mapM checkConstrTerm ts)
> checkConstrTerm :: ConstrTerm -> PCM ConstrTerm
......
src/Checks/TypeCheck.lhs
View file @ a35f0d57
......@@ -64,13 +64,13 @@ constructor and type environments.
\begin{verbatim}
> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv)
> typeCheck m tcEnv tyEnv ds =
> run (tcDecls m tcEnv' Map.empty vds >>
> typeCheck m tcEnv tyEnv decls =
> run (tcDecls m tcEnv' Map.empty valueDecls >>
> S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
> return (tcEnv',subst theta tyEnv'))
> (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv))
> where (tds,vds) = partition isTypeDecl ds
> tcEnv' = bindTypes m tds tcEnv
> return (tcEnv', subst theta tyEnv'))
> (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv)) -- initEnv
> where (typeDecls, valueDecls) = partition isTypeDecl decls
> tcEnv' = bindTypes m typeDecls tcEnv
\end{verbatim}
......@@ -172,19 +172,19 @@ have been properly renamed and all type synonyms are already expanded.
\begin{verbatim}
> bindConstrs :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
> bindConstrs m tcEnv tyEnv =
> foldr (bindData . snd) tyEnv (localBindings tcEnv)
> where bindData (DataType tc n cs) tyEnv' =
> foldr (bindConstr m n (constrType' tc n)) tyEnv' (catMaybes cs)
> bindData (RenamingType tc n (DataConstr c n' [ty])) tyEnv' =
> bindGlobalInfo NewtypeConstructor m c
> (ForAllExist n n' (TypeArrow ty (constrType' tc n)))
> tyEnv'
> bindData (AliasType _ _ _) tyEnv' = tyEnv'
> bindConstr m' n ty (DataConstr c n' tys) =
> bindGlobalInfo DataConstructor m' c
> (ForAllExist n n' (foldr TypeArrow ty tys))
> constrType' tc n = TypeConstructor tc (map TypeVariable [0..n-1])
> bindConstrs m tcEnv tyEnv = foldr (bindData . snd) tyEnv (localBindings tcEnv)
> where
> bindData (DataType tc n cs) tyEnv' =
> foldr (bindConstr m n (constrType' tc n)) tyEnv' (catMaybes cs)
> bindData (RenamingType tc n (DataConstr c n' [ty])) tyEnv' =
> bindGlobalInfo NewtypeConstructor m c
> (ForAllExist n n' (TypeArrow ty (constrType' tc n)))
> tyEnv'
> bindData (AliasType _ _ _) tyEnv' = tyEnv'
> bindConstr m' n ty (DataConstr c n' tys) =
> bindGlobalInfo DataConstructor m' c
> (ForAllExist n n' (foldr TypeArrow ty tys))
> constrType' tc n = TypeConstructor tc (map TypeVariable [0..n-1])
\end{verbatim}
\paragraph{Defining Field Labels}
......
src/Checks/WarnCheck.hs
View file @ a35f0d57
This diff is collapsed.
src/CompilerEnv.hs
View file @ a35f0d57
......@@ -39,7 +39,7 @@ data CompilerEnv = CompilerEnv
, labelEnv :: LabelEnv -- ^ record labels
, opPrecEnv :: PEnv -- ^ operator precedences
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions, ...
, valueEnv :: ValueEnv -- ^ functions and data constructors
}
initCompilerEnv :: ModuleIdent -> CompilerEnv
......
src/Frontend.hs
View file @ a35f0d57
......@@ -24,7 +24,7 @@ import Control.Monad.Writer
import Curry.Base.MessageMonad
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), Interface, parseModule)
import Curry.Syntax (Module (..), parseModule)
import CompilerEnv
import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
......@@ -68,7 +68,7 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax ::
(Options -> CompilerEnv -> Module -> (CompilerEnv, Module, Interface, [Message]))
(Options -> CompilerEnv -> Module -> (CompilerEnv, Module))
-> [FilePath] -> FilePath -> MsgMonad Module -> IO (MsgMonad Module)
genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
errs <- makeInterfaces paths fn mod1
......@@ -76,8 +76,8 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
then do
iEnv <- loadInterfaces paths mod1
let env = importModules opts mod1 iEnv
(_, mod', _, msgs) = check opts env mod1
return (tell msgs >> return mod')
(_, mod') = check opts env mod1
return (return mod')
else return $ failWith $ head errs
where opts = mkOpts paths
......
src/Imports.hs
View file @ a35f0d57
......@@ -39,10 +39,6 @@ import CompilerEnv
import CompilerOpts
import Records (importLabels, recordExpansion1, recordExpansion2)
-- ---------------------------------------------------------------------------
-- Interface
-- ---------------------------------------------------------------------------
-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
importModules :: Options -> Module -> InterfaceEnv -> CompilerEnv
......@@ -61,15 +57,6 @@ importModules opts (Module mid _ imps _) iEnv
Nothing -> internalError $ "Imports.importModules: no interface for "
++ show m
-- |
qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
qualifyEnv opts env = recordExpansion2 opts
$ qualifyLocal env
$ foldl (flip importInterfaceIntf) initEnv
$ Map.elems
$ interfaceEnv env
where initEnv = initCompilerEnv $ moduleIdent env
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------
......@@ -390,6 +377,15 @@ importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
-- ---------------------------------------------------------------------------
-- |
qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
qualifyEnv opts env = recordExpansion2 opts
$ qualifyLocal env
$ foldl (flip importInterfaceIntf) initEnv
$ Map.elems
$ interfaceEnv env
where initEnv = initCompilerEnv $ moduleIdent env
qualifyLocal :: CompilerEnv -> CompilerEnv -> CompilerEnv
qualifyLocal currentEnv initEnv = currentEnv
{ opPrecEnv = foldr bindQual pEnv $ localBindings $ opPrecEnv currentEnv
......
src/Modules.lhs
View file @ a35f0d57
......@@ -83,8 +83,9 @@ code are obsolete and commented out.
> compileModule :: Options -> FilePath -> IO ()
> compileModule opts fn = do
> (env, modul, intf, warnings) <- uncurry (checkModule opts) `liftM` loadModule opts fn
> showWarnings opts $ warnings
> loaded <- loadModule opts fn
> let (env, modul) = uncurry (checkModule opts) loaded
> showWarnings opts $ uncurry warnCheck loaded
> writeParsed opts fn modul
> writeAbstractCurry opts fn env modul
> when withFlat $ do
......@@ -95,6 +96,7 @@ code are obsolete and commented out.
> -- dump intermediate results
> mapM_ (doDump opts) dumps
> -- generate target code
> let intf = exportInterface env modul
> let modSum = summarizeModule (tyConsEnv env2) intf modul
> writeFlat opts fn env2 modSum il
> where
......@@ -174,22 +176,19 @@ Haskell and original MCC where a module obtains \texttt{main}).
-- Checking a module
-- ---------------------------------------------------------------------------
> checkModule :: Options -> CompilerEnv -> CS.Module
> -> (CompilerEnv, CS.Module, CS.Interface, [Message])
> checkModule opts env mdl = (env', mdl', intf, warnings)
> checkModule :: Options -> CompilerEnv -> CS.Module -> (CompilerEnv, CS.Module)
> checkModule opts env mdl = qualifyEnvs
> $ expand
> $ uncurry qual
> $ (if withFlat then uncurry typeCheck else id)
> $ uncurry precCheck
> $ uncurry (syntaxCheck opts)
> $ kindCheck env mdl
> where
> warnings = warnCheck env mdl
> intf = exportInterface env' mdl'
> (env', mdl') = qualifyE $ expand $ uncurry qual
> $ (if withFlat then uncurry typeCheck else id)
> $ uncurry precCheck
> $ uncurry (syntaxCheck opts)
> $ uncurry kindCheck
> (env, mdl)
> expand (e, m) = if withFlat then (e, expandInterface e m) else (e, m)
> qualifyE (e, m) = (qualifyEnv opts e, m)
> withFlat = any (`elem` optTargetTypes opts)
> [FlatCurry, FlatXml, ExtendedFlatCurry]
> expand (e, m) = if withFlat then (e, expandInterface e m) else (e, m)
> qualifyEnvs (e, m) = (qualifyEnv opts e, m)
> withFlat = any (`elem` optTargetTypes opts)
> [FlatCurry, FlatXml, ExtendedFlatCurry]
-- ---------------------------------------------------------------------------
-- Translating a module
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment