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

Many different changes

parent d63b8fd7
......@@ -63,16 +63,16 @@ Executable cymake
, Base.TypeSubst
, Base.Typing
, Base.Utils
, Check.KindCheck
, Check.PrecCheck
, Check.SyntaxCheck
, Check.TypeCheck
, Check.WarnCheck
, Checks.KindCheck
, Checks.PrecCheck
, Checks.SyntaxCheck
, Checks.TypeCheck
, Checks.WarnCheck
, Env.Arity
, Env.Eval
, Env.Interfaces
, Env.Interface
, Env.Label
, Env.ModuleAliases
, Env.ModuleAlias
, Env.NestEnv
, Env.OldScopeEnv
, Env.OpPrec
......@@ -80,19 +80,19 @@ Executable cymake
, Env.TopEnv
, Env.TypeConstructors
, Env.Value
, Gen.GenAbstractCurry
, Gen.GenFlatCurry
, Generators.GenAbstractCurry
, Generators.GenFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL.Pretty
, IL.Type
, IL.XML
, Transform.CaseCompletion
, Transform.CurryToIL
, Transform.Desugar
, Transform.Lift
, Transform.Qual
, Transform.Simplify
, Transformations.CaseCompletion
, Transformations.CurryToIL
, Transformations.Desugar
, Transformations.Lift
, Transformations.Qual
, Transformations.Simplify
Library
hs-source-dirs: src
Build-Depends: filepath
......
......@@ -16,7 +16,6 @@ import qualified Data.Set as Set (fromList, notMember)
import Curry.Base.Ident
import Curry.Syntax
import qualified IL
class Expr e where
fv :: e -> [Ident]
......@@ -200,21 +199,3 @@ bvFuncPatt = bvfp []
bvfp bvs (InfixFuncPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (RecordPattern fs r)
= foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)
-- intermediate language
instance Expr IL.Expression where
fv (IL.Variable v) = [v]
fv (IL.Apply e1 e2) = fv e1 ++ fv e2
fv (IL.Case _ _ e alts) = fv e ++ fv alts
fv (IL.Or e1 e2) = fv e1 ++ fv e2
fv (IL.Exist v e) = filter (/= v) (fv e)
fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
where (vs,es) = unzip [(v,e') | IL.Binding v e' <- bds]
fv _ = []
instance Expr IL.Alt where
fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
fv (IL.Alt _ e) = fv e
......@@ -16,12 +16,11 @@ This module implements substitutions on types.
> import Data.List (nub)
> import Data.Maybe (fromJust, isJust)
> import Env.TopEnv
> import Env.Value (ValueInfo (..))
> import Base.Subst
> import Base.Types
> import Env.TopEnv
> import Env.Value (ValueInfo (..))
> type TypeSubst = Subst Int Type
......
{- |
Module : $Header$
Description : Different checks on a Curry module
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module subsumes the different checks to be performed on a Curry
module during compilation, e.g. type checking.
-}
module Checks where
import Curry.Base.MessageMonad (Message)
import Curry.Syntax
import qualified Check.KindCheck as KC (kindCheck)
import qualified Check.PrecCheck as PC (precCheck)
import qualified Check.SyntaxCheck as SC (syntaxCheck)
import qualified Check.TypeCheck as TC (typeCheck)
import qualified Check.WarnCheck as WC (warnCheck)
import qualified Checks.KindCheck as KC (kindCheck)
import qualified Checks.PrecCheck as PC (precCheck)
import qualified Checks.SyntaxCheck as SC (syntaxCheck)
import qualified Checks.TypeCheck as TC (typeCheck)
import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv
import CompilerOpts
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
kindCheck decls env = (decls', env)
where decls' = KC.kindCheck (moduleIdent env) (tyConsEnv env) decls
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
precCheck decls env = (decls', env { opPrecEnv = pEnv' })
where (pEnv', decls') = PC.precCheck (moduleIdent env) (opPrecEnv env) decls
-- |Apply the syntax check.
syntaxCheck :: Options -> [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
syntaxCheck opts decls env = (decls', env)
where decls' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) decls
withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check.
typeCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls
-- TODO: Which one?
-- |Check for warnings.
warnCheck :: CompilerEnv -> ([Decl], [Decl]) -> [Message]
warnCheck env = uncurry $ WC.warnCheck (moduleIdent env) (valueEnv env)
......@@ -22,7 +22,7 @@ hand side of a type declaration are actually defined and no identifier
is defined more than once.
\begin{verbatim}
> module Check.KindCheck (kindCheck) where
> module Checks.KindCheck (kindCheck) where
> import Curry.Base.Position
> import Curry.Base.Ident
......
......@@ -15,7 +15,7 @@ and rearrange infix applications according to the relative precedences
of the operators involved.
\begin{verbatim}
> module Check.PrecCheck (precCheck) where
> module Checks.PrecCheck (precCheck) where
> import Data.List (partition, mapAccumL)
......
......@@ -19,7 +19,7 @@ the same key.} Finally, all (adjacent) equations of a function are
merged into a single definition.
\begin{verbatim}
> module Check.SyntaxCheck (syntaxCheck) where
> module Checks.SyntaxCheck (syntaxCheck) where
> import Control.Monad.State as S (State, evalState, get, liftM, modify)
> import Data.List ((\\), find, insertBy, partition)
......@@ -36,7 +36,7 @@ merged into a single definition.
> import Base.Utils ((++!), findDouble, mapAccumM)
> import Env.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity)
> import Env.ModuleAliases (AliasEnv, lookupAlias)
> import Env.ModuleAlias (AliasEnv, lookupAlias)
> import Env.NestEnv
> import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..))
......@@ -72,12 +72,12 @@ A global state transformer is used for generating fresh integer keys
by which the variables get renamed.
\begin{verbatim}
> type RenameState a = S.State Int a
> type RenameState a = S.State Integer a
> run :: RenameState a -> a
> run m = S.evalState m (globalKey + 1)
> newId :: RenameState Int
> newId :: RenameState Integer
> newId = S.modify succ >> S.get
\end{verbatim}
......@@ -108,7 +108,7 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> | RecordLabel QualIdent [Ident]
> deriving (Eq, Show)
> globalKey :: Int
> globalKey :: Integer
> globalKey = uniqueId (mkIdent "")
> renameInfo :: TCEnv -> AliasEnv -> ArityEnv -> ValueInfo -> RenameInfo
......@@ -253,7 +253,7 @@ local declarations.
> checkModule withExt m env ds = liftM snd (checkTopDecls withExt m env ds)
> checkTopDecls :: Bool -> ModuleIdent -> RenameEnv -> [Decl]
> -> RenameState (RenameEnv,[Decl])
> -> RenameState (RenameEnv, [Decl])
> checkTopDecls withExt m env ds =
> checkDeclGroup (bindFuncDecl m) withExt m globalKey env ds
......@@ -288,14 +288,14 @@ top-level.
> newId >>= \k -> checkDeclGroup bindVarDecl withExt m k (nestEnv env) ds
> checkDeclGroup :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent
> -> Int -> RenameEnv -> [Decl]
> -> Integer -> RenameEnv -> [Decl]
> -> RenameState (RenameEnv,[Decl])
> checkDeclGroup bindDecl withExt m k env ds =
> mapM (checkDeclLhs withExt k m env) ds' >>=
> checkDecls bindDecl withExt m env . joinEquations
> where ds' = sortFuncDecls ds
> checkDeclLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Decl -> RenameState Decl
> checkDeclLhs :: Bool -> Integer -> ModuleIdent -> RenameEnv -> Decl -> RenameState Decl
> checkDeclLhs _ k _ _ (InfixDecl p fix' pr ops) =
> return (InfixDecl p fix' pr (map (flip renameIdent k) ops))
> checkDeclLhs _ k _ env (TypeSig p vs ty) =
......@@ -318,7 +318,7 @@ top-level.
> (map (checkVar "free variables declaration" k env) vs))
> checkDeclLhs _ _ _ _ d = return d
> checkEquationLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Position
> checkEquationLhs :: Bool -> Integer -> ModuleIdent -> RenameEnv -> Position
> -> [Equation] -> RenameState Decl
> checkEquationLhs withExt k m env p [Equation p' lhs rhs] =
> either (return . funDecl) (checkDeclLhs withExt k m env . patDecl)
......@@ -329,7 +329,7 @@ top-level.
> | otherwise = PatternDecl p' t rhs
> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs"
> checkEqLhs :: ModuleIdent -> Int -> RenameEnv -> Position -> Lhs
> checkEqLhs :: ModuleIdent -> Integer -> RenameEnv -> Position -> Lhs
> -> Either (Ident,Lhs) ConstrTerm
> checkEqLhs m k env _ (FunLhs f ts)
> | isDataConstr f env
......@@ -358,7 +358,7 @@ top-level.
> Right _ -> errorAt' $ nonVariable "curried definition" f
> where (f,_) = flatLhs lhs
> checkOpLhs :: Int -> RenameEnv -> (ConstrTerm -> ConstrTerm) -> ConstrTerm
> checkOpLhs :: Integer -> RenameEnv -> (ConstrTerm -> ConstrTerm) -> ConstrTerm
> -> Either (Ident,Lhs) ConstrTerm
> checkOpLhs k env f (InfixPattern t1 op t2)
> | isJust m || isDataConstr op' env =
......@@ -368,14 +368,14 @@ top-level.
> op'' = renameIdent op' k
> checkOpLhs _ _ f t = Right (f t)
> checkVar :: String -> Int -> RenameEnv -> Ident -> Ident
> checkVar :: String -> Integer -> RenameEnv -> Ident -> Ident
> checkVar what k env v
> | False && isDataConstr v env = errorAt' (nonVariable what v)---------------
> | otherwise = renameIdent v k
> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent
> -> RenameEnv -> [Decl] -> RenameState (RenameEnv,[Decl])
> -> RenameEnv -> [Decl] -> RenameState (RenameEnv, [Decl])
> checkDecls bindDecl withExt m env ds =
> case findDouble bvs of
> Nothing ->
......@@ -441,7 +441,7 @@ top-level.
> checkLhsTerm withExt k p m env lhs >>=
> return . checkConstrTerms withExt (nestEnv env)
> checkLhsTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv -> Lhs
> checkLhsTerm :: Bool -> Integer -> Position -> ModuleIdent -> RenameEnv -> Lhs
> -> RenameState Lhs
> checkLhsTerm withExt k p m env (FunLhs f ts) =
> do
......@@ -479,7 +479,7 @@ top-level.
> Just v -> errorAt' (duplicateVariable v)
> where bvs = bv ts
> checkConstrTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv
> checkConstrTerm :: Bool -> Integer -> Position -> ModuleIdent -> RenameEnv
> -> ConstrTerm -> RenameState ConstrTerm
> checkConstrTerm _ _ _ _ _ (LiteralPattern l) =
> liftM LiteralPattern (renameLiteral l)
......@@ -613,7 +613,7 @@ top-level.
> checkConstrTerm _ _ _ _ _ (InfixFuncPattern _ _ _) = error $
> "SyntaxCheck.checkConstrTerm: infix function pattern not defined"
> checkFieldPatt :: Bool -> Int -> ModuleIdent -> QualIdent -> RenameEnv
> checkFieldPatt :: Bool -> Integer -> ModuleIdent -> QualIdent -> RenameEnv
> -> Field ConstrTerm -> RenameState (Field ConstrTerm)
> checkFieldPatt withExt k m r env (Field p l t)
> = case (lookupVar l env) of
......
......@@ -21,7 +21,7 @@ unannotated declarations, but allows for polymorphic recursion when a
type annotation is present.
\begin{verbatim}
> module Check.TypeCheck (typeCheck) where
> module Checks.TypeCheck (typeCheck) where
> import Control.Monad.State as S
> import Data.List (nub, partition)
......
......@@ -4,7 +4,7 @@
February 2006,
Martin Engelke (men@informatik.uni-kiel.de)
-}
module Check.WarnCheck (warnCheck) where
module Checks.WarnCheck (warnCheck) where
import Control.Monad.State (State, execState, filterM, gets, modify, unless, when)
import qualified Data.Map as Map (empty, insert, lookup)
......
{- |
Module : $Header$
Description : Environment containing the module's information
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module defines an environment for a module containing the information
needed throughout the compilation of the module.
-}
-- TODO: rename to Base.ModuleEnv ?
module CompilerEnv where
import Curry.Base.Ident (ModuleIdent)
import Env.Arity
import Env.Eval
import Env.Interfaces
import Env.Interface
import Env.Label
import Env.ModuleAliases
import Env.ModuleAlias
import Env.OpPrec
import Env.TypeConstructors
import Env.Value
-- |A compiler environment
-- |A compiler environment contains information about the module currently
-- compiled. The information is updated during the different stages of
-- compilation.
data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent
, aliasEnv :: AliasEnv
, arityEnv :: ArityEnv
, evalAnnotEnv :: EvalEnv
, interfaceEnv :: InterfaceEnv
, labelEnv :: LabelEnv
, opPrecEnv :: PEnv
, tyConsEnv :: TCEnv
, valueEnv :: ValueEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, arityEnv :: ArityEnv -- ^ arity of functions and data constructors
, evalAnnotEnv :: EvalEnv -- ^ evaluation annotations
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, labelEnv :: LabelEnv -- ^ record labels
, opPrecEnv :: PEnv -- ^ operator precedences
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions, ...
}
initCompilerEnv :: ModuleIdent -> CompilerEnv
......@@ -31,7 +49,7 @@ initCompilerEnv mid = CompilerEnv
, arityEnv = initAEnv
, evalAnnotEnv = initEEnv
, interfaceEnv = initInterfaceEnv
, labelEnv = initLEnv
, labelEnv = initLabelEnv
, opPrecEnv = initPEnv
, tyConsEnv = initTCEnv
, valueEnv = initDCEnv
......
......@@ -37,13 +37,13 @@ data Options = Options
, optImportPaths :: [FilePath] -- ^ directories for imports
, optOutput :: Maybe FilePath -- ^ name of output file
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ do not create an interface file
, optWarn :: Bool -- ^ warnings on/off
, optOverlapWarn :: Bool -- ^ "overlap" warnings on/off
, optInterface :: Bool -- ^ create an interface file
, optWarn :: Bool -- ^ show warnings
, optOverlapWarn :: Bool -- ^ show "overlap" warnings
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [Extension] -- ^ language extensions
, optExtensions :: [Extension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dumps
} -- deriving Show
}
-- | Default compiler options
defaultOptions :: Options
......@@ -64,14 +64,14 @@ defaultOptions = Options
, optDumps = []
}
-- |Data type representing the type of the target file
-- |Type of the target file
data TargetType
= Parsed
| FlatCurry
| ExtendedFlatCurry
| FlatXml
| AbstractCurry
| UntypedAbstractCurry
= Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry
| ExtendedFlatCurry -- ^ Extended FlatCurry
| FlatXml -- ^ FlatCurry as XML
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ UntypedAbstractCurry
deriving Eq
-- |Data type representing the verbosity level
......@@ -90,11 +90,11 @@ classifyVerbosity _ = Verbose
-- |Data type for representing code dumps
data DumpLevel
= DumpRenamed -- ^ dump source after renaming
| DumpTypes -- ^ dump types after typechecking
| DumpDesugared -- ^ dump source after desugaring
| DumpSimplified -- ^ dump source after simplification
| DumpLifted -- ^ dump source after lambda-lifting
= DumpRenamed -- ^ dump source after renaming
| DumpTypes -- ^ dump types after typechecking
| DumpDesugared -- ^ dump source after desugaring
| DumpSimplified -- ^ dump source after simplification
| DumpLifted -- ^ dump source after lambda-lifting
| DumpIL -- ^ dump IL code after translation
| DumpCase -- ^ dump IL code after case elimination
deriving (Eq, Bounded, Enum, Show)
......
{- |CurryBuilder - Generates Curry representations for a Curry source file
including all imported modules.
September 2005, Martin Engelke (men@informatik.uni-kiel.de)
March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
May 2011, refinements b Bjoern Peemoeller (bjp@informatik.uni-kiel.de)
{- |
Module : $Header$
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2007, Sebastian Fischer (sebf@informatik.uni-kiel.de)
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module contains functions to generate Curry representations for a
Curry source file including all imported modules.
-}
module CurryBuilder (buildCurry, smake) where
......@@ -23,45 +31,53 @@ import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
{- |Compile the Curry program 'file' including all imported modules,
depending on the 'Options'. The compilation was successful if the
returned list is empty, otherwise it contains error messages.
-}
-- |Compile the Curry module in the given source file including all imported
-- modules, depending on the 'Options'.
buildCurry :: Options -> FilePath -> IO ()
buildCurry opts file = do
mbFile <- lookupCurryFile (optImportPaths opts) file
case mbFile of
Nothing -> abortWith [errMissingFile file]
Just f -> do
(mods, errs) <- flatDeps opts f
if null errs
then makeCurry (defaultToFlatCurry opts) mods f
else abortWith errs
where defaultToFlatCurry opt
| null $ optTargetTypes opt = opt { optTargetTypes = [FlatCurry] }
| otherwise = opt
Just fn -> do
(srcs, depErrs) <- flatDeps opts fn
if not $ null depErrs
then abortWith depErrs
else makeCurry (defaultToFlatCurry opts) srcs fn
where
defaultToFlatCurry opt
| null $ optTargetTypes opt = opt { optTargetTypes = [FlatCurry] }
| otherwise = opt
-- |Compiles the given source modules, which must be in topological order
makeCurry :: Options -> [(ModuleIdent, Source)] -> FilePath -> IO ()
makeCurry opts mods targetFile = mapM_ (compile . snd) mods where
compile (Source file deps) = do
interfaceExists <- doesModuleExist $ flatIntName file
if dropExtension targetFile == dropExtension file
then if interfaceExists && not (optForce opts) && null (optDumps opts)
then smake (targetNames file) -- dest files
(file : mapMaybe flatInterface deps) -- dep files
(generateFile file) -- action on changed
(skipFile file) -- action on unchanged
else generateFile file
else if interfaceExists
then smake [flatName' file]
(file : mapMaybe flatInterface deps)
(compileFile file)
(skipFile file)
else compileFile file
makeCurry opts srcs targetFile = mapM_ (compile . snd) srcs where
compile (Source fn deps) = do
interfaceExists <- doesModuleExist $ flatIntName fn
let isFinalFile = dropExtension targetFile == dropExtension fn
isEnforced = optForce opts || (not $ null $ optDumps opts)
destFiles = if isFinalFile then destNames fn else [flatName' fn]
depFiles = fn : mapMaybe flatInterface deps
actOutdated = if isFinalFile then generateFile fn else compileFile fn
actUpToDate = skipFile fn
if interfaceExists && not (isEnforced && isFinalFile)
then smake destFiles depFiles actOutdated actUpToDate
else actOutdated
compile _ = return ()
targetNames fn = [ gen fn | (tgt, gen) <- nameGens
, tgt `elem` optTargetTypes opts]
compileFile f = do
status opts $ "compiling " ++ f
compileModule (opts { optTargetTypes = [FlatCurry], optDumps = [] }) f
skipFile f = status opts $ "skipping " ++ f
generateFile f = do
status opts $ "generating " ++ head (destNames f)
compileModule opts f
destNames fn = [ gen fn | (tgt, gen) <- nameGens
, tgt `elem` optTargetTypes opts]
where nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
......@@ -72,52 +88,38 @@ makeCurry opts mods targetFile = mapM_ (compile . snd) mods where
, (FlatXml , xmlName )
]
flatInterface mod1 = case lookup mod1 mods of
Just (Source file _) -> Just $ flatIntName file
Just (Interface file) -> Just $ flatIntName file
_ -> Nothing
flatName'
| ExtendedFlatCurry `elem` optTargetTypes opts = extFlatName
| otherwise = flatName
compileFile f = do
status opts $ "compiling " ++ f
compileModule (opts { optTargetTypes = [FlatCurry], optDumps = [] }) f
generateFile f = do
status opts $ "generating " ++ head (targetNames f)
compileModule opts f
skipFile f = status opts $ "skipping " ++ f
{- |A simple make function
smake <destination files>
<dependencies>
<io action, if dependencies are newer than destination files>
<io action, if destination files are newer than dependencies>
-}
smake :: [FilePath] -> [FilePath] -> IO a -> IO a -> IO a
smake dests deps cmd alt = do
flatInterface m = case lookup m srcs of
Just (Source fn _) -> Just $ flatIntName fn