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

Merge branch 'master' into curry-interface

Conflicts:
	src/Checks.hs
	src/Interfaces.hs
	src/Modules.hs
parents 10ad2de3 515afbcd
Name: curry-frontend
Version: 0.3.7
Version: 0.3.8
Cabal-Version: >= 1.6
Synopsis: Compile the functional logic language Curry to several
intermediate formats
......@@ -35,8 +35,8 @@ Executable cymake
else
Build-Depends: base == 3.*
Build-Depends:
curry-base == 0.3.7
, mtl, containers, pretty, transformers
curry-base == 0.3.8
, containers, either, mtl, pretty, transformers
ghc-options: -Wall
Other-Modules:
Base.CurryTypes
......
......@@ -14,7 +14,7 @@ import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
import Curry.Base.Message hiding (warn)
import CompilerOpts (Options (optVerbosity, optWarn), Verbosity (..))
import CompilerOpts (Options (..), Verbosity (..))
info :: Options -> String -> IO ()
info opts msg = unless (optVerbosity opts < VerbInfo)
......@@ -25,8 +25,11 @@ status opts msg = unless (optVerbosity opts < VerbStatus)
(putStrLn $ msg ++ " ...")
warn :: Options -> [Message] -> IO ()
warn opts msgs = when (optWarn opts && not (null msgs))
$ putErrLn (show $ ppMessages ppWarning $ sort msgs)
warn opts msgs = when (optWarn opts && not (null msgs)) $ do
putErrLn (show $ ppMessages ppWarning $ sort msgs)
when (optWarnAsError opts) $ do
putErrLn "Failed due to -Werror"
exitFailure
-- |Print an error message on 'stderr'
putErrLn :: String -> IO ()
......
......@@ -23,8 +23,7 @@ TODO: Use MultiParamTypeClasses ?
> , TypeScheme (..), ExistTypeScheme (..), monoType, polyType
> -- * Predefined types
> , unitType, boolType, charType, intType, floatType, stringType
> , successType, listType, ioType, tupleType, primType
> , typeVar, predefTypes
> , successType, listType, ioType, tupleType, typeVar, predefTypes
> ) where
> import Curry.Base.Ident
......@@ -286,12 +285,12 @@ There are a few predefined types:
> tupleType :: [Type] -> Type
> tupleType tys = primType (tupleId (length tys)) tys
> primType :: Ident -> [Type] -> Type
> primType = TypeConstructor . qualifyWith preludeMIdent
> typeVar :: Int -> Type
> typeVar = TypeVariable
> primType :: Ident -> [Type] -> Type
> primType = TypeConstructor . qualifyWith preludeMIdent
> predefTypes :: [(Type, [DataConstr])]
> predefTypes = let a = typeVar 0 in
> [ (unitType , [ DataConstr unitId 0 [] ])
......
......@@ -13,6 +13,7 @@
-}
module Checks where
import Control.Monad.Trans.Either
import Curry.Syntax (Module (..), Interface (..))
import Base.Messages
......@@ -28,20 +29,8 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv
import CompilerOpts
data CheckResult a
= CheckSuccess a
| CheckFailed [Message]
instance Monad CheckResult where
return = CheckSuccess
(>>=) = thenCheck
thenCheck :: CheckResult a -> (a -> CheckResult b) -> CheckResult b
thenCheck chk cont = case chk of
CheckSuccess a -> cont a
CheckFailed errs -> CheckFailed errs
-- TODO: More documentation
type Check m = Options -> CompilerEnv -> Module
-> EitherT [Message] m (CompilerEnv, Module)
interfaceCheck :: CompilerEnv -> Interface -> CheckResult ()
interfaceCheck env intf
......@@ -55,10 +44,10 @@ interfaceCheck env intf
-- * Declarations: Nullary type constructors and type variables are
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
kindCheck :: Monad m => Check m
kindCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Check for a correct syntax.
......@@ -66,10 +55,10 @@ kindCheck env (Module m es is ds)
-- * Declarations: Nullary data constructors and variables are
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
syntaxCheck :: Monad m => Check m
syntaxCheck opts env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
......@@ -78,32 +67,32 @@ syntaxCheck opts env (Module m es is ds)
-- * Declarations: Expressions are reordered according to the specified
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = CheckSuccess (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = CheckFailed msgs
precCheck :: Monad m => Check m
precCheck _ env (Module m es is ds)
| null msgs = right (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = left 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 -> CheckResult (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds)
| null msgs = CheckSuccess (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = CheckFailed msgs
typeCheck :: Monad m => Check m
typeCheck _ env mdl@(Module _ _ _ ds)
| null msgs = right (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = left msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
-- |Check the export specification
exportCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
exportCheck env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es' is ds)
| otherwise = CheckFailed msgs
exportCheck :: Monad m => Check m
exportCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es' is ds)
| otherwise = left msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: CompilerEnv -> Module -> [Message]
warnCheck env mdl = WC.warnCheck (valueEnv env) mdl
warnCheck :: Options -> CompilerEnv -> Module -> [Message]
warnCheck opts env mdl = WC.warnCheck opts (valueEnv env) (tyConsEnv env) mdl
......@@ -181,15 +181,21 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> data RenameInfo
> -- |Arity of data constructor
> = Constr Int
> = Constr QualIdent Int
> -- |Record type and all labels for a single record label
> | RecordLabel QualIdent [Ident]
> -- |Arity of global function
> | GlobalVar Int QualIdent
> | GlobalVar QualIdent Int
> -- |Arity of local function
> | LocalVar Int Ident
> | LocalVar Ident Int
> deriving (Eq, Show)
> ppRenameInfo :: RenameInfo -> Doc
> ppRenameInfo (Constr qn _) = text (escQualName qn)
> ppRenameInfo (RecordLabel qn _) = text (escQualName qn)
> ppRenameInfo (GlobalVar qn _) = text (escQualName qn)
> ppRenameInfo (LocalVar n _) = text (escName n)
\end{verbatim}
Since record types are currently translated into data types, it is necessary
to ensure that all identifiers for records and constructors are different.
......@@ -197,10 +203,10 @@ Furthermore, it is not allowed to declare a label more than once.
\begin{verbatim}
> renameInfo :: TCEnv -> ValueInfo -> RenameInfo
> renameInfo _ (DataConstructor _ a _) = Constr $ a
> renameInfo _ (NewtypeConstructor _ _) = Constr 1
> renameInfo _ (Value qid a _) = GlobalVar a qid
> renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of
> renameInfo _ (DataConstructor qid a _) = Constr qid a
> renameInfo _ (NewtypeConstructor qid _) = Constr qid 1
> renameInfo _ (Value qid a _) = GlobalVar qid a
> renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
> _ -> internalError $ "SyntaxCheck.renameInfo: ambiguous record " ++ show r
......@@ -227,15 +233,15 @@ Furthermore, it is not allowed to declare a label more than once.
> bindConstr :: ConstrDecl -> SCM ()
> bindConstr (ConstrDecl _ _ c tys) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr $ length tys)
> modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) $ length tys)
> bindConstr (ConOpDecl _ _ _ op _) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m op (Constr 2)
> modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2)
> bindNewConstr :: NewConstrDecl -> SCM ()
> bindNewConstr (NewConstrDecl _ _ c _) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr 1)
> modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1)
> bindRecordLabel :: Ident -> [Ident] -> Ident -> SCM ()
> bindRecordLabel t allLabels l = do
......@@ -248,21 +254,20 @@ Furthermore, it is not allowed to declare a label more than once.
> -- |Bind a global function declaration in the 'RenameEnv'
> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
> bindFuncDecl m (FunctionDecl _ ident equs) env
> | null equs = internalError "SyntaxCheck.bindFuncDecl: no equations"
> | otherwise = let arty = length $ snd $ getFlatLhs $ head equs
> qid = qualifyWith m ident
> in bindGlobal m ident (GlobalVar arty qid) env
> bindFuncDecl m (ForeignDecl _ _ _ ident texpr) env
> = let arty = typeArity texpr
> qid = qualifyWith m ident
> in bindGlobal m ident (GlobalVar arty qid) env
> bindFuncDecl m (TypeSig _ ids texpr) env
> = foldr bindTS env $ map (qualifyWith m) ids
> bindFuncDecl _ (FunctionDecl _ _ []) _
> = internalError "SyntaxCheck.bindFuncDecl: no equations"
> bindFuncDecl m (FunctionDecl _ f (eq:_)) env
> = let arty = length $ snd $ getFlatLhs eq
> in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> bindFuncDecl m (ForeignDecl _ _ _ f ty) env
> = let arty = typeArity ty
> in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> bindFuncDecl m (TypeSig _ fs ty) env
> = foldr bindTS env $ map (qualifyWith m) fs
> where
> bindTS qid env'
> | null $ qualLookupVar qid env'
> = bindGlobal m (unqualify qid) (GlobalVar (typeArity texpr) qid) env'
> bindTS qf env'
> | null $ qualLookupVar qf env'
> = bindGlobal m (unqualify qf) (GlobalVar qf (typeArity ty)) env'
> | otherwise
> = env'
> bindFuncDecl _ _ env = env
......@@ -274,14 +279,14 @@ Furthermore, it is not allowed to declare a label more than once.
> bindVarDecl (FunctionDecl _ f eqs) env
> | null eqs = internalError "SyntaxCheck.bindVarDecl: no equations"
> | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs
> in bindLocal (unRenameIdent f) (LocalVar arty f) env
> in bindLocal (unRenameIdent f) (LocalVar f arty) env
> bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t)
> bindVarDecl (FreeDecl _ vs) env = foldr bindVar env vs
> bindVarDecl _ env = env
> bindVar :: Ident -> RenameEnv -> RenameEnv
> bindVar v | isAnonId v = id
> | otherwise = bindLocal (unRenameIdent v) (LocalVar 0 v)
> | otherwise = bindLocal (unRenameIdent v) (LocalVar v 0)
> lookupVar :: Ident -> RenameEnv -> [RenameInfo]
> lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v
......@@ -293,7 +298,8 @@ Furthermore, it is not allowed to declare a label more than once.
> lookupTupleConstr :: Ident -> [RenameInfo]
> lookupTupleConstr v
> | isTupleId v = [Constr $ tupleArity v]
> | isTupleId v = let a = tupleArity v
> in [Constr (qualifyWith preludeMIdent $ tupleId a) a]
> | otherwise = []
> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
......@@ -451,7 +457,7 @@ top-level.
> joinEquations [] = return []
> joinEquations (FunctionDecl p f eqs : FunctionDecl _ f' [eq] : ds)
> | f == f' = do
> when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity f
> when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity [f, f']
> joinEquations (FunctionDecl p f (eqs ++ [eq]) : ds)
> where getArity = length . snd . getFlatLhs
> joinEquations (d : ds) = (d :) `liftM` joinEquations ds
......@@ -577,11 +583,11 @@ checkParen
> m <- getModuleIdent
> k <- getScopeId
> case qualLookupVar c env of
> [Constr n] -> processCons c n
> [r] -> processVarFun r k
> [Constr _ n] -> processCons c n
> [r] -> processVarFun r k
> rs -> case qualLookupVar (qualQualify m c) env of
> [Constr n] -> processCons (qualQualify m c) n
> [r] -> processVarFun r k
> [Constr _ n] -> processCons (qualQualify m c) n
> [r] -> processVarFun r k
> []
> | null ts && not (isQualified c) ->
> return $ VariablePattern $ renameIdent (unqualify c) k
......@@ -590,7 +596,7 @@ checkParen
> report $ errUndefinedData c
> return $ ConstructorPattern c ts'
> _ -> do ts' <- mapM (checkPattern p) ts
> report $ errAmbiguousData c
> report $ errAmbiguousData rs c
> return $ ConstructorPattern c ts'
> where
> n' = length ts
......@@ -617,14 +623,14 @@ checkParen
> m <- getModuleIdent
> env <- getRenameEnv
> case qualLookupVar op env of
> [Constr n] -> infixPattern op n
> [_] -> funcPattern op
> rs -> case qualLookupVar (qualQualify m op) env of
> [Constr n] -> infixPattern (qualQualify m op) n
> [Constr _ n] -> infixPattern op n
> [_] -> funcPattern op
> rs -> case qualLookupVar (qualQualify m op) env of
> [Constr _ n] -> infixPattern (qualQualify m op) n
> [_] -> funcPattern (qualQualify m op)
> rs' -> do if (null rs && null rs')
> then report $ errUndefinedData op
> else report $ errAmbiguousData op
> else report $ errAmbiguousData rs op
> liftM2 (flip InfixPattern op) (checkPattern p t1)
> (checkPattern p t2)
> where
......@@ -782,17 +788,17 @@ checkParen
> case qualLookupVar v env of
> [] -> do report $ errUndefinedVariable v
> return $ Variable v
> [Constr _] -> return $ Constructor v
> [Constr _ _] -> return $ Constructor v
> [GlobalVar _ _] -> return $ Variable v
> [LocalVar _ v'] -> return $ Variable $ qualify v'
> [LocalVar v' _] -> return $ Variable $ qualify v'
> rs -> do
> m <- getModuleIdent
> case qualLookupVar (qualQualify m v) env of
> [] -> do report $ errAmbiguousIdent rs v
> return $ Variable v
> [Constr _] -> return $ Constructor v
> [Constr _ _] -> return $ Constructor v
> [GlobalVar _ _] -> return $ Variable v
> [LocalVar _ v'] -> return $ Variable $ qualify v'
> [LocalVar v' _] -> return $ Variable $ qualify v'
> rs' -> do report $ errAmbiguousIdent rs' v
> return $ Variable v
......@@ -815,16 +821,16 @@ checkParen
> env <- getRenameEnv
> case qualLookupVar v env of
> [] -> report (errUndefinedVariable v) >> return op
> [Constr _] -> return $ InfixConstr v
> [Constr _ _] -> return $ InfixConstr v
> [GlobalVar _ _] -> return $ InfixOp v
> [LocalVar _ v'] -> return $ InfixOp $ qualify v'
> [LocalVar v' _] -> return $ InfixOp $ qualify v'
> rs -> do
> m <- getModuleIdent
> case qualLookupVar (qualQualify m v) env of
> [] -> report (errAmbiguousIdent rs v) >> return op
> [Constr _] -> return $ InfixConstr v
> [Constr _ _] -> return $ InfixConstr v
> [GlobalVar _ _] -> return $ InfixOp v
> [LocalVar _ v'] -> return $ InfixOp $ qualify v'
> [LocalVar v' _] -> return $ InfixOp $ qualify v'
> rs' -> report (errAmbiguousIdent rs' v) >> return op
> where v = opName op
......@@ -918,7 +924,7 @@ the user about the fact that the identifier is ambiguous.
> isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv
> isConstr :: RenameInfo -> Bool
> isConstr (Constr _) = True
> isConstr (Constr _ _) = True
> isConstr (GlobalVar _ _) = False
> isConstr (LocalVar _ _) = False
> isConstr (RecordLabel _ _) = False
......@@ -929,14 +935,14 @@ varIdent (LocalVar _ v) = v
varIdent _ = internalError "SyntaxCheck.varIdent: no variable"
> qualVarIdent :: RenameInfo -> QualIdent
> qualVarIdent (GlobalVar _ v) = v
> qualVarIdent (LocalVar _ v) = qualify v
> qualVarIdent (GlobalVar v _) = v
> qualVarIdent (LocalVar v _) = qualify v
> qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable"
> arity :: RenameInfo -> Int
> arity (Constr n) = n
> arity (GlobalVar n _) = n
> arity (LocalVar n _) = n
> arity (Constr _ n) = n
> arity (GlobalVar _ n) = n
> arity (LocalVar _ n) = n
> arity (RecordLabel _ ls) = length ls
\end{verbatim}
......@@ -1013,27 +1019,28 @@ Error messages.
> errUndefinedVariable :: QualIdent -> Message
> errUndefinedVariable v = posMessage v $ hsep $ map text
> [qualName v, "is undefined"]
> [escQualName v, "is undefined"]
> errUndefinedData :: QualIdent -> Message
> errUndefinedData c = posMessage c $ hsep $ map text
> ["Undefined data constructor", qualName c]
> ["Undefined data constructor", escQualName c]
> errUndefinedLabel :: Ident -> Message
> errUndefinedLabel l = posMessage l $ hsep $ map text
> ["Undefined record label", escName l]
> errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
> errAmbiguousIdent rs | any isConstr rs = errAmbiguousData
> | otherwise = errAmbiguousVariable
> errAmbiguousIdent rs qn | any isConstr rs = errAmbiguousData rs qn
> | otherwise = errAmbiguous "variable" rs qn
> errAmbiguousVariable :: QualIdent -> Message
> errAmbiguousVariable v = posMessage v $ hsep $ map text
> ["Ambiguous variable", qualName v]
> errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
> errAmbiguousData = errAmbiguous "data constructor"
> errAmbiguousData :: QualIdent -> Message
> errAmbiguousData c = posMessage c $ hsep $ map text
> ["Ambiguous data constructor", qualName c]
> errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
> errAmbiguous what rs qn = posMessage qn
> $ text "Ambiguous" <+> text what <+> text (escQualName qn)
> $+$ text "It could refer to:"
> $+$ nest 2 (vcat (map ppRenameInfo rs))
> errDuplicateDefinition :: Ident -> Message
> errDuplicateDefinition v = posMessage v $ hsep $ map text
......@@ -1041,7 +1048,7 @@ Error messages.
> errDuplicateVariable :: Ident -> Message
> errDuplicateVariable v = posMessage v $ hsep $ map text
> [idName v, "occurs more than once in pattern"]
> [escName v, "occurs more than once in pattern"]
> errMultipleDataConstructor :: [Ident] -> Message
> errMultipleDataConstructor [] = internalError
......@@ -1065,11 +1072,11 @@ Error messages.
> errMissingLabel :: Position -> Ident -> QualIdent -> String -> Message
> errMissingLabel p l r what = posMessage p $ hsep $ map text
> ["Missing label", escName l, "in the", what, "of", escName (unqualify r)]
> ["Missing label", escName l, "in the", what, "of", escQualName r]
> errIllegalLabel :: Ident -> QualIdent -> Message
> errIllegalLabel l r = posMessage l $ hsep $ map text
> ["Label", escName l, "is not defined in record", escName (unqualify r)]
> ["Label", escName l, "is not defined in record", escQualName r]
> errIllegalRecordId :: Ident -> Message
> errIllegalRecordId r = posMessage r $ hsep $ map text
......@@ -1094,13 +1101,17 @@ Error messages.
> errNotALabel l = posMessage l $
> text (escName l) <+> text "is not a record label"
> errDifferentArity :: Ident -> Message
> errDifferentArity f = posMessage f $ hsep $ map text
> ["Equations for", escName f, "have different arities"]
> errDifferentArity :: [Ident] -> Message
> errDifferentArity [] = internalError
> "SyntaxCheck.errDifferentArity: empty list"
> errDifferentArity (i:is) = posMessage i $
> text "Equations for" <+> text (escName i) <+> text "have different arities"
> <+> text "at:" $+$
> nest 2 (vcat (map (ppPosition . getPosition) (i:is)))
> errWrongArity :: QualIdent -> Int -> Int -> Message
> errWrongArity c arity' argc = posMessage c $ hsep (map text
> ["Data constructor", qualName c, "expects", arguments arity'])
> ["Data constructor", escQualName c, "expects", arguments arity'])
> <> comma <+> text "but is applied to" <+> text (show argc)
> where arguments 0 = "no arguments"
> arguments 1 = "1 argument"
......
This diff is collapsed.
This diff is collapsed.
......@@ -12,12 +12,12 @@
This module defines data structures holding options for the
compilation of Curry programs, and utility functions for printing
help information as well as parsing the cmd arguments.
help information as well as parsing the command line arguments.
-}
module CompilerOpts
( Options (..), CymakeMode (..), Verbosity (..), TargetType (..)
, Extension (..), DumpLevel (..), dumpLevel
, defaultOptions, getCompilerOpts, usage
, WarnFlag (..), Extension (..), DumpLevel (..)
, dumpLevel, defaultOptions, getCompilerOpts, usage
) where
import Data.List (intercalate, nub)
......@@ -28,6 +28,10 @@ import System.FilePath (splitSearchPath)
import Curry.Files.Filenames (currySubdir)
-- -----------------------------------------------------------------------------
-- Option data structures
-- -----------------------------------------------------------------------------
-- |Data type for recording compiler options
data Options = Options
-- general
......@@ -41,7 +45,8 @@ data Options = Options
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ create an interface file
, optWarn :: Bool -- ^ show warnings
, optOverlapWarn :: Bool -- ^ show "overlap" warnings
, optWarnFlags :: [WarnFlag]
, optWarnAsError :: Bool
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [Extension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dump levels
......@@ -61,7 +66,8 @@ defaultOptions = Options
, optUseSubdir = True
, optInterface = True
, optWarn = True
, optOverlapWarn = True
, optWarnFlags = stdWarnFlags
, optWarnAsError = False
, optTargetTypes = []
, optExtensions = []
, optDumps = []
......@@ -69,7 +75,7 @@ defaultOptions = Options
, optDumpRaw = False
}
-- |Modus operand of the program
-- |Modus operandi of the program
data CymakeMode
= ModeHelp -- ^ Show help information
| ModeVersion -- ^ Show version
......@@ -78,6 +84,20 @@ data CymakeMode
| ModeMake -- ^ Compile with dependencies
deriving (Eq, Show)
-- |Verbosity level
data Verbosity
= VerbQuiet -- ^ be quiet
| VerbStatus -- ^ show status of compilation
| VerbInfo -- ^ also show additional info
deriving (Eq, Ord, Show)
-- |Description and flag of verbosities
verbosities :: [(Verbosity, String, String)]
verbosities = [ ( VerbQuiet , "0", "quiet" )
, ( VerbStatus, "1", "status")
, ( VerbInfo , "2", "info" )
]
-- |Type of the target file
data TargetType
= Parsed -- ^ Parsed source code
......@@ -85,24 +105,41 @@ data TargetType
| ExtendedFlatCurry -- ^ Extended FlatCurry
| FlatXml -- ^ FlatCurry as XML
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ UntypedAbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
deriving (Eq, Show)
-- |Data type representing the verbosity level
data Verbosity
= VerbQuiet -- ^ be quiet
| VerbStatus -- ^ show status of compilation
| VerbInfo -- ^ show also additional info
deriving (Eq, Ord, Show)
-- |Warnings flags
data WarnFlag
= WarnMultipleImports -- ^ Warn for multiple imports
| WarnDisjoinedRules -- ^ Warn for disjoined function rules