|
sourcecode:
|
module FlatCurry.ShowIntMod
( showInterface, showCurryModule, showCurryDataDecl, showCurryFuncDecl
, showFlatCurry, showFuncDeclAsCurry, showFuncDeclAsFlatCurry
, funcModule, leqFunc
) where
import Data.Char ( isAlpha )
import Data.List ( intercalate, sortBy )
import FlatCurry.Types
import FlatCurry.Goodies ( funcName )
import FlatCurry.Pretty ( Options (..), defaultOptions, ppProg, ppFuncDecl )
import FlatCurry.Show
import Text.Pretty ( pPrint )
------------------------------------------------------------------------------
-- 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) = unlines $
["module " ++ mod ++ " where\n"] ++
concatMap showInterfaceImport imports ++ [""] ++
map showInterfaceOpDecl (sortBy leqOp ops) ++
(if null ops then [] else [""]) ++
concatMap (showInterfaceType (showQNameInModule mod))
(sortBy leqType types) ++ [""] ++
concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
(sortBy leqFunc funcs)
-- write import declaration
showInterfaceImport :: String -> [String]
showInterfaceImport impmod | impmod == "Prelude" = []
| otherwise = ["import " ++ impmod]
-- show operator declaration
showInterfaceOpDecl :: OpDecl -> String
showInterfaceOpDecl (Op op InfixOp prec) = "infix " ++show prec++" "++showOp op
showInterfaceOpDecl (Op op InfixlOp prec) = "infixl "++show prec++" "++showOp op
showInterfaceOpDecl (Op op InfixrOp prec) = "infixr "++show prec++" "++showOp op
showOp :: (_,String) -> String
showOp (_,on) = if isAlpha (head on) then '`' : on ++ "`"
else on
-- show type declaration if it is not a dictionary
showInterfaceType :: (QName -> String) -> TypeDecl -> [String]
showInterfaceType tt (Type (_,tcons) vis tvars constrs) =
if vis==Public && not (isDict tcons)
then ["data " ++ tcons ++ concatMap (\(i,_) -> [' ', chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)]
else []
where
isDict fn = take 6 fn == "_Dict#"
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]
else []
showInterfaceType tt (TypeNew (_,tcons) vis tvars newconsdecl) =
if vis==Public
then ["newtype " ++ tcons ++
concatMap (\ (i,_) -> [' ', chr (97+i)]) tvars ++
" = " ++ showCurryNewConsDecl tt newconsdecl]
else []
showExportConsDecl :: (QName -> String) -> ConsDecl -> String
showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
cname ++ concatMap (\t -> " " ++ showCurryType tt True t) argtypes
-- 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 && not (classOperations fname)
then [showCurryId fname ++ " :: " ++
showCurryType ttrans False ftype ++
(if genstub then "\n" ++ showCurryId fname ++ " external\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:
showCurryModule :: Prog -> String
showCurryModule (Prog mod imports types funcs ops) = unlines $
["module " ++ mod ++ "(" ++ showTypeExports types ++
showFuncExports funcs ++ ") where\n"] ++
concatMap showInterfaceImport imports ++ [""] ++
map showInterfaceOpDecl ops ++
(if null ops then [] else [""]) ++
map (showCurryDataDecl (showQNameInModule mod)) types
++ [""] ++
map (showCurryFuncDecl (showQNameInModule mod)
(showQNameInModule mod)) funcs
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 []
exptype (TypeNew tcons vis _ (NewCons _ ncvis _)) =
if vis == Public
then [snd tcons ++ if ncvis == Public then "(..)" else ""]
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)
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
showCurryDataDecl tt (TypeNew tcons _ tvars newconsdecl) =
"newtype " ++ snd tcons ++ concatMap (\(i,_) -> [' ',chr (97+i)]) tvars ++
" = " ++ showCurryNewConsDecl tt newconsdecl
showCurryConsDecl :: (QName -> String) -> ConsDecl -> String
showCurryConsDecl tt (Cons cname _ _ argtypes) =
snd cname ++ concatMap (\t->" "++ showCurryType tt True t) argtypes
showCurryNewConsDecl :: (QName -> String) -> NewConsDecl -> String
showCurryNewConsDecl tt (NewCons cname _ texp) =
snd cname ++ " " ++ showCurryType tt True texp
-- 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"
showCurryRule tf fname (Rule lhs rhs) =
concatMap (\ (l,r) -> showCurryPatternRule tf l r)
(rule2equations (shallowPattern2Expr fname lhs) rhs)
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
tname (TypeNew (_,tn) _ _ _) = tn
leqFunc :: FuncDecl -> FuncDecl -> Bool
leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2
---------------------------------------------------------------------------
--- Show FlatCurry module in pretty-printed form
showFlatCurry :: Prog -> String
showFlatCurry = pPrint . ppProg defaultOptions
-- 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)
-----------------------------------------------------------------------------
|