Commit ceaa5c29 authored by Michael Hanus's avatar Michael Hanus
Browse files

browser: ShowFlatCurry deleted and GenInt re-used

parent 41a4145d
......@@ -5,15 +5,23 @@
-- add access to a new analysis here and recompile the browser.
-----------------------------------------------------------------------------
module BrowserAnalysis(moduleAnalyses,allFunctionAnalyses,functionAnalyses) where
module BrowserAnalysis(moduleAnalyses,allFunctionAnalyses,functionAnalyses
, funcModule)
where
import FileGoodies(stripSuffix)
import List(intersperse)
import Pretty (pPrint)
import FlatCurry.Types
import FlatCurry.Goodies (funcName)
import FlatCurry.Pretty (Options (..), defaultOptions, ppProg, ppFuncDecl)
import FlatCurry.Show (showFlatFunc, showFlatProg)
import AnalysisTypes
import Analysis(AOutFormat(..))
import AnalysisServer(analyzeFunctionForBrowser)
import Registry(functionAnalysisInfos)
import FlatCurry.Types
import FlatCurry.Goodies
import FlatCurry.Show(showFlatFunc)
import Overlapping
import PatternComplete
import SolutionComplete
......@@ -23,34 +31,34 @@ import Indeterminism
import CalledByAnalysis
import Linearity
import AddTypes
import ShowFlatCurry
import List(intersperse)
import Imports
import FileGoodies(stripSuffix)
import GenInt(showInterface, showCurryModule, showCurryFuncDecl)
import ShowGraph
infix 1 `showWith`,`showWithMsg`
-----------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- The list of all available analyses for individual modules.
-- Each analysis must return a string representation of its analysis result
-- or an IO action to show the result.
moduleAnalyses :: [(String, ModuleAnalysis ModuleAnalysisResult)]
moduleAnalyses =
[("Interface",
InterfaceAnalysis (\int -> ContentsResult CurryProg (showInterface False int))),
InterfaceAnalysis (\int -> ContentsResult CurryProg (showInterface False int)))
--("Write Interface",
-- InterfaceAnalysis (\int -> ModuleAction (putStrLn (showInterface False int)))),
--("Read source file",
-- SourceCodeAnalysis (\fname -> readFile fname >>= \prog ->
-- return (ContentsResult CurryProg prog))),
("Curry code (generated from FlatCurry)",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryMod prog))),
("Source program with type signatures added", SourceCodeAnalysis addTypes),
("FlatCurry code",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showFlatCurry prog))),
("FlatCurry expression",
FlatCurryAnalysis (\prog -> ContentsResult FlatCurryExp (showFlatProg prog)))]
,("Curry code (generated from FlatCurry)",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showCurryModule prog)))
,("Source program with type signatures added", SourceCodeAnalysis addTypes)
,("FlatCurry code",
FlatCurryAnalysis (\prog -> ContentsResult CurryProg (showFlatCurry prog)))
,("FlatCurry expression",
FlatCurryAnalysis (\prog -> ContentsResult FlatCurryExp (showFlatProg prog)))
]
addTypes :: String -> IO ModuleAnalysisResult
addTypes fname
......@@ -60,6 +68,10 @@ addTypes fname
= do prog <- addTypeSignatures (stripSuffix fname)
return (ContentsResult CurryProg prog)
--- Show FlatCurry module in pretty-printed form
showFlatCurry :: Prog -> String
showFlatCurry = pPrint . ppProg defaultOptions
-----------------------------------------------------------------------------------
-- The list of all available analyses for individual functions.
-- Each analysis must return a string or an IO action representation of its
......@@ -101,6 +113,20 @@ functionAnalyses =
("Purity", GlobalAnalysis analyseIndeterminism `showWithMsg` showIndet)]
-- Show individual functions:
showFuncDeclAsCurry :: FuncDecl -> String
showFuncDeclAsCurry fd =
showCurryFuncDecl (showQNameInModule (funcModule fd))
(showQNameInModule (funcModule fd)) fd
showFuncDeclAsFlatCurry :: FuncDecl -> String
showFuncDeclAsFlatCurry fd = pPrint (ppFuncDecl opts fd)
where opts = defaultOptions { currentModule = funcModule fd }
funcModule :: FuncDecl -> String
funcModule fd = fst (funcName fd)
-----------------------------------------------------------------------------
-- The list of all available analyses for sets of functions.
-- Each analysis must return a short(!) string representation (no more than a few chars)
-- of its analysis result that is prefixed to the function name in the list
......
......@@ -29,7 +29,7 @@ import AnalysisTypes
import BrowserAnalysis
import Dependency (callsDirectly,indirectlyDependent)
import ImportCalls
import ShowFlatCurry (leqFunc,funcModule)
import GenInt (leqFunc)
import ShowGraph
import Analysis (AOutFormat(..))
......
......@@ -12,18 +12,19 @@ ANADIR = $(CURRYTOOLS)/analysis
TOOL = $(BINDIR)/currybrowse
# source modules of the Curry Browser:
DEPS = BrowserGUI.curry ShowFlatCurry.curry Imports.curry \
DEPS = BrowserGUI.curry Imports.curry \
AnalysisTypes.curry BrowserAnalysis.curry ShowGraph.curry \
$(CASS)/AnalysisServer.curry $(CASS)/AnalysisDoc.curry \
$(CASS)/Registry.curry \
$(CURRYTOOLS)/addtypes/AddTypes.curry \
$(CURRYTOOLS)/genint/GenInt.curry \
$(CURRYTOOLS)/importcalls/ImportCalls.curry \
$(LIBDIR)/GUI.curry $(LIBDIR)/IOExts.curry $(LIBDIR)/System.curry \
$(LIBDIR)/FlatCurry/Types.curry $(LIBDIR)/FlatCurry/Files.curry \
$(LIBDIR)/FlatCurry/Show.curry \
analysis/*.curry $(ANADIR)/*.curry
LOADPATH = analysis:$(CASS):$(ANADIR):$(CURRYTOOLS)/importcalls:$(CURRYTOOLS)/addtypes
LOADPATH = analysis:$(CASS):$(ANADIR):$(CURRYTOOLS)/genint:$(CURRYTOOLS)/importcalls:$(CURRYTOOLS)/addtypes
.PHONY: all compile install clean uninstall
......
------------------------------------------------------------------------------
--- Generate an interface description or a human-readable
--- presentation of a Curry module.
---
--- The interface description contains the type declarations
--- for all entities defined and exported by this module.
---
--- The human-readable presentation is (almost) Curry source code
--- generated from a FlatCurry program.
---
--- @author Michael Hanus, Bjoern Peemoeller
--- @version April 2016
------------------------------------------------------------------------------
module ShowFlatCurry
( showFlatCurry, showInterface
, showCurryMod, showFlatProg
, showFuncDeclAsCurry, showFuncDeclAsFlatCurry
, leqFunc, funcModule
) where
import Char (isAlpha)
import List (intercalate)
import Pretty (pPrint)
import Sort (mergeSortBy,leqString)
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import FlatCurry.Pretty (Options (..), defaultOptions, ppProg, ppFuncDecl)
import FlatCurry.Show
--- Show FlatCurry module in pretty-printed form
showFlatCurry :: Prog -> String
showFlatCurry = pPrint . ppProg defaultOptions
-----------------------------------------------------------------------
-- Generate interface description for a program:
-- If first argument is True, generate stubs (...external) for
-- all functions so that the resulting interface is a valid Curry program.
showInterface :: Bool -> Prog -> String
showInterface genstub (Prog mod imports types funcs ops) =
concatMap showInterfaceImport imports ++ "\n" ++
concatMap showInterfaceOpDecl (mergeSortBy leqOp ops) ++
(if null ops then "" else "\n") ++
concatMap (showInterfaceType (showQNameInModule mod))
(mergeSortBy leqType types) ++ "\n" ++
concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
(mergeSortBy leqFunc funcs) ++ "\n"
-- show import declaration
showInterfaceImport :: String -> String
showInterfaceImport impmod = if impmod=="Prelude" then ""
else "import "++impmod++"\n"
-- show operator declaration
showInterfaceOpDecl :: OpDecl -> String
showInterfaceOpDecl (Op op InfixOp prec) = "infix "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixlOp prec) = "infixl "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixrOp prec) = "infixr "++show prec++" "++showOp op++"\n"
showOp :: (_,String) -> String
showOp (_,on) = if isAlpha (head on) then '`':on++"`"
else on
-- show type declaration
showInterfaceType :: (QName -> String) -> TypeDecl -> String
showInterfaceType tt (Type (_,tcons) vis tvars constrs) =
if vis==Public
then "data " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)
++ "\n"
else ""
where
constxt = intercalate " | "
(map (showExportConsDecl tt)
(filter (\ (Cons _ _ cvis _)->cvis==Public) constrs))
showInterfaceType tt (TypeSyn (_,tcons) vis tvars texp) =
if vis==Public
then "type " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
" = " ++ showCurryType tt True texp ++ "\n"
else ""
showExportConsDecl :: (QName -> String) -> ConsDecl -> String
showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- show function type declaration
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> String
showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
if vis==Public
then showCurryId fname ++ " :: " ++
showCurryType ttrans False ftype ++ "\n" ++
(if genstub then showCurryId fname ++ " external\n\n" else "")
else ""
---------------------------------------------------------------------------
-- generate a human-readable representation of a Curry module:
showCurryMod :: Prog -> String
showCurryMod (Prog mod imports types funcs ops) =
"module "++mod++"("++showTypeExports types++
showFuncExports funcs++") where\n\n"++
concatMap showInterfaceImport imports ++ "\n" ++
concatMap showInterfaceOpDecl ops ++
(if null ops then "" else "\n") ++
concatMap (showCurryDataDecl (showQNameInModule mod)) types
++ "\n" ++
concatMap (showCurryFuncDecl (showQNameInModule mod)
(showQNameInModule mod)) funcs
++ "\n-- end of module " ++ mod ++ "\n"
showTypeExports :: [TypeDecl] -> String
showTypeExports types = concatMap (++",") (concatMap exptype types)
where
exptype (Type tcons vis _ cdecls) =
if vis==Public
then [snd tcons++let cs = expcons cdecls in (if cs=="()" then "" else cs)]
else []
exptype (TypeSyn tcons vis _ _) = if vis==Public then [snd tcons] else []
expcons cds = "(" ++ intercalate "," (concatMap expc cds) ++ ")"
expc (Cons cname _ vis _) = if vis==Public then [snd cname] else []
showFuncExports :: [FuncDecl] -> String
showFuncExports funcs = intercalate "," (concatMap expfun funcs)
where
expfun (Func fname _ vis _ _) = if vis==Public then [snd fname] else []
showCurryDataDecl :: (QName -> String) -> TypeDecl -> String
showCurryDataDecl tt (Type tcons _ tvars constrs) =
"data " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)
++ "\n"
where constxt = intercalate " | " (map (showCurryConsDecl tt) constrs)
showCurryDataDecl tt (TypeSyn tcons _ tvars texp) =
"type " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
" = " ++ showCurryType tt True texp ++ "\n"
showCurryConsDecl :: (QName -> String) -> ConsDecl -> String
showCurryConsDecl tt (Cons cname _ _ argtypes) =
snd cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- generate function definitions:
showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> FuncDecl -> String
showCurryFuncDecl tt tf (Func fname _ _ ftype frule) =
showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++
showCurryRule tf fname frule
-- format rule as set of pattern matching rules:
showCurryRule :: (QName -> String) -> QName -> Rule -> String
showCurryRule _ fname (External _) = showCurryId (snd fname) ++ " external\n\n"
showCurryRule tf fname (Rule lhs rhs) =
concatMap (\ (l,r) -> showCurryPatternRule tf l r)
(rule2equations (shallowPattern2Expr fname lhs) rhs)
++ "\n"
splitFreeVars :: Expr -> ([Int],Expr)
splitFreeVars exp = case exp of
Free vars e -> (vars,e)
_ -> ([],exp)
showCurryPatternRule :: (QName -> String) -> Expr -> Expr -> String
showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
showCurryExpr tf False 0 l ++
showCurryCRHS tf e ++
(if vars==[] then "" else
" where " ++ intercalate "," (map showCurryVar vars) ++ " free")
++ "\n"
showCurryCRHS :: (QName -> String) -> Expr -> String
showCurryCRHS tf r = case r of
Comb _ ("Prelude","cond") [e1, e2] -> " | " ++ showCurryCondRule e1 e2
_ -> " = " ++ showCurryExpr tf False 2 r
where
showCurryCondRule e1 e2 = showCurryExpr tf False 2 e1 ++
" = " ++ showCurryExpr tf False 4 e2
-- transform a rule consisting of a left- and a right-hand side
-- (represented as expressions) into a set of pattern matching rules:
rule2equations :: Expr -> Expr -> [(Expr,Expr)]
rule2equations lhs rhs = case rhs of
Case Flex (Var i) bs -> caseIntoLhs lhs i bs
Or e1 e2 -> rule2equations lhs e1 ++ rule2equations lhs e2
_ -> [(lhs,rhs)]
caseIntoLhs :: Expr -> Int -> [BranchExpr] -> [(Expr,Expr)]
caseIntoLhs _ _ [] = []
caseIntoLhs lhs vi (Branch (Pattern c vs) e : bs) =
rule2equations (substitute [vi] [shallowPattern2Expr c vs] lhs) e
++ caseIntoLhs lhs vi bs
caseIntoLhs lhs vi (Branch (LPattern lit) e : bs) =
rule2equations (substitute [vi] [Lit lit] lhs) e
++ caseIntoLhs lhs vi bs
shallowPattern2Expr :: QName -> [Int] -> Expr
shallowPattern2Expr name vars =
Comb ConsCall name (map (\i->Var i) vars)
-- (substitute vars exps expr) = expr[vars/exps]
-- i.e., replace all occurrences of vars by corresponding exps in the
-- expression expr
substitute :: [Int] -> [Expr] -> Expr -> Expr
substitute vars exps expr = substituteAll vars exps 0 expr
-- (substituteAll vars exps base expr):
-- substitute all occurrences of variables by corresonding expressions:
-- * substitute all occurrences of var_i by exp_i in expr
-- (if vars=[var_1,...,var_n] and exps=[exp_1,...,exp_n])
-- * substitute all other variables (Var j) by (Var (base+j))
--
-- here we assume that the new variables in guards and case patterns
-- do not occur in the list "vars" of replaced variables!
substituteAll :: [Int] -> [Expr] -> Int -> Expr -> Expr
substituteAll vars exps b (Var i) = replaceVar vars exps i
where replaceVar [] _ var = Var (b + var)
replaceVar (_:_) [] var = Var (b + var)
replaceVar (v:vs) (e:es) var = if v == var then e
else replaceVar vs es var
substituteAll _ _ _ (Lit l) = Lit l
substituteAll vs es b (Comb combtype c exps) =
Comb combtype c (map (substituteAll vs es b) exps)
substituteAll vs es b (Let bindings exp) =
Let (map (\(x,e)->(x+b,substituteAll vs es b e)) bindings)
(substituteAll vs es b exp)
substituteAll vs es b (Free vars e) =
Free (map (+b) vars) (substituteAll vs es b e)
substituteAll vs es b (Or e1 e2) =
Or (substituteAll vs es b e1) (substituteAll vs es b e2)
substituteAll vs es b (Case ctype e 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 vs es b (Branch (Pattern l pvs) e) =
Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e)
substituteAllCase vs es b (Branch (LPattern l) e) =
Branch (LPattern l) (substituteAll vs es b e)
-------- Definition of some orderings:
leqOp :: OpDecl -> OpDecl -> Bool
leqOp (Op (_,op1) _ p1) (Op (_,op2) _ p2) = p1>p2 || p1==p2 && op1<=op2
leqType :: TypeDecl -> TypeDecl -> Bool
leqType t1 t2 = (tname t1) <= (tname t2)
where tname (Type (_,tn) _ _ _) = tn
tname (TypeSyn (_,tn) _ _ _) = tn
leqFunc :: FuncDecl -> FuncDecl -> Bool
leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2
---------------------------------------------------------------------------
-- Show individual functions:
showFuncDeclAsCurry :: FuncDecl -> String
showFuncDeclAsCurry fd =
showCurryFuncDecl (showQNameInModule (funcModule fd))
(showQNameInModule (funcModule fd)) fd
showFuncDeclAsFlatCurry :: FuncDecl -> String
showFuncDeclAsFlatCurry fd = pPrint (ppFuncDecl opts fd)
where opts = defaultOptions { currentModule = funcModule fd }
funcModule :: FuncDecl -> String
funcModule fd = fst (funcName fd)
......@@ -9,38 +9,38 @@
--- generated from a FlatCurry program.
---
--- @author Michael Hanus
--- @version April 2016
--- @version August 2016
------------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-}
import FilePath (takeFileName, (</>))
import Char (isAlpha)
import Directory (doesFileExist, getModificationTime)
import Distribution (stripCurrySuffix,modNameToPath
,lookupModuleSourceInLoadPath)
import FilePath (takeFileName, (</>))
import List (intercalate)
import Sort (mergeSortBy,leqString)
import System (getArgs,getEnviron,system)
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Show
import List
import Char(isAlpha)
import System(getArgs,getEnviron,system)
import Directory
import FileGoodies
import Sort(mergeSortBy,leqString)
import Distribution(stripCurrySuffix,modNameToPath
,lookupModuleSourceInLoadPath)
main :: IO ()
main = do
args <- getArgs
case args of
["-mod",mod] -> showCurryMod (stripCurrySuffix mod)
["-int",mod] -> showInterface (stripCurrySuffix mod)
["-mod",mod] -> printCurryMod (stripCurrySuffix mod)
["-int",mod] -> printInterface (stripCurrySuffix mod)
["-mod",mod,target] -> writeCurryMod target (stripCurrySuffix mod)
["-int",mod,target] -> writeInterface target (stripCurrySuffix mod)
_ -> putStrLn $ "ERROR: Illegal arguments for genint: " ++
intercalate " " args ++ "\n" ++
"Usage: [-mod|-int] module_name [targetfile]"
-- show interface on stdout:
showInterface :: String -> IO ()
showInterface progname =
-- print interface on stdout:
printInterface :: String -> IO ()
printInterface progname =
do intstring <- genInt False progname
putStrLn ("Interface of module \""++progname++"\":\n")
putStrLn intstring
......@@ -78,16 +78,21 @@ getFlatProg modname = do
-- If first argument is True, generate stubs (...external) for
-- all functions so that the resulting interface is a valid Curry program.
genInt :: Bool -> String -> IO String
genInt genstub progname = do
(Prog mod imports types funcs ops) <- getFlatInt progname
return $ "module " ++ mod ++ " where\n" ++
concatMap showInterfaceImport imports ++ "\n" ++
concatMap showInterfaceOpDecl (mergeSortBy leqOp ops) ++
(if null ops then "" else "\n") ++
concatMap (showInterfaceType (showQNameInModule mod))
(mergeSortBy leqType types) ++ "\n" ++
concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
(mergeSortBy leqFunc funcs) ++ "\n"
genInt genstub progname = getFlatInt progname >>= return . showInterface genstub
-- Shows an interface description for a program:
-- If first argument is True, generate stubs (...external) for
-- all functions so that the resulting interface is a valid Curry program.
showInterface :: Bool -> Prog -> String
showInterface genstub (Prog mod imports types funcs ops) =
"module " ++ mod ++ " where\n" ++
concatMap showInterfaceImport imports ++ "\n" ++
concatMap showInterfaceOpDecl (mergeSortBy leqOp ops) ++
(if null ops then "" else "\n") ++
concatMap (showInterfaceType (showQNameInModule mod))
(mergeSortBy leqType types) ++ "\n" ++
concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
(mergeSortBy leqFunc funcs) ++ "\n"
-- Get a FlatCurry program (parse only if necessary):
getFlatInt :: String -> IO Prog
......@@ -107,26 +112,32 @@ getFlatInt modname = do
else readFlatCurryFile fintprogname
-- write import declaration
showInterfaceImport :: String -> String
showInterfaceImport impmod = if impmod=="Prelude"
then ""
else "import "++impmod++"\n"
-- show operator declaration
showInterfaceOpDecl :: OpDecl -> String
showInterfaceOpDecl (Op op InfixOp prec) = "infix "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixlOp prec) = "infixl "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixrOp prec) = "infixr "++show prec++" "++showOp op++"\n"
showOp :: (_,String) -> String
showOp (_,on) = if isAlpha (head on) then '`':on++"`"
else on
-- show type declaration
-- show type declaration if it is not a dictionary
showInterfaceType :: (QName -> String) -> TypeDecl -> String
showInterfaceType tt (Type (_,tcons) vis tvars constrs) =
if vis==Public
if vis==Public && not (isDict tcons)
then "data " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)
++ "\n"
else ""
where
isDict fn = take 6 fn == "_Dict#"
constxt = intercalate " | "
(map (showExportConsDecl tt)
(filter (\ (Cons _ _ cvis _)->cvis==Public) constrs))
......@@ -136,23 +147,29 @@ showInterfaceType tt (TypeSyn (_,tcons) vis tvars texp) =
" = " ++ showCurryType tt True texp ++ "\n"
else ""
showExportConsDecl :: (QName -> String) -> ConsDecl -> String
showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- show function type declaration
-- show function type declaration if it is not an internal
-- operation to implement type classes
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> String
showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
if vis==Public
if vis==Public && not (classOperations fname)
then showCurryId fname ++ " :: " ++
showCurryType ttrans False ftype ++ "\n" ++
(if genstub then showCurryId fname ++ " external\n\n" else "")
else ""
where
classOperations fn = take 6 fn `elem` ["_impl#","_inst#"]
|| take 5 fn == "_def#" || take 7 fn == "_super#"
---------------------------------------------------------------------------
-- generate a human-readable representation of a Curry module:
-- show representation on stdout:
showCurryMod :: String -> IO ()
showCurryMod progname =
printCurryMod :: String -> IO ()
printCurryMod progname =
do modstring <- genCurryMod progname
putStrLn ("-- Program file: "++progname)
putStrLn modstring
......@@ -166,13 +183,14 @@ writeCurryMod targetfile progname =
modstring)
putStrLn ("Module written into file \""++targetfile++"\"")
-- generate a human-readable representation of a Curry module:
genCurryMod :: String -> IO String
genCurryMod progname = do
prog <- readFlatCurryFile (flatCurryFileName progname)
return $ showCurryProgram prog
return $ showCurryModule prog
showCurryProgram :: Prog -> String
showCurryProgram (Prog mod imports types funcs ops) =
showCurryModule :: Prog -> String
showCurryModule (Prog mod imports types funcs ops) =
"module "++mod++"("++showTypeExports types++
showFuncExports funcs++") where\n\n"++
concatMap showInterfaceImport imports ++ "\n" ++
......@@ -184,6 +202,7 @@ showCurryProgram (Prog mod imports types funcs ops) =
(showQNameInModule mod)) funcs
++ "\n-- end of module " ++ mod ++ "\n"
showTypeExports :: [TypeDecl] -> String
showTypeExports types = concatMap (++",") (concatMap exptype types)
where
exptype (Type tcons vis _ cdecls) =
......@@ -195,10 +214,12 @@ showTypeExports types = concatMap (++",") (concatMap exptype types)
expcons cds = "(" ++ intercalate "," (concatMap expc cds) ++ ")"
expc (Cons cname _ vis _) = if vis==Public then [snd cname] else []
showFuncExports :: [FuncDecl] -> String
showFuncExports funcs = intercalate "," (concatMap expfun funcs)
where
expfun (Func fname _ vis _ _) = if vis==Public then [snd fname] else []
showCurryDataDecl :: (QName -> String) -> TypeDecl -> String
showCurryDataDecl tt (Type tcons _ tvars constrs) =
"data " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)
......@@ -208,35 +229,31 @@ showCurryDataDecl tt (TypeSyn tcons _ tvars texp) =
"type " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
" = " ++ showCurryType tt True texp ++ "\n"
showCurryConsDecl :: (QName -> String) -> ConsDecl -> String
showCurryConsDecl tt (Cons cname _ _ argtypes) =
snd cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- generate function definitions:
showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> FuncDecl -> String
showCurryFuncDecl tt tf (Func fname _ _ ftype frule) =
showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++
showCurryRule tf fname frule
showCurryRule tf fname (External _) = showCurryId (tf fname) ++ " external\n\n"
showCurryRule tf fname (Rule lhs rhs) =
--showCurryRuleAsCase tf fname (Rule lhs rhs)
showCurryRuleAsPatterns tf fname (Rule lhs rhs)
-- format rule as case expression:
showCurryRuleAsCase tf fname (Rule lhs rhs) =
showCurryId (tf fname) ++ " " ++ intercalate " " (map showCurryVar lhs) ++
" = " ++ showCurryExpr tf False 0 rhs ++ "\n\n"
-- format rule as set of pattern matching rules:
showCurryRuleAsPatterns tf fname (Rule lhs rhs) =
showCurryRule :: (QName -> String) -> QName -> Rule -> String
showCurryRule _ fname (External _) = showCurryId (snd fname) ++ " external\n\n"
showCurryRule tf fname (Rule lhs rhs) =
concatMap (\ (l,r) -> showCurryPatternRule tf l r)
(rule2equations (shallowPattern2Expr fname lhs) rhs)
++ "\n"
splitFreeVars :: Expr -> ([Int],Expr)
splitFreeVars exp = case exp of
Free vars e -> (vars,e)
_ -> ([],exp)
showCurryPatternRule :: (QName -> String) -> Expr -> Expr -> String
showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
showCurryExpr tf False 0 l ++
showCurryCRHS tf e ++
......@@ -244,14 +261,13 @@ showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
" where " ++ intercalate "," (map showCurryVar vars) ++ " free")
++ "\n"
showCurryCRHS tf r =
if isGuardedExpr r
then " | " ++ showCurryCondRule r
else " = " ++ showCurryExpr tf False 2 r
showCurryCRHS :: (QName -> String) -> Expr -> String
showCurryCRHS tf r = case r of
Comb _ ("Prelude","cond") [e1, e2] -> " | " ++ showCurryCondRule e1 e2
_ -> " = " ++ showCurryExpr tf False 2 r