{- | Module : $Header$ Description : A pretty printer for Curry Copyright : (c) 1999 - 2004 Wolfgang Lux 2005 Martin Engelke 2011 - 2015 Björn Peemöller 2016 Finn Teegen License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module implements a pretty printer for Curry expressions. It was derived from the Haskell pretty printer provided in Simon Marlow's Haskell parser. -} {-# LANGUAGE CPP #-} 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 #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Curry.Base.Ident import Curry.Base.Pretty import Curry.Syntax.Type import Curry.Syntax.Utils (opName) -- TODO use span infos -- |Pretty print a module 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) -- |Pretty print a declaration 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 _ c tys) = sep [ ppIdent c <+> fsep (map (ppTypeExpr 2) tys) ] ppConstr (ConOpDecl _ ty1 op ty2) = sep [ ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2 ] ppConstr (RecordDecl _ c fs) = sep [ 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) -- --------------------------------------------------------------------------- -- Interfaces -- --------------------------------------------------------------------------- -- |Pretty print an interface 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 -- |Pretty print an interface declaration 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 -- --------------------------------------------------------------------------- -- Kinds -- --------------------------------------------------------------------------- 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] -- --------------------------------------------------------------------------- -- Types -- --------------------------------------------------------------------------- -- |Pretty print a qualified type expression ppQualTypeExpr :: QualTypeExpr -> Doc ppQualTypeExpr (QualTypeExpr _ cx ty) = ppContext cx <+> ppTypeExpr 0 ty -- |Pretty print a type expression 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 spi ty1 ty2) = parenIf (p > 0) (fsep (ppArrowType (ArrowType spi 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 -- --------------------------------------------------------------------------- -- Literals -- --------------------------------------------------------------------------- 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) -- --------------------------------------------------------------------------- -- Patterns -- --------------------------------------------------------------------------- -- |Pretty print a constructor term 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))) -- |Pretty print a record field pattern ppFieldPatt :: Field (Pattern a) -> Doc ppFieldPatt (Field _ l t) = ppQIdent l <+> equals <+> ppPattern 0 t -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- ppCondExpr :: Doc -> CondExpr a -> Doc ppCondExpr eq (CondExpr _ g e) = vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)] -- |Pretty print an expression 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)) -- |Pretty print a statement 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" -- |Pretty print an alternative in a case expression ppAlt :: Alt a -> Doc ppAlt (Alt _ t rhs) = ppRule (ppPattern 0 t) rarrow rhs -- |Pretty print a free variable ppVar :: Var a -> Doc ppVar (Var _ ident) = ppIdent ident -- |Pretty print a record field expression (Haskell syntax) ppFieldExpr :: Field (Expression a) -> Doc ppFieldExpr (Field _ l e) = ppQIdent l <+> equals <+> ppExpr 0 e -- |Pretty print an operator ppOp :: InfixOp a -> Doc ppOp (InfixOp _ op) = ppQInfixOp op ppOp (InfixConstr _ op) = ppQInfixOp op -- --------------------------------------------------------------------------- -- Names -- --------------------------------------------------------------------------- -- |Pretty print an identifier 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) -- --------------------------------------------------------------------------- -- Print printing utilities -- --------------------------------------------------------------------------- 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