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

Refactoring

parent 3308d905
......@@ -20,7 +20,6 @@ module Modules
import Control.Monad (liftM, unless, when)
import Data.Maybe (fromMaybe)
import Text.PrettyPrint (Doc)
import Curry.Base.MessageMonad
import Curry.Base.Position
......@@ -182,7 +181,7 @@ checkModule opts env mdl = qualEnv
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
-> (CompilerEnv, IL.Module, [(DumpLevel, Doc)])
-> (CompilerEnv, IL.Module, [(DumpLevel, String)])
transModule opts env mdl = (env5, ilCaseComp, dumps)
where
flat' = FlatCurry `elem` optTargetTypes opts
......@@ -192,13 +191,13 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
(lifted , env3) = lift simplified env2
(il , env4) = ilTrans flat' lifted env3
(ilCaseComp, env5) = completeCase il env4
dumps = [ (DumpRenamed , CS.ppModule mdl )
, (DumpTypes , ppTypes (moduleIdent env) (valueEnv env))
, (DumpDesugared , CS.ppModule desugared )
, (DumpSimplified, CS.ppModule simplified )
, (DumpLifted , CS.ppModule lifted )
, (DumpIL , IL.ppModule il )
, (DumpCase , IL.ppModule ilCaseComp)
dumps = [ (DumpRenamed , show $ CS.ppModule mdl )
, (DumpTypes , show $ ppTypes (moduleIdent env) (valueEnv env))
, (DumpDesugared , show $ CS.ppModule desugared )
, (DumpSimplified, show $ CS.ppModule simplified )
, (DumpLifted , show $ CS.ppModule lifted )
, (DumpIL , show $ IL.ppModule il )
, (DumpCase , show $ IL.ppModule ilCaseComp)
]
-- ---------------------------------------------------------------------------
......@@ -287,9 +286,9 @@ showWarnings opts msgs = when (optWarn opts)
-- |The 'doDump' function writes the selected information to the
-- standard output.
doDump :: Options -> (DumpLevel, Doc) -> IO ()
doDump :: Options -> (DumpLevel, String) -> IO ()
doDump opts (level, dump) = when (level `elem` optDumps opts) $ putStrLn $
unlines [header, replicate (length header) '=', show dump]
unlines [header, replicate (length header) '=', dump]
where header = dumpHeader level
dumpHeader :: DumpLevel -> String
......
......@@ -570,22 +570,22 @@ module.
> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]
> modulesType (IL.TypeConstructor tc tys) ms =
> modules tc (foldr modulesType ms tys)
> modulesType (IL.TypeVariable _) ms = ms
> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)
> modulesType (IL.TypeVariable _) ms = ms
> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)
> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]
> modulesExpr (IL.Function f _) ms = modules f ms
> modulesExpr (IL.Function f _) ms = modules f ms
> modulesExpr (IL.Constructor c _) ms = modules c ms
> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
> where modulesAlt (IL.Alt t e') ms' = modulesConstrTerm t (modulesExpr e' ms')
> modulesConstrTerm (IL.ConstructorPattern c _) ms' = modules c ms'
> modulesConstrTerm _ ms' = ms'
> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
> modulesExpr _ ms = ms
> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
> modulesExpr _ ms = ms
> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]
> modulesBinding (IL.Binding _ e) = modulesExpr e
......
......@@ -128,13 +128,12 @@ as it allows value declarations at the top-level of a module.
> desugarModule :: ModuleIdent -> TCEnv -> [Decl]
> -> DesugarState ([Decl],ValueEnv)
> desugarModule m tcEnv ds =
> do
> dss <- mapM (desugarRecordDecl m tcEnv) ds
> let ds' = concat dss
> ds'' <- desugarDeclGroup m tcEnv ds'
> tyEnv' <- getValueEnv
> return (filter isTypeDecl ds' ++ ds'', tyEnv')
> desugarModule m tcEnv ds = do
> dss <- mapM (desugarRecordDecl m tcEnv) ds
> let ds' = concat dss
> ds'' <- desugarDeclGroup m tcEnv ds'
> tyEnv' <- getValueEnv
> return (filter isTypeDecl ds' ++ ds'', tyEnv')
\end{verbatim}
Within a declaration group, all type signatures and evaluation
......@@ -144,27 +143,25 @@ declarations to the group that must be desugared as well.
\begin{verbatim}
> desugarDeclGroup :: ModuleIdent -> TCEnv -> [Decl] -> DesugarState [Decl]
> desugarDeclGroup m tcEnv ds =
> do
> dss' <- mapM (desugarDeclLhs m tcEnv) (filter isValueDecl ds)
> mapM (desugarDeclRhs m tcEnv) (concat dss')
> desugarDeclGroup m tcEnv ds = do
> dss' <- mapM (desugarDeclLhs m tcEnv) (filter isValueDecl ds)
> mapM (desugarDeclRhs m tcEnv) (concat dss')
> desugarDeclLhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState [Decl]
> desugarDeclLhs m tcEnv (PatternDecl p t rhs) =
> do
> (ds',t') <- desugarTerm m tcEnv p [] t
> dss' <- mapM (desugarDeclLhs m tcEnv) ds'
> return (PatternDecl p t' rhs : concat dss')
> desugarDeclLhs m _ (FlatExternalDecl p fs) =
> do
> tyEnv <- getValueEnv
> return (map (externalDecl tyEnv p) fs)
> where externalDecl tyEnv p' f =
> desugarDeclLhs m tcEnv (PatternDecl p t rhs) = do
> (ds',t') <- desugarTerm m tcEnv p [] t
> dss' <- mapM (desugarDeclLhs m tcEnv) ds'
> return (PatternDecl p t' rhs : concat dss')
> desugarDeclLhs m _ (FlatExternalDecl p fs) = do
> tyEnv <- getValueEnv
> return (map (externalDecl tyEnv p) fs)
> where
> externalDecl tyEnv p' f =
> ExternalDecl p' CallConvPrimitive (Just (name f)) f
> (fromType (typeOf tyEnv (Variable (qual f))))
> qual f
> | unRenameIdent f == f = qualifyWith m f
> | otherwise = qualify f
> qual f
> | unRenameIdent f == f = qualifyWith m f
> | otherwise = qualify f
> desugarDeclLhs _ _ d = return [d]
\end{verbatim}
......@@ -179,15 +176,14 @@ and a record label belongs to only one record declaration.
\begin{verbatim}
> desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl
> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) =
> do
> tyEnv <- getValueEnv
> let ty = (flip typeOf (Variable (qual f))) tyEnv
> liftM (FunctionDecl p f)
> (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)
> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) = do
> tyEnv <- getValueEnv
> let ty = (flip typeOf (Variable (qual f))) tyEnv
> liftM (FunctionDecl p f)
> (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)
> where qual f1
> | unRenameIdent f1 == f1 = qualifyWith m f1
> | otherwise = qualify f1
> | otherwise = qualify f1
> desugarDeclRhs _ _ (ExternalDecl p cc ie f ty) =
> return (ExternalDecl p cc (ie `mplus` Just (name f)) f ty)
> desugarDeclRhs m tcEnv (PatternDecl p t rhs) =
......
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