Commit d7c80601 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott Committed by Finn Teegen
Browse files

Remove some redundancy in TypedFlatCurry

parent 952f1c6a
......@@ -37,7 +37,7 @@ genFlatExpr :: TExpr -> Expr
genFlatExpr = trTExpr
(const Var)
(const Lit)
(\ct name args -> Comb ct (fst name) args)
(\_ ct name args -> Comb ct name args)
(\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)
(\vs e -> Free (map fst vs) e)
Or
......@@ -47,7 +47,7 @@ genFlatExpr = trTExpr
genFlatPattern :: TPattern -> Pattern
genFlatPattern = trTPattern
(\name args -> Pattern (fst name) $ map fst args)
(\_ name args -> Pattern name $ map fst args)
(const LPattern)
-- transforms a FlatCurry module to a FlatCurry interface
......
......@@ -371,9 +371,8 @@ trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e
-- Translate a pattern
trPat :: IL.ConstrTerm -> FlatState TPattern
trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l
trPat (IL.ConstructorPattern ty c vs) = do
qty <- trType $ foldr (IL.TypeArrow . fst) ty vs
TPattern <$> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs
trPat (IL.ConstructorPattern ty c vs) =
TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs
trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat"
-- Convert a case type
......@@ -406,15 +405,19 @@ genCall call ty f es = do
genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr
genTComb ty qid es ct = do
ty' <- trType ty
TComb ct (qid, ty') <$> mapM trTExpr es
let ty'' = defunc ty' (length es)
TComb ty'' ct qid <$> mapM trTExpr es
where
defunc t 0 = t
defunc (FuncType _ t2) n = defunc t2 (n - 1)
defunc _ _ = internalError "GenTypedFlatCurry.genTComb.defunc"
genApply :: TExpr -> [IL.Expression] -> FlatState TExpr
genApply e es = do
ap <- trQualIdent $ qApplyId
ap <- trQualIdent qApplyId
es' <- mapM trTExpr es
return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1
in TComb FuncCall (ap, FuncType (FuncType ty1 ty2)
(FuncType ty1 ty2)) [e1, e2])
return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1
in TComb ty2 FuncCall ap [e1, e2])
e es'
-- -----------------------------------------------------------------------------
......@@ -457,9 +460,10 @@ instance Normalize TRule where
normalize (TExternal ty s) = flip TExternal s <$> normalize ty
instance Normalize TExpr where
normalize (TVarE ty v) = flip TVarE v <$> normalize ty
normalize (TVarE ty v) = flip TVarE v <$> normalize ty
normalize (TLit ty l) = flip TLit l <$> normalize ty
normalize (TComb ct f es) = TComb ct <$> normalize f
normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty
<*> pure f
<*> mapM normalize es
normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds
<*> normalize e
......@@ -477,7 +481,8 @@ instance Normalize TBranchExpr where
normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e
instance Normalize TPattern where
normalize (TPattern c vs) = TPattern <$> normalize c
normalize (TPattern ty c vs) = TPattern <$> normalize ty
<*> pure c
<*> mapM normalize vs
normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty
......
......@@ -327,7 +327,7 @@ matchInterface ifn i = do
writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO ()
writeFlat opts env mdl il = do
(_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg) -- TODO ???
(_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg)
when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfc
when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tafcyProg
when fcyTarget $ do
......
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