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

Use FlatCurryPretty for pretty-printing of FlatCurry

parent c9fa0c2c
...@@ -45,10 +45,10 @@ moduleAnalyses = ...@@ -45,10 +45,10 @@ moduleAnalyses =
-- SourceCodeAnalysis (\fname -> readFile fname >>= \prog -> -- SourceCodeAnalysis (\fname -> readFile fname >>= \prog ->
-- return (ContentsResult CurryProg prog))), -- return (ContentsResult CurryProg prog))),
("Curry code (generated from FlatCurry)", ("Curry code (generated from FlatCurry)",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryMod False prog))), FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryMod prog))),
("Source program with type signatures added", SourceCodeAnalysis addTypes), ("Source program with type signatures added", SourceCodeAnalysis addTypes),
("FlatCurry code", ("FlatCurry code",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryMod True prog))), FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showFlatCurry prog))),
("FlatCurry expression", ("FlatCurry expression",
FlatCurryAnalysis (\prog -> ContentsResult FlatCurryExp (showFlatProg prog)))] FlatCurryAnalysis (\prog -> ContentsResult FlatCurryExp (showFlatProg prog)))]
......
...@@ -8,22 +8,30 @@ ...@@ -8,22 +8,30 @@
--- The human-readable presentation is (almost) Curry source code --- The human-readable presentation is (almost) Curry source code
--- generated from a FlatCurry program. --- generated from a FlatCurry program.
--- ---
--- @author Michael Hanus --- @author Michael Hanus, Björn Peemöller
--- @version April 2013 --- @version June 2015
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
module ShowFlatCurry(showInterface,showCurryMod,showFlatProg, module ShowFlatCurry
showFuncDeclAsCurry,showFuncDeclAsFlatCurry,leqFunc, ( showFlatCurry, showInterface
funcModule) , showCurryMod, showFlatProg
where , showFuncDeclAsCurry, showFuncDeclAsFlatCurry
, leqFunc, funcModule
) where
import Char (isAlpha)
import List (intercalate)
import Pretty (pPrint)
import Sort (mergeSort,leqString)
import FlatCurry import FlatCurry
import FlatCurryShow
import FlatCurryGoodies import FlatCurryGoodies
import List import FlatCurryPretty (Options (..), defaultOptions, ppProg, ppFuncDecl)
import Char(isAlpha) import FlatCurryShow
import Sort(mergeSort,leqString)
--- Show FlatCurry module in pretty-printed form
showFlatCurry :: Prog -> String
showFlatCurry = pPrint . ppProg defaultOptions
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- Generate interface description for a program: -- Generate interface description for a program:
...@@ -89,8 +97,8 @@ showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) = ...@@ -89,8 +97,8 @@ showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
-- generate a human-readable representation of a Curry module: -- generate a human-readable representation of a Curry module:
showCurryMod :: Bool -> Prog -> String showCurryMod :: Prog -> String
showCurryMod ascase (Prog mod imports types funcs ops) = showCurryMod (Prog mod imports types funcs ops) =
"module "++mod++"("++showTypeExports types++ "module "++mod++"("++showTypeExports types++
showFuncExports funcs++") where\n\n"++ showFuncExports funcs++") where\n\n"++
concatMap showInterfaceImport imports ++ "\n" ++ concatMap showInterfaceImport imports ++ "\n" ++
...@@ -99,7 +107,7 @@ showCurryMod ascase (Prog mod imports types funcs ops) = ...@@ -99,7 +107,7 @@ showCurryMod ascase (Prog mod imports types funcs ops) =
concatMap (showCurryDataDecl (showQNameInModule mod)) types concatMap (showCurryDataDecl (showQNameInModule mod)) types
++ "\n" ++ ++ "\n" ++
concatMap (showCurryFuncDecl (showQNameInModule mod) concatMap (showCurryFuncDecl (showQNameInModule mod)
(showQNameInModule mod) ascase) funcs (showQNameInModule mod)) funcs
++ "\n-- end of module " ++ mod ++ "\n" ++ "\n-- end of module " ++ mod ++ "\n"
showTypeExports :: [TypeDecl] -> String showTypeExports :: [TypeDecl] -> String
...@@ -135,31 +143,15 @@ showCurryConsDecl tt (Cons cname _ _ argtypes) = ...@@ -135,31 +143,15 @@ showCurryConsDecl tt (Cons cname _ _ argtypes) =
-- generate function definitions: -- generate function definitions:
showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> Bool -> FuncDecl -> String showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> FuncDecl -> String
showCurryFuncDecl tt tf ascase (Func fname _ _ ftype frule) = showCurryFuncDecl tt tf (Func fname _ _ ftype frule) =
showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++ showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++
showCurryRule tf ascase fname frule showCurryRule tf fname frule
showCurryRule :: (QName -> String) -> Bool -> QName -> Rule -> String
showCurryRule _ _ fname (External _) = showCurryId (snd fname) ++ " external\n\n"
showCurryRule tf ascase fname (Rule lhs rhs) =
if ascase then showCurryRuleAsCase tf fname (Rule lhs rhs)
else showCurryRuleAsPatterns tf fname (Rule lhs rhs)
-- format rule as case expression:
showCurryRuleAsCase :: (QName -> String) -> QName -> Rule -> String
showCurryRuleAsCase tf fname (Rule lhs rhs)
| length lhs == 2 && not (isAlpha (head (snd fname))) -- infix op
= showCurryVar (head lhs) ++ " " ++ tf fname ++ " " ++ showCurryVar (lhs!!1) ++
" = " ++ showCurryExpr tf False 0 rhs ++ "\n\n"
| otherwise
= tf fname ++ " " ++ intercalate " " (map showCurryVar lhs) ++
" = " ++ showCurryExpr tf False 0 rhs ++ "\n\n"
showCurryRuleAsCase _ fname (External _) = showCurryId (snd fname) ++ " external\n"
-- format rule as set of pattern matching rules: -- format rule as set of pattern matching rules:
showCurryRuleAsPatterns :: (QName -> String) -> QName -> Rule -> String showCurryRule :: (QName -> String) -> QName -> Rule -> String
showCurryRuleAsPatterns tf fname (Rule lhs rhs) = showCurryRule _ fname (External _) = showCurryId (snd fname) ++ " external\n\n"
showCurryRule tf fname (Rule lhs rhs) =
concatMap (\ (l,r) -> showCurryPatternRule tf l r) concatMap (\ (l,r) -> showCurryPatternRule tf l r)
(rule2equations (shallowPattern2Expr fname lhs) rhs) (rule2equations (shallowPattern2Expr fname lhs) rhs)
++ "\n" ++ "\n"
...@@ -178,14 +170,12 @@ showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in ...@@ -178,14 +170,12 @@ showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
++ "\n" ++ "\n"
showCurryCRHS :: (QName -> String) -> Expr -> String showCurryCRHS :: (QName -> String) -> Expr -> String
showCurryCRHS tf r = showCurryCRHS tf r = case r of
if isGuardedExpr r Comb _ ("Prelude","cond") [e1, e2] -> " | " ++ showCurryCondRule e1 e2
then " | " ++ showCurryCondRule r _ -> " = " ++ showCurryExpr tf False 2 r
else " = " ++ showCurryExpr tf False 2 r
where where
showCurryCondRule (Comb _ _ [e1,e2]) = showCurryCondRule e1 e2 = showCurryExpr tf False 2 e1 ++
showCurryExpr tf False 2 e1 ++ " = " ++ showCurryExpr tf False 4 e2 " = " ++ showCurryExpr tf False 4 e2
-- transform a rule consisting of a left- and a right-hand side -- transform a rule consisting of a left- and a right-hand side
-- (represented as expressions) into a set of pattern matching rules: -- (represented as expressions) into a set of pattern matching rules:
...@@ -226,9 +216,10 @@ substitute vars exps expr = substituteAll vars exps 0 expr ...@@ -226,9 +216,10 @@ substitute vars exps expr = substituteAll vars exps 0 expr
substituteAll :: [Int] -> [Expr] -> Int -> Expr -> Expr substituteAll :: [Int] -> [Expr] -> Int -> Expr -> Expr
substituteAll vars exps b (Var i) = replaceVar vars exps i substituteAll vars exps b (Var i) = replaceVar vars exps i
where replaceVar [] [] var = Var (b+var) where replaceVar [] _ var = Var (b + var)
replaceVar (v:vs) (e:es) var = if v==var then e replaceVar (_:_) [] var = Var (b + var)
else replaceVar vs es var replaceVar (v:vs) (e:es) var = if v == var then e
else replaceVar vs es var
substituteAll _ _ _ (Lit l) = Lit l substituteAll _ _ _ (Lit l) = Lit l
substituteAll vs es b (Comb combtype c exps) = substituteAll vs es b (Comb combtype c exps) =
Comb combtype c (map (substituteAll vs es b) exps) Comb combtype c (map (substituteAll vs es b) exps)
...@@ -241,21 +232,13 @@ substituteAll vs es b (Or e1 e2) = ...@@ -241,21 +232,13 @@ substituteAll vs es b (Or e1 e2) =
Or (substituteAll vs es b e1) (substituteAll vs es b e2) Or (substituteAll vs es b e1) (substituteAll vs es b e2)
substituteAll vs es b (Case ctype e cases) = substituteAll vs es b (Case ctype e cases) =
Case ctype (substituteAll vs es b e) (map (substituteAllCase vs es b) cases) Case ctype (substituteAll vs es b e) (map (substituteAllCase vs es b) cases)
substituteAll vs es b (Typed e t) = Typed (substituteAll vs es b e) t
substituteAllCase :: [Int] -> [Expr] -> Int -> BranchExpr -> BranchExpr substituteAllCase :: [Int] -> [Expr] -> Int -> BranchExpr -> BranchExpr
substituteAllCase vs es b (Branch (Pattern l pvs) e) = substituteAllCase vs es b (Branch (Pattern l pvs) e) =
Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e) Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e)
substituteAllCase vs es b (Branch (LPattern l) e) = substituteAllCase vs es b (Branch (LPattern l) e) =
Branch (LPattern l) (substituteAll vs es b e) Branch (LPattern l) (substituteAll vs es b e)
substituteAll vs es b (Typed e t) =
Typed (substituteAll vs es b e) t
-- Is the expression a guarded expressions?
isGuardedExpr :: Expr -> Bool
isGuardedExpr e = case e of
Comb _ f _ -> f == ("Prelude","cond")
_ -> False
-------- Definition of some orderings: -------- Definition of some orderings:
...@@ -276,12 +259,11 @@ leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2 ...@@ -276,12 +259,11 @@ leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2
showFuncDeclAsCurry :: FuncDecl -> String showFuncDeclAsCurry :: FuncDecl -> String
showFuncDeclAsCurry fd = showFuncDeclAsCurry fd =
showCurryFuncDecl (showQNameInModule (funcModule fd)) showCurryFuncDecl (showQNameInModule (funcModule fd))
(showQNameInModule (funcModule fd)) False fd (showQNameInModule (funcModule fd)) fd
showFuncDeclAsFlatCurry :: FuncDecl -> String showFuncDeclAsFlatCurry :: FuncDecl -> String
showFuncDeclAsFlatCurry fd = showFuncDeclAsFlatCurry fd = pPrint (ppFuncDecl opts fd)
showCurryFuncDecl (showQNameInModule (funcModule fd)) where opts = defaultOptions { currentModule = funcModule fd }
(showQNameInModule (funcModule fd)) True fd
funcModule :: FuncDecl -> String funcModule :: FuncDecl -> String
funcModule fd = fst (funcName fd) funcModule fd = fst (funcName fd)
Supports Markdown
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