|
sourcecode:
|
module FlatCurry.Annotated.Pretty where
import Prelude hiding ( empty )
import Text.Pretty
import FlatCurry.Annotated.Types
--- pretty-print a FlatCurry module
ppProg :: AProg _ -> Doc
ppProg (AProg m is ts fs os) = compose (<$+$>)
[ ppHeader m ts fs
, ppImports is
, ppOpDecls os
, ppTypeDecls ts
, ppFuncDecls fs
]
--- pretty-print the module header
ppHeader :: String -> [TypeDecl] -> [AFuncDecl _] -> Doc
ppHeader m ts fs = indent $
sep [text "module" <+> text m, ppExports ts fs, text "where"]
--- pretty-print the export list
ppExports :: [TypeDecl] -> [AFuncDecl _] -> Doc
ppExports ts fs = tupledSpaced (map ppTypeExport ts ++ ppFuncExports fs)
--- pretty-print a type export
ppTypeExport :: TypeDecl -> Doc
ppTypeExport (Type qn vis _ cs)
| vis == Private = empty
| all isPublicCons cs = ppPrefixOp qn <+> text "(..)"
| otherwise = ppPrefixOp qn <+> tupled (ppConsExports cs)
where isPublicCons (Cons _ _ v _) = v == Public
ppTypeExport (TypeSyn qn vis _ _ )
| vis == Private = empty
| otherwise = ppPrefixOp qn
ppTypeExport (TypeNew qn vis _ (NewCons _ vis' _))
| vis == Private || vis' == Private = empty
| otherwise = ppPrefixOp qn <+> text "(..)"
--- pretty-print the export list of constructors
ppConsExports :: [ConsDecl] -> [Doc]
ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs]
--- pretty-print the export list of functions
ppFuncExports :: [AFuncDecl _] -> [Doc]
ppFuncExports fs = [ ppPrefixOp qn | AFunc qn _ Public _ _ <- fs]
--- pretty-print a list of import statements
ppImports :: [String] -> Doc
ppImports = vsep . map ppImport
--- pretty-print a single import statement
ppImport :: String -> Doc
ppImport m = indent $ text "import" <+> text m
--- pretty-print a list of operator fixity declarations
ppOpDecls :: [OpDecl] -> Doc
ppOpDecls = vsep . map ppOpDecl
--- pretty-print a single operator fixity declaration
ppOpDecl :: OpDecl -> Doc
ppOpDecl (Op qn fix n) = indent $ ppFixity fix <+> int n <+> ppInfixOp qn
--- pretty-print the associativity keyword
ppFixity :: Fixity -> Doc
ppFixity InfixOp = text "infix"
ppFixity InfixlOp = text "infixl"
ppFixity InfixrOp = text "infixr"
--- pretty-print a list of type declarations
ppTypeDecls :: [TypeDecl] -> Doc
ppTypeDecls = compose (<$+$>) . map ppTypeDecl
--- pretty-print a type declaration
ppTypeDecl :: TypeDecl -> Doc
ppTypeDecl (Type qn _ vs cs) = indent $ text "data" <+> ppQName qn
<+> hsep (map (ppTVarIndex . fst) vs) <$$> ppConsDecls cs
ppTypeDecl (TypeSyn qn _ vs ty) = indent $ text "type" <+> ppQName qn
<+> hsep (map (ppTVarIndex . fst) vs) </> equals <+> ppTypeExp ty
ppTypeDecl (TypeNew qn _ vs c) = indent $ text "newtype" <+> ppQName qn
<+> hsep (empty : map (ppTVarIndex . fst) vs) $$ ppNewConsDecl c
--- pretty-print the constructor declarations
ppConsDecls :: [ConsDecl] -> Doc
ppConsDecls cs = vsep $
zipWith (<+>) (equals : repeat bar) (map ppConsDecl cs)
--- pretty print a single constructor
ppConsDecl :: ConsDecl -> Doc
ppConsDecl (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr 2) tys
--- pretty print a single newtype constructor
ppNewConsDecl :: NewConsDecl -> Doc
ppNewConsDecl (NewCons qn _ ty) = hsep [ppPrefixOp qn, ppTypeExpr 2 ty]
--- pretty a top-level type expression
ppTypeExp :: TypeExpr -> Doc
ppTypeExp = ppTypeExpr 0
--- pretty-print a type expression
ppTypeExpr :: Int -> TypeExpr -> Doc
ppTypeExpr _ (TVar v) = ppTVarIndex v
ppTypeExpr p (FuncType ty1 ty2) = parensIf (p > 0) $
ppTypeExpr 1 ty1 </> rarrow <+> ppTypeExp ty2
ppTypeExpr p (TCons qn tys)
| isListId qn && length tys == 1 = brackets (ppTypeExp (head tys))
| isTupleId qn = tupled (map ppTypeExp tys)
| otherwise = parensIf (p > 1 && not (null tys)) $ sep
(ppPrefixOp qn : map (ppTypeExpr 2) tys)
ppTypeExpr p (ForallType vs ty)
| null vs = ppTypeExpr p ty
| otherwise = parensIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty
--- pretty-print explicitly quantified type variables
ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc
ppQuantifiedVars vs
| null vs = empty
| otherwise = text "forall" <+> hsep (map (ppTVarIndex . fst) vs) <+> char '.'
--- pretty-print a type variable
ppTVarIndex :: TVarIndex -> Doc
ppTVarIndex i = text $ vars !! i
where vars = [ chr c : if n == 0 then [] else show n
| n <- [0 ..], c <- [ord 'a' .. ord 'z']
]
--- pretty-print a list of function declarations
ppFuncDecls :: [AFuncDecl _] -> Doc
ppFuncDecls = compose (<$+$>) . map ppFuncDecl
--- pretty-print a function declaration
ppFuncDecl :: AFuncDecl _ -> Doc
ppFuncDecl (AFunc qn _ _ ty r)
= indent (sep [ppPrefixOp qn, text "::", ppTypeExp ty])
<$$> indent (ppPrefixOp qn <+> ppRule r)
--- pretty-print a function rule
ppRule :: ARule _ -> Doc
ppRule (ARule _ vs e)
| null vs = equals <+> ppExp e
| otherwise = hsep (map ppAVarIndex vs) </> equals <+> ppExp e
ppRule (AExternal _ e) = text "external" <+> dquotes (text e)
--- pretty-print a top-level expression
ppExp :: AExpr _ -> Doc
ppExp = ppExpr 0
--- pretty-print an expression
ppExpr :: Int -> AExpr _ -> Doc
ppExpr _ (AVar _ v) = ppVarIndex v
ppExpr _ (ALit _ l) = ppLiteral l
ppExpr p (AComb _ _ qn es) = ppComb p qn es
ppExpr p (AFree _ vs e)
| null vs = ppExpr p e
| otherwise = parensIf (p > 0) $ sep
[ text "let"
<+> encloseSep empty empty comma
(map ppAVarIndex vs)
<+> text "free"
, text "in" </> ppExp e
]
ppExpr p (ALet _ ds e) = parensIf (p > 0) $ sep
[text "let" <+> ppDecls ds, text "in" <+> ppExp e]
ppExpr p (AOr _ e1 e2) = parensIf (p > 0)
$ ppExpr 1 e1 <+> text "?" <+> ppExpr 1 e2
ppExpr p (ACase _ ct e bs) = parensIf (p > 0) $ indent
$ ppCaseType ct <+> ppExpr 1 e <+> text "of"
<$$> vsep (map ppBranch bs)
ppExpr p (ATyped _ e ty) = parensIf (p > 0)
$ ppExp e <+> text "::" <+> ppTypeExp ty
--- pretty-print an annotated variable
ppAVarIndex :: (VarIndex, _) -> Doc
ppAVarIndex (i, _) | i < 0 = text $ 'x' : show (negate i)
| otherwise = text $ 'v' : show i
--- pretty-print a variable
ppVarIndex :: VarIndex -> Doc
ppVarIndex i | i < 0 = text $ 'x' : show (negate i)
| otherwise = text $ 'v' : show i
--- pretty-print a literal
ppLiteral :: Literal -> Doc
ppLiteral (Intc i) = int i
ppLiteral (Floatc f) = float f
ppLiteral (Charc c) = text (showEscape c)
--- Escape character literal
showEscape :: Char -> String
showEscape c
| o < 10 = "'\\00" ++ show o ++ "'"
| o < 32 = "'\\0" ++ show o ++ "'"
| o == 127 = "'\\127'"
| otherwise = show c
where o = ord c
--- Pretty print a constructor or function call
ppComb :: Int -> (QName, _) -> [AExpr _] -> Doc
ppComb p (qn, _) es | isListId qn && null es = text "[]"
| isTupleId qn = tupled (map ppExp es)
| otherwise = case es of
[] -> ppPrefixOp qn
[e1,e2]
| isInfixOp qn -> parensIf (p > 0)
$ sep [ppExpr 1 e1, ppInfixOp qn, ppExpr 1 e2]
_ -> parensIf (p > 0)
$ sep (ppPrefixOp qn : map (ppExpr 1) es)
--- pretty-print a list of declarations
ppDecls :: [((VarIndex, _), AExpr _)] -> Doc
ppDecls = semiBracesSpaced . map ppDecl
--- pretty-print a single declaration
ppDecl :: ((VarIndex, _), AExpr _) -> Doc
ppDecl (v, e) = ppAVarIndex v <+> equals <+> ppExp e
--- Pretty print the type of a case expression
ppCaseType :: CaseType -> Doc
ppCaseType Rigid = text "case"
ppCaseType Flex = text "fcase"
--- Pretty print a case branch
ppBranch :: ABranchExpr _ -> Doc
ppBranch (ABranch p e) = ppPattern p <+> rarrow <+> indent (ppExp e)
--- Pretty print a pattern
ppPattern :: APattern _ -> Doc
ppPattern (APattern _ (c, _) vs)
| isListId c && null vs = text "[]"
| isTupleId c = tupled (map ppAVarIndex vs)
| otherwise = case vs of
[v1,v2] | isInfixOp c -> ppAVarIndex v1 <+> ppInfixOp c <+> ppAVarIndex v2
_ -> hsep (ppPrefixOp c : map ppAVarIndex vs)
ppPattern (ALPattern _ l) = ppLiteral l
--- pretty-print a prefix operator
ppPrefixOp :: QName -> Doc
ppPrefixOp qn = parensIf (isInfixOp qn) (ppQName qn)
--- pretty-print an infix operator
ppInfixOp :: QName -> Doc
ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn)
--- Pretty-print a qualified name
ppQName :: QName -> Doc
ppQName (m, i)
| m == "Prelude" && i `elem` builtin = text i
| otherwise = text $ m ++ '.' : i
where builtin = [ "[]", "?", ":", "+", "-", "*", "<"
, ">", "<=", ">=", "==", "/=", "&>", "&" ]
--- Check whether an operator is an infix operator
isInfixOp :: QName -> Bool
isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd
--- Check whether an identifier represents a list
isListId :: QName -> Bool
isListId (m, i) = m `elem` ["Prelude", ""] && i == "[]"
--- Check whether an identifier represents a tuple
isTupleId :: QName -> Bool
isTupleId (m, i) = m `elem` ["Prelude", ""] && i == mkTuple (length i)
where mkTuple n = '(' : replicate (n - 2) ',' ++ ")"
--- Indentation
indent :: Doc -> Doc
indent = nest 2
|