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