{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module IR.Pretty () where

import Common.Pretty
import Data.Char (GeneralCategory (..), generalCategory, isSpace)
import Data.List (dropWhileEnd)
import IR.IR
import IR.Types.Type (pattern Hole)


indents :: Doc ann -> Doc ann
indents :: Doc ann -> Doc ann
indents = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align


lineSep :: Doc ann -> Doc ann
lineSep :: Doc ann -> Doc ann
lineSep = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
forall ann. Doc ann
line


hardlineSep :: Doc ann -> Doc ann
hardlineSep :: Doc ann -> Doc ann
hardlineSep = Doc ann -> Doc ann -> Doc ann
forall a b. a -> b -> a
const Doc ann
forall ann. Doc ann
hardline


layoutBlock' :: Doc ann -> Doc ann
layoutBlock' :: Doc ann -> Doc ann
layoutBlock' Doc ann
d = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
indented Doc ann
oneLiner
 where
  oneLiner :: Doc ann
oneLiner = Doc ann
" " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d
  indented :: Doc ann
indented = Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
indents (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
indents Doc ann
d)


layoutBlock :: Doc ann -> Doc ann
layoutBlock :: Doc ann -> Doc ann
layoutBlock Doc ann
d = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
indented Doc ann
oneLiner
 where
  oneLiner :: Doc ann
oneLiner = Doc ann
" { " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" }"
  indented :: Doc ann
indented = Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
indents Doc ann
d


hardBlock :: Doc ann -> Doc ann
hardBlock :: Doc ann -> Doc ann
hardBlock Doc ann
d = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
indented Doc ann
oneLiner
 where
  oneLiner :: Doc ann
oneLiner = Doc ann
" " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d
  indented :: Doc ann
indented = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
indents Doc ann
d


hardvsep :: [Doc ann] -> Doc ann
hardvsep :: [Doc ann] -> Doc ann
hardvsep = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\Doc ann
x Doc ann
y -> Doc ann
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
y)


{- | Pretty Typeclass: pretty print the IR

Adds
* indentation and line breaks
* some parens (not minimal parens, but fewer than around every node)
Omits
* let _ =
* type annotations
Reverts
* curried funcs of one arg back to multiple arg funcs
-}
instance Pretty (Program Type) where
  pretty :: Program Type -> Doc ann
pretty Program{[(Binder Type, Expr Type)]
programDefs :: forall t. Program t -> [(Binder t, Expr t)]
programDefs :: [(Binder Type, Expr Type)]
programDefs, [(TConId, TypeDef)]
typeDefs :: forall t. Program t -> [(TConId, TypeDef)]
typeDefs :: [(TConId, TypeDef)]
typeDefs, [(VarId, Type)]
externDecls :: forall t. Program t -> [(VarId, Type)]
externDecls :: [(VarId, Type)]
externDecls, String
cDefs :: forall t. Program t -> String
cDefs :: String
cDefs} =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
      Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
line ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
        [[Doc ann]] -> [Doc ann]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [Doc ann]
forall ann. [Doc ann]
cDefsChunk
          , ((TConId, TypeDef) -> Doc ann) -> [(TConId, TypeDef)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (TConId, TypeDef) -> Doc ann
forall ann. (TConId, TypeDef) -> Doc ann
prettyTypDef [(TConId, TypeDef)]
typeDefs
          , ((VarId, Type) -> Doc ann) -> [(VarId, Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (VarId, Type) -> Doc ann
forall t ann. Pretty t => (VarId, t) -> Doc ann
prettyExternDecl [(VarId, Type)]
externDecls
          , ((Binder Type, Expr Type) -> Doc ann)
-> [(Binder Type, Expr Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Binder Type, Expr Type) -> Doc ann
forall ann. (Binder Type, Expr Type) -> Doc ann
prettyDef [(Binder Type, Expr Type)]
programDefs
          ]
   where
    cDefsChunk :: [Doc ann]
cDefsChunk
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace String
cDefs' = []
      | Bool
otherwise = [Doc ann
"$$$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
cDefs' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"$$$"]
    cDefs' :: String
cDefs' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isLineBreak (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isLineBreak String
cDefs
    isLineBreak :: Char -> Bool
isLineBreak (Char -> GeneralCategory
generalCategory -> GeneralCategory
LineSeparator) = Bool
True
    isLineBreak (Char -> GeneralCategory
generalCategory -> GeneralCategory
ParagraphSeparator) = Bool
True
    isLineBreak Char
'\n' = Bool
True
    isLineBreak Char
'\r' = Bool
True
    isLineBreak Char
_ = Bool
False

    prettyExternDecl :: (Pretty t) => (VarId, t) -> Doc ann
    prettyExternDecl :: (VarId, t) -> Doc ann
prettyExternDecl (VarId
v, t
t) = Doc ann
"extern" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
v Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> t -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty t
t

    -- Generates readable Doc representation of an IR Type Definition
    prettyTypDef :: (TConId, TypeDef) -> Doc ann
    prettyTypDef :: (TConId, TypeDef) -> Doc ann
prettyTypDef (TConId
tcon, TypeDef{variants :: TypeDef -> [(DConId, TypeVariant)]
variants = [(DConId, TypeVariant)]
vars}) =
      Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TConId
tcon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
indentNo ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((DConId, TypeVariant) -> Doc ann)
-> [(DConId, TypeVariant)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (DConId, TypeVariant) -> Doc ann
forall ann. (DConId, TypeVariant) -> Doc ann
prettyDCon [(DConId, TypeVariant)]
vars) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
    prettyDCon :: (DConId, TypeVariant) -> Doc ann
    prettyDCon :: (DConId, TypeVariant) -> Doc ann
prettyDCon (DConId
dcon, VariantNamed [(VarId, Type)]
argz) =
      DConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DConId
dcon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type -> Doc ann)
-> ((VarId, Type) -> Type) -> (VarId, Type) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarId, Type) -> Type
forall a b. (a, b) -> b
snd ((VarId, Type) -> Doc ann) -> [(VarId, Type)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VarId, Type)]
argz)
    prettyDCon (DConId
dcon, VariantUnnamed [Type]
argz) =
      DConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DConId
dcon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type -> Doc ann) -> [Type] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
argz)


prettyDef :: (Binder Type, Expr Type) -> Doc ann
prettyDef :: (Binder Type, Expr Type) -> Doc ann
prettyDef (Binder Type
v, Expr Type -> ([Binder Type], Expr Type)
forall t. Expr t -> ([Binder t], Expr t)
unfoldLambda -> ([], Expr Type
b)) = Bool -> Binder Type -> Doc ann
forall ann. Bool -> Binder Type -> Doc ann
prettyBinderTyped Bool
False Binder Type
v Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
b)
prettyDef (Binder Type
v, Expr Type -> ([Binder Type], Expr Type)
forall t. Expr t -> ([Binder t], Expr t)
unfoldLambda -> ([Binder Type]
as, Expr Type
b)) =
  let args :: Doc ann
args = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock' (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Binder Type -> Doc ann) -> [Binder Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Binder Type -> Doc ann
forall ann. Bool -> Binder Type -> Doc ann
prettyBinderTyped Bool
True) [Binder Type]
as
      t :: Type
t = Binder Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
extract Binder Type
v
      typeInfo :: Doc ann
typeInfo
        | Type -> Bool
hasTypeInfo Type
t = Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
t
        | Bool
otherwise = Doc ann
""
   in Binder Type -> Doc ann
forall a ann. Show a => Binder a -> Doc ann
prettyBinderUntyped Binder Type
v Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
args Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
typeInfo Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
b)


instance Pretty (Expr Type) where
  pretty :: Expr Type -> Doc ann
pretty = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettySeq


prettySeq :: Expr Type -> Doc ann
prettySeq :: Expr Type -> Doc ann
prettySeq (Let [(BindAnon Type
_, Expr Type
e)] Expr Type
b Type
_) = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyStm Expr Type
e Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
lineSep Doc ann
"; " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettySeq Expr Type
b
prettySeq (Let [(Binder Type, Expr Type)
d] Expr Type
b Type
_) = Doc ann
"let" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Binder Type, Expr Type) -> Doc ann
forall ann. (Binder Type, Expr Type) -> Doc ann
prettyDef (Binder Type, Expr Type)
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardlineSep Doc ann
"; " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettySeq Expr Type
b
prettySeq (Let [(Binder Type, Expr Type)]
ds Expr Type
b Type
_) = Doc ann
"let" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hardvsep (((Binder Type, Expr Type) -> Doc ann)
-> [(Binder Type, Expr Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Binder Type, Expr Type) -> Doc ann
forall ann. (Binder Type, Expr Type) -> Doc ann
prettyDef [(Binder Type, Expr Type)]
ds) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardlineSep Doc ann
"; " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettySeq Expr Type
b
prettySeq Expr Type
e = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyStm Expr Type
e


prettyStm :: Expr Type -> Doc ann
prettyStm :: Expr Type -> Doc ann
prettyStm (Prim Primitive
After [Expr Type
d, Expr Type
l, Expr Type
r] Type
_) = Doc ann
"after" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardBlock (Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
r)
prettyStm (Prim Primitive
Assign [Expr Type
l, Expr Type
r] Type
_) = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
hardBlock (Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
r)
prettyStm Expr Type
e = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
e


prettyOp :: Expr Type -> Doc ann
-- TODO: fix precedence and associativity here
prettyOp :: Expr Type -> Doc ann
prettyOp (Prim (PrimOp PrimOp
po) [Expr Type
o] Type
_) = PrimOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PrimOp
po Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
o
prettyOp (Prim (PrimOp PrimOp
po) [Expr Type
l, Expr Type
r] Type
_) = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PrimOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PrimOp
po Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
r
prettyOp Expr Type
e = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyBlk Expr Type
e


prettyBlk :: Expr Type -> Doc ann
prettyBlk :: Expr Type -> Doc ann
prettyBlk (Match Expr Type
s [(Alt Type, Expr Type)]
as Type
_) =
  Doc ann
"match" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyOp Expr Type
s Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
lineSep Doc ann
" | ") ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ ((Alt Type, Expr Type) -> Doc ann)
-> [(Alt Type, Expr Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Alt Type, Expr Type) -> Doc ann
forall ann. (Alt Type, Expr Type) -> Doc ann
prettyArm [(Alt Type, Expr Type)]
as)
prettyBlk e :: Expr Type
e@Lambda{} =
  let ([Binder Type]
as, Expr Type
b) = Expr Type -> ([Binder Type], Expr Type)
forall t. Expr t -> ([Binder t], Expr t)
unfoldLambda Expr Type
e
      args :: Doc ann
args = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Binder Type -> Doc ann) -> [Binder Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Binder Type -> Doc ann
forall ann. Bool -> Binder Type -> Doc ann
prettyBinderTyped Bool
True) [Binder Type]
as
   in Doc ann
"fun" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
args Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
b)
prettyBlk (Prim Primitive
Loop [Expr Type
b] Type
_) = Doc ann
"loop" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
b)
prettyBlk (Prim Primitive
Wait [Expr Type
e] Type
_) =
  Doc ann
"wait" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyApp Expr Type
e
prettyBlk (Prim Primitive
Wait [Expr Type]
es Type
_) =
  Doc ann
"wait" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
lineSep Doc ann
" || ") ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Expr Type -> Doc ann) -> [Expr Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Expr Type]
es)
prettyBlk (Prim Primitive
Par [Expr Type
e] Type
_) =
  Doc ann
"par" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyApp Expr Type
e
prettyBlk (Prim Primitive
Par [Expr Type]
es Type
_) =
  Doc ann
"par" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
lineSep Doc ann
" || ") ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Expr Type -> Doc ann) -> [Expr Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Expr Type]
es)
prettyBlk (Prim Primitive
Drop [Expr Type
e, Expr Type
r] Type
_) =
  Doc ann
"%do" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
e) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"%dropping" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
r
prettyBlk (Prim (CCall CSym
s) [Expr Type]
es Type
_) = Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CSym -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CSym
s Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
", " ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Expr Type -> Doc ann) -> [Expr Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Expr Type]
es)
prettyBlk Expr Type
e = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyApp Expr Type
e


prettyArm :: (Alt Type, Expr Type) -> Doc ann
prettyArm :: (Alt Type, Expr Type) -> Doc ann
prettyArm (Alt Type
a, Expr Type
e) = Alt Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Alt Type
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock (Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
e))


prettyApp :: Expr Type -> Doc ann
prettyApp :: Expr Type -> Doc ann
prettyApp (Prim (FfiCall VarId
s) [Expr Type]
es Type
_) = VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
s Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Expr Type -> Doc ann) -> [Expr Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom [Expr Type]
es)
prettyApp (Prim Primitive
New [Expr Type
e] Type
_) = Doc ann
"new" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
e
prettyApp (Prim Primitive
Deref [Expr Type
e] Type
_) = Doc ann
"deref" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
e
prettyApp (Prim Primitive
Dup [Expr Type
r] Type
_) = Doc ann
"%dup" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
r
prettyApp (Exception ExceptType
et Type
_) = Doc ann
"%exception" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ExceptType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExceptType
et
prettyApp e :: Expr Type
e@App{} =
  let (Expr Type
f, ((Expr Type, Type) -> Expr Type)
-> [(Expr Type, Type)] -> [Expr Type]
forall a b. (a -> b) -> [a] -> [b]
map (Expr Type, Type) -> Expr Type
forall a b. (a, b) -> a
fst -> [Expr Type]
as) = Expr Type -> (Expr Type, [(Expr Type, Type)])
forall t. Expr t -> (Expr t, [(Expr t, t)])
unfoldApp Expr Type
e
   in Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
f Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
layoutBlock' ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Expr Type -> Doc ann) -> [Expr Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom [Expr Type]
as)
prettyApp Expr Type
e = Expr Type -> Doc ann
forall ann. Expr Type -> Doc ann
prettyAtom Expr Type
e


prettyAtom :: Expr Type -> Doc ann
prettyAtom :: Expr Type -> Doc ann
prettyAtom (Var VarId
v Type
_) = VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
v
prettyAtom (Lit Literal
l Type
_) = Literal -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Literal
l
prettyAtom (Data DConId
d Type
_) = DConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DConId
d
prettyAtom (Prim Primitive
Break [Expr Type]
_ Type
_) = Doc ann
"break"
prettyAtom (Prim (CQuote String
c) [Expr Type]
_ Type
_) = Doc ann
"$$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
c Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"$$"
prettyAtom Expr Type
e = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Expr Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr Type
e


instance Pretty ExceptType where
  pretty :: ExceptType -> Doc ann
pretty (ExceptDefault Literal
l) = Literal -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Literal
l


instance Pretty (Alt Type) where
  pretty :: Alt Type -> Doc ann
pretty (AltData DConId
d [] Type
_) = DConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DConId
d
  pretty (AltData DConId
d [Alt Type]
as Type
_) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ DConId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty DConId
d Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Alt Type -> Doc ann) -> [Alt Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Alt Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Alt Type]
as)
  pretty (AltLit Literal
a Type
_) = Literal -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Literal
a
  pretty (AltBinder Binder Type
b) = Binder Type -> Doc ann
forall a ann. Show a => Binder a -> Doc ann
prettyBinderUntyped Binder Type
b


instance Pretty Literal where
  pretty :: Literal -> Doc ann
pretty (LitIntegral Integer
i) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i
  pretty Literal
LitEvent = Doc ann
"()"


instance Pretty PrimOp where
  pretty :: PrimOp -> Doc ann
pretty PrimOp
PrimNeg = Doc ann
"-"
  pretty PrimOp
PrimNot = Doc ann
"!"
  pretty PrimOp
PrimBitNot = Doc ann
"~"
  pretty PrimOp
PrimAdd = Doc ann
"+"
  pretty PrimOp
PrimSub = Doc ann
"-"
  pretty PrimOp
PrimMul = Doc ann
"*"
  pretty PrimOp
PrimDiv = Doc ann
"/"
  pretty PrimOp
PrimMod = Doc ann
"%"
  pretty PrimOp
PrimBitAnd = Doc ann
"&"
  pretty PrimOp
PrimBitOr = Doc ann
"|"
  pretty PrimOp
PrimEq = Doc ann
"=="
  pretty PrimOp
PrimNeq = Doc ann
"!="
  pretty PrimOp
PrimGt = Doc ann
">"
  pretty PrimOp
PrimGe = Doc ann
">="
  pretty PrimOp
PrimLt = Doc ann
"<"
  pretty PrimOp
PrimLe = Doc ann
"<="


-- | Pretty-print a binder, never with type information.
prettyBinderUntyped :: Show a => Binder a -> Doc ann
prettyBinderUntyped :: Binder a -> Doc ann
prettyBinderUntyped (BindVar VarId
v a
_) = VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
v
prettyBinderUntyped (BindAnon a
_) = Doc ann
"_"


{- | Pretty-print a binder.

 Only print type info if it's useful (not just a hole).
-}
prettyBinderTyped :: Bool -> Binder Type -> Doc ann
prettyBinderTyped :: Bool -> Binder Type -> Doc ann
prettyBinderTyped Bool
needsParen (BindVar VarId
v Type
t)
  | Type -> Bool
hasTypeInfo Type
t = (if Bool
needsParen then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens else Doc ann -> Doc ann
forall a. a -> a
id) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
v Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
t
  | Bool
otherwise = VarId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VarId
v
prettyBinderTyped Bool
needsParen (BindAnon Type
t)
  | Type -> Bool
hasTypeInfo Type
t = (if Bool
needsParen then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens else Doc ann -> Doc ann
forall a. a -> a
id) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"_:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
t
  | Bool
otherwise = Doc ann
"_"


-- | Whether a 'Type' has any information worth printing out.
hasTypeInfo :: Type -> Bool
hasTypeInfo :: Type -> Bool
hasTypeInfo Type
Hole = Bool
False
hasTypeInfo Type
_ = Bool
True