Commit 5990337c authored by Fredrik Wieczerkowski's avatar Fredrik Wieczerkowski
Browse files

Re-apply partial version 3 changes (MonadFail, ...)


Co-authored-by: default avatarKai-Oliver Prott <kai.prott@hotmail.de>
parent 08cc34f2
Change log for curry-frontend
=============================
Version 2.0.0
=============
* Implemented the "MonadFail-Proposal" for curry
(see <https://wiki.haskell.org/MonadFail_Proposal>)
Version 1.0.4
=============
* Fixed bug in type checking of instances
* Fixed bugs in deriving of `Bounded` instances.
Version 1.0.3
=============
......@@ -313,3 +320,4 @@ Version 0.3.0
* All compiler warnings removed.
* Fixed various implementation bugs (#9, #16, #19, #29, #289).
......@@ -196,7 +196,7 @@ bindDerivedInstance clsEnv p tc pty tys cls = do
, (fromEnumId, 1), (enumFromId, 1)
, (enumFromThenId, 2)
]
| cls == qBoundedId = [(maxBoundId, 1), (minBoundId, 1)]
| cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)]
| cls == qReadId = [(readsPrecId, 2)]
| cls == qShowId = [(showsPrecId, 2)]
| otherwise =
......
......@@ -496,10 +496,24 @@ checkInstanceDecl (InstanceDecl p cx qcls ty ds) = do
m <- getModuleIdent
tcEnv <- getTyConsEnv
checkMethods qcls (clsMethods m qcls tcEnv) ds
mapM_ checkAmbiguousMethod ds
InstanceDecl p cx qcls ty <$> checkTopDecls ds
checkInstanceDecl _ =
internalError "SyntaxCheck.checkInstanceDecl: no instance declaration"
checkAmbiguousMethod :: Decl a -> SCM ()
checkAmbiguousMethod (FunctionDecl _ _ f _) = do
m <- getModuleIdent
rename <- getRenameEnv
case lookupVar f rename of
rs1@(_:_:_) -> case qualLookupVar (qualifyWith m f) rename of
[] -> report $ errAmbiguousIdent rs1 (qualify f)
rs2@(_:_:_) -> report $ errAmbiguousIdent rs2 (qualify f)
_ -> return ()
_ -> return ()
checkAmbiguousMethod _ =
internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration"
checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()
checkMethods qcls ms ds =
mapM_ (report . errUndefinedMethod qcls) $ filter (`notElem` ms) fs
......
......@@ -1287,7 +1287,9 @@ tcStmt _ ps mTy (StmtDecl spi ds) = do
(ps', ds') <- tcDecls ds
return ((ps `Set.union` ps', mTy), StmtDecl spi ds')
tcStmt p ps mTy st@(StmtBind spi t e) = do
(ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy
failable <- checkFailableBind t
let freshMType = if failable then freshMonadFailType else freshMonadType
(ps', ty) <- maybe freshMType (return . (,) emptyPredSet) mTy
alpha <- freshTypeVar
(ps'', e') <-
tcArg p "statement" (ppStmt st) (ps `Set.union` ps') (applyType ty [alpha]) e
......@@ -1295,6 +1297,42 @@ tcStmt p ps mTy st@(StmtBind spi t e) = do
(ps''', t') <- tcPatternArg p "statement" (ppStmt st) ps'' alpha t
return ((ps''', Just ty), StmtBind spi t' e')
checkFailableBind :: Pattern a -> TCM Bool
checkFailableBind (ConstructorPattern _ _ idt ps ) = do
tcEnv <- getTyConsEnv
case qualLookupTypeInfo idt tcEnv of
[RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False
[DataType _ _ cs]
| length cs == 1 -> or <$> mapM checkFailableBind ps
| otherwise -> return True
_ -> return True
checkFailableBind (InfixPattern _ _ p1 idt p2) = do
tcEnv <- getTyConsEnv
case qualLookupTypeInfo idt tcEnv of
[RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1
<*> checkFailableBind p2
[DataType _ _ cs]
| length cs == 1 -> (||) <$> checkFailableBind p1
<*> checkFailableBind p2
| otherwise -> return True
_ -> return True
checkFailableBind (RecordPattern _ _ idt fs ) = do
tcEnv <- getTyConsEnv
case qualLookupTypeInfo idt tcEnv of
[RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs
[DataType _ _ cs]
| length cs == 1 -> or <$> mapM (checkFailableBind . fieldContent) fs
| otherwise -> return True
_ -> return True
where fieldContent (Field _ _ c) = c
checkFailableBind (TuplePattern _ ps ) =
or <$> mapM checkFailableBind ps
checkFailableBind (AsPattern _ _ p ) = checkFailableBind p
checkFailableBind (ParenPattern _ p ) = checkFailableBind p
checkFailableBind (LazyPattern _ _ ) = return False
checkFailableBind (VariablePattern _ _ _ ) = return False
checkFailableBind _ = return True
tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp (InfixOp _ op) = do
m <- getModuleIdent
......@@ -1590,6 +1628,9 @@ freshFractionalType = freshPredType [qFractionalId]
freshMonadType :: TCM (PredSet, Type)
freshMonadType = freshPredType [qMonadId]
freshMonadFailType :: TCM (PredSet, Type)
freshMonadFailType = freshPredType [qMonadFailId]
freshConstrained :: [Type] -> TCM Type
freshConstrained = freshVar . TypeConstrained
......
......@@ -26,22 +26,24 @@ import Control.Monad
import Control.Monad.State.Strict (State, execState, gets, modify)
import qualified Data.IntSet as IntSet
(IntSet, empty, insert, notMember, singleton, union, unions)
import qualified Data.Map as Map (empty, insert, lookup)
import qualified Data.Map as Map (empty, insert, lookup, (!))
import Data.Maybe
(catMaybes, fromMaybe, listToMaybe)
import Data.List
((\\), intersect, intersectBy, nub, sort, unionBy)
import Data.Char
(isLower, isUpper, toLower, toUpper, isAlpha)
import qualified Data.Set.Extra as Set
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent)
import Curry.Syntax.Utils (typeVariables)
import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent, ppConstraint)
import Base.CurryTypes (ppTypeScheme)
import Base.CurryTypes (ppTypeScheme, fromPred, toPredSet)
import Base.Messages (Message, posMessage, internalError)
import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv
, qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv
......@@ -66,6 +68,7 @@ import CompilerOpts
-- - overlapping case alternatives
-- - non-adjacent function rules
-- - wrong case mode
-- - redundant context
warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv
-> Module a -> [Message]
warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
......@@ -76,6 +79,7 @@ warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
checkMissingTypeSignatures ds
checkModuleAlias is
checkCaseMode ds
checkRedContext ds
where Module _ _ mid es is ds = fmap (const ()) mdl
type ScopeEnv = NestEnv IdInfo
......@@ -1457,10 +1461,168 @@ isDataDeclName CaseModeGoedel (x:_) | isAlpha x = isUpper x
isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x
isDataDeclName _ _ = True
-- ---------------------------------------------------------------------------
-- Warn for redundant context
-- ---------------------------------------------------------------------------
--traverse the AST for QualTypeExpr/Context and check for redundancy
checkRedContext :: [Decl a] -> WCM ()
checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl
getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet
getRedPredSet m cenv tcEnv ps =
Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup
where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps
qualifyAndAddPred p@(Pred qid ty) (ps', pm') =
let qp = Pred (getOrigName m qid tcEnv) ty
in (Set.insert qp ps', Map.insert qp p pm')
getPredFromContext :: Context -> ([Ident], PredSet)
getPredFromContext cx =
let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx
in (vs, toPredSet vs cx)
checkRedContext' :: (Pred -> Message) -> PredSet -> WCM ()
checkRedContext' f ps = do
m <- gets moduleId
cenv <- gets classEnv
tcEnv <- gets tyConsEnv
mapM_ (report . f) (getRedPredSet m cenv tcEnv ps)
checkRedContextDecl :: Decl a -> WCM ()
checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) =
checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs
checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs
checkRedContextDecl (ClassDecl _ cx i _ ds) = do
checkRedContext'
(warnRedContext (text ("class declaration " ++ escName i)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (InstanceDecl _ cx qid _ ds) = do
checkRedContext'
(warnRedContext (text ("instance declaration " ++ escQualName qid)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (DataDecl _ _ _ cs _) = mapM_ checkRedContextConstrDecl cs
checkRedContextDecl _ = return ()
checkRedContextConstrDecl :: ConstrDecl -> WCM ()
checkRedContextConstrDecl (ConstrDecl _ _ cx idt _ ) =
checkRedContext'
(warnRedContext (text ("constructor declaration " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextConstrDecl (ConOpDecl _ _ cx _ idt _) =
checkRedContext'
(warnRedContext (text ("constructor operator " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextConstrDecl (RecordDecl _ _ cx idt _ ) =
checkRedContext'
(warnRedContext (text ("record declaration " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextEq :: Equation a -> WCM ()
checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs
checkRedContextRhs :: Rhs a -> WCM ()
checkRedContextRhs (SimpleRhs _ e ds) = do
checkRedContextExpr e
mapM_ checkRedContextDecl ds
checkRedContextRhs (GuardedRhs _ cs ds) = do
mapM_ checkRedContextCond cs
mapM_ checkRedContextDecl ds
checkRedContextCond :: CondExpr a -> WCM ()
checkRedContextCond (CondExpr _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr :: Expression a -> WCM ()
checkRedContextExpr (Paren _ e) = checkRedContextExpr e
checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do
checkRedContextExpr e
checkRedContext' (warnRedContext (text "type signature") vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (RecordUpdate _ e fs) = do
checkRedContextExpr e
mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (Tuple _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (ListCompr _ e sts) = do
checkRedContextExpr e
mapM_ checkRedContextStmt sts
checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e
checkRedContextExpr (EnumFromThen _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromTo _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e
checkRedContextExpr (Apply _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (InfixApply _ e1 _ e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (LeftSection _ e _) = checkRedContextExpr e
checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e
checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e
checkRedContextExpr (Let _ ds e) = do
mapM_ checkRedContextDecl ds
checkRedContextExpr e
checkRedContextExpr (IfThenElse _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (Case _ _ e as) = do
checkRedContextExpr e
mapM_ checkRedContextAlt as
checkRedContextExpr _ = return ()
checkRedContextStmt :: Statement a -> WCM ()
checkRedContextStmt (StmtExpr _ e) = checkRedContextExpr e
checkRedContextStmt (StmtDecl _ ds) = mapM_ checkRedContextDecl ds
checkRedContextStmt (StmtBind _ _ e) = checkRedContextExpr e
checkRedContextAlt :: Alt a -> WCM ()
checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs
checkRedContextFieldExpr :: Field (Expression a) -> WCM ()
checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e
-- ---------------------------------------------------------------------------
-- Warnings messages
-- ---------------------------------------------------------------------------
warnRedFuncString :: [Ident] -> Doc
warnRedFuncString is = text "type signature for function" <>
text (if length is == 1 then [] else "s") <+>
csep (map (text . escName) is)
-- Doc description -> TypeVars -> Pred -> Warning
warnRedContext :: Doc -> [Ident] -> Pred -> Message
warnRedContext d vs p@(Pred qid _) = posMessage qid $
text "Redundant context in" <+> d <> colon <+>
quotes (ppConstraint $ fromPred vs p) -- idents use ` ' as quotes not ' '
-- seperate a list by ', '
csep :: [Doc] -> Doc
csep [] = empty
csep [x] = x
csep (x:xs) = x <> comma <+> csep xs
warnCaseMode :: Ident -> CaseMode -> Message
warnCaseMode i@(Ident _ name _ ) c = posMessage i $
text "Wrong case mode in symbol" <+> text (escName i) <+>
......
......@@ -18,8 +18,9 @@
-}
module CompilerOpts
( Options (..), CppOpts (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)
, CaseMode (..), CymakeMode (..), Verbosity (..), TargetType (..)
, WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel
, OptimizationOpts(..), CaseMode (..), CymakeMode (..), Verbosity (..)
, TargetType (..), WarnFlag (..), KnownExtension (..), DumpLevel (..)
, dumpLevel
, defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts
, getCompilerOpts, updateOpts, usage
) where
......@@ -43,24 +44,25 @@ import Curry.Syntax.Extension
-- |Compiler options
data Options = Options
-- general
{ optMode :: CymakeMode -- ^ modus operandi
, optVerbosity :: Verbosity -- ^ verbosity level
{ optMode :: CymakeMode -- ^ modus operandi
, optVerbosity :: Verbosity -- ^ verbosity level
-- compilation
, optForce :: Bool -- ^ force (re-)compilation of target
, optLibraryPaths :: [FilePath] -- ^ directories to search in
-- for libraries
, optImportPaths :: [FilePath] -- ^ directories to search in
-- for imports
, optHtmlDir :: Maybe FilePath -- ^ output directory for HTML
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ create a FlatCurry interface file?
, optPrepOpts :: PrepOpts -- ^ preprocessor options
, optWarnOpts :: WarnOpts -- ^ warning options
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [KnownExtension] -- ^ enabled language extensions
, optDebugOpts :: DebugOpts -- ^ debug options
, optCaseMode :: CaseMode -- ^ case mode
, optCppOpts :: CppOpts -- ^ C preprocessor options
, optForce :: Bool -- ^ force (re-)compilation of target
, optLibraryPaths :: [FilePath] -- ^ directories to search in
-- for libraries
, optImportPaths :: [FilePath] -- ^ directories to search in
-- for imports
, optHtmlDir :: Maybe FilePath -- ^ output directory for HTML
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ create a FlatCurry interface file?
, optPrepOpts :: PrepOpts -- ^ preprocessor options
, optWarnOpts :: WarnOpts -- ^ warning options
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [KnownExtension] -- ^ enabled language extensions
, optDebugOpts :: DebugOpts -- ^ debug options
, optCaseMode :: CaseMode -- ^ case mode
, optCppOpts :: CppOpts -- ^ C preprocessor options
, optOptimizations :: OptimizationOpts -- ^ Optimization options
} deriving Show
-- |C preprocessor options
......@@ -100,24 +102,30 @@ data DebugOpts = DebugOpts
, dbDumpSimple :: Bool -- ^ print more readable environments
} deriving Show
data OptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL
, optDesugarNewtypes :: Bool -- ^ Desugar newtypes
} deriving Show
-- | Default compiler options
defaultOptions :: Options
defaultOptions = Options
{ optMode = ModeMake
, optVerbosity = VerbStatus
, optForce = False
, optLibraryPaths = []
, optImportPaths = []
, optHtmlDir = Nothing
, optUseSubdir = True
, optInterface = True
, optPrepOpts = defaultPrepOpts
, optWarnOpts = defaultWarnOpts
, optTargetTypes = []
, optExtensions = []
, optDebugOpts = defaultDebugOpts
, optCaseMode = CaseModeFree
, optCppOpts = defaultCppOpts
{ optMode = ModeMake
, optVerbosity = VerbStatus
, optForce = False
, optLibraryPaths = []
, optImportPaths = []
, optHtmlDir = Nothing
, optUseSubdir = True
, optInterface = True
, optPrepOpts = defaultPrepOpts
, optWarnOpts = defaultWarnOpts
, optTargetTypes = []
, optExtensions = []
, optDebugOpts = defaultDebugOpts
, optCaseMode = CaseModeFree
, optCppOpts = defaultCppOpts
, optOptimizations = defaultOptimizationOpts
}
-- | Default C preprocessor options
......@@ -153,6 +161,12 @@ defaultDebugOpts = DebugOpts
, dbDumpSimple = False
}
defaultOptimizationOpts :: OptimizationOpts
defaultOptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports = True
, optDesugarNewtypes = True
}
-- |Modus operandi of the program
data CymakeMode
= ModeHelp -- ^ Show help information and exit
......@@ -200,7 +214,8 @@ data WarnFlag
| WarnMissingSignatures -- ^ Warn for missing type signatures
| WarnMissingMethods -- ^ Warn for missing method implementations
| WarnOrphanInstances -- ^ Warn for orphan instances
| WarnIrregularCaseMode
| WarnIrregularCaseMode -- ^ Warn for irregular case mode
| WarnRedundantContext -- ^ Warn for redundant context in type signatures
deriving (Eq, Bounded, Enum, Show)
-- |Warning flags enabled by default
......@@ -209,7 +224,7 @@ stdWarnFlags =
[ WarnMultipleImports , WarnDisjoinedRules --, WarnUnusedGlobalBindings
, WarnUnusedBindings , WarnNameShadowing , WarnOverlapping
, WarnIncompletePatterns, WarnMissingSignatures, WarnMissingMethods
, WarnIrregularCaseMode
, WarnIrregularCaseMode , WarnRedundantContext
]
-- |Description and flag of warnings flags
......@@ -237,6 +252,8 @@ warnFlags =
, "orphan instances" )
, ( WarnIrregularCaseMode , "irregular-case-mode"
, "irregular case mode")
, ( WarnRedundantContext , "redundant-context"
, "redundant context")
]
-- |Dump level
......@@ -342,6 +359,10 @@ onDebugOpts :: (DebugOpts -> DebugOpts) -> OptErr -> OptErr
onDebugOpts f (opts, errs)
= (opts { optDebugOpts = f (optDebugOpts opts) }, errs)
onOptimOpts :: (OptimizationOpts -> OptimizationOpts) -> OptErr -> OptErr
onOptimOpts f (opts, errs)
= (opts { optOptimizations = f (optOptimizations opts) }, errs)
withArg :: ((a -> b) -> OptErr -> OptErr)
-> (String -> a -> b) -> String -> OptErr -> OptErr
withArg lift f arg = lift (f arg)
......@@ -464,10 +485,11 @@ options =
(NoArg (onOpts $ \ opts -> opts { optExtensions =
nub $ kielExtensions ++ optExtensions opts }))
"enable extended Curry functionalities"
, mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions
, mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions
, mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions
, mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions
, mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions
, mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions
, mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions
, mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions
, mkOptDescr onOptimOpts "O" [] "opt" "optimization option" optimizeDescriptions
, Option "" ["cpp"]
(NoArg (onCppOpts $ \ opts -> opts { cppRun = True }))
"run C preprocessor"
......@@ -492,9 +514,9 @@ cppDefinitionErr :: String -> String
cppDefinitionErr = (++) "Invalid format for option '-D': "
targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr)
targetOption ty flag desc
targetOption ty flag
= Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ ty : optTargetTypes opts })) desc
nub $ ty : optTargetTypes opts }))
verbDescriptions :: OptErrTable Options
verbDescriptions = map toDescr verbosities
......@@ -564,11 +586,23 @@ debugDescriptions =
= (name , "dump code after " ++ desc
, \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
optimizeDescriptions :: OptErrTable OptimizationOpts
optimizeDescriptions =
[ ( "remove-unused-imports" , "removes unused imports"
, \ opts -> opts { optRemoveUnusedImports = True })
, ( "no-remove-unused-imports", "prevents removing of unused imports"
, \ opts -> opts { optRemoveUnusedImports = False })
, ( "no-desugar-newtypes", "prevents desugaring of newtypes in FlatCurry"
, \ opts -> opts { optDesugarNewtypes = False })
, ( "desugar-newtypes", "desugars newtypes in FlatCurry"
, \ opts -> opts { optDesugarNewtypes = True })
]
addFlag :: Eq a => a -> [a] -> [a]
addFlag o opts = nub $ o : opts
removeFlag :: Eq a => a -> [a] -> [a]
removeFlag o opts = filter (/= o) opts
removeFlag o = filter (/= o)
-- |Update the 'Options' record by the parsed and processed arguments
updateOpts :: Options -> [String] -> (Options, [String], [String])
......
......@@ -34,7 +34,8 @@ import Curry.Syntax ( ModulePragma (..), Extension (KnownExtension)
import Base.Messages
import CompilerOpts ( Options (..), CppOpts (..), DebugOpts (..)
, TargetType (..), defaultDebugOpts, updateOpts )
, TargetType (..), defaultDebugOpts, updateOpts
, optRemoveUnusedImports )
import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
......@@ -101,9 +102,9 @@ makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs)
adjustOptions :: Bool -> Options -> Options
adjustOptions final opts
| final = opts { optForce = optForce opts || isDump }
| otherwise = opts { optForce = False
, optDebugOpts = defaultDebugOpts
| final = opts { optForce = optForce opts || isDump }
| otherwise = opts { optForce = False
, optDebugOpts = defaultDebugOpts
}
where
isDump = not $ null $ dbDumpLevels $ optDebugOpts opts
......
......@@ -392,7 +392,7 @@ qNegateId :: QualIdent
qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
qIfThenElseId :: QualIdent
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "ifThenElse")
prelUntyped :: QualIdent
prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"
......
......@@ -262,6 +262,11 @@ trTypeDecl (IL.DataDecl qid a cs) = do
vis <- getTypeVisibility qid
cs' <- mapM trConstrDecl cs
return [Type q' vis [0 .. a - 1] cs']
trTypeDecl (IL.NewtypeDecl qid a nc) = do
q' <- trQualIdent qid
vis <- getTypeVisibility qid
nc' <- trNewConstrDecl nc
return [TypeNew q' vis [0 .. a - 1] nc']
trTypeDecl (IL.ExternalDataDecl qid a) = do
q' <- trQualIdent qid
vis <- getTypeVisibility qid
......@@ -275,6 +280,13 @@ trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)
<*> getVisibility qid
<*> mapM trType tys
-- Translate a constructor declaration for newtypes
trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl (IL.NewConstrDecl qid ty) = NewCons
<$> trQualIdent qid
<*> getVisibility qid
<*> trType ty
-- Translate a type expression
trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys
......
......@@ -261,6 +261,11 @@ trTypeDecl (IL.DataDecl qid a cs) = do
vis <- getTypeVisibility qid
cs' <- mapM trConstrDecl cs
return [Type q' vis [0 .. a - 1] cs']
trTypeDecl (IL.NewtypeDecl qid a nc) = do
q' <- trQualIdent qid