{-# OPTIONS -fglasgow-exts #-} -- uses pattern guards to recognize strings and lists ------------------------------------------------------------------------------ --- A pretty printer for AbstractHaskell, adapted from AbstractCurryPrinter --- --- This library defines a function "showProg" that shows --- an AbstractCurry program in standard Curry syntax. --- --- @author Martin Engelke, Bernd Brassel, Michael Hanus, Sebastian Fischer --- @version May 2007 -- in November 2004: -- - added filter for type variables (to print as var0, like in Prelude) -- - prettyprint list patterns -- in July 2005: -- - added options to most functions -- - print qualified symbol when necessary (local functions missing) -- in May 2007: -- - prettier representation of Curry and Haskell Strings ------------------------------------------------------------------------------ module ShowFunctionalProg(showProg,showProgOpt, showTypeDecls, showTypeDecl, showTypeExpr, showFuncDecl, showExpr,showPattern, isInfixOpName,isTuple) where import Curry.ExtendedFlat.Type(QName(..), qnOf) import FunctionalProg import Data.List import Data.Char(ord) import Monad (ap) import Brace ------------------------------------------------------------------------------- -- Functions to print an AbstractCurry program in standard Curry syntax ------------------------------------------------------------------------------- data Options = PrintOpt { unqual :: Bool, sep :: String} defaultOptions :: Options defaultOptions = PrintOpt False "" --- Shows an AbstractCurry program in standard Curry syntax. showProg :: Prog -> String showProg = showProgOpt (unqual defaultOptions) showProgOpt :: Bool -> Prog -> String showProgOpt uq (Prog m imps exps typedecls insdecls funcdecls opdecls) = "module "++m++showExports m exps ++" where\n\n" ++ showImports imps ++ showOpDecls opdecls ++ showTypeDecls opts typedecls ++ showInsDecls opts insdecls ++ separate "\n\n" (map (showFuncDeclOpt opts) funcdecls) ++ "\n" where opts = defaultOptions{unqual=uq} ----------------------------------------- -- export declaration ----------------------------------------- showExports :: String -> [String] -> String showExports m exps = brace " (" ")" ", " (("module "++m):exps) ----------------------------------------- -- import declaration ----------------------------------------- showImports :: [String] -> String showImports imps = brace "" "\n\n" "\n" (map ("import "++) imps) ----------------------------------------- -- infix operators ----------------------------------------- showOpDecls :: [OpDecl] -> String showOpDecls opdecls = brace "" "\n\n" "\n" (map showOpDecl opdecls) showOpDecl :: OpDecl -> String showOpDecl (Op qn fixity precedence) = separate " " [showFixity fixity, show precedence, '`':showIdentifier (localName qn) ++"`"] showFixity :: Fixity -> String showFixity InfixOp = "infix" showFixity InfixlOp = "infixl" showFixity InfixrOp = "infixr" -------------------------------------------------- -- type declarations, instances, type classes -------------------------------------------------- --- Shows a list of AbstractCurry type declarations in standard Curry syntax. showTypeDecls :: Options -> [TypeDecl] -> String showTypeDecls opts typedecls = brace "" "\n\n" "\n\n" (map (showTypeDecl opts) typedecls) --- Shows an AbstractCurry type declaration in standard Curry syntax. showTypeDecl :: Options -> TypeDecl -> String showTypeDecl opts t = decl ++ showIdentifier (localName (typeName t)) ++ brace " " "" " " (map (showTypeExpr opts False . TVar) (typeVars t)) ++ " = "++ (case t of TypeSyn{typeExpr=e} -> showTypeExpr opts False e Type{consDecls=cs} -> separate "\n | " (map (showConsDecl opts) cs) ++ brace "\n deriving (" ")" "," (derive t)) where decl = case t of {TypeSyn{} -> "type "; Type{} -> "data "} showConsDecl :: Options -> ConsDecl -> String showConsDecl opts c = separate (if strictArgs c then " !" else " ") (showIdentifier (localName (consName c)) : map (showTypeExpr opts True) (consArgs c)) showInsDecls :: Options -> [InstanceDecl] -> String showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is) showInsDecl :: Options -> InstanceDecl -> String showInsDecl opts (Instance tcs tc fs) = "instance " ++ showTypeConstr opts tcs ++ showTypeClass opts tc ++ brace " where\n " "\n\n" " " (map (showFuncDeclOpt (opts{sep=" "})) fs) showTypeConstr :: Options -> [TypeClass] -> String showTypeConstr opts tcs = brace "(" ") => " "," (map (showTypeClass opts) tcs) showTypeClass :: Options -> TypeClass -> String showTypeClass opts (TypeClass qn ts) = localName qn ++ brace " " "" " " (map (showTypeExpr opts True) ts) --- Shows an AbstractCurry type expression in standard Curry syntax. --- If the first argument is True, the type expression is enclosed --- in brackets. showTypeExpr :: Options -> Bool -> TypeExpr -> String showTypeExpr _ _ (TVar name) = showIdentifier name showTypeExpr opts nested (FuncType domain range) = (if nested then brace "(" ")" else separate) " -> " [showTypeExpr opts (case domain of {FuncType _ _ -> False; _ -> True}) domain, showTypeExpr opts False range] showTypeExpr opts nested (TCons qn typelist) = (if nested && not (null typelist) then brace "(" ")" else separate) "" [showTypeCons opts qn typelist] showTypeExpr opts nested (TConstr tcs t) = (if nested then brace "(" ")" else separate) "" [showTypeConstr opts tcs ++ showTypeExpr opts False t] showTypeCons :: Options -> QName -> [TypeExpr] -> String showTypeCons opts qn ts = showSymbol opts qn ++ brace " " "" " " (map (showTypeExpr opts True) ts) ------------------------------------------ -- function declarations ------------------------------------------ --- Shows an AbstractCurry function declaration in standard Curry syntax. showFuncDecl :: FuncDecl -> String showFuncDecl = showFuncDeclOpt defaultOptions showFuncDeclOpt :: Options -> FuncDecl -> String showFuncDeclOpt opts f = maybe "" (\t->fname ++" :: "++ (showTypeExpr opts False t) ++ "\n") (funcType f) ++ maybe (fname ++ " external") (brace (fname++" ") "\n\n" ("\n"++sep opts++fname++" ") . map (showRule opts)) (funcBody f) where fname = showIdentifier (localName (funcName f)) showRule :: Options -> Rule -> String showRule opts (Rule ps r ls) = separate " " (map (showPatternOpt opts) ps) ++ showRhs opts r ++ brace "\n where\n " "" "\n " (map (showLocalDecl opts) ls) showRhs :: Options -> Rhs -> String showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e showRhs opts (GuardedExpr gs) = brace "\n " "" "\n " (map (showGuard opts) gs) showGuard :: Options -> (Expr,Expr) -> String showGuard opts (g,r) = " | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r showLocalDecl :: Options -> LocalDecl -> String showLocalDecl opts (LocalFunc funcdecl) = showFuncDeclOpt (opts{sep=" "}) funcdecl showLocalDecl opts (LocalPat pattern expr ls) = showPatternOpt opts pattern ++ " = " ++ showExprOpt opts expr ++ brace "\n where\n " "" "\n " (map (showLocalDecl opts) ls) --------------------------------------- -- symbols, expresssions, identifiers --------------------------------------- -- Remove characters '<' and '>' from identifiers sind these characters -- are sometimes introduced in new identifiers generated by the front end (for sections) -- also eliminate non standard characters. showIdentifier :: String -> String showIdentifier "[]" = "[]" showIdentifier "_" = "_" showIdentifier name | isInfixOpName name = "("++name++")" | isTuple name = name | otherwise = let newName = normChars name in if head newName=='\'' then "c_"++newName else newName where normChars :: String -> String normChars [] = [] normChars (c@'_':cs) = c:normChars cs normChars (c:cs) | (co >= na && co <= nz) = c:normChars cs | (co >= nA && co <= nZ) = c:normChars cs | (co >= n0 && co <= n9) = c:normChars cs | otherwise = '\'':show co++normChars cs where co = ord c na = 97 nz = 122 nA = 65 nZ = 90 n0 = 48 n9 = 57 --- Shows an AbstractCurry expression in standard Curry syntax. showExpr :: Expr -> String showExpr = showExprOpt defaultOptions showExprOpt :: Options -> Expr -> String showExprOpt _ (Var name) = showIdentifier name showExprOpt _ (Lit lit) = showLiteral lit showExprOpt opts (Symbol name) = showSymbol opts name showExprOpt opts e@(Apply func arg) | Just cs <- expAsCurryString e = fromCurryString cs | Just cl <- expAsCurryList e = fromCurryList cl | Just hs <- expAsHaskellString e = fromHaskellString hs | Just hl <- expAsHaskellList e = fromHaskellList hl | otherwise = showExprOpt opts func ++ brace "(" ")" "" [showExprOpt opts arg] where -- string or list is non-empty (the empty string is parsed as empty list) fromCurryString s = "(fromHaskellString " ++ show s++ ")" fromCurryList es = "(fromHaskellList [" ++ concat (intersperse "," (map (showExprOpt opts) es)) ++ "])" fromHaskellString :: String -> String fromHaskellString s = show s -- quotation marks and quoted special chars fromHaskellList es = "[" ++ concat (intersperse "," (map (showExprOpt opts) es)) ++ "]" showExprOpt opts (Lambda patts expr) = showLambda opts patts expr showExprOpt opts (LetDecl localdecls expr) = brace "let {" "} in " "; " (map (showLocalDecl opts) localdecls) ++ showExprOpt opts expr showExprOpt opts (DoExpr stmts) = brace "do\n " "\n " "\n " (map (showStatement opts) stmts) showExprOpt opts (ListComp expr stmts) = brace "[" "]" " | " [showExprOpt opts expr,separate ", " (map (showStatement opts) stmts)] showExprOpt opts (Case expr branches) = brace ("case " ++ showExprOpt opts expr ++ " of\n") "\n" "\n " (map (showBranchExpr opts) branches) showExprOpt _ (String s) = '"':s++"\"" --" showSymbol :: Options -> QName -> String showSymbol _ qn | modName qn == "" = showIdentifier (localName qn) showSymbol opts qn | isInfixOpName (localName qn) = brace "(" ")" "" [modName qn ++ "." ++ localName qn] | not (unqual opts) || "External" `isPrefixOf` modName qn = modName qn++"."++showIdentifier (localName qn) | otherwise = showIdentifier (localName qn) showLambda :: Options -> [Pattern] -> Expr -> String showLambda opts patts expr = brace "\\ " " -> " " " (map (showPatternOpt opts) patts) ++ showExprOpt opts expr showStatement :: Options -> Statement -> String showStatement opts (SExpr expr) = showExprOpt opts expr showStatement opts (SPat pattern expr) = showPatternOpt opts pattern ++ " <- " ++ showExprOpt opts expr showStatement opts (SLet localdecls) = brace "let " " in \n " "\n " (map (showLocalDecl opts) localdecls) -- try to transform expression into a non-empty Curry string expAsCurryString :: Expr -> Maybe String expAsCurryString (Symbol qn) | qnOf qn == ("CurryPrelude","List") = Just "" expAsCurryString (Apply (Apply (Symbol qn1) (Apply (Symbol qn2) (Lit (Charc c)))) cs) | qnOf qn1 == ("CurryPrelude",":<") && qnOf qn2 == ("CurryPrelude","C_Char") = Just (c:) `ap` expAsCurryString cs expAsCurryString _ = Nothing -- try to transform expression into a Curry list expAsCurryList :: Expr -> Maybe [Expr] expAsCurryList (Symbol qn) | qnOf qn == ("CurryPrelude","List") = Just [] expAsCurryList (Apply (Apply (Symbol qn) x) xs) | qnOf qn == ("CurryPrelude",":<") = Just (x:) `ap` expAsCurryList xs expAsCurryList _ = Nothing -- try to transform expression into a non-empty Haskell string expAsHaskellString :: Expr -> Maybe String expAsHaskellString (Symbol qn) | qnOf qn == ("","[]") = Just "" expAsHaskellString (Apply (Apply (Symbol qn) (Lit (Charc c))) cs) | qnOf qn == ("",":") = Just (c:) `ap` expAsHaskellString cs expAsHaskellString _ = Nothing -- try to transform expression into a Haskell list expAsHaskellList :: Expr -> Maybe [Expr] expAsHaskellList (Symbol qn) | qnOf qn == ("","[]") = Just [] expAsHaskellList (Apply (Apply (Symbol qn) x) xs) | qnOf qn == ("",":") = Just (x:) `ap` expAsHaskellList xs expAsHaskellList _ = Nothing ------------------------------------------------------- -- patterns ------------------------------------------------------- showPattern :: Pattern -> String showPattern = showPatternOpt defaultOptions showPatternOpt :: Options -> Pattern -> String showPatternOpt _ (PVar name) = showIdentifier name showPatternOpt _ (PLit lit) = showLiteral lit showPatternOpt opts (PComb name []) = showSymbol opts name showPatternOpt opts (PComb sym ps) = brace "(" ")" " " (showSymbol opts sym:map (showPatternOpt opts) ps) showPatternOpt opts (AsPat v p) = showPatternOpt opts (PVar v)++"@"++showPatternOpt opts p showBranchExpr :: Options -> BranchExpr -> String showBranchExpr opts (Branch pattern expr) = showPatternOpt opts pattern ++ " -> " ++ showExprOpt opts expr showLiteral :: Literal -> String showLiteral (HasIntc i) = '(':show i++"::Int)" showLiteral (Intc i) = '(':show i++"::C_Int)" showLiteral (Floatc f) = '(':show f++"::Float)" showLiteral (Charc c) = "'"++showCharc c++"'" showCharc :: Char -> String showCharc c = case c of '\n' -> "\\n" '\t' -> "\\t" '\r' -> "\\r" '\\' -> "\\\\" '\"' -> "\\\"" '\'' -> "\\'" _ -> [c] ------------------------------------------------------------------------------- --- tests for various properties of AbstractCurry constructs ------------------------------------------------------------------------------- isInfixOpName :: String -> Bool isInfixOpName = all (`elem` infixIDs) isTuple :: String -> Bool isTuple "" = False isTuple (c:cs) = c=='(' && dropWhile (==',') cs == ")" ------------------------------------------------------------------------------ --- constants used by AbstractCurryPrinter ------------------------------------------------------------------------------ infixIDs :: String infixIDs = "~!@#$%^&*+-=<>?./|\\:"