Commit 497d3b23 authored by Michael Hanus's avatar Michael Hanus
Browse files

abstract-haskell packaged

parents
*~
.cpm
.curry
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.
abstract-haskell
================
This package contains libraries with data types to
represent Haskell programs in Curry and show them in
standard Haskell syntax.
{
"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" ]
}
------------------------------------------------------------------------
--- 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
------------------------------------------------------------------------------
--- 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