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