------------------------------------------------------------------------------ --- Some tools to support meta-programming in Curry based on FlatCurry. --- --- This library contains --- --- --- Note that the previously contained function "writeFLC" --- is no longer supported. Use Flat2Fcy.writeFCY instead --- and change file suffix into ".efc"! --- --- @author Michael Hanus --- @version August 2005 -- modified to support new ExtendedFlat format in August 2009 (Holger Siegel) ------------------------------------------------------------------------------ module ShowFlatCurry(showFlatProg,showFlatType,showFlatFunc, showCurryType,showCurryExpr,showCurryId,showCurryVar) where import List import Char import Brace import Curry.ExtendedFlat.Type --- Shows a FlatCurry program term as a string (with some pretty printing). showFlatProg :: Prog -> String showFlatProg (Prog modname imports types funcs ops) = "module " ++show modname++" where" ++ concatMap ("\nimport "++) imports ++ concatMap showFlatType types ++ concatMap showFlatFunc funcs showFlatVisibility :: Visibility -> [Char] showFlatVisibility Public = " Public " showFlatVisibility Private = " Private " showFlatFixity InfixOp = " InfixOp " showFlatFixity InfixlOp = " InfixlOp " showFlatFixity InfixrOp = " InfixrOp " showFlatOp :: OpDecl -> [Char] showFlatOp (Op name fix prec) = "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" showFlatType :: TypeDecl -> String showFlatType (Type qn _ tpars []) = "\ndata " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " external" showFlatType (Type qn _ tpars consdecls) = "\ndata " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " = " ++ separate " | " (map showCurryCons consdecls) showFlatType (TypeSyn qn _ tpars texp) = "\ntype " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " = " ++ showCurryType localName False texp showCurryCons :: ConsDecl -> [Char] showCurryCons (Cons qn _ _ types) = localName qn ++ brace " " "" " " (map (showCurryType localName True) types) showFlatFunc :: FuncDecl -> String showFlatFunc (Func qn _ _ ftype _) = '\n':localName qn++" :: "++showCurryType localName False ftype showFlatRule :: Rule -> [Char] showFlatRule (Rule params expr) = " (Rule " ++ showFlatList show params ++ showFlatExpr expr ++ ")" showFlatRule (External name) = " (External " ++ show name ++ ")" showFlatTypeExpr :: TypeExpr -> String showFlatTypeExpr (FuncType t1 t2) = "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")" showFlatTypeExpr (TCons tc ts) = "(TCons " ++ show tc ++ showFlatList showFlatTypeExpr ts ++ ")" showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")" showFlatCombType :: CombType -> String showFlatCombType FuncCall = "FuncCall" showFlatCombType ConsCall = "ConsCall" showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" showFlatExpr :: Expr -> String showFlatExpr (Var n) = "(Var " ++ show n ++ ")" showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")" showFlatExpr (Comb ctype cf es) = "(Comb " ++ showFlatCombType ctype ++ " " ++ show cf ++ showFlatList showFlatExpr es ++ ")" showFlatExpr (Let bindings exp) = "(Let " ++ showFlatList showFlatBinding bindings ++ showFlatExpr exp ++ ")" where showFlatBinding (x,e) = "("++show x++","++showFlatExpr e++")" showFlatExpr (Free xs e) = "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")" showFlatExpr (Or e1 e2) = "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")" showFlatExpr (Case _ Rigid e bs) = "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Case _ Flex e bs) = "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatLit :: Literal -> String showFlatLit (Intc _ i) = "(Intc " ++ show i ++ ")" showFlatLit (Floatc _ f) = "(Floatc " ++ show f ++ ")" showFlatLit (Charc _ c) = if ord c >= 32 && ord c < 127 then "(Charc '" ++ [c] ++ "')" else "(Charc (chr " ++ show (ord c) ++ "))" showFlatBranch :: BranchExpr -> String showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p ++ showFlatExpr e ++ ")" showFlatPattern :: Pattern -> String showFlatPattern (Pattern qn xs) = "(Pattern " ++ show qn ++ showFlatList show xs ++ ")" showFlatPattern (LPattern lit) = "(LPattern " ++ showFlatLit lit ++ ")" -- format a finite list of elements: showFlatList :: (a->String) -> [a] -> String showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] " showFlatListElems :: (a->String) -> [a] -> String showFlatListElems format elems = concat (intersperse "," (map format elems)) ------------------------------------------------------------------------------ --- Shows a FlatCurry type in Curry syntax. --- --- @param trans - a translation function from qualified type names --- to external type names --- @param nested - True iff brackets must be written around complex types --- @param texpr - the FlatCurry type expression to be formatted --- @return the String representation of the formatted type expression showTypeVar :: Int -> String showTypeVar i = if i<27 then [chr (97+i)] else 't':show i showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String showCurryType _ _ (TVar i) = showTypeVar i showCurryType tf nested (FuncType t1 t2) = showBracketsIf nested (showCurryType tf (isFuncType t1) t1 ++ " -> " ++ showCurryType tf False t2) showCurryType tf nested (TCons tc ts) | ts==[] = tf tc | qnOf tc==("Prelude","[]") = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type | "(," `isPrefixOf` localName tc -- tuple type = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")" | otherwise = showBracketsIf nested (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts) isFuncType :: TypeExpr -> Bool isFuncType (TVar _) = False isFuncType (FuncType _ _) = True isFuncType (TCons _ _) = False ------------------------------------------------------------------------------ --- Shows a FlatCurry expressions in (almost) Curry syntax. --- --- @param trans - a translation function from qualified functions names --- to external function names --- @param nested - True iff brackets must be written around complex terms --- @param indent - the indentation used in case expressions and if-then-else --- @param expr - the FlatCurry expression to be formatted --- @return the String representation of the formatted expression showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String showCurryExpr _ _ _ (Var n) = showCurryVar n showCurryExpr _ _ _ (Lit l) = showCurryLit l showCurryExpr tf _ _ (Comb _ cf []) = showCurryId (tf cf) showCurryExpr tf nested b (Comb _ cf [e]) = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryExpr tf True b e) showCurryExpr tf nested b (Comb ct cf [e1,e2]) | qnOf cf==("Prelude","apply") = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) | isAlpha (head (localName cf)) = showBracketsIf nested (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2]) | isFiniteList (Comb ct cf [e1,e2]) = if isStringConstant (Comb ct cf [e1,e2]) then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\"" else "[" ++ concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2]))) ++ "]" | localName cf == "(,)" -- pair constructor? = "(" ++ showCurryExpr tf False b e1 ++ "," ++ showCurryExpr tf False b e2 ++ ")" | otherwise = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++ showCurryExpr tf True b e2 ) showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es)) | qnOf cf==("Prelude","if_then_else") && es==[] = showBracketsIf nested ("\n" ++ sceBlanks b ++ " if " ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++ sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++ sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3) | "(," `isPrefixOf` localName cf -- tuple constructor? = "(" ++ concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es))) ++ ")" | otherwise = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es)) showCurryExpr tf nested b (Let bindings expr) = showBracketsIf nested ("\n"++sceBlanks b++"let " ++ concat (intersperse ("\n "++sceBlanks b) (map (\ (x,e)->showCurryVar x ++" = "++showCurryExpr tf False (b+4) e) bindings)) ++ ("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) expr) showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e showCurryExpr tf nested b (Free (x:xs) e) = showBracketsIf nested ("let " ++ concat (intersperse "," (map showCurryVar (x:xs))) ++ " free in " ++ showCurryExpr tf False b e) showCurryExpr tf nested b (Or e1 e2) = showBracketsIf nested (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2) showCurryExpr tf nested b (Case _ ctype e cs) = showBracketsIf nested ((if ctype==Rigid then "case " else "fcase ") ++ showCurryExpr tf True b e ++ " of\n " ++ showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b) showCurryVar :: VarIndex -> String showCurryVar i = "v" ++ show (idxOf i) --- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. showCurryId :: String -> String showCurryId name | isAlpha (head name) = name | name == "[]" = name | otherwise = ('(':name)++")" showCurryLit :: Literal -> String showCurryLit (Intc _ i) = show i showCurryLit (Floatc _ f) = show f showCurryLit (Charc _ c) = show c showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String showCurryCase tf b (Branch (Pattern l vs) e) = sceBlanks b ++ showPattern (tf l) vs ++ " -> " ++ showCurryExpr tf False b e ++ "\n" where showPattern c [] = c showPattern c [x] = c ++ " " ++ showCurryVar x showPattern c [x1,x2] = if isAlpha (head c) then c ++ " " ++ showCurryVar x1 ++ " " ++ showCurryVar x2 else if c=="(,)" -- pair constructor? then "(" ++ showCurryVar x1 ++ "," ++ showCurryVar x2 ++ ")" else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2 showPattern c (x1:x2:x3:xs) = if take 2 c == "(," -- tuple constructor? then "("++ concat (intersperse "," (map showCurryVar (x1:x2:x3:xs))) ++")" else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs) showCurryCase tf b (Branch (LPattern l) e) = sceBlanks b ++ showCurryLit l ++ " " ++ " -> " ++ showCurryExpr tf False b e ++ "\n" showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String] showCurryFiniteList _ _ (Comb _ qn []) | qnOf qn == ("Prelude","[]") = [] showCurryFiniteList tf b (Comb _ qn [e1,e2]) | qnOf qn == ("Prelude",":") = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 -- show a string constant showCurryStringConstant :: Expr -> String showCurryStringConstant (Comb _ qn []) | qnOf qn == ("Prelude","[]") = [] showCurryStringConstant (Comb _ qn [e1,e2]) | qnOf qn == ("Prelude",":") = showCharExpr e1 ++ showCurryStringConstant e2 -- FIXME Pattern match(es) are non-exhaustive showCharExpr :: Expr -> String showCharExpr (Lit (Charc _ c)) | c=='"' = "\\\"" | c=='\'' = "\\\'" | c=='\n' = "\\n" | o < 32 || o > 126 = ['\\',chr(o `div` 100 + 48), chr(((o `mod` 100) `div` 10 + 48)),chr(o `mod` 10 + 48)] | otherwise = [c] where o = ord c showCurryElems :: (a->String) -> [a] -> String showCurryElems format elems = concat (intersperse " " (map format elems)) showBracketsIf :: Bool -> String -> String showBracketsIf True s ='(' : s ++ ")" showBracketsIf False s = s sceBlanks :: Int -> String sceBlanks b = take b (repeat ' ') -- Is the expression a finite list (with an empty list at the end)? isFiniteList :: Expr -> Bool isFiniteList (Var _) = False isFiniteList (Lit _) = False isFiniteList (Comb _ name args) | qnOf name==("Prelude","[]") && args==[] = True | qnOf name==("Prelude",":") && length args == 2 = isFiniteList (args!!1) | otherwise = False isFiniteList (Let _ _) = False isFiniteList (Free _ _) = False isFiniteList (Or _ _) = False isFiniteList (Case _ _ _ _) = False -- Is the expression a string constant? isStringConstant :: Expr -> Bool isStringConstant e = case e of Comb _ name args -> (qnOf name==("Prelude","[]") && null args) || (qnOf name==("Prelude",":") && length args == 2 && isCharConstant (head args) && isStringConstant (args!!1)) _ -> False -- Is the expression a character constant? isCharConstant :: Expr -> Bool isCharConstant e = case e of Lit (Charc _ _) -> True _ -> False ------------------------------------------------------------------------------