module Curry.Syntax.Pretty
( ppModule, ppInterface, ppIDecl, ppDecl, ppIdent, ppPattern, ppFieldPatt
, ppExpr, ppOp, ppStmt, ppFieldExpr, ppQualTypeExpr, ppTypeExpr, ppKindExpr
, ppAlt, ppQIdent, ppConstraint, ppInstanceType, ppConstr, ppNewConstr
, ppFieldDecl, ppEquation, ppMIdent
) where
import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Syntax.Type
import Curry.Syntax.Utils (opName)
ppModule :: Module a -> Doc
ppModule (Module ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds
ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec
-> [ImportDecl] -> Doc
ppModuleHeader ps m es is
| null is = header
| otherwise = header $+$ text "" $+$ (vcat $ map ppImportDecl is)
where header = (vcat $ map ppModulePragma ps)
$+$ text "module" <+> ppMIdent m
<+> maybePP ppExportSpec es <+> text "where"
ppModulePragma :: ModulePragma -> Doc
ppModulePragma (LanguagePragma _ exts) =
ppPragma "LANGUAGE" $ list $ map ppExtension exts
ppModulePragma (OptionsPragma _ tool args) =
ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . ppTool) tool <+> text args
ppPragma :: String -> Doc -> Doc
ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}"
ppExtension :: Extension -> Doc
ppExtension (KnownExtension _ e) = text (show e)
ppExtension (UnknownExtension _ e) = text e
ppTool :: Tool -> Doc
ppTool (UnknownTool t) = text t
ppTool t = text (show t)
ppExportSpec :: ExportSpec -> Doc
ppExportSpec (Exporting _ es) = parenList (map ppExport es)
ppExport :: Export -> Doc
ppExport (Export x) = ppQIdent x
ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)
ppExport (ExportTypeAll tc) = ppQIdent tc <> text "(..)"
ppExport (ExportModule m) = text "module" <+> ppMIdent m
ppImportDecl :: ImportDecl -> Doc
ppImportDecl (ImportDecl _ m q asM is) =
text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM
<+> maybePP ppImportSpec is
where ppQualified q' = if q' then text "qualified" else empty
ppAs m' = text "as" <+> ppMIdent m'
ppImportSpec :: ImportSpec -> Doc
ppImportSpec (Importing _ is) = parenList (map ppImport is)
ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is)
ppImport :: Import -> Doc
ppImport (Import x) = ppIdent x
ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)
ppImport (ImportTypeAll tc) = ppIdent tc <> text "(..)"
ppBlock :: [Decl a] -> Doc
ppBlock = vcat . map ppDecl
ppSepBlock :: [Decl a] -> Doc
ppSepBlock = vcat . map (\d -> text "" $+$ ppDecl d)
ppDecl :: Decl a -> Doc
ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)
ppDecl (DataDecl _ tc tvs cs clss) =
sep (ppTypeDeclLhs "data" tc tvs :
map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs) ++
[ppDeriving clss]))
ppDecl (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs
ppDecl (NewtypeDecl _ tc tvs nc clss) =
sep (ppTypeDeclLhs "newtype" tc tvs <+> equals :
map indent [ppNewConstr nc, ppDeriving clss])
ppDecl (TypeDecl _ tc tvs ty) =
sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
ppDecl (TypeSig _ fs qty) =
list (map ppIdent fs) <+> text "::" <+> ppQualTypeExpr qty
ppDecl (FunctionDecl _ _ _ eqs) = vcat (map ppEquation eqs)
ppDecl (ExternalDecl _ vs) = list (map ppVar vs) <+> text "external"
ppDecl (PatternDecl _ t rhs) = ppRule (ppPattern 0 t) equals rhs
ppDecl (FreeDecl _ vs) = list (map ppVar vs) <+> text "free"
ppDecl (DefaultDecl _ tys) =
text "default" <+> parenList (map (ppTypeExpr 0) tys)
ppDecl (ClassDecl _ cx cls clsvar ds) =
ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+>
ppIf (not $ null ds) (text "where") $$
ppIf (not $ null ds) (indent $ ppBlock ds)
ppDecl (InstanceDecl _ cx qcls inst ds) =
ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
ppIf (not $ null ds) (text "where") $$
ppIf (not $ null ds) (indent $ ppBlock ds)
ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc
ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty
ppContext :: Context -> Doc
ppContext [] = empty
ppContext [c] = ppConstraint c <+> darrow
ppContext cs = parenList (map ppConstraint cs) <+> darrow
ppConstraint :: Constraint -> Doc
ppConstraint (Constraint qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty
ppInstanceType :: InstanceType -> Doc
ppInstanceType = ppTypeExpr 2
ppDeriving :: [QualIdent] -> Doc
ppDeriving [] = empty
ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls
ppDeriving qclss = text "deriving" <+> parenList (map ppQIdent qclss)
ppPrec :: Infix -> Maybe Precedence -> Doc
ppPrec fix p = pPrint fix <+> ppPrio p
where
ppPrio Nothing = empty
ppPrio (Just p') = integer p'
ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
ppConstr :: ConstrDecl -> Doc
ppConstr (ConstrDecl _ tvs cx c tys) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> fsep (map (ppTypeExpr 2) tys)
]
ppConstr (ConOpDecl _ tvs cx ty1 op ty2) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2
]
ppConstr (RecordDecl _ tvs cx c fs) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> record (list (map ppFieldDecl fs))
]
ppFieldDecl :: FieldDecl -> Doc
ppFieldDecl (FieldDecl _ ls ty) = list (map ppIdent ls)
<+> text "::" <+> ppTypeExpr 0 ty
ppNewConstr :: NewConstrDecl -> Doc
ppNewConstr (NewConstrDecl _ c ty) = sep [ppIdent c <+> ppTypeExpr 2 ty]
ppNewConstr (NewRecordDecl _ c (i,ty)) =
sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> ppTypeExpr 0 ty)]
ppQuantifiedVars :: [Ident] -> Doc
ppQuantifiedVars tvs
| null tvs = empty
| otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'
ppEquation :: Equation a -> Doc
ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs
ppLhs :: Lhs a -> Doc
ppLhs (FunLhs f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts)
ppLhs (OpLhs t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2
ppLhs (ApLhs lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts)
ppRule :: Doc -> Doc -> Rhs a -> Doc
ppRule lhs eq (SimpleRhs _ e ds) =
sep [lhs <+> eq, indent (ppExpr 0 e)] $$ ppLocalDefs ds
ppRule lhs eq (GuardedRhs es ds) =
sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds
ppLocalDefs :: [Decl a] -> Doc
ppLocalDefs ds
| null ds = empty
| otherwise = indent (text "where" <+> ppBlock ds)
ppInterface :: Interface -> Doc
ppInterface (Interface m is ds)
= text "interface" <+> ppMIdent m <+> text "where" <+> lbrace
$$ vcat (punctuate semi $ map ppIImportDecl is ++ map ppIDecl ds)
$$ rbrace
ppIImportDecl :: IImportDecl -> Doc
ppIImportDecl (IImportDecl _ m) = text "import" <+> ppMIdent m
ppIDecl :: IDecl -> Doc
ppIDecl (IInfixDecl _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op
ppIDecl (HidingDataDecl _ tc k tvs) =
text "hiding" <+> ppITypeDeclLhs "data" tc k tvs
ppIDecl (IDataDecl _ tc k tvs cs hs) =
sep (ppITypeDeclLhs "data" tc k tvs :
map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)) ++
[indent (ppHiding hs)])
ppIDecl (INewtypeDecl _ tc k tvs nc hs) =
sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals
, indent (ppNewConstr nc)
, indent (ppHiding hs)
]
ppIDecl (ITypeDecl _ tc k tvs ty) =
sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (ppTypeExpr 0 ty)]
ppIDecl (IFunctionDecl _ f cm a qty) =
sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm
, int a, text "::", ppQualTypeExpr qty ]
ppIDecl (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+>
ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar)
ppIDecl (IClassDecl _ cx qcls k clsvar ms hs) =
ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+>
lbrace $$
vcat (punctuate semi $ map (indent . ppIMethodDecl) ms) $$
rbrace <+> ppHiding hs
ppIDecl (IInstanceDecl _ cx qcls inst impls m) =
ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
lbrace $$
vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$
rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m
ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc
ppITypeDeclLhs kw tc k tvs =
text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)
ppIMethodDecl :: IMethodDecl -> Doc
ppIMethodDecl (IMethodDecl _ f a qty) =
ppIdent f <+> maybePP int a <+> text "::" <+> ppQualTypeExpr qty
ppIMethodImpl :: IMethodImpl -> Doc
ppIMethodImpl (f, a) = ppIdent f <+> int a
ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc
ppQIdentWithKind tc (Just k) = parens $ ppQIdent tc <+> text "::" <+> ppKindExpr 0 k
ppQIdentWithKind tc Nothing = ppQIdent tc
ppHiding :: [Ident] -> Doc
ppHiding hs
| null hs = empty
| otherwise = ppPragma "HIDING" $ list $ map ppIdent hs
ppKindExpr :: Int -> KindExpr -> Doc
ppKindExpr _ Star = char '*'
ppKindExpr p (ArrowKind k1 k2) =
parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2)))
where
ppArrowKind (ArrowKind k1' k2') = ppKindExpr 1 k1' <+> rarrow : ppArrowKind k2'
ppArrowKind k = [ppKindExpr 0 k]
ppQualTypeExpr :: QualTypeExpr -> Doc
ppQualTypeExpr (QualTypeExpr cx ty) = ppContext cx <+> ppTypeExpr 0 ty
ppTypeExpr :: Int -> TypeExpr -> Doc
ppTypeExpr _ (ConstructorType tc) = ppQIdent tc
ppTypeExpr p (ApplyType ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])
where ppApplyType (ApplyType ty1' ty2') tys = ppApplyType ty1' (ty2' : tys)
ppApplyType ty tys =
ppTypeExpr 1 ty <+> fsep (map (ppTypeExpr 2) tys)
ppTypeExpr _ (VariableType tv) = ppIdent tv
ppTypeExpr _ (TupleType tys) = parenList (map (ppTypeExpr 0) tys)
ppTypeExpr _ (ListType ty) = brackets (ppTypeExpr 0 ty)
ppTypeExpr p (ArrowType ty1 ty2) = parenIf (p > 0)
(fsep (ppArrowType (ArrowType ty1 ty2)))
where
ppArrowType (ArrowType ty1' ty2') =
ppTypeExpr 1 ty1' <+> rarrow : ppArrowType ty2'
ppArrowType ty = [ppTypeExpr 0 ty]
ppTypeExpr _ (ParenType ty) = parens (ppTypeExpr 0 ty)
ppTypeExpr p (ForallType vs ty)
| null vs = ppTypeExpr p ty
| otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty
ppLiteral :: Literal -> Doc
ppLiteral (Char c) = text (show c)
ppLiteral (Int i) = integer i
ppLiteral (Float f) = double f
ppLiteral (String s) = text (show s)
ppPattern :: Int -> Pattern a -> Doc
ppPattern p (LiteralPattern _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)
where isNegative (Char _) = False
isNegative (Int i) = i < 0
isNegative (Float f) = f < 0.0
isNegative (String _) = False
ppPattern p (NegativePattern _ l) = parenIf (p > 1)
(ppInfixOp minusId <> ppLiteral l)
ppPattern _ (VariablePattern _ v) = ppIdent v
ppPattern p (ConstructorPattern _ c ts) = parenIf (p > 1 && not (null ts))
(ppQIdent c <+> fsep (map (ppPattern 2) ts))
ppPattern p (InfixPattern _ t1 c t2) = parenIf (p > 0)
(sep [ppPattern 1 t1 <+> ppQInfixOp c, indent (ppPattern 0 t2)])
ppPattern _ (ParenPattern t) = parens (ppPattern 0 t)
ppPattern _ (TuplePattern ts) = parenList (map (ppPattern 0) ts)
ppPattern _ (ListPattern _ ts) = bracketList (map (ppPattern 0) ts)
ppPattern _ (AsPattern v t) = ppIdent v <> char '@' <> ppPattern 2 t
ppPattern _ (LazyPattern t) = char '~' <> ppPattern 2 t
ppPattern p (FunctionPattern _ f ts) = parenIf (p > 1 && not (null ts))
(ppQIdent f <+> fsep (map (ppPattern 2) ts))
ppPattern p (InfixFuncPattern _ t1 f t2) = parenIf (p > 0)
(sep [ppPattern 1 t1 <+> ppQInfixOp f, indent (ppPattern 0 t2)])
ppPattern p (RecordPattern _ c fs) = parenIf (p > 1)
(ppQIdent c <+> record (list (map ppFieldPatt fs)))
ppFieldPatt :: Field (Pattern a) -> Doc
ppFieldPatt (Field _ l t) = ppQIdent l <+> equals <+> ppPattern 0 t
ppCondExpr :: Doc -> CondExpr a -> Doc
ppCondExpr eq (CondExpr _ g e) =
vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]
ppExpr :: Int -> Expression a -> Doc
ppExpr _ (Literal _ l) = ppLiteral l
ppExpr _ (Variable _ v) = ppQIdent v
ppExpr _ (Constructor _ c) = ppQIdent c
ppExpr _ (Paren e) = parens (ppExpr 0 e)
ppExpr p (Typed e qty) =
parenIf (p > 0) (ppExpr 0 e <+> text "::" <+> ppQualTypeExpr qty)
ppExpr _ (Tuple es) = parenList (map (ppExpr 0) es)
ppExpr _ (List _ es) = bracketList (map (ppExpr 0) es)
ppExpr _ (ListCompr e qs) =
brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))
ppExpr _ (EnumFrom e) = brackets (ppExpr 0 e <+> text "..")
ppExpr _ (EnumFromThen e1 e2) =
brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")
ppExpr _ (EnumFromTo e1 e2) =
brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)
ppExpr _ (EnumFromThenTo e1 e2 e3) =
brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
<+> text ".." <+> ppExpr 0 e3)
ppExpr p (UnaryMinus e) =
parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e)
ppExpr p (Apply e1 e2) =
parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
ppExpr p (InfixApply e1 op e2) =
parenIf (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),
indent (ppExpr 1 e2)])
ppExpr _ (LeftSection e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))
ppExpr _ (RightSection op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)
ppExpr p (Lambda t e) = parenIf (p > 0)
(sep [backsl <> fsep (map (ppPattern 2) t) <+> rarrow, indent (ppExpr 0 e)])
ppExpr p (Let ds e) = parenIf (p > 0)
(sep [text "let" <+> ppBlock ds, text "in" <+> ppExpr 0 e])
ppExpr p (Do sts e) = parenIf (p > 0)
(text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))
ppExpr p (IfThenElse e1 e2 e3) = parenIf (p > 0)
(text "if" <+>
sep [ppExpr 0 e1,
text "then" <+> ppExpr 0 e2,
text "else" <+> ppExpr 0 e3])
ppExpr p (Case ct e alts) = parenIf (p > 0)
(ppCaseType ct <+> ppExpr 0 e <+> text "of" $$
indent (vcat (map ppAlt alts)))
ppExpr p (Record _ c fs) = parenIf (p > 0)
(ppQIdent c <+> record (list (map ppFieldExpr fs)))
ppExpr _ (RecordUpdate e fs) =
ppExpr 0 e <+> record (list (map ppFieldExpr fs))
ppStmt :: Statement a -> Doc
ppStmt (StmtExpr e) = ppExpr 0 e
ppStmt (StmtBind t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)]
ppStmt (StmtDecl ds) = text "let" <+> ppBlock ds
ppCaseType :: CaseType -> Doc
ppCaseType Rigid = text "case"
ppCaseType Flex = text "fcase"
ppAlt :: Alt a -> Doc
ppAlt (Alt _ t rhs) = ppRule (ppPattern 0 t) rarrow rhs
ppVar :: Var a -> Doc
ppVar (Var _ ident) = ppIdent ident
ppFieldExpr :: Field (Expression a) -> Doc
ppFieldExpr (Field _ l e) = ppQIdent l <+> equals <+> ppExpr 0 e
ppOp :: InfixOp a -> Doc
ppOp (InfixOp _ op) = ppQInfixOp op
ppOp (InfixConstr _ op) = ppQInfixOp op
ppIdent :: Ident -> Doc
ppIdent x = parenIf (isInfixOp x) (text (idName x))
ppQIdent :: QualIdent -> Doc
ppQIdent x = parenIf (isQInfixOp x) (text (qualName x))
ppInfixOp :: Ident -> Doc
ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x))
ppQInfixOp :: QualIdent -> Doc
ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x))
ppMIdent :: ModuleIdent -> Doc
ppMIdent m = text (moduleName m)
indent :: Doc -> Doc
indent = nest 2
parenList :: [Doc] -> Doc
parenList = parens . list
record :: Doc -> Doc
record doc | isEmpty doc = braces empty
| otherwise = braces $ space <> doc <> space
bracketList :: [Doc] -> Doc
bracketList = brackets . list