KiCS-0.8.4: src/ShowFunctionalProg.hs

{-# 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 <var0> 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 =  "~!@#$%^&*+-=<>?./|\\:"