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

tools adapted to typeclasses

parent 12bf8a2d
......@@ -229,4 +229,10 @@ startValue (CombinedDependencyTypeAnalysis _ _ _ startval _) = startval
--- in a module.
data AOutFormat = AText | ANote
instance Eq AOutFormat where
AText == AText = True
ANote == ANote = True
AText == ANote = False
ANote == AText = False
-------------------------------------------------------------------------
\ No newline at end of file
......@@ -115,7 +115,7 @@ updateCurrentProperty pn pv = do
currprops <- getProperties
writeGlobal currProps (Just (replaceKeyValue pn pv currprops))
replaceKeyValue :: a -> b -> [(a,b)] -> [(a,b)]
replaceKeyValue :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
replaceKeyValue k v [] = [(k,v)]
replaceKeyValue k v ((k1,v1):kvs) =
if k==k1 then (k,v):kvs else (k1,v1) : replaceKeyValue k v kvs
......
......@@ -78,7 +78,7 @@ showProgInfo (ProgInfo fm1 fm2) =
"Public: "++showFM fm1++"\nPrivate: "++showFM fm2
-- Equality on ProgInfo
equalProgInfo :: ProgInfo a -> ProgInfo a -> Bool
equalProgInfo :: Eq a => ProgInfo a -> ProgInfo a -> Bool
equalProgInfo (ProgInfo pi1p pi1v) (ProgInfo pi2p pi2v) =
eqFM pi1p pi2p && eqFM pi1v pi2v
......
......@@ -82,7 +82,7 @@ registeredAnalysis =
--- by the server/client analysis tool from a given analysis and
--- analysis show function. The first argument is a short title for the
--- analysis.
cassAnalysis :: String -> Analysis a -> (AOutFormat -> a -> String)
cassAnalysis :: Eq a => String -> Analysis a -> (AOutFormat -> a -> String)
-> RegisteredAnalysis
cassAnalysis title analysis showres =
RegAna (analysisName analysis)
......
......@@ -39,13 +39,13 @@ newProgInfoStoreRef = newIORef []
-----------------------------------------------------------------------
--- Analyze a list of modules (in the given order) with a given analysis.
--- The analysis results are stored in the corresponding analysis result files.
analysisClient :: Analysis a -> [String] -> IO ()
analysisClient :: Eq a => Analysis a -> [String] -> IO ()
analysisClient analysis modnames = do
store <- newIORef []
fpmethod <- getFPMethod
mapIO_ (analysisClientWithStore store analysis fpmethod) modnames
analysisClientWithStore :: IORef (ProgInfoStore a) -> Analysis a -> String
analysisClientWithStore :: Eq a => IORef (ProgInfoStore a) -> Analysis a -> String
-> String -> IO ()
analysisClientWithStore store analysis fpmethod moduleName = do
prog <- readNewestFlatCurry moduleName
......@@ -133,19 +133,19 @@ map2 f (xs,ys) = (map f xs, map f ys)
--- Update a given value list (second argument) w.r.t. new values given
--- in the first argument list.
updateList :: [(a,b)] -> [(a,b)] -> [(a,b)]
updateList :: Eq a => [(a,b)] -> [(a,b)] -> [(a,b)]
updateList [] oldList = oldList
updateList ((key,newValue):newList) oldList =
updateList newList (updateValue (key,newValue) oldList)
updateValue :: (a,b) -> [(a,b)] -> [(a,b)]
updateValue :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
updateValue _ [] = []
updateValue (key1,newValue) ((key2,value2):list) =
if key1==key2 then (key1,newValue):list
else (key2,value2):(updateValue (key1,newValue) list)
-----------------------------------------------------------------------
execCombinedAnalysis :: Analysis a -> Prog -> ProgInfo a -> [(QName,a)]
execCombinedAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)]
-> String -> String -> IO (ProgInfo a)
execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod =
case analysis of
......@@ -169,7 +169,7 @@ execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod =
-----------------------------------------------------------------------
--- Run an analysis but load default values (e.g., for external operations)
--- before and do not analyse the operations or type for these defaults.
runAnalysis :: Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
runAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
-> IO (ProgInfo a)
runAnalysis analysis prog importInfos startvals fpmethod = do
deflts <- loadDefaultAnalysisValues (analysisName analysis) (progName prog)
......@@ -201,7 +201,8 @@ runAnalysis analysis prog importInfos startvals fpmethod = do
--- Executes an anlysis on a given program w.r.t. an imported ProgInfo
--- and some start values (for dependency analysis).
--- The fixpoint iteration method to be applied is passed as the last argument.
executeAnalysis :: Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
executeAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)]
-> String
-> ProgInfo a
executeAnalysis (SimpleFuncAnalysis _ anaFunc) prog _ _ _ =
(lists2ProgInfo . map2 (\func -> (funcName func, anaFunc func))
......@@ -292,7 +293,7 @@ consDeclsOfType (TypeSyn _ _ _ _) = []
--- * ProgInfo for imported entities
--- * current ProgInfo
--- Result: fixpoint ProgInfo
simpleIteration :: (t -> [(QName,a)] -> a) -> (t -> QName)
simpleIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
-> ([(t,[QName])],[(t,[QName])])
-> ProgInfo a -> ProgInfo a -> ProgInfo a
simpleIteration analysis nameOf declsWithDeps importInfos currvals =
......@@ -313,7 +314,7 @@ simpleIteration analysis nameOf declsWithDeps importInfos currvals =
then currvals
else simpleIteration analysis nameOf declsWithDeps importInfos newproginfo
wlIteration :: (t -> [(QName,a)] -> a) -> (t -> QName)
wlIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
-> [(t,[QName])] -> [(t,[QName])] -> SetRBT QName
-> ProgInfo a -> FM QName a -> FM QName a
--wlIteration analysis nameOf declsToDo declsDone changedEntities
......
......@@ -22,7 +22,7 @@ clean_TOOLDIRS=$(addprefix clean_,$(TOOLDIRS))
uninstall_TOOLDIRS=$(addprefix uninstall_,$(TOOLDIRS))
.PHONY: all
all: genint # $(TOOLDIRS)
all: $(TOOLDIRS)
.PHONY: force
......
......@@ -162,7 +162,7 @@ tvars (CFuncType t1 t2) (CFuncType t1' t2')
--- give a list of variables names depending on whether they are singletons
--- or not
varNames :: Int -> [(_,CTypeExpr)] -> Success
varNames :: Eq a => Int -> [(a,CTypeExpr)] -> Success
varNames _ [] = success
varNames n ((i,v):ivs)
| null is = (v=:=(CTVar (0,"_"))) &> (varNames n others)
......
......@@ -30,6 +30,12 @@ showDemand fmt (x:xs) =
-- Abstract demand domain.
data DemandDomain = Bot | Top
instance Eq DemandDomain where
Bot == Bot = True
Top == Top = True
Bot == Top = False
Top == Bot = False
-- Least upper bound on abstract demand domain.
lub :: DemandDomain -> DemandDomain -> DemandDomain
lub Bot x = x
......
......@@ -60,6 +60,13 @@ showOverlap ANote False = ""
--- Data type to represent determinism information.
data Deterministic = NDet | Det
instance Eq Deterministic where
NDet == NDet = True
Det == Det = True
NDet == Det = False
Det == NDet = False
-- Show determinism information as a string.
showDet :: AOutFormat -> Deterministic -> String
showDet _ NDet = "nondeterministic"
......
......@@ -23,6 +23,11 @@ import GenericProgInfo
--- if i-th argument is non-ground (P [...,i,...]).
data Ground = G | A | P [Int]
instance Eq Ground where
G == x = case x of { G -> True ; _ -> False }
A == x = case x of { A -> True ; _ -> False }
P i == x = case x of { P j -> i==j ; _ -> False }
-- Show groundness information as a string.
showGround :: AOutFormat -> Ground -> String
showGround ANote G = "G"
......@@ -115,6 +120,9 @@ groundApply (P ps) gargs =
--- is non-ground (if i is a member of the third argument).
data NDEffect = NDEffect Bool Bool [Int]
instance Eq NDEffect where
NDEffect x1 y1 z1 == NDEffect x2 y2 z2 = x1==x2 && y1==y2 && z1==z2
noEffect :: NDEffect
noEffect = NDEffect False False []
......
......@@ -13,6 +13,12 @@ import GenericProgInfo
-- datatype order: higher-order or first-order
data Order = HO | FO
instance Eq Order where
HO == HO = True
FO == FO = True
HO == FO = False
FO == HO = False
-- Show higher-order information as a string.
showOrder :: AOutFormat -> Order -> String
showOrder _ HO = "higher-order"
......
......@@ -34,6 +34,12 @@ import Unsafe(trace)
-- `Empty` represents no possible value.
data AType = Any | AnyC | Cons QName | Empty
instance Eq AType where
_ == _ = error "TODO: Eq RequiredValue.AType"
instance Ord AType where
_ < _ = error "TODO: Ord RequiredValue.AType"
--- Is some abstract type a constructor?
isConsValue :: AType -> Bool
isConsValue av = case av of Cons _ -> True
......@@ -82,6 +88,9 @@ showAType _ Empty = "_|_"
--- or a list of possible argument/result type pairs.
data AFType = EmptyFunc | AFType [([AType],AType)]
instance Eq AFType where
_ == _ = error "TODO: Eq RequiredValue.AFType"
-- Shows an abstract value.
showAFType :: AOutFormat -> AFType -> String
showAFType _ EmptyFunc = "EmptyFunc"
......
......@@ -33,6 +33,12 @@ import Unsafe(trace)
-- `Cons cs` a value rooted by some of the constructor `cs`, and
data AType = Cons [QName] | AnyC | Any
instance Eq AType where
_ == _ = error "TODO: Eq RequiredValues.AType"
instance Ord AType where
_ < _ = error "TODO: Ord RequiredValues.AType"
--- Abstract representation of no possible value.
empty :: AType
empty = Cons []
......@@ -82,6 +88,9 @@ showAType _ (Cons cs) = "{" ++ intercalate "," (map snd cs) ++ "}"
--- or a list of possible argument/result type pairs.
data AFType = EmptyFunc | AFType [([AType],AType)]
instance Eq AFType where
_ == _ = error "TODO: Eq RequiredValues.AFType"
-- Shows an abstract value.
showAFType :: AOutFormat -> AFType -> String
showAFType _ EmptyFunc = "EmptyFunc"
......@@ -301,7 +310,7 @@ prelude = "Prelude"
-- Auxiliaries:
-- Union on sorted lists:
union :: [a] -> [a] -> [a]
union :: Ord a => [a] -> [a] -> [a]
union [] ys = ys
union xs@(_:_) [] = xs
union (x:xs) (y:ys) | x==y = x : union xs ys
......@@ -309,7 +318,7 @@ union (x:xs) (y:ys) | x==y = x : union xs ys
| otherwise = y : union (x:xs) ys
-- Intersection on sorted lists:
intersect :: [a] -> [a] -> [a]
intersect :: Ord a => [a] -> [a] -> [a]
intersect [] _ = []
intersect (_:_) [] = []
intersect (x:xs) (y:ys) | x==y = x : intersect xs ys
......
......@@ -48,6 +48,11 @@ data Completeness =
| InComplete -- incompletely defined
| InCompleteOr -- incompletely defined in each branch of an "Or"
instance Eq Completeness where
Complete == x = case x of { Complete -> True ; _ -> False }
InComplete == x = case x of { InComplete -> True ; _ -> False }
InCompleteOr == x = case x of { InCompleteOr -> True ; _ -> False }
--- A function is totally defined if it is pattern complete and depends
--- only on totally defined functions.
totalAnalysis :: Analysis Bool
......
......@@ -47,3 +47,6 @@ data ContentsKind =
| FlatCurryExp -- FlatCurry expression
| OtherText -- some other text
instance Eq ContentsKind where
_ == _ = error "TODO: Eq AnalysisTypes.ContentsKind"
......@@ -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(..))
......@@ -143,7 +143,7 @@ changeTrees n (Node t v subtrees : trees) =
return (Node t v nsts : trees)
else changeTrees (n-l) trees >>= \nts -> return (Node t v subtrees : nts)
openNode :: (a, [(a, [String])]) -> IO [Tree (String, [(a, [String])])]
openNode :: Eq a => (a, [(a, [String])]) -> IO [Tree (String, [(a, [String])])]
openNode (mod,modimps) = let mbimps = lookup mod modimps in
return $ maybe [] (map (\m->Leaf m (m,modimps))) mbimps
......@@ -627,7 +627,7 @@ browserGUI gstate rmod rtxt names =
self <- getValue rfun gp
fana <- getCurrentFunctionAnalysis gstate
funs <- getFuns gstate
if mod==Nothing || null self || fana==Nothing then done else do
if isNothing mod || null self || isNothing fana then done else do
result <- performAnalysis (fromJust fana) (showDoing gp)
(funs!!readNat self)
showAnalysisResult result gp
......@@ -762,7 +762,7 @@ findFunDeclInProgText FlatCurryExp progtext fname =
findFunDeclInProgText OtherText _ _ = 0
-- finds first declaration line:
findFirstDeclLine :: [a] -> [[a]] -> Int -> Int
findFirstDeclLine :: Eq a => [a] -> [[a]] -> Int -> Int
findFirstDeclLine _ [] _ = 0 -- not found
findFirstDeclLine f (l:ls) n =
if isPrefixOf f l then n else findFirstDeclLine f ls (n+1)
......
......@@ -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)