Commit fd0f8c4b authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Add option to prevent desugaring of newtypes

parent 8f2fc916
......@@ -103,8 +103,9 @@ data DebugOpts = DebugOpts
} deriving Show
data OptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports :: Bool }
deriving Show
{ optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL
, optDesugarNewtypes :: Bool -- ^ Desugar newtypes
} deriving Show
-- | Default compiler options
defaultOptions :: Options
......@@ -162,7 +163,9 @@ defaultDebugOpts = DebugOpts
defaultOptimizationOpts :: OptimizationOpts
defaultOptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports = True }
{ optRemoveUnusedImports = True
, optDesugarNewtypes = True
}
-- |Modus operandi of the program
data CymakeMode
......@@ -586,9 +589,13 @@ debugDescriptions =
optimizeDescriptions :: OptErrTable OptimizationOpts
optimizeDescriptions =
[ ( "remove-unused-imports" , "removes unused imports"
, \ opts -> opts { optRemoveUnusedImports = True })
, \ opts -> opts { optRemoveUnusedImports = True })
, ( "no-remove-unused-imports", "prevents removing of unused imports"
, \ opts -> opts { optRemoveUnusedImports = False })
, \ 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]
......
......@@ -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
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
......@@ -274,6 +279,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
......
......@@ -60,6 +60,9 @@ ppDecl (DataDecl tc n cs) = sep $
text "data" <+> ppTypeLhs tc n :
map (nest dataIndent)
(zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs))
ppDecl (NewtypeDecl tc n nc) = sep $
text "newtype" <+> ppTypeLhs tc n :
[nest dataIndent (equals <+> ppNewConstr nc)]
ppDecl (ExternalDataDecl tc n) =
text "external data" <+> ppTypeLhs tc n
ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep
......@@ -73,6 +76,9 @@ ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
ppConstr :: ConstrDecl -> Doc
ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)
ppNewConstr :: NewConstrDecl -> Doc
ppNewConstr (NewConstrDecl c ty) = ppQIdent c <+> fsep [ppType 2 ty]
ppTypeSig :: QualIdent -> Type -> Doc
ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty
......
......@@ -39,6 +39,12 @@ showsDecl (DataDecl qident arity constrdecls)
. shows arity . space
. showsList showsConstrDecl constrdecls
. showsString ")"
showsDecl (NewtypeDecl qident arity newconstrdecl)
= showsString "(NewtypeDecl "
. showsQualIdent qident . space
. shows arity . space
. showsNewConstrDecl newconstrdecl
. showsString ")"
showsDecl (ExternalDataDecl qident arity)
= showsString "(ExternalDataDecl "
. showsQualIdent qident . space
......@@ -64,6 +70,13 @@ showsConstrDecl (ConstrDecl qident tys)
. showsList showsType tys
. showsString ")"
showsNewConstrDecl :: NewConstrDecl -> ShowS
showsNewConstrDecl (NewConstrDecl qident ty)
= showsString "(NewConstrDecl "
. showsQualIdent qident . space
. showsType ty
. showsString ")"
showsType :: Type -> ShowS
showsType (TypeConstructor qident types)
= showsString "(TypeConstructor "
......
......@@ -43,8 +43,9 @@
module IL.Type
( -- * Data types
Module (..), Decl (..), ConstrDecl (..), Type (..), Literal (..)
, ConstrTerm (..), Expression (..), Eval (..), Alt (..), Binding (..)
Module (..), Decl (..), ConstrDecl (..), NewConstrDecl (..), Type (..)
, Literal (..), ConstrTerm (..), Expression (..), Eval (..)
, Alt (..), Binding (..)
) where
import Curry.Base.Ident
......@@ -56,11 +57,15 @@ data Module = Module ModuleIdent [ModuleIdent] [Decl]
data Decl
= DataDecl QualIdent Int [ConstrDecl]
| NewtypeDecl QualIdent Int NewConstrDecl
| ExternalDataDecl QualIdent Int
| FunctionDecl QualIdent [(Type, Ident)] Type Expression
| ExternalDecl QualIdent Type
deriving (Eq, Show)
data NewConstrDecl = NewConstrDecl QualIdent Type
deriving (Eq, Show)
data ConstrDecl = ConstrDecl QualIdent [Type]
deriving (Eq, Show)
......
......@@ -261,17 +261,19 @@ checkModule opts mdl = do
transModule :: Options -> CompEnv (CS.Module PredType)
-> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type))
transModule opts mdl = do
derived <- dumpCS DumpDerived $ derive mdl
desugared <- dumpCS DumpDesugared $ desugar derived
dicts <- dumpCS DumpDictionaries $ insertDicts desugared
newtypes <- dumpCS DumpNewtypes $ removeNewtypes dicts
simplified <- dumpCS DumpSimplified $ simplify newtypes
lifted <- dumpCS DumpLifted $ lift simplified
il <- dumpIL DumpTranslated $ ilTrans remIm lifted
ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il
derived <- dumpCS DumpDerived $ derive mdl
desugared <- dumpCS DumpDesugared $ desugar derived
dicts <- dumpCS DumpDictionaries $ insertDicts desugared
newtypes <- dumpCS DumpNewtypes $ removeNewtypes remNT dicts
simplified <- dumpCS DumpSimplified $ simplify newtypes
lifted <- dumpCS DumpLifted $ lift simplified
il <- dumpIL DumpTranslated $ ilTrans remIm lifted
ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il
return (ilCaseComp, newtypes)
where
remIm = optRemoveUnusedImports $ optOptimizations opts
optOpts = optOptimizations opts
remIm = optRemoveUnusedImports optOpts
remNT = optDesugarNewtypes optOpts
dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a)
-> CYIO (CompEnv (CS.Module a))
dumpCS = dumpWith opts CS.showModule CS.ppModule
......
......@@ -58,9 +58,9 @@ insertDicts (env, mdl) = (env { interfaceEnv = intfEnv'
(classEnv env) (instEnv env) (opPrecEnv env) mdl
-- |Remove newtype constructors.
removeNewtypes :: CompEnv (Module Type) -> CompEnv (Module Type)
removeNewtypes (env, mdl) = (env, mdl')
where mdl' = NT.removeNewtypes (valueEnv env) mdl
removeNewtypes :: Bool -> CompEnv (Module Type) -> CompEnv (Module Type)
removeNewtypes remNT (env, mdl) = (env, mdl')
where mdl' = NT.removeNewtypes remNT (valueEnv env) mdl
-- |Simplify the source code, changes the value environment.
simplify :: CompEnv (Module Type) -> CompEnv (Module Type)
......
......@@ -97,6 +97,7 @@ ccDecl dd@(DataDecl _ _ _) = return dd
ccDecl edd@(ExternalDataDecl _ _) = return edd
ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e
ccDecl ed@(ExternalDecl _ _) = return ed
ccDecl nd@(NewtypeDecl _ _ _) = return nd
ccExpr :: Expression -> CCM Expression
ccExpr l@(Literal _ _) = return l
......
......@@ -68,6 +68,8 @@ imports m = Set.toList . Set.delete m . foldr mdlsDecl Set.empty
mdlsDecl :: IL.Decl -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsDecl (IL.DataDecl _ _ cs) ms = foldr mdlsConstrsDecl ms cs
where mdlsConstrsDecl (IL.ConstrDecl _ tys) ms' = foldr mdlsType ms' tys
mdlsDecl (IL.NewtypeDecl _ _ nc) ms = mdlsNewConstrDecl nc
where mdlsNewConstrDecl (IL.NewConstrDecl _ ty) = mdlsType ty ms
mdlsDecl (IL.ExternalDataDecl _ _) ms = ms
mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms)
mdlsDecl (IL.ExternalDecl _ ty) ms = mdlsType ty ms
......@@ -147,6 +149,7 @@ constrType c = do
trDecl :: Decl Type -> TransM [IL.Decl]
trDecl (DataDecl _ tc tvs cs _) = (:[]) <$> trData tc tvs cs
trDecl (NewtypeDecl _ tc tvs nc _) = (:[]) <$> trNewtype tc tvs nc
trDecl (ExternalDataDecl _ tc tvs) = (:[]) <$> trExternalData tc tvs
trDecl (FunctionDecl _ ty f eqs) = (:[]) <$> trFunction f ty eqs
trDecl (ExternalDecl _ vs) = mapM trExternal vs
......@@ -157,6 +160,11 @@ trData tc tvs cs = do
tc' <- trQualify tc
IL.DataDecl tc' (length tvs) <$> mapM trConstrDecl cs
trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl
trNewtype tc tvs nc = do
tc' <- trQualify tc
IL.NewtypeDecl tc' (length tvs) <$> trNewConstrDecl nc
trConstrDecl :: ConstrDecl -> TransM IL.ConstrDecl
trConstrDecl d = do
c' <- trQualify (constr d)
......@@ -167,6 +175,17 @@ trConstrDecl d = do
constr (ConOpDecl _ _ _ _ op _) = op
constr (RecordDecl _ _ _ c _) = c
trNewConstrDecl :: NewConstrDecl -> TransM IL.NewConstrDecl
trNewConstrDecl d = do
c' <- trQualify (constr d)
ty' <- arrowArgs <$> constrType c'
case ty' of
[ty] -> return $ IL.NewConstrDecl c' (transType ty)
_ -> internalError "CurryToIL.trNewConstrDecl: invalid constructor type"
where
constr (NewConstrDecl _ c _) = c
constr (NewRecordDecl _ c _) = c
trExternalData :: Ident -> [Ident] -> TransM IL.Decl
trExternalData tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc
......
......@@ -30,8 +30,10 @@ import Base.Types
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
removeNewtypes :: ValueEnv -> Module Type -> Module Type
removeNewtypes vEnv mdl = R.runReader (nt mdl) vEnv
removeNewtypes :: Bool -> ValueEnv -> Module Type -> Module Type
removeNewtypes remNT vEnv mdl
| remNT = R.runReader (nt mdl) vEnv
| otherwise = mdl
type NTM a = R.Reader ValueEnv a
......
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