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

Removed unused transformation, improved call structure

parent d1bd5d3b
......@@ -28,10 +28,10 @@ import Base.Messages
import CompilerEnv
import CompilerOpts
type Check m a = Options -> CompilerEnv -> a -> CYT m (CompilerEnv, a)
type Check m a = Options -> CompEnv a -> CYT m (CompEnv a)
interfaceCheck :: Monad m => Check m Interface
interfaceCheck _ env intf
interfaceCheck _ (env, intf)
| null msgs = ok (env, intf)
| otherwise = failMessages msgs
where msgs = IC.interfaceCheck (opPrecEnv env) (tyConsEnv env)
......@@ -43,7 +43,7 @@ interfaceCheck _ env intf
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: Monad m => Check m Module
kindCheck _ env mdl
kindCheck _ (env, mdl)
| null msgs = ok (env, mdl')
| otherwise = failMessages msgs
where (mdl', msgs) = KC.kindCheck (tyConsEnv env) mdl
......@@ -54,7 +54,7 @@ kindCheck _ env mdl
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env mdl
syntaxCheck opts (env, mdl)
| null msgs = ok (env { extensions = exts }, mdl')
| otherwise = failMessages msgs
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env)
......@@ -66,7 +66,7 @@ syntaxCheck opts env mdl
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: Monad m => Check m Module
precCheck _ env (Module ps m es is ds)
precCheck _ (env, Module ps m es is ds)
| null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds')
| otherwise = failMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
......@@ -75,7 +75,7 @@ precCheck _ env (Module ps m es is ds)
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: Monad m => Check m Module
typeCheck _ env mdl@(Module _ _ _ _ ds)
typeCheck _ (env, mdl@(Module _ _ _ _ ds))
| null msgs = ok (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = failMessages msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
......@@ -83,7 +83,7 @@ typeCheck _ env mdl@(Module _ _ _ _ ds)
-- |Check the export specification
exportCheck :: Monad m => Check m Module
exportCheck _ env (Module ps m es is ds)
exportCheck _ (env, Module ps m es is ds)
| null msgs = ok (env, Module ps m es' is ds)
| otherwise = failMessages msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
......
......@@ -27,6 +27,8 @@ import Env.OpPrec
import Env.TypeConstructor
import Env.Value
type CompEnv a = (CompilerEnv, a)
-- |A compiler environment contains information about the module currently
-- compiled. The information is updated during the different stages of
-- compilation.
......
......@@ -91,7 +91,7 @@ fullParse :: Options -> FilePath -> String -> CYIO Module
fullParse opts fn _ = do
buildCurry (opts { optTargetTypes = []}) fn
(env, mdl) <- loadAndCheckModule opts' fn
return (fst $ qual opts env mdl)
return (snd $ qual opts (env, mdl))
where
opts' = opts { optWarnOpts = (optWarnOpts opts) { wnWarn = False }
, optTargetTypes = []
......
......@@ -80,7 +80,7 @@ compileModule opts fn = do
(env, mdl) <- loadAndCheckModule opts fn
liftIO $ writeOutput opts fn (env, mdl)
loadAndCheckModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
loadAndCheckModule :: Options -> FilePath -> CYIO (CompEnv CS.Module)
loadAndCheckModule opts fn = do
(env, mdl) <- loadModule opts fn >>= checkModule opts
warn (optWarnOpts opts) $ warnCheck opts env mdl
......@@ -90,7 +90,7 @@ loadAndCheckModule opts fn = do
-- Loading a module
-- ---------------------------------------------------------------------------
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
loadModule :: Options -> FilePath -> CYIO (CompEnv CS.Module)
loadModule opts fn = do
parsed <- parseModule opts fn
-- check module header
......@@ -182,78 +182,58 @@ importPrelude opts fn m@(CS.Module ps mid es is ds)
checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()
checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)
where
checkInterface intf = do
_ <- interfaceCheck opts (importInterfaces opts intf iEnv) intf
return ()
checkInterface intf
= interfaceCheck opts (importInterfaces opts intf iEnv, intf) >> return ()
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------
-- TODO: The order of the checks should be improved!
checkModule :: Options -> (CompilerEnv, CS.Module)
-> CYIO (CompilerEnv, CS.Module)
checkModule opts (env, mdl) = do
showDump (DumpParsed , env , presentCS mdl)
checkModule :: Options -> CompEnv CS.Module -> CYIO (CompEnv CS.Module)
checkModule opts mdl = do
_ <- dumpCS DumpParsed mdl
-- Should be separated into kind checking and type syntax checking (see MCC)
(env1, kc) <- kindCheck opts env mdl
showDump (DumpKindChecked , env1, presentCS kc)
(env2, sc) <- syntaxCheck opts env1 kc
showDump (DumpSyntaxChecked, env2, presentCS sc)
(env3, pc) <- precCheck opts env2 sc
showDump (DumpPrecChecked , env3, presentCS pc)
(env4, tc) <- typeCheck opts env3 pc
showDump (DumpTypeChecked , env4, presentCS tc)
kc <- kindCheck opts mdl >>= dumpCS DumpKindChecked
sc <- syntaxCheck opts kc >>= dumpCS DumpSyntaxChecked
pc <- precCheck opts sc >>= dumpCS DumpPrecChecked
tc <- typeCheck opts pc >>= dumpCS DumpTypeChecked
-- TODO: This is a workaround to avoid the expansion of the export
-- specification for generating the HTML listing.
-- It would be better if checking and expansion are separated.
if null (optTargetTypes opts)
then return (env4, tc)
else do
(env5, ec) <- exportCheck opts env4 tc
showDump (DumpExportChecked, env5, presentCS ec)
return (env5, ec)
where
showDump = doDump (optDebugOpts opts)
presentCS = if dbDumpRaw (optDebugOpts opts) then show else show . CS.ppModule
then return tc
else exportCheck opts tc >>= dumpCS DumpExportChecked
where dumpCS = dumpWith opts CS.ppModule
-- ---------------------------------------------------------------------------
-- Translating a module
-- ---------------------------------------------------------------------------
transModule :: Options -> CompilerEnv -> CS.Module
-> IO (CompilerEnv, IL.Module)
transModule opts env mdl = do
let (desugared , env1) = desugar mdl env
showDump (DumpDesugared , env1, presentCS desugared)
let (simplified, env2) = simplify flat' desugared env1
showDump (DumpSimplified , env2, presentCS simplified)
let (lifted , env3) = lift simplified env2
showDump (DumpLifted , env3, presentCS lifted )
let (il , env4) = ilTrans flat' lifted env3
showDump (DumpTranslated , env4, presentIL il )
let (ilCaseComp, env5) = completeCase il env4
showDump (DumpCaseCompleted, env5, presentIL ilCaseComp)
return (env5, ilCaseComp)
transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module)
transModule opts mdl = do
desugared <- dumpCS DumpDesugared $ desugar True mdl
simplified <- dumpCS DumpSimplified $ simplify desugared
lifted <- dumpCS DumpLifted $ lift simplified
il <- dumpIL DumpTranslated $ ilTrans lifted
ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il
return ilCaseComp
where
flat' = FlatCurry `elem` optTargetTypes opts
showDump = doDump (optDebugOpts opts)
presentCS = if dumpRaw then show else show . CS.ppModule
presentIL = if dumpRaw then show else show . IL.ppModule
dumpRaw = dbDumpRaw (optDebugOpts opts)
dumpCS = dumpWith opts CS.ppModule
dumpIL = dumpWith opts IL.ppModule
-- ---------------------------------------------------------------------------
-- Writing output
-- ---------------------------------------------------------------------------
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeOutput opts fn (env, modul) = do
writeParsed opts fn modul
let (qlfd, env1) = qual opts env modul
let (env1, qlfd) = qual opts (env, modul)
doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
writeAbstractCurry opts fn env1 qlfd
when withFlat $ do
(env2, il) <- transModule opts env1 qlfd
(env2, il) <- transModule opts (env1, qlfd)
-- generate interface file
let intf = exportInterface env2 qlfd
writeInterface opts fn intf
......@@ -354,6 +334,13 @@ writeAbstractCurry opts fname env modul = do
type Dump = (DumpLevel, CompilerEnv, String)
dumpWith :: (MonadIO m, Show a)
=> Options -> (a -> Doc) -> DumpLevel -> CompEnv a -> m (CompEnv a)
dumpWith opts view lvl res@(env, mdl) = do
let str = if dbDumpRaw (optDebugOpts opts) then show mdl else show (view mdl)
doDump (optDebugOpts opts) (lvl, env, str)
return res
-- |Translate FlatCurry into the intermediate language 'IL'
-- |The 'dump' function writes the selected information to standard output.
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
......
......@@ -32,36 +32,36 @@ import CompilerOpts
import Imports (qualifyEnv)
import qualified IL
-- |Add missing case branches
completeCase :: IL.Module -> CompilerEnv -> (IL.Module, CompilerEnv)
completeCase mdl env = (CC.completeCase (interfaceEnv env) mdl, env)
-- |Translate into the intermediate language
ilTrans :: Bool -> Module -> CompilerEnv -> (IL.Module, CompilerEnv)
ilTrans flat mdl env = (il, env)
where il = IL.ilTrans flat (valueEnv env) (tyConsEnv env) mdl
-- |Translate a type into its representation in the intermediate language
transType :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
transType = IL.transType
-- |Fully qualify used constructors and functions.
qual :: Options -> CompEnv Module -> CompEnv Module
qual opts (env, mdl) = (qualifyEnv opts env, mdl')
where mdl' = Q.qual (moduleIdent env) (tyConsEnv env) (valueEnv env) mdl
-- |Remove syntactic sugar
desugar :: Module -> CompilerEnv -> (Module, CompilerEnv)
desugar mdl env = (mdl', env { valueEnv = tyEnv' })
where (mdl', tyEnv') = DS.desugar (extensions env) (valueEnv env)
(tyConsEnv env) mdl
desugar :: Bool -> CompEnv Module -> CompEnv Module
desugar dsfp (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
where (mdl', tyEnv') = DS.desugar dsfp (extensions env) (valueEnv env)
(tyConsEnv env) mdl
-- |Simplify the source code.
simplify :: CompEnv Module -> CompEnv Module
simplify (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
where (mdl', tyEnv') = S.simplify (valueEnv env) (tyConsEnv env) mdl
-- |Lift local declarations
lift :: Module -> CompilerEnv -> (Module, CompilerEnv)
lift mdl env = (mdl', env { valueEnv = tyEnv' })
lift :: CompEnv Module -> CompEnv Module
lift (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
where (mdl', tyEnv') = L.lift (valueEnv env) mdl
-- |Fully qualify used constructors and functions.
qual :: Options -> CompilerEnv -> Module -> (Module, CompilerEnv)
qual opts env mdl = (mdl', qualifyEnv opts env)
where mdl' = Q.qual (moduleIdent env) (tyConsEnv env) (valueEnv env) mdl
-- |Translate into the intermediate language
ilTrans :: CompEnv Module -> CompEnv IL.Module
ilTrans (env, mdl) = (env, il)
where il = IL.ilTrans (valueEnv env) (tyConsEnv env) mdl
-- |Simplify the source code.
simplify :: Bool -> Module -> CompilerEnv -> (Module, CompilerEnv)
simplify flat mdl env = (mdl', env { valueEnv = tyEnv' })
where (mdl', tyEnv') = S.simplify flat (valueEnv env) (tyConsEnv env) mdl
-- |Translate a type into its representation in the intermediate language
transType :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
transType = IL.transType
-- |Add missing case branches
completeCase :: CompEnv IL.Module -> CompEnv IL.Module
completeCase (env, mdl) = (env, CC.completeCase (interfaceEnv env) mdl)
......@@ -18,10 +18,15 @@
Because of name conflicts between the source and intermediate language
data structures, we can use only a qualified import for the 'IL' module.
-}
{-# LANGUAGE CPP #-}
module Transformations.CurryToIL (ilTrans, transType) where
import Control.Monad (liftM, liftM2)
#if __GLASGOW_HASKELL__ >= 710
import Control.Applicative ((<$>))
#else
import Control.Applicative ((<$>), (<*>))
#endif
import qualified Control.Monad.Reader as R
import Data.List (nub, partition)
import qualified Data.Map as Map (Map, empty, insert, lookup)
......@@ -42,27 +47,21 @@ import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import qualified IL as IL
ilTrans :: Bool -> ValueEnv -> TCEnv -> Module -> IL.Module
ilTrans flat tyEnv tcEnv (Module _ m _ _ ds) = IL.Module m (imports m ds') ds'
where ds' = R.runReader (concatMapM trDecl ds)
(TransEnv flat m tyEnv tcEnv)
ilTrans :: ValueEnv -> TCEnv -> Module -> IL.Module
ilTrans tyEnv tcEnv (Module _ m _ _ ds) = IL.Module m (imports m ds') ds'
where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m tyEnv tcEnv)
transType :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
transType m tyEnv tcEnv ty = R.runReader (trType ty)
(TransEnv True m tyEnv tcEnv)
transType m tyEnv tcEnv ty = R.runReader (trType ty) (TransEnv m tyEnv tcEnv)
data TransEnv = TransEnv
{ flatTrans :: Bool
, moduleIdent :: ModuleIdent
{ moduleIdent :: ModuleIdent
, valueEnv :: ValueEnv
, tyConsEnv :: TCEnv
}
type TransM a = R.Reader TransEnv a
isFlat :: TransM Bool
isFlat = R.asks flatTrans
getModuleIdent :: TransM ModuleIdent
getModuleIdent = R.asks moduleIdent
......@@ -84,22 +83,22 @@ trQualify i = getModuleIdent >>= \m -> return $ qualifyWith m i
-- alias types.
trDecl :: Decl -> TransM [IL.Decl]
trDecl (DataDecl _ tc tvs cs) = (:[]) `liftM` trData tc tvs cs
trDecl (NewtypeDecl _ tc tvs nc) = (:[]) `liftM` trNewtype tc tvs nc
trDecl (FunctionDecl p f eqs) = (:[]) `liftM` trFunction p f eqs
trDecl (ForeignDecl _ cc ie f _) = (:[]) `liftM` trForeign f cc ie
trDecl (DataDecl _ tc tvs cs) = (:[]) <$> trData tc tvs cs
trDecl (NewtypeDecl _ tc tvs nc) = (:[]) <$> trNewtype tc tvs nc
trDecl (FunctionDecl p f eqs) = (:[]) <$> trFunction p f eqs
trDecl (ForeignDecl _ cc ie f _) = (:[]) <$> trForeign f cc ie
trDecl _ = return []
trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl
trData tc tvs cs = do
tc' <- trQualify tc
IL.DataDecl tc' (length tvs) `liftM` mapM trConstrDecl cs
IL.DataDecl tc' (length tvs) <$> mapM trConstrDecl cs
trConstrDecl :: ConstrDecl -> TransM (IL.ConstrDecl [IL.Type])
trConstrDecl d = do
c' <- trQualify (constr d)
ty' <- arrowArgs `liftM` constrType c'
IL.ConstrDecl c' `liftM` mapM trType ty'
ty' <- arrowArgs <$> constrType c'
IL.ConstrDecl c' <$> mapM trType ty'
where
constr (ConstrDecl _ _ c _) = c
constr (ConOpDecl _ _ _ op _) = op
......@@ -108,8 +107,8 @@ trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl
trNewtype tc tvs (NewConstrDecl _ _ c _) = do
tc' <- trQualify tc
c' <- trQualify c
[ty] <- arrowArgs `liftM` constrType c'
(IL.NewtypeDecl tc' (length tvs) . IL.ConstrDecl c') `liftM` trType ty
[ty] <- arrowArgs <$> constrType c'
(IL.NewtypeDecl tc' (length tvs) . IL.ConstrDecl c') <$> trType ty
trForeign :: Ident -> CallConv -> Maybe String -> TransM IL.Decl
trForeign _ _ Nothing = internalError "CurryToIL.trForeign: no target"
......@@ -135,7 +134,7 @@ trForeign f cc (Just ie) = do
-- translIntfDecl ::IDecl -> TransM [IL.Decl]
-- translIntfDecl (IDataDecl _ tc tvs cs)
-- | not (isQualified tc) = (:[]) `liftM`
-- | not (isQualified tc) = (:[]) <$>
-- translIntfData (unqualify tc) tvs cs
-- translIntfDecl _ = return []
......@@ -151,11 +150,11 @@ trForeign f cc (Just ie) = do
-- translIntfConstrDecl tvs (ConstrDecl _ _ c tys) = do
-- m <- getModuleIdent
-- c' <- trQualify c
-- IL.ConstrDecl c' `liftM` mapM trType (toQualTypes m tvs tys)
-- IL.ConstrDecl c' <$> mapM trType (toQualTypes m tvs tys)
-- translIntfConstrDecl tvs (ConOpDecl _ _ ty1 op ty2) = do
-- m <- getModuleIdent
-- op' <- trQualify op
-- IL.ConstrDecl op' `liftM` mapM trType (toQualTypes m tvs [ty1, ty2])
-- IL.ConstrDecl op' <$> mapM trType (toQualTypes m tvs [ty1, ty2])
-- Types:
-- The type representation in the intermediate language is the same as
......@@ -167,7 +166,7 @@ trForeign f cc (Just ie) = do
-- them back into their corresponding type constructors first.
trType :: Type -> TransM IL.Type
trType ty = trTy `liftM` elimRecordTypes (maximum $ 0 : typeVars ty) ty
trType ty = trTy <$> elimRecordTypes (maximum $ 0 : typeVars ty) ty
where
trTy (TypeConstructor tc tys) = IL.TypeConstructor tc (map trTy tys)
trTy (TypeVariable tv) = IL.TypeVariable tv
......@@ -180,12 +179,12 @@ trType ty = trTy `liftM` elimRecordTypes (maximum $ 0 : typeVars ty) ty
elimRecordTypes :: Int -> Type -> TransM Type
elimRecordTypes n (TypeConstructor t tys)
= TypeConstructor t `liftM` mapM (elimRecordTypes n) tys
= TypeConstructor t <$> mapM (elimRecordTypes n) tys
elimRecordTypes _ v@(TypeVariable _) = return v
elimRecordTypes n (TypeConstrained tys v)
= flip TypeConstrained v `liftM` mapM (elimRecordTypes n) tys
= flip TypeConstrained v <$> mapM (elimRecordTypes n) tys
elimRecordTypes n (TypeArrow t1 t2)
= liftM2 TypeArrow (elimRecordTypes n t1) (elimRecordTypes n t2)
= TypeArrow <$> elimRecordTypes n t1 <*> elimRecordTypes n t2
elimRecordTypes _ s@(TypeSkolem _) = return s
elimRecordTypes n (TypeRecord fs)
| null fs = internalError "CurryToIL.elimRecordTypes: empty record type"
......@@ -196,7 +195,7 @@ elimRecordTypes n (TypeRecord fs)
(elimRecordTypes n)
(Map.lookup i vs))
[0 .. n'-1]
TypeConstructor r `liftM` tys
TypeConstructor r <$> tys
matchTypeVars :: [(Ident, Type)] -> Map.Map Int Type -> (Ident, Type)
-> Map.Map Int Type
......@@ -246,35 +245,21 @@ matchTypeVars fs vs (l, ty) = maybe vs (match' vs ty) (lookup l fs)
trFunction :: Position -> Ident -> [Equation] -> TransM IL.Decl
trFunction p f eqs = do
f' <- trQualify f
ty' <- varType f' >>= trType
flat <- isFlat
let vs = if not flat && isFpSelectorId f then trArgs eqs funVars else funVars
alts <-mapM (trEquation vs addVars) eqs
f' <- trQualify f
ty' <- varType f' >>= trType
alts <-mapM (trEquation vs ws) eqs
let expr = flexMatch (srcRefOf p) vs alts
return $ IL.FunctionDecl f' vs ty' expr
where
-- funVars are the variables needed for the function: _1, _2, etc.
-- addVars is an infinite list for introducing additional variables later
(funVars, addVars) = splitAt (equationArity (head eqs))
(argNames (mkIdent ""))
-- vs are the variables needed for the function: _1, _2, etc.
-- ws is an infinite list for introducing additional variables later
(vs, ws) = splitAt (equationArity (head eqs)) (argNames (mkIdent ""))
equationArity (Equation _ lhs _) = p_equArity lhs
where
p_equArity (FunLhs _ ts) = length ts
p_equArity (OpLhs _ _ _) = 2
p_equArity _ = internalError "ILTrans - illegal equation"
-- TODO: What is this for?
trArgs :: [Equation] -> [Ident] -> [Ident]
trArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =
v : map (translArg (bindRenameEnv v t Map.empty)) ts
where
translArg env (VariablePattern v') = case Map.lookup v' env of
Just x -> x
Nothing -> internalError "Transformations.CurryToIL.trArgs"
translArg _ _ = internalError "Translation of arguments not defined"
trArgs _ _ = internalError "Translation of arguments not defined" -- TODO
trEquation :: [Ident] -- identifiers for the function's parameters
-> [Ident] -- infinite list of additional identifiers
-> Equation -- equation to be translated
......@@ -322,31 +307,31 @@ trExpr _ env (Variable v)
| otherwise = case Map.lookup (unqualify v) env of
Nothing -> fun
Just v' -> return $ IL.Variable v' -- apply renaming
where fun = (IL.Function v . arrowArity) `liftM` varType v
where fun = (IL.Function v . arrowArity) <$> varType v
trExpr _ _ (Constructor c)
= (IL.Constructor c . arrowArity) `liftM` constrType c
= (IL.Constructor c . arrowArity) <$> constrType c
trExpr vs env (Apply e1 e2)
= liftM2 IL.Apply (trExpr vs env e1) (trExpr vs env e2)
= IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2
trExpr vs env (Let ds e) = do
e' <- trExpr vs env' e
case ds of
[FreeDecl _ vs']
-> return $ foldr IL.Exist e' vs'
[d] | all (`notElem` bv d) (qfv emptyMIdent d)
-> flip IL.Let e' `liftM` trBinding d
_ -> flip IL.Letrec e' `liftM` mapM trBinding ds
-> flip IL.Let e' <$> trBinding d
_ -> flip IL.Letrec e' <$> mapM trBinding ds
where
env' = foldr2 Map.insert env bvs bvs
bvs = bv ds
trBinding (PatternDecl _ (VariablePattern v) rhs)
= IL.Binding v `liftM` trRhs vs env' rhs
= IL.Binding v <$> trRhs vs env' rhs
trBinding p = error $ "unexpected binding: " ++ show p
trExpr (v:vs) env (Case r ct e alts) = do
-- the ident v is used for the case expression subject, as this could
-- be referenced in the case alternatives by a variable pattern
e' <- trExpr vs env e
let matcher = if ct == Flex then flexMatch else rigidMatch
expr <- matcher r [v] `liftM` mapM (trAlt (v:vs) env) alts
expr <- matcher r [v] <$> mapM (trAlt (v:vs) env) alts
return $ case expr of
IL.Case r' mode (IL.Variable v') alts'
-- subject is not referenced -> forget v and insert subject
......@@ -355,8 +340,8 @@ trExpr (v:vs) env (Case r ct e alts) = do
-- subject is referenced -> introduce binding for v as subject
| v `elem` fv expr -> IL.Let (IL.Binding v e') expr
| otherwise -> expr
trExpr vs env (Typed e ty) = liftM2 IL.Typed (trExpr vs env e)
(trType $ toType [] ty)
trExpr vs env (Typed e ty) = IL.Typed <$> trExpr vs env e
<*> trType (toType [] ty)
trExpr _ _ _ = internalError "CurryToIL.trExpr"
trAlt :: [Ident] -> RenameEnv -> Alt -> TransM Match
......
......@@ -103,6 +103,7 @@ data DesugarState = DesugarState
, tyConsEnv :: TCEnv -- read-only
, valueEnv :: ValueEnv
, nextId :: Integer -- counter
, desugarFP :: Bool
}
type DsM a = S.State DesugarState a
......@@ -122,6 +123,9 @@ getValueEnv = S.gets valueEnv
modifyValueEnv :: (ValueEnv -> ValueEnv) -> DsM ()
modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s }
desugarFunPats :: DsM Bool
desugarFunPats = S.gets desugarFP
getNextId :: DsM Integer
getNextId = do
nid <- S.gets nextId
......@@ -163,12 +167,12 @@ freshMonoTypeVar prefix t = getTypeOf t >>= \ ty ->
-- Actually, the transformation is slightly more general than necessary
-- as it allows value declarations at the top-level of a module.
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module
desugar :: Bool -> [KnownExtension] -> ValueEnv -> TCEnv -> Module
-> (Module, ValueEnv)
desugar xs tyEnv tcEnv (Module ps m es is ds)
desugar dsFunPats xs tyEnv tcEnv (Module ps m es is ds)
= (Module ps m es is ds', valueEnv s')
where (ds', s') = S.runState (desugarModuleDecls ds)
(DesugarState m xs tcEnv tyEnv 1)
(DesugarState m xs tcEnv tyEnv 1 dsFunPats)
desugarModuleDecls :: [Decl] -> DsM [Decl]
desugarModuleDecls ds = do
......@@ -212,19 +216,19 @@ genForeignDecl p f = do
-- and a record label belongs to only one record declaration.
dsDeclRhs :: Decl -> DsM Decl
dsDeclRhs (FunctionDecl p f eqs) =
FunctionDecl p f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl p t rhs) =
PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs (ForeignDecl p cc ie f ty) =
return $ ForeignDecl p cc (ie `mplus` Just (idName f)) f ty
dsDeclRhs vars@(FreeDecl _ _) = return vars
dsDeclRhs (FunctionDecl p f eqs) = FunctionDecl p f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs (ForeignDecl p cc ie f ty) = return $ ForeignDecl p cc ie' f ty
where ie' = ie `mplus` Just (idName f)
dsDeclRhs fs@(FreeDecl _ _) = return fs
dsDeclRhs _ = error "Desugar.dsDeclRhs: no pattern match"
dsEquation :: Equation -> DsM Equation
dsEquation (Equation p lhs rhs) = do
(cs1 , ts1) <- dsNonLinearity ts
(ds2, cs2, ts2) <- dsFunctionalPatterns p ts1
funpats <- desugarFunPats
(ds2, cs2, ts2) <- if funpats then dsFunctionalPatterns p ts1
else return ([], [], ts1)
(ds3 , ts3) <- mapAccumM (dsPattern p) [] ts2
rhs' <- dsRhs p (addConstraints (cs2 ++ cs1))
$ addDecls (ds2 ++ ds3) $ rhs
......@@ -239,7 +243,7 @@ dsEquation (Equation p lhs rhs) = do
-- all variables. If it encounters a variable which has been previously
-- introduced, the second occurrence is changed to a fresh variable
-- and a new pair (newvar, oldvar) is saved to generate constraints later.
-- Non-linear patterns in functional patterns are not desugared,
-- Non-linear patterns inside single functional patterns are not desugared,
-- as this special case is handled later.
dsNonLinearity :: [Pattern] -> DsM ([Expression], [Pattern])
dsNonLinearity ts = do
......@@ -430,6 +434,7 @@ fp2Expr t = internalError $
-- with a local declaration for 'v'.
dsPattern :: Position -> [Decl] -> Pattern -> DsM ([Decl], Pattern)
dsPattern _ ds v@(VariablePattern _) = return (ds, v)
dsPattern p ds (LiteralPattern l) = do
dl <- dsLiteral l
case dl of
......@@ -437,7 +442,6 @@ dsPattern p ds (LiteralPattern l) = do
Right (rs,ls) -> dsPattern p ds $ ListPattern rs $ map LiteralPattern ls
dsPattern p ds (NegativePattern _ l) =