{- | Module : $Header$ Description : Pretty printer for IL Copyright : (c) 1999 - 2003 Wolfgang Lux Martin Engelke 2011 - 2015 Björn Peemöller 2017 Finn Teegen License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module implements just another pretty printer, this time for the intermediate language. It was mainly adapted from the Curry pretty printer which, in turn, is based on Simon Marlow's pretty printer for Haskell. -} {-# LANGUAGE CPP #-} module IL.Pretty (ppModule) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Curry.Base.Ident import Curry.Base.Pretty import IL.Type dataIndent :: Int dataIndent = 2 bodyIndent :: Int bodyIndent = 2 exprIndent :: Int exprIndent = 2 caseIndent :: Int caseIndent = 2 altIndent :: Int altIndent = 2 orIndent :: Int orIndent = 2 ppModule :: Module -> Doc ppModule (Module m is ds) = sepByBlankLine [ppHeader m, vcat (map ppImport is), sepByBlankLine (map ppDecl ds)] ppHeader :: ModuleIdent -> Doc ppHeader m = text "module" <+> text (moduleName m) <+> text "where" ppImport :: ModuleIdent -> Doc ppImport m = text "import" <+> text (moduleName m) ppDecl :: Decl -> Doc ppDecl (DataDecl tc ks cs) = sep $ text "data" <+> ppTypeLhs tc (length ks) : map (nest dataIndent) (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)) ppDecl (NewtypeDecl tc ks nc) = sep $ text "newtype" <+> ppTypeLhs tc (length ks) : [nest dataIndent (equals <+> ppNewConstr nc)] ppDecl (ExternalDataDecl tc ks) = text "external data" <+> ppTypeLhs tc (length ks) ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep [ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals , nest bodyIndent (ppExpr 0 e)] ppDecl (ExternalDecl f _ ty) = text "external" <+> ppTypeSig f ty ppTypeLhs :: QualIdent -> Int -> Doc ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars)) ppConstr :: ConstrDecl -> Doc ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys) ppNewConstr :: NewConstrDecl -> Doc ppNewConstr (NewConstrDecl c ty) = ppQIdent c <+> fsep [ppType 2 ty] ppTypeSig :: QualIdent -> Type -> Doc ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty ppType :: Int -> Type -> Doc ppType p (TypeConstructor tc tys) | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys))) | tc == qListId && length tys == 1 = brackets (ppType 0 (head tys)) | otherwise = parenIf (p > 1 && not (null tys)) (ppQIdent tc <+> fsep (map (ppType 2) tys)) ppType _ (TypeVariable n) = ppTypeVar n ppType p (TypeArrow ty1 ty2) = parenIf (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2))) where ppArrow (TypeArrow ty1' ty2') = ppType 1 ty1' <+> text "->" : ppArrow ty2' ppArrow ty = [ppType 0 ty] ppType p (TypeForall ns ty) | null ns = ppType p ty | otherwise = parenIf (p > 0) $ ppQuantifiedTypeVars ns <+> ppType 0 ty ppTypeVar :: Int -> Doc ppTypeVar n | n >= 0 = text (typeVars !! n) | otherwise = text ('_':show (-n)) ppQuantifiedTypeVars :: [(Int, Kind)] -> Doc ppQuantifiedTypeVars ns | null ns = empty | otherwise = text "forall" <+> hsep (map (ppTypeVar . fst) ns) <> char '.' ppBinding :: Binding -> Doc ppBinding (Binding v expr) = sep [ppIdent v <+> equals, nest bodyIndent (ppExpr 0 expr)] ppAlt :: Alt -> Doc ppAlt (Alt pat expr) = sep [ppConstrTerm pat <+> text "->", nest altIndent (ppExpr 0 expr)] ppLiteral :: Literal -> Doc ppLiteral (Char c) = text (show c) ppLiteral (Int i) = integer i ppLiteral (Float f) = double f ppConstrTerm :: ConstrTerm -> Doc ppConstrTerm (LiteralPattern _ l) = ppLiteral l ppConstrTerm (ConstructorPattern _ c [(_, v1), (_, v2)]) | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2 ppConstrTerm (ConstructorPattern _ c vs) | isQTupleId c = parens $ fsep (punctuate comma $ map (ppIdent . snd) vs) | otherwise = ppQIdent c <+> fsep (map (ppIdent . snd) vs) ppConstrTerm (VariablePattern _ v) = ppIdent v ppExpr :: Int -> Expression -> Doc ppExpr _ (Literal _ l) = ppLiteral l ppExpr _ (Variable _ v) = ppIdent v ppExpr _ (Function _ f _) = ppQIdent f ppExpr _ (Constructor _ c _) = ppQIdent c ppExpr p (Apply (Apply (Function _ f _) e1) e2) | isQInfixOp f = ppInfixApp p e1 f e2 ppExpr p (Apply (Apply (Constructor _ c _) e1) e2) | isQInfixOp c = ppInfixApp p e1 c e2 ppExpr p (Apply e1 e2) = parenIf (p > 2) $ sep [ppExpr 2 e1, nest exprIndent (ppExpr 3 e2)] ppExpr p (Case ev e alts) = parenIf (p > 0) $ text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$ nest caseIndent (vcat $ map ppAlt alts) where ppEval Rigid = text "rigid" ppEval Flex = text "flex" ppExpr p (Or e1 e2) = parenIf (p > 0) $ sep [nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)] ppExpr p (Exist v _ e) = parenIf (p > 0) $ sep [text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e] ppExpr p (Let b e) = parenIf (p > 0) $ sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e] ppExpr p (Letrec bs e) = parenIf (p > 0) $ sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in", ppExpr 0 e] ppExpr p (Typed e ty) = parenIf (p > 0) $ sep [ppExpr 0 e, text "::", ppType 0 ty] ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc ppInfixApp p e1 op e2 = parenIf (p > 1) $ sep [ppExpr 2 e1 <+> ppQInfixOp op, nest exprIndent (ppExpr 2 e2)] ppIdent :: Ident -> Doc ppIdent ident | isInfixOp ident = parens (ppName ident) | otherwise = ppName ident ppQIdent :: QualIdent -> Doc ppQIdent ident | isQInfixOp ident = parens (ppQual ident) | otherwise = ppQual ident ppQInfixOp :: QualIdent -> Doc ppQInfixOp op | isQInfixOp op = ppQual op | otherwise = char '`' <> ppQual op <> char '`' ppName :: Ident -> Doc ppName x = text (idName x) ppQual :: QualIdent -> Doc ppQual x = text (qualName x) typeVars :: [String] typeVars = [mkTypeVar c i | i <- [0 .. ], c <- ['a' .. 'z']] where mkTypeVar :: Char -> Int -> String mkTypeVar c i = c : if i == 0 then [] else show i