abstract-haskell packaged

.gitignore

+*~
+.cpm
+.curry

LICENSE

+Copyright (c) 2017, Michael Hanus
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the names of the copyright holders nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

+abstract-haskell
+================
+
+This package contains libraries with data types to
+represent Haskell programs in Curry and show them in
+standard Haskell syntax.

package.json

+{
+    "name": "abstract-haskell",
+    "version": "2.0.0",
+    "author": "Michael Hanus <Michael Hanus>",
+    "synopsis": "Libraries to represent Haskell programs in Curry",
+    "category": [ "Programming" ],
+    "license": "BSD-3-Clause",
+    "licenseFile": "LICENSE",
+    "dependencies": {
+    },
+    "compilerCompatibility": {
+        "pakcs": ">= 2.0.0",
+        "kics2": ">= 2.0.0"
+    },
+    "exportedModules": [ "AbstractHaskell.Types", "AbstractHaskell.Goodies",
+                         "AbstractHaskell.Printer" ]
+}

src/AbstractHaskell/Goodies.curry

+------------------------------------------------------------------------
+--- This module provides some useful functions to write the code
+--- generating AbstractHaskell programs more compact and readable.
+------------------------------------------------------------------------
+
+module AbstractHaskell.Goodies where
+
+import Char            (toLower)
+import List            ((\\), union)
+
+import AbstractHaskell.Types
+
+infixr 9 ~>
+
+--- lower the first character in a string
+lowerFirst :: String -> String
+lowerFirst []     = [] -- this case should not occur, but one never knows...
+lowerFirst (y:ys) = toLower y : ys
+
+--- Construct the name of an n-ary tuple.
+tupleName :: Int -> QName
+tupleName arity | arity > 1 = pre ('(' : replicate (arity - 1) ',' ++ ")")
+                | otherwise = error $ "tupleName: illegal arity " ++ show arity
+
+-- -----------------------------------------------------------------------------
+-- Goodies for types
+-- -----------------------------------------------------------------------------
+
+--- A type variable.
+ctvar :: String -> TypeExpr
+ctvar s = TVar (1, s)
+
+--- A function type.
+(~>) :: TypeExpr -> TypeExpr -> TypeExpr
+t1 ~> t2 = FuncType t1 t2
+
+--- A base type (type constructor without arguments).
+baseType :: QName -> TypeExpr
+baseType t = TCons t []
+
+--- Constructs a list type from element type.
+listType :: TypeExpr -> TypeExpr
+listType a = TCons (pre "[]") [a]
+
+--- Constructs a tuple type from list of component types.
+tupleType :: [TypeExpr] -> TypeExpr
+tupleType ts | l == 0    = baseType (pre "()")
+             | l == 1    = head ts
+             | otherwise = TCons (tupleName l) ts
+ where l = length ts
+
+--- Constructs an IO type from a type.
+ioType :: TypeExpr -> TypeExpr
+ioType a = TCons (pre "IO") [a]
+
+--- Constructs a Maybe type from element type.
+maybeType :: TypeExpr -> TypeExpr
+maybeType a = TCons (pre "Maybe") [a]
+
+--- The `String` type.
+stringType :: TypeExpr
+stringType = baseType (pre "String")
+
+--- The `Int` type.
+intType :: TypeExpr
+intType = baseType (pre "Int")
+
+--- The `Bool` type.
+boolType :: TypeExpr
+boolType = baseType (pre "Bool")
+
+--- The `Date` type.
+dateType :: TypeExpr
+dateType = baseType ("Time", "CalendarTime")
+
+tyVarsOf :: TypeExpr -> [TVarIName]
+tyVarsOf (TVar             tv) = [tv]
+tyVarsOf (FuncType      t1 t2) = tyVarsOf t1 `union` tyVarsOf t2
+tyVarsOf (TCons         _ tys) = foldr union [] (map tyVarsOf tys)
+tyVarsOf (ForallType tvs _ ty) = tyVarsOf ty \\ tvs
+
+-- -----------------------------------------------------------------------------
+-- Goodies for function declarations
+-- -----------------------------------------------------------------------------
+
+--- A typed function declaration.
+tfunc :: QName -> Int -> Visibility -> TypeExpr -> [Rule] -> FuncDecl
+tfunc name arity v t rules = Func "" name arity v (CType [] t) (Rules rules)
+
+--- A typed function declaration with a type context.
+ctfunc :: QName -> Int -> Visibility -> [Context] -> TypeExpr -> [Rule]
+       -> FuncDecl
+ctfunc name arity v tc t rules = Func "" name arity v (CType tc t) (Rules rules)
+
+--- A typed function declaration with a documentation comment.
+cmtfunc :: String -> QName -> Int -> Visibility -> [Context] -> TypeExpr
+        -> [Rule] -> FuncDecl
+cmtfunc comment name arity v tc t rules =
+  Func comment name arity v (CType tc t) (Rules rules)
+
+funcDecls :: Prog -> [FuncDecl]
+funcDecls (Prog _ _ _ fs _) = fs
+
+funcName :: FuncDecl -> QName
+funcName (Func _ f _ _ _ _) = f
+
+typeOf :: FuncDecl -> TypeSig
+typeOf (Func _ _ _ _ ty _) = ty
+
+commentOf :: FuncDecl -> String
+commentOf (Func cmt _ _ _ _ _) = cmt
+
+simpleRule :: [Pattern] -> Expr -> Rules
+simpleRule ps e = Rules [Rule ps (SimpleRhs e) []]
+
+-- -----------------------------------------------------------------------------
+-- Building expressions
+-- -----------------------------------------------------------------------------
+
+--- An application of a qualified function name to a list of arguments.
+applyF :: QName -> [Expr] -> Expr
+applyF f es = foldl Apply (Symbol f) es
+
+--- A constant, i.e., an application without arguments.
+constF :: QName -> Expr
+constF f = applyF f []
+
+--- An application of a variable to a list of arguments.
+applyV :: VarIName -> [Expr] -> Expr
+applyV v es = foldl Apply (Var v) es
+
+--- Constructs a tuple pattern from list of component patterns.
+tuplePat :: [Pattern] -> Pattern
+tuplePat ps = PTuple ps
+
+--- Constructs a tuple expression from list of component expressions.
+tupleExpr :: [Expr] -> Expr
+tupleExpr es = Tuple es
+
+--- transform a string constant into AbstractHaskell term
+string2ac :: String -> Expr
+string2ac = Lit . Stringc
+
+pre :: String -> QName
+pre f = ("Prelude", f)
+
+cvar :: String -> Expr
+cvar s = Var (1,s)
+
+--- Build a let declaration (with a possibly empty list of local declarations)
+clet :: [LocalDecl] -> Expr -> Expr
+clet locals cexp = if null locals then cexp else Let locals cexp
+
+list2ac :: [Expr] -> Expr
+list2ac es = List es
+
+declVar :: VarIName -> Expr -> LocalDecl
+declVar v e = LocalPat (PVar v) e []
+
+-- -----------------------------------------------------------------------------
+-- Perform a renaming
+-- -----------------------------------------------------------------------------
+
+renameSymbolInProg :: (QName -> QName) -> Prog -> Prog
+renameSymbolInProg ren (Prog name imports typedecls fundecls opdecls) =
+  Prog
+    (fst (ren (name, "")))
+    (map (\mod -> fst $ ren (mod, "")) imports)
+    (map (renameSymbolInTypeDecl ren) typedecls)
+    (map (renameSymbolInFunc ren) fundecls)
+    (map (renameOpDecl ren) opdecls)
+
+renameSymbolInTypeDecl :: (QName -> QName) -> TypeDecl -> TypeDecl
+renameSymbolInTypeDecl ren tdecl = case tdecl of
+  Type qf vis tvars cdecls  -> Type (ren qf) vis tvars
+                                      (map (renameSymbolInConsDecl ren) cdecls)
+  TypeSyn qf vis tvars texp -> TypeSyn (ren qf) vis tvars
+                                         (renameSymbolInTypeExpr ren texp)
+  Instance qf texp ctxt rules ->
+    Instance (ren qf) (renameSymbolInTypeExpr ren texp)
+              (map (renameSymbolInContext ren) ctxt)
+              (map renameSymbolInInstRule rules)
+ where
+  renameSymbolInInstRule (qf,rule) =
+    (ren qf, renameSymbolInRule ren rule)
+
+renameSymbolInConsDecl :: (QName -> QName) -> ConsDecl -> ConsDecl
+renameSymbolInConsDecl ren (Cons qf ar vis texps) =
+  Cons (ren qf) ar vis  (map (renameSymbolInTypeExpr ren) texps)
+
+renameSymbolInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
+renameSymbolInTypeExpr ren texp = case texp of
+  TCons qf texps      -> TCons (ren qf) (map (renameSymbolInTypeExpr ren) texps)
+  FuncType te1 te2    -> FuncType (renameSymbolInTypeExpr ren te1)
+                                  (renameSymbolInTypeExpr ren te2)
+  TVar v              -> TVar v
+  ForallType v cx te  -> ForallType v (map (renameSymbolInContext ren) cx)
+                                      (renameSymbolInTypeExpr ren te)
+
+renameSymbolInExpr :: (QName -> QName) -> Expr -> Expr
+renameSymbolInExpr ren exp = case exp of
+  Var _               -> exp
+  Lit _               -> exp
+  Symbol qf           -> Symbol (ren qf)
+  Apply e1 e2         -> Apply (renameSymbolInExpr ren e1)
+                               (renameSymbolInExpr ren e2)
+  InfixApply e1 op e2 -> InfixApply (renameSymbolInExpr ren e1)
+                                    (ren op)
+                                    (renameSymbolInExpr ren e2)
+  Lambda pats e       -> Lambda (map (renameSymbolInPat ren) pats)
+                                  (renameSymbolInExpr ren e)
+  Let locals e        -> Let (map (renameSymbolInLocal ren) locals)
+                                  (renameSymbolInExpr ren e)
+  DoExpr stats        -> DoExpr (map (renameSymbolInStat ren) stats)
+  ListComp e stats    -> ListComp (renameSymbolInExpr ren e)
+                                    (map (renameSymbolInStat ren) stats)
+  Case e branches     -> Case (renameSymbolInExpr ren e)
+                                (map (renameSymbolInBranch ren) branches)
+  Typed e ty          -> Typed (renameSymbolInExpr ren e) ty
+  IfThenElse e1 e2 e3 -> IfThenElse (renameSymbolInExpr ren e1)
+                                    (renameSymbolInExpr ren e2)
+                                    (renameSymbolInExpr ren e3)
+  Tuple es            -> Tuple (map (renameSymbolInExpr ren) es)
+  List  es            -> List  (map (renameSymbolInExpr ren) es)
+
+renameSymbolInPat :: (QName -> QName) -> Pattern -> Pattern
+renameSymbolInPat ren pat = case pat of
+  PComb qf pats    -> PComb (ren qf) (map (renameSymbolInPat ren) pats)
+  PAs var apat     -> PAs var (renameSymbolInPat ren apat)
+  PTuple ps        -> PTuple (map (renameSymbolInPat ren) ps)
+  PList ps         -> PList (map (renameSymbolInPat ren) ps)
+  _                -> pat -- PVar or PLit
+
+renameSymbolInBranch :: (QName -> QName) -> BranchExpr -> BranchExpr
+renameSymbolInBranch ren (Branch pat e) =
+  Branch (renameSymbolInPat ren pat) (renameSymbolInExpr ren e)
+
+renameSymbolInStat :: (QName -> QName) -> Statement -> Statement
+renameSymbolInStat ren stat = case stat of
+  SExpr e     -> SExpr (renameSymbolInExpr ren e)
+  SPat pat e  -> SPat (renameSymbolInPat ren pat)
+                        (renameSymbolInExpr ren e)
+  SLet locals -> SLet (map (renameSymbolInLocal ren) locals)
+
+renameSymbolInLocal :: (QName -> QName) -> LocalDecl -> LocalDecl
+renameSymbolInLocal ren local = case local of
+  LocalFunc fdecl       -> LocalFunc (renameSymbolInFunc ren fdecl)
+  LocalPat pat e locals -> LocalPat (renameSymbolInPat ren pat)
+                                      (renameSymbolInExpr ren e)
+                                      (map (renameSymbolInLocal ren) locals)
+
+renameSymbolInTypeSig :: (QName -> QName) -> TypeSig -> TypeSig
+renameSymbolInTypeSig _   Untyped       = Untyped
+renameSymbolInTypeSig ren (CType tc te) =
+  CType (map (renameSymbolInContext ren) tc) (renameSymbolInTypeExpr ren te)
+
+renameSymbolInContext :: (QName -> QName) -> Context -> Context
+renameSymbolInContext ren (Context qn texps) =
+  Context (ren qn) (map (renameSymbolInTypeExpr ren) texps)
+
+renameSymbolInFunc :: (QName -> QName) -> FuncDecl -> FuncDecl
+renameSymbolInFunc ren (Func cmt qf ar vis ctype rules) =
+  Func cmt (ren qf) ar vis
+       (renameSymbolInTypeSig ren ctype)
+       (renameSymbolInRules ren rules)
+
+renameSymbolInRules :: (QName -> QName) -> Rules -> Rules
+renameSymbolInRules ren (Rules rs) = Rules (map (renameSymbolInRule ren) rs)
+renameSymbolInRules _   External   = External
+
+renameSymbolInRule :: (QName -> QName) -> Rule -> Rule
+renameSymbolInRule ren (Rule ps rhs ds) =
+  Rule (map (renameSymbolInPat ren) ps)
+       (renameSymbolInRhs ren rhs)
+       (map (renameSymbolInLocal ren) ds)
+
+renameSymbolInRhs :: (QName -> QName) -> Rhs -> Rhs
+renameSymbolInRhs ren (SimpleRhs   e) = SimpleRhs (renameSymbolInExpr ren e)
+renameSymbolInRhs ren (GuardedRhs gs) = GuardedRhs $
+  map (\ (c, e) -> (renameSymbolInExpr ren c, renameSymbolInExpr ren e)) gs
+
+renameOpDecl :: (QName -> QName) -> OpDecl -> OpDecl
+renameOpDecl ren (Op qf fix prio) = Op (ren qf) fix prio

src/AbstractHaskell/Printer.curry

+------------------------------------------------------------------------------
+--- A pretty printer for AbstractHaskell programs.
+---
+--- This library defines a function "ppProg" that shows
+--- an AbstractHaskell program in standard Haskell syntax.
+---
+--- @author Björn Peemöller
+--- @version May 2017
+------------------------------------------------------------------------------
+module AbstractHaskell.Printer
+  ( Options (..), defaultOptions, pPrint, ppProg, ppHeader, ppImports
+  , ppDecls
+  ) where
+
+import Pretty
+
+import AbstractHaskell.Types
+import AbstractHaskell.Goodies (tyVarsOf)
+
+data Options = Options
+  { currentModule :: String
+  , qualImpModule :: String -> Bool -- should a module be qualified imported?
+  }
+
+defaultOptions :: Options
+defaultOptions = Options { currentModule = "", qualImpModule = const False }
+
+pPrint :: Doc -> String
+pPrint = pretty 80
+
+-- ---------------------------------------------------------------------------
+-- Functions to print an AbstractHaskell program in standard Haskell syntax
+-- ---------------------------------------------------------------------------
+
+--- Shows an AbstractHaskell program in standard Haskell syntax.
+--- The export list contains the public functions and the
+--- types with their data constructors (if all data constructors are public),
+--- otherwise only the type constructors.
+--- The potential comments in function declarations are formatted as
+--- documentation comments.
+ppProg :: Options ->  Prog -> Doc
+ppProg opts (Prog m is ts fs os) = compose (<$+$>)
+  [ ppHeader  opts' m ts fs
+  , ppImports opts' is
+  , ppDecls   opts' os ts fs
+  ]
+ where opts' = opts { currentModule = m }
+
+ppHeader :: Options -> String -> [TypeDecl] -> [FuncDecl] -> Doc
+ppHeader opts m ts fs = indent $ sep
+  [ text "module" <+> text m
+  , ppExports opts ts fs
+  , text "where"
+  ]
+
+ppDecls :: Options -> [OpDecl] -> [TypeDecl] -> [FuncDecl] -> Doc
+ppDecls opts os ts fs = compose (<$+$>)
+  [ ppOpDecls        os
+  , ppTypeDecls opts ts
+  , ppFuncDecls opts fs
+  ]
+
+-- ---------------------------------------------------------------------------
+-- Module Header
+-- ---------------------------------------------------------------------------
+
+--- Create the export specification for a list of types and a list of functions.
+--- Note that for types all constructors are exported regardless of the Haskell
+--- export specification (= the visibility information of the constructors)
+--- because record update expressions have been previously desugared into
+--- case expressions mentioning all constructors belonging to the set of labels
+--- in the update. While the record update expression is valid in Curry even if
+--- the constructors are not imported (they are, at least implicitly), the case
+--- expression is only valid if all mentioned constructors are exported.
+--- Therefore, to avoid any GHC errors, we simply export all constructors.
+--- This should be no problem since imported entities are always used fully
+--- qualified after the translation process.
+--- (bjp, jrt 2015-03-04)
+ppExports :: Options -> [TypeDecl] -> [FuncDecl] -> Doc
+ppExports opts ts fs = tupledSpaced $ filter (not . isEmpty)
+                     $ map ppTypeExport ts ++ map ppFuncExport fs
+ where
+  ppTypeExport :: TypeDecl -> Doc
+  ppTypeExport (Type     qn vis _ _)
+    | vis == Public = ppQName opts qn <+> text "(..)"
+    | otherwise     = empty
+  ppTypeExport (TypeSyn  qn vis _ _)
+    | vis == Public = ppQName opts qn
+    | otherwise     = empty
+  ppTypeExport (Instance _  _   _ _) = empty
+
+  ppFuncExport :: FuncDecl -> Doc
+  ppFuncExport (Func _ qn _ vis _ _)
+    | vis == Public = ppPrefixQOp opts qn
+    | otherwise     = empty
+
+-- ---------------------------------------------------------------------------
+-- Imports + infix operator declarations
+-- ---------------------------------------------------------------------------
+
+ppImports :: Options -> [String] -> Doc
+ppImports opts = vsep . map (ppImport opts)
+
+ppImport :: Options -> String -> Doc
+ppImport opts imp
+    -- Import module qualified if required:
+  | qualImpModule opts imp = indent $ fillSep $ map text
+                               ["import", "qualified", imp]
+  | otherwise              = indent $ text "import" <+> text imp
+
+ppOpDecls :: [OpDecl] -> Doc
+ppOpDecls = vsep . map ppOpDecl
+
+ppOpDecl :: OpDecl -> Doc
+ppOpDecl (Op qn fix prec) = ppFixity fix <+> int prec <+> ppInfixOp (snd qn)
+
+ppFixity :: Fixity -> Doc
+ppFixity InfixOp  = text "infix"
+ppFixity InfixlOp = text "infixl"
+ppFixity InfixrOp = text "infixr"
+
+-- ---------------------------------------------------------------------------
+-- Type declarations
+-- ---------------------------------------------------------------------------
+
+--- pretty-print a list of AbstractHaskell type declarations
+ppTypeDecls :: Options -> [TypeDecl] -> Doc
+ppTypeDecls opts = compose (<$+$>) . map (ppTypeDecl opts)
+
+--- pretty-print an AbstractHaskell type declaration
+ppTypeDecl :: Options -> TypeDecl -> Doc
+ppTypeDecl opts (TypeSyn qname _ vs ty) = indent $
+   text "type" <+> ppName qname <+> fillSep (map ppTypeVar vs)
+               </> equals <+> ppTypeExp opts ty
+ppTypeDecl opts (Type    qname _ vs cs)
+  | null cs   = empty
+  | otherwise = indent $
+    (text "data" <+> ppName qname <+> fillSep (map ppTypeVar vs))
+    $$ ppConsDecls opts cs
+ppTypeDecl opts (Instance qname ty ctxts rs) = indent $
+  text "instance" <+> ppContexts opts ctxts
+    <+> ppQName opts qname <+> ppTypeExpr opts 2 ty
+    <+> (text "where" $$ vsep (map ppInstRule rs))
+ where ppInstRule ((_, f), r) = ppRule opts f  r
+
+--- pretty-print the constructor declarations
+ppConsDecls :: Options -> [ConsDecl] -> Doc
+ppConsDecls o cs = vsep $ zipWith (<+>) (equals : repeat bar)
+                                        (map (ppConsDecl o) cs)
+
+--- pretty print a single constructor declaration
+ppConsDecl :: Options -> ConsDecl -> Doc
+ppConsDecl o (Cons (_, qn) _ _ tys) = indent $ fillSep
+                                    $ ppPrefixOp qn : map (ppTypeExpr o 2) tys
+
+ppContexts :: Options -> [Context] -> Doc
+ppContexts opts cs
+  | null cs   = empty
+  | otherwise = tupled (map (ppContext opts) cs) <+> doubleArrow
+
+ppContext :: Options -> Context -> Doc
+ppContext opts (Context qn ts) = ppTypeExp opts (TCons qn ts)
+
+--- pretty a top-level type expression
+ppTypeExp :: Options -> TypeExpr -> Doc
+ppTypeExp o = ppTypeExpr o 0
+
+--- Shows an AbstractHaskell type expression in standard Haskell syntax.
+ppTypeExpr :: Options -> Int -> TypeExpr -> Doc
+ppTypeExpr _ _ (TVar           v) = ppTypeVar v
+ppTypeExpr o p (FuncType   t1 t2) = parensIf (p > 0) $
+  ppTypeExpr o 1 t1 </> rarrow <+> ppTypeExp o t2
+ppTypeExpr o p (TCons     qn tys)
+  | isList qn && length tys == 1 = brackets (ppTypeExp o (head tys))
+  | isTuple qn                   = tupled (map (ppTypeExp o) tys)
+  | otherwise                    = parensIf (p > 1 && not (null tys))
+                                 $ fillSep
+                                 $ ppQName o qn : map (ppTypeExpr o 2) tys
+ppTypeExpr o p (ForallType vs cx t) = parensIf (p > 0) $
+  text "forall" <+> fillSep (map ppTypeVar vs) <+> dot <+> ppContexts o cx <+> ppTypeExp o t
+
+ppTypeVar :: TVarIName -> Doc
+ppTypeVar (_, name) = text name
+
+-- ---------------------------------------------------------------------------
+-- Function Declaration
+-- ---------------------------------------------------------------------------
+
+ppFunc :: FuncDecl -> Doc
+ppFunc = ppFuncDecl defaultOptions
+
+ppFuncDecls :: Options -> [FuncDecl] -> Doc
+ppFuncDecls opts = compose (<$+$>) . map (ppFuncDecl opts)
+
+ppFuncDecl :: Options -> FuncDecl -> Doc
+ppFuncDecl opts (Func cmt (_,name) _ _ ty (Rules rs))
+  =  ppComment cmt
+  $$ indent (ppTypeSig opts name ty)
+  $$ vsep (map (ppRule opts name) rs)
+ppFuncDecl _    (Func _ _ _ _ _ External) = empty
+
+ppComment :: String -> Doc
+ppComment = vsep . map (\c -> text "---" <+> text c) . lines
+
+--- Shows an AbstractHaskell type signature of a given function name.
+ppTypeSig :: Options -> String -> TypeSig -> Doc
+ppTypeSig _    _ Untyped         = empty
+ppTypeSig opts f (CType ctxt ty) = hsep [ ppPrefixOp f, doubleColon
+                                        , ppScopedTyVars ty
+                                        , ppContexts opts ctxt
+                                        , ppTypeExp opts ty
+                                        ]
+
+ppScopedTyVars :: TypeExpr -> Doc
+ppScopedTyVars ty
+  | null tvs  = empty
+  | otherwise = text "forall" <+> fillSep (map ppTypeVar tvs) <+> dot
+  where tvs = tyVarsOf ty
+
+ppRule :: Options -> String -> Rule -> Doc
+ppRule opts f (Rule ps rhs ds) = indent $
+  hsep (ppPrefixOp f : map (ppPattern opts 1) ps)
+  <+> equals </> ppRhs opts rhs $$ ppLocalDecls opts ds
+
+ppRhs :: Options -> Rhs -> Doc
+ppRhs opts (SimpleRhs   e) = ppExpr opts 0 e
+ppRhs opts (GuardedRhs gs) = indent $ vsep (map (ppCond opts) gs)
+
+ppCond :: Options -> (Expr, Expr) -> Doc
+ppCond opts (c, e) = bar <+> ppExpr opts 0 c </> equals <+> ppExpr opts 0 e
+
+ppLocalDecls :: Options -> [LocalDecl] -> Doc
+ppLocalDecls opts ds
+  | null ds   = empty
+  | otherwise = text "where" $$ ppBlock opts ds
+
+ppBlock :: Options -> [LocalDecl] -> Doc
+ppBlock opts ds = align (vsep (map (ppLocalDecl opts) ds))
+
+ppLocalDecl :: Options -> LocalDecl -> Doc
+ppLocalDecl opts (LocalFunc     f) = ppFuncDecl opts f
+ppLocalDecl opts (LocalPat p e ds) = indent $
+  ppPattern opts 0 p <+> equals <+> ppExpr opts 0 e
+  $$ ppLocalDecls opts ds
+
+ppExp :: Expr -> Doc
+ppExp = ppExpr defaultOptions 0
+
+ppExpr :: Options -> Int -> Expr -> Doc
+ppExpr _    _ (Var               v) = ppVar v
+ppExpr _    _ (Lit               l) = ppLiteral l
+ppExpr opts _ (Symbol           op) = ppPrefixQOp opts op
+ppExpr opts p (Apply         e1 e2) = parensIf (p > 1) $
+  fillSep [ppExpr opts 1 e1, ppExpr opts 2 e2]
+ppExpr opts p (InfixApply e1 op e2) = parensIf (p > 0) $
+  fillSep [ppExpr opts 1 e1 <+> ppInfixQOp opts op, ppExpr opts 1 e2]
+ppExpr opts p (Lambda         ps e) = parensIf (p > 0) $
+  fillSep [ char '\\' <> hsep (map (ppPattern opts 1) ps) <+> rarrow
+          , ppExpr opts 0 e
+          ]
+ppExpr opts p (Let            ds e) = parensIf (p > 0) $
+  sep [text "let" <+> ppBlock opts ds, text "in" <+> ppExpr opts 0 e]
+ppExpr opts p (DoExpr          sts) = parensIf (p > 0) $
+  text "do" <+> vsep (map (ppStmt opts) sts)
+ppExpr opts _ (ListComp       e qs) = brackets $
+  ppExpr opts 0 e <+> bar <+> sequence (map (ppStmt opts) qs)
+ppExpr opts p (Case           e bs) = parensIf (p > 0)
+  (text "case" <+> ppExpr opts 0 e <+> text "of"
+  $$ align (vsep (map (ppBranchExpr opts) bs)))
+ppExpr opts p (Typed          e ty) = parensIf (p > 0) $
+  ppExpr opts 0 e <+> doubleColon <+> ppTypeExp opts ty
+ppExpr opts p (IfThenElse    c t e) = parensIf (p > 0) $
+  text "if" <+> fillSep [ ppExpr opts 0 c
+                        , text "then" <+> ppExpr opts 0 t
+                        , text "else" <+> ppExpr opts 0 e
+                        ]
+ppExpr opts _ (Tuple        es) = tupled (map (ppExpr opts 0) es)
+ppExpr opts _ (List         es) = list   (map (ppExpr opts 0) es)
+
+ppStmt :: Options -> Statement -> Doc
+ppStmt opts (SExpr  e) = ppExpr opts 0 e
+ppStmt opts (SPat p e) = fillSep [ppPattern opts 0 p, larrow, ppExpr opts 0 e]
+ppStmt opts (SLet  ds) = text "let" <+> ppBlock opts ds
+
+ppPattern :: Options -> Int -> Pattern -> Doc
+ppPattern _    _ (PVar     v) = ppVar v
+ppPattern opts _ (PLit     l) = ppLitPattern opts l
+ppPattern opts p (PComb c ts) = parensIf (p > 0 && not (null ts))
+                              $ hsep (ppQName opts c : map (ppPattern opts 1) ts)
+ppPattern opts _ (PAs    v t) = ppVar v <> at <> ppPattern opts 1 t
+ppPattern opts _ (PTuple  ts) = tupled (map (ppPattern opts 0) ts)
+ppPattern opts _ (PList   ts) = list   (map (ppPattern opts 0) ts)
+
+ppVar :: VarIName -> Doc
+ppVar (_, name) = text name
+
+ppLitPattern :: Options -> Literal -> Doc
+ppLitPattern _ l = ppLiteral l