module Language.Haskell.FreeTheorems.PrettyTypes where
import Text.PrettyPrint
import Language.Haskell.FreeTheorems.BasicSyntax
import Language.Haskell.FreeTheorems.PrettyBase
prettyDeclaration :: Declaration -> Doc
prettyDeclaration (TypeDecl decl) = prettyTypeDeclaration decl
prettyDeclaration (DataDecl decl) = prettyDataDeclaration decl
prettyDeclaration (NewtypeDecl decl) = prettyNewtypeDeclaration decl
prettyDeclaration (ClassDecl decl) = prettyClassDeclaration decl
prettyDeclaration (TypeSig decl) = prettySignature decl
instance Show Declaration where
show = show . prettyDeclaration
showList ds = (++) (show . vcat . map prettyDeclaration $ ds)
prettyTypeDeclaration :: TypeDeclaration -> Doc
prettyTypeDeclaration (Type ident vs t) =
isep 2 (
[text "type", prettyIdentifier ident]
++ map prettyTypeVariable vs
++ [text "=", prettyTypeExpression NoParens t])
instance Show TypeDeclaration where
show = show . prettyTypeDeclaration
prettyDataDeclaration :: DataDeclaration -> Doc
prettyDataDeclaration (Data ident vs ds) =
isep 4 [ isep 2 (
[text "data", prettyIdentifier ident]
++ (map prettyTypeVariable vs))
, vcat (zipWith (<+>) (char '=' : repeat (char '|'))
(map prettyDataConstructorDeclaration ds))]
instance Show DataDeclaration where
show = show . prettyDataDeclaration
prettyDataConstructorDeclaration :: DataConstructorDeclaration -> Doc
prettyDataConstructorDeclaration (DataCon ident bs) =
isep 2 $ [prettyIdentifier ident] ++ map prettyBangTypeExpression bs
instance Show DataConstructorDeclaration where
show = show . prettyDataConstructorDeclaration
prettyBangTypeExpression :: BangTypeExpression -> Doc
prettyBangTypeExpression (Banged t) = char '!'
<> prettyTypeExpression ParensFunOrCon t
prettyBangTypeExpression (Unbanged t) = prettyTypeExpression ParensFunOrCon t
instance Show BangTypeExpression where
show = show . prettyBangTypeExpression
prettyNewtypeDeclaration :: NewtypeDeclaration -> Doc
prettyNewtypeDeclaration (Newtype ident vs con t) =
isep 2 (
[text "newtype", prettyIdentifier ident]
++ map prettyTypeVariable vs
++ [char '=', prettyIdentifier con, prettyTypeExpression ParensFunOrCon t])
instance Show NewtypeDeclaration where
show = show . prettyNewtypeDeclaration
prettyClassDeclaration :: ClassDeclaration -> Doc
prettyClassDeclaration (Class scs ident tv sigs) =
let ctx = zip scs (repeat tv)
in isep 2 [text "class", prettyContext ctx, prettyIdentifier ident,
prettyTypeVariable tv,
if null sigs then empty else text "where"]
$$ nest 4 (vcat (map prettySignature sigs))
instance Show ClassDeclaration where
show = show . prettyClassDeclaration
prettySignature :: Signature -> Doc
prettySignature (Signature ident t) =
isep 2 [prettyIdentifier ident, text "::", prettyTypeExpression NoParens t]
instance Show Signature where
show = show . prettySignature
prettyContext :: [(TypeClass, TypeVariable)] -> Doc
prettyContext [] = empty
prettyContext ctx =
let prettyCV (c,v) = prettyTypeClass c <+> prettyTypeVariable v
in fsep (
(parensIf ((length ctx) > 1)
(fsep $ punctuate comma $ map prettyCV ctx))
: [text "=>"])
instance Show TypeExpression where
showsPrec d t =
let p = case d of
0 -> NoParens
1 -> ParensFun
otherwise -> ParensFunOrCon
in (++) (show (prettyTypeExpression p t))
prettyTypeExpression :: Parens -> TypeExpression -> Doc
prettyTypeExpression _ (TypeVar v) = prettyTypeVariable v
prettyTypeExpression _ (TypeCon ConUnit _) = prettyTypeConstructor ConUnit
prettyTypeExpression _ (TypeCon ConList [t]) =
brackets (prettyTypeExpression NoParens t)
prettyTypeExpression _ (TypeCon ConList []) = prettyTypeConstructor ConList
prettyTypeExpression _ (TypeCon ConList (_:_:_)) = brackets (text "...")
prettyTypeExpression _ (TypeCon (ConTuple _) ts) =
parens $ fsep $ punctuate comma $ map (prettyTypeExpression NoParens) ts
prettyTypeExpression _ (TypeCon ConInt _) = prettyTypeConstructor ConInt
prettyTypeExpression _ (TypeCon ConInteger _) = prettyTypeConstructor ConInteger
prettyTypeExpression _ (TypeCon ConFloat _) = prettyTypeConstructor ConFloat
prettyTypeExpression _ (TypeCon ConDouble _) = prettyTypeConstructor ConDouble
prettyTypeExpression _ (TypeCon ConChar _) = prettyTypeConstructor ConChar
prettyTypeExpression p (TypeCon (Con ident) ts) =
parensIf (p >= ParensFunOrCon && not (null ts)) $
isep 2 $ (prettyIdentifier ident)
: (map (prettyTypeExpression ParensFunOrCon) ts)
prettyTypeExpression p (TypeFun t1 t2) =
parensIf (p > NoParens) $
fsep (zipWith (<+>) (empty : repeat (text "->"))
(map (prettyTypeExpression ParensFun) (t1 : funs t2)))
where
funs (TypeFun t1 t2) = t1 : funs t2
funs t = [t]
prettyTypeExpression p (TypeFunLab t1 t2) =
parensIf (p > NoParens) $
fsep (zipWith (<+>) (empty : repeat (text "->"))
(map (prettyTypeExpression ParensFun) (t1 : funs t2)))
where
funs (TypeFunLab t1 t2) = t1 : funs t2
funs t = [t]
prettyTypeExpression p (TypeAbs v tcs t) =
let (vs, cx, t') = collectAbstractions v tcs t
in parensIf (p > NoParens) $
fsep $
[text "forall"] ++ (map prettyTypeVariable vs)
++ [char '.', prettyContext cx, prettyTypeExpression NoParens t']
prettyTypeExpression p (TypeAbsLab v tcs t) =
let (vs, cx, t') = collectAbstractions v tcs t
in parensIf (p > NoParens) $
fsep $
[text "forall"] ++ (map prettyTypeVariable vs)
++ [char '.', prettyContext cx, prettyTypeExpression NoParens t']
prettyTypeExpression p (TypeExp te) = prettyFixedTypeExpression te
collectAbstractions ::
TypeVariable
-> [TypeClass]
-> TypeExpression
-> ([TypeVariable], [(TypeClass, TypeVariable)], TypeExpression)
collectAbstractions v tcs t =
let cx = zip tcs (repeat v)
in case t of
TypeAbs v' tcs' t' ->
let (vs, cx', t'') = collectAbstractions v' tcs' t'
in (v : vs, cx ++ cx', t'')
TypeAbsLab v' tcs' t' ->
let (vs, cx', t'') = collectAbstractions v' tcs' t'
in (v : vs, cx ++ cx', t'')
otherwise -> ([v], cx, t)
prettyTypeConstructor :: TypeConstructor -> Doc
prettyTypeConstructor ConUnit = parens (empty)
prettyTypeConstructor ConList = brackets (empty)
prettyTypeConstructor (ConTuple n) =
parens . hcat . punctuate comma . take n . repeat $ empty
prettyTypeConstructor ConInt = text "Int"
prettyTypeConstructor ConInteger = text "Integer"
prettyTypeConstructor ConFloat = text "Float"
prettyTypeConstructor ConDouble = text "Double"
prettyTypeConstructor ConChar = text "Char"
prettyTypeConstructor (Con c) = prettyIdentifier c
prettyTypeVariable :: TypeVariable -> Doc
prettyTypeVariable (TV ident) = prettyIdentifier ident
instance Show TypeVariable where
show = show . prettyTypeVariable
prettyTypeClass :: TypeClass -> Doc
prettyTypeClass (TC ident) = prettyIdentifier ident
instance Show TypeClass where
show = show . prettyTypeClass
prettyFixedTypeExpression :: FixedTypeExpression -> Doc
prettyFixedTypeExpression (TF ident) = prettyIdentifier ident
instance Show FixedTypeExpression where
show = show . prettyFixedTypeExpression
prettyIdentifier :: Identifier -> Doc
prettyIdentifier (Ident i) = text i
instance Show Identifier where
show = show . prettyIdentifier