{-# LANGUAGE GADTs
, OverloadedStrings
, KindSignatures
, DataKinds
, FlexibleContexts
, UndecidableInstances
, LambdaCase
#-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Language.Hakaru.Pretty.Haskell
(
pretty
, prettyString
, prettyPrec
, prettyAssoc
, prettyPrecAssoc
, prettyType
, ppVariable
, ppVariables
, ppBinder
, ppCoerceTo
, ppUnsafeFrom
, ppRatio
, Associativity(..)
, ppBinop
, Pretty(..)
) where
import Data.Ratio
import Text.PrettyPrint (Doc, (<>), (<+>))
import qualified Text.PrettyPrint as PP
import qualified Data.Foldable as F
import qualified Data.List.NonEmpty as L
import qualified Data.Text as Text
import qualified Data.Sequence as Seq
import Prelude hiding ((<>))
import Data.Number.Nat (fromNat)
import Data.Number.Natural (fromNatural)
import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, List1(..)
,Foldable21(..))
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Types.Coercion
import Language.Hakaru.Types.HClasses
import Language.Hakaru.Types.Sing
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Syntax.Datum
import Language.Hakaru.Syntax.Reducer
import Language.Hakaru.Syntax.ABT
pretty :: (ABT Term abt) => abt '[] a -> Doc
pretty :: abt '[] a -> Doc
pretty = Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
0
prettyString :: (ABT Term abt)
=> Sing a
-> abt '[] a
-> Doc
prettyString :: Sing a -> abt '[] a -> Doc
prettyString Sing a
typ abt '[] a
ast =
String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack ([Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
header [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ String -> Text
Text.pack (String -> Sing a -> abt '[] a -> String
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
String -> Sing a -> abt '[] a -> String
prettyProg String
"prog" Sing a
typ abt '[] a
ast)])
prettyProg :: (ABT Term abt)
=> String
-> Sing a
-> abt '[] a
-> String
prettyProg :: String -> Sing a -> abt '[] a -> String
prettyProg String
name Sing a
typ abt '[] a
ast =
Style -> Doc -> String
PP.renderStyle Style
PP.style
( [Doc] -> Doc
PP.sep [String -> Doc
PP.text (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::"), Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
typ)]
Doc -> Doc -> Doc
PP.$+$ [Doc] -> Doc
PP.sep [String -> Doc
PP.text (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =") , Int -> Doc -> Doc
PP.nest Int
2 (abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
ast)] )
prettyPrec :: (ABT Term abt) => Int -> abt '[] a -> Doc
prettyPrec :: Int -> abt '[] a -> Doc
prettyPrec Int
p = [Doc] -> Doc
toDoc ([Doc] -> Doc) -> (abt '[] a -> [Doc]) -> abt '[] a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LC_ abt a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
p (LC_ abt a -> [Doc])
-> (abt '[] a -> LC_ abt a) -> abt '[] a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_
prettyAssoc :: (ABT Term abt) => Assoc (abt '[]) -> Doc
prettyAssoc :: Assoc (abt '[]) -> Doc
prettyAssoc = Int -> Assoc (abt '[]) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Int -> Assoc (abt '[]) -> Doc
prettyPrecAssoc Int
0
prettyPrecAssoc :: (ABT Term abt) => Int -> Assoc (abt '[]) -> Doc
prettyPrecAssoc :: Int -> Assoc (abt '[]) -> Doc
prettyPrecAssoc Int
p (Assoc Variable a
x abt '[] a
e) =
[Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"Assoc"
[ Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
ppVariable Variable a
x
, Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
11 abt '[] a
e
]
prettyType :: Sing (a :: Hakaru) -> Doc
prettyType :: Sing a -> Doc
prettyType Sing a
SInt = String -> Doc
PP.text String
"Int"
prettyType Sing a
SNat = String -> Doc
PP.text String
"Int"
prettyType Sing a
SReal = String -> Doc
PP.text String
"Double"
prettyType Sing a
SProb = String -> Doc
PP.text String
"Prob"
prettyType (SArray t) =
let t' :: Doc
t' = Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t) in
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [String -> Doc
PP.text String
"MayBoxVec", Doc
t', Doc
t'])
prettyType (SMeasure t) =
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [String -> Doc
PP.text String
"Measure", Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t)])
prettyType (SFun t1 t2) =
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t1 Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"->", Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
t2])
prettyType (SData _ (SDone `SPlus` SVoid)) =
String -> Doc
PP.text String
"()"
prettyType (SData _ (SDone `SPlus` SDone `SPlus` SVoid)) =
String -> Doc
PP.text String
"Bool"
prettyType (SData _ (SDone `SPlus` (SKonst t `SEt` SDone) `SPlus` SVoid)) =
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [String -> Doc
PP.text String
"Maybe", Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t)])
prettyType (SData _ ((SKonst t1 `SEt` SDone) `SPlus`
(SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [String -> Doc
PP.text String
"Either", Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t1),
Int -> Doc -> Doc
PP.nest Int
2 (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t2)])
prettyType (SData _ ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
Doc -> Doc
PP.parens ([Doc] -> Doc
PP.sep [Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t1 Doc -> Doc -> Doc
<> Doc
PP.comma, Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
t2])
prettyType Sing a
s = String -> Doc
forall a. HasCallStack => String -> a
error (String
"TODO: prettyType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall a. Show a => a -> String
show Sing a
s)
class Pretty (f :: Hakaru -> *) where
prettyPrec_ :: Int -> f a -> Docs
type Docs = [Doc]
toDoc :: Docs -> Doc
toDoc :: [Doc] -> Doc
toDoc = [Doc] -> Doc
PP.sep
ppVariable :: Variable (a :: Hakaru) -> Doc
ppVariable :: Variable a -> Doc
ppVariable Variable a
x = Doc
hint Doc -> Doc -> Doc
<> (Int -> Doc
PP.int (Int -> Doc) -> (Variable a -> Int) -> Variable a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Int
fromNat (Nat -> Int) -> (Variable a -> Nat) -> Variable a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable a -> Nat
forall k (a :: k). Variable a -> Nat
varID) Variable a
x
where
hint :: Doc
hint
| Text -> Bool
Text.null (Variable a -> Text
forall k (a :: k). Variable a -> Text
varHint Variable a
x) = Char -> Doc
PP.char Char
'x'
| Bool
otherwise = (String -> Doc
PP.text (String -> Doc) -> (Variable a -> String) -> Variable a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Variable a -> Text) -> Variable a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable a -> Text
forall k (a :: k). Variable a -> Text
varHint) Variable a
x
ppVariables :: List1 Variable (xs :: [Hakaru]) -> Docs
ppVariables :: List1 Variable xs -> [Doc]
ppVariables = [Doc] -> [Doc]
ppList ([Doc] -> [Doc])
-> (List1 Variable xs -> [Doc]) -> List1 Variable xs -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Variable xs -> [Doc]
forall (xs :: [Hakaru]). List1 Variable xs -> [Doc]
go
where
go :: List1 Variable (xs :: [Hakaru]) -> Docs
go :: List1 Variable xs -> [Doc]
go List1 Variable xs
Nil1 = []
go (Cons1 Variable x
x List1 Variable xs
xs) = Variable x -> Doc
forall (a :: Hakaru). Variable a -> Doc
ppVariable Variable x
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: List1 Variable xs -> [Doc]
forall (xs :: [Hakaru]). List1 Variable xs -> [Doc]
go List1 Variable xs
xs
ppBinder :: (ABT Term abt) => abt xs a -> Docs
ppBinder :: abt xs a -> [Doc]
ppBinder abt xs a
e =
case abt xs a -> ([Doc], [Doc])
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> ([Doc], [Doc])
ppViewABT abt xs a
e of
([], [Doc]
body) -> [Doc]
body
([Doc]
vars,[Doc]
body) -> Char -> Doc
PP.char Char
'\\' Doc -> Doc -> Doc
<+> [Doc] -> Doc
PP.sep [Doc]
vars Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"->" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
body
ppUncurryBinder :: (ABT Term abt) => abt xs a -> Docs
ppUncurryBinder :: abt xs a -> [Doc]
ppUncurryBinder abt xs a
e =
case abt xs a -> ([Doc], [Doc])
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> ([Doc], [Doc])
ppViewABT abt xs a
e of
([Doc]
vars,[Doc]
body) -> Char -> Doc
PP.char Char
'\\' Doc -> Doc -> Doc
<+> [Doc] -> Doc
unc [Doc]
vars Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"->" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
body
where
unc :: [Doc] -> Doc
unc :: [Doc] -> Doc
unc [] = String -> Doc
PP.text String
"()"
unc (Doc
x:[Doc]
xs) = Doc -> Doc
PP.parens (Doc
x Doc -> Doc -> Doc
<> Doc
PP.comma Doc -> Doc -> Doc
<> [Doc] -> Doc
unc [Doc]
xs)
ppViewABT :: (ABT Term abt) => abt xs a -> ([Doc], Docs)
ppViewABT :: abt xs a -> ([Doc], [Doc])
ppViewABT abt xs a
e = [Doc] -> View (Term abt) xs a -> ([Doc], [Doc])
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
[Doc] -> View (Term abt) xs a -> ([Doc], [Doc])
go [] (abt xs a -> View (Term abt) xs a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> View (syn abt) xs a
viewABT abt xs a
e)
where
go :: (ABT Term abt) => [Doc] -> View (Term abt) xs a -> ([Doc],Docs)
go :: [Doc] -> View (Term abt) xs a -> ([Doc], [Doc])
go [Doc]
xs (Syn Term abt a
t) = ([Doc] -> [Doc]
forall a. [a] -> [a]
reverse [Doc]
xs, Int -> LC_ abt a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
0 (abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ (Term abt a -> abt '[] a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn Term abt a
t)))
go [Doc]
xs (Var Variable a
x) = ([Doc] -> [Doc]
forall a. [a] -> [a]
reverse [Doc]
xs, [Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
ppVariable Variable a
x])
go [Doc]
xs (Bind Variable a
x View (Term abt) xs a
v) =
let x' :: Doc
x' = if Bool
True
then Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
ppVariable Variable a
x
else Char -> Doc
PP.char Char
'_'
in [Doc] -> View (Term abt) xs a -> ([Doc], [Doc])
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
[Doc] -> View (Term abt) xs a -> ([Doc], [Doc])
go (Doc
x' Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
xs) View (Term abt) xs a
v
instance (ABT Term abt) => Pretty (LC_ abt) where
prettyPrec_ :: Int -> LC_ abt a -> [Doc]
prettyPrec_ Int
p (LC_ abt '[] a
e) =
abt '[] a
-> (Variable a -> [Doc]) -> (Term abt a -> [Doc]) -> [Doc]
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn abt '[] a
e ((Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[]) (Doc -> [Doc]) -> (Variable a -> Doc) -> Variable a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
ppVariable) ((Term abt a -> [Doc]) -> [Doc]) -> (Term abt a -> [Doc]) -> [Doc]
forall a b. (a -> b) -> a -> b
$ \Term abt a
t ->
case Term abt a
t of
SCon args a
o :$ SArgs abt args
es -> Int -> SCon args a -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *)
(args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
ABT Term abt =>
Int -> SCon args a -> SArgs abt args -> [Doc]
ppSCon Int
p SCon args a
o SArgs abt args
es
NaryOp_ NaryOp a
o Seq (abt '[] a)
es ->
let prettyNaryOp :: NaryOp a -> (String, Int, Maybe String)
prettyNaryOp :: NaryOp a -> (String, Int, Maybe String)
prettyNaryOp NaryOp a
And = (String
"&&", Int
3, String -> Maybe String
forall a. a -> Maybe a
Just String
"true")
prettyNaryOp NaryOp a
Or = (String
"||", Int
2, String -> Maybe String
forall a. a -> Maybe a
Just String
"false")
prettyNaryOp NaryOp a
Xor = (String
"`xor`", Int
0, String -> Maybe String
forall a. a -> Maybe a
Just String
"false")
prettyNaryOp NaryOp a
Iff = (String
"`iff`", Int
0, String -> Maybe String
forall a. a -> Maybe a
Just String
"true")
prettyNaryOp (Min HOrd a
_) = (String
"`min`", Int
5, Maybe String
forall a. Maybe a
Nothing)
prettyNaryOp (Max HOrd a
_) = (String
"`max`", Int
5, Maybe String
forall a. Maybe a
Nothing)
prettyNaryOp (Sum HSemiring a
_) = (String
"+", Int
6, String -> Maybe String
forall a. a -> Maybe a
Just String
"zero")
prettyNaryOp (Prod HSemiring a
_) = (String
"*", Int
7, String -> Maybe String
forall a. a -> Maybe a
Just String
"one")
in
let (String
opName,Int
opPrec,Maybe String
maybeIdentity) = NaryOp a -> (String, Int, Maybe String)
forall (a :: Hakaru). NaryOp a -> (String, Int, Maybe String)
prettyNaryOp NaryOp a
o in
if Seq (abt '[] a) -> Bool
forall a. Seq a -> Bool
Seq.null Seq (abt '[] a)
es
then
case Maybe String
maybeIdentity of
Just String
identity -> [String -> Doc
PP.text String
identity]
Maybe String
Nothing ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"syn"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"NaryOp_"
[ String -> Doc
PP.text (Int -> NaryOp a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 NaryOp a
o String
"")
, String -> Doc
PP.text String
"(Seq.fromList [])"
]]
else
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
opPrec)
([Doc] -> [Doc]) -> ([abt '[] a] -> [Doc]) -> [abt '[] a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
PP.punctuate (Doc
PP.space Doc -> Doc -> Doc
<> String -> Doc
PP.text String
opName)
([Doc] -> [Doc]) -> ([abt '[] a] -> [Doc]) -> [abt '[] a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (abt '[] a -> Doc) -> [abt '[] a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
opPrec)
([abt '[] a] -> [Doc]) -> [abt '[] a] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Seq (abt '[] a) -> [abt '[] a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (abt '[] a)
es
Literal_ Literal a
v -> Int -> Literal a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
p Literal a
v
Empty_ Sing ('HArray a)
_ -> [String -> Doc
PP.text String
"empty"]
Array_ abt '[] 'HNat
e1 abt '[ 'HNat] a
e2 ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"array"
[ abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] 'HNat
e1 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$'
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ abt '[ 'HNat] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt '[ 'HNat] a
e2
]
ArrayLiteral_ [abt '[] a]
es -> Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"arrayLit" ([Doc] -> [Doc]
ppList ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (abt '[] a -> Doc) -> [abt '[] a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
0) [abt '[] a]
es)
Datum_ Datum (abt '[]) (HData' t)
d -> Int -> Datum (LC_ abt) (HData' t) -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
p ((forall (i :: Hakaru). abt '[] i -> LC_ abt i)
-> Datum (abt '[]) (HData' t) -> Datum (LC_ abt) (HData' t)
forall k1 k2 (f :: (k1 -> *) -> k2 -> *) (a :: k1 -> *)
(b :: k1 -> *) (j :: k2).
Functor11 f =>
(forall (i :: k1). a i -> b i) -> f a j -> f b j
fmap11 forall (i :: Hakaru). abt '[] i -> LC_ abt i
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ Datum (abt '[]) (HData' t)
d)
Case_ abt '[] a
e1 [Branch a abt a]
bs ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"case_"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] a
e1
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
ppList ((Branch a abt a -> Doc) -> [Branch a abt a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Doc] -> Doc
toDoc ([Doc] -> Doc)
-> (Branch a abt a -> [Doc]) -> Branch a abt a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Branch a abt a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
0) [Branch a abt a]
bs)
]
Bucket abt '[] 'HNat
b abt '[] 'HNat
ee Reducer abt '[] a
r ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"bucket"
[ abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] 'HNat
b
, abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] 'HNat
ee
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (Int -> Reducer abt '[] a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
p Reducer abt '[] a
r)
]
Superpose_ NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
pes ->
case NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
pes of
(abt '[] 'HProb
e1,abt '[] ('HMeasure a)
e2) L.:| [] ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"pose"
[ abt '[] 'HProb -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] 'HProb
e1 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$'
, abt '[] ('HMeasure a) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] ('HMeasure a)
e2
]
NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
_ ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"superpose"
[ [Doc] -> Doc
toDoc
([Doc] -> Doc)
-> ([(abt '[] 'HProb, abt '[] ('HMeasure a))] -> [Doc])
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Doc]
ppList
([Doc] -> [Doc])
-> ([(abt '[] 'HProb, abt '[] ('HMeasure a))] -> [Doc])
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((abt '[] 'HProb, abt '[] ('HMeasure a)) -> Doc)
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(abt '[] 'HProb
e1,abt '[] ('HMeasure a)
e2) -> [Doc] -> Doc
ppTuple [abt '[] 'HProb -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HProb
e1, abt '[] ('HMeasure a) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] ('HMeasure a)
e2])
([(abt '[] 'HProb, abt '[] ('HMeasure a))] -> Doc)
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))] -> Doc
forall a b. (a -> b) -> a -> b
$ NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
pes
]
Reject_ Sing ('HMeasure a)
_ -> [String -> Doc
PP.text String
"reject"]
ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Docs
ppSCon :: Int -> SCon args a -> SArgs abt args -> [Doc]
ppSCon Int
p SCon args a
Lam_ = \(abt vars a
e1 :* SArgs abt args
End) ->
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
adjustHead (String -> Doc
PP.text String
"lam $" Doc -> Doc -> Doc
<+>) (abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e1)
ppSCon Int
p SCon args a
App_ = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"`app`" Int
9 Associativity
LeftAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppSCon Int
p SCon args a
Let_ = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
(Doc -> Doc) -> [Doc] -> [Doc]
adjustHead
(String -> Doc
PP.text String
"let_" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$' Doc -> Doc -> Doc
<+>)
(abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e2)
ppSCon Int
p (PrimOp_ PrimOp typs a
o) = \SArgs abt args
es -> Int -> PrimOp typs a -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
(args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
Int -> PrimOp typs a -> SArgs abt args -> [Doc]
ppPrimOp Int
p PrimOp typs a
o SArgs abt args
es
ppSCon Int
p (ArrayOp_ ArrayOp typs a
o) = \SArgs abt args
es -> Int -> ArrayOp typs a -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
(args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
Int -> ArrayOp typs a -> SArgs abt args -> [Doc]
ppArrayOp Int
p ArrayOp typs a
o SArgs abt args
es
ppSCon Int
p (CoerceTo_ Coercion a a
c) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> Coercion a a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> Coercion a b -> abt '[] a -> [Doc]
ppCoerceTo Int
p Coercion a a
c abt vars a
abt '[] a
e1
ppSCon Int
p (UnsafeFrom_ Coercion a b
c) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> Coercion a b -> abt '[] b -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> Coercion a b -> abt '[] b -> [Doc]
ppUnsafeFrom Int
p Coercion a b
c abt vars a
abt '[] b
e1
ppSCon Int
p (MeasureOp_ MeasureOp typs a
o) = \SArgs abt args
es -> Int -> MeasureOp typs a -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
(args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
Int -> MeasureOp typs a -> SArgs abt args -> [Doc]
ppMeasureOp Int
p MeasureOp typs a
o SArgs abt args
es
ppSCon Int
p SCon args a
Dirac = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"dirac" abt vars a
abt '[] a
e1
ppSCon Int
p SCon args a
MBind = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
(Doc -> Doc) -> [Doc] -> [Doc]
adjustHead
(Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
1 abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
">>=" Doc -> Doc -> Doc
<+>)
(abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e2)
ppSCon Int
p (Transform_ Transform args a
t) = Int -> Transform args a -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *)
(args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
ABT Term abt =>
Int -> Transform args a -> SArgs abt args -> [Doc]
ppTransform Int
p Transform args a
t
ppSCon Int
p SCon args a
Integrate = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"integrate"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e3)
]
ppSCon Int
p (Summate HDiscrete a
_ HSemiring a
_) = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"summate"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e3)
]
ppSCon Int
p (Product HDiscrete a
_ HSemiring a
_) = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"product"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e3)
]
ppSCon Int
_ SCon args a
Plate = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"plate"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$'
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e2
]
ppSCon Int
_ SCon args a
Chain = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"chain"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$'
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e3
]
ppTransform :: (ABT Term abt)
=> Int -> Transform args a -> SArgs abt args -> Docs
ppTransform :: Int -> Transform args a -> SArgs abt args -> [Doc]
ppTransform Int
p Transform args a
t SArgs abt args
es =
case Transform args a
t of
Transform args a
Expect ->
case SArgs abt args
es of
abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End ->
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
(Doc -> Doc) -> [Doc] -> [Doc]
adjustHead
(String -> Doc
PP.text String
"expect" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> Char -> Doc
PP.char Char
'$' Doc -> Doc -> Doc
<+>)
(abt vars a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt vars a
e2)
Transform args a
_ -> Int -> String -> SArgs abt args -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *)
(as :: [([Hakaru], Hakaru)]).
ABT Term abt =>
Int -> String -> SArgs abt as -> [Doc]
ppApply Int
p (Transform args a -> String
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
Transform args a -> String
transformName Transform args a
t) SArgs abt args
es
ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Docs
ppCoerceTo :: Int -> Coercion a b -> abt '[] a -> [Doc]
ppCoerceTo =
\Int
p Coercion a b
c abt '[] a
e -> Int -> String -> [Doc] -> [Doc]
ppFun Int
p (Coercion a b -> String
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> String
prettyShow Coercion a b
c) [abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] a
e]
where
prettyShow :: Coercion a b -> String
prettyShow (CCons (Signed HRing b
HRing_Real) Coercion b b
CNil) = String
"fromProb"
prettyShow (CCons (Signed HRing b
HRing_Int) Coercion b b
CNil) = String
"nat2int"
prettyShow (CCons (Continuous HContinuous b
HContinuous_Real) Coercion b b
CNil) = String
"fromInt"
prettyShow (CCons (Continuous HContinuous b
HContinuous_Prob) Coercion b b
CNil) = String
"nat2prob"
prettyShow (CCons (Continuous HContinuous b
HContinuous_Prob)
(CCons (Signed HRing b
HRing_Real) Coercion b b
CNil)) = String
"nat2real"
prettyShow (CCons (Signed HRing b
HRing_Int)
(CCons (Continuous HContinuous b
HContinuous_Real) Coercion b b
CNil)) = String
"nat2real"
prettyShow Coercion a b
c = String
"coerceTo_ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Coercion a b -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Coercion a b
c String
""
ppUnsafeFrom :: ABT Term abt => Int -> Coercion a b -> abt '[] b -> Docs
ppUnsafeFrom :: Int -> Coercion a b -> abt '[] b -> [Doc]
ppUnsafeFrom =
\Int
p Coercion a b
c abt '[] b
e -> Int -> String -> [Doc] -> [Doc]
ppFun Int
p (Coercion a b -> String
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> String
prettyShow Coercion a b
c) [abt '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] b
e]
where
prettyShow :: Coercion a b -> String
prettyShow (CCons (Signed HRing b
HRing_Real) Coercion b b
CNil) = String
"unsafeProb"
prettyShow (CCons (Signed HRing b
HRing_Int) Coercion b b
CNil) = String
"unsafeNat"
prettyShow Coercion a b
c = String
"unsafeFrom_ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Coercion a b -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Coercion a b
c String
""
ppPrimOp
:: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
=> Int -> PrimOp typs a -> SArgs abt args -> Docs
ppPrimOp :: Int -> PrimOp typs a -> SArgs abt args -> [Doc]
ppPrimOp Int
p PrimOp typs a
Not = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"not" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Impl = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"syn"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"Impl"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
]]
ppPrimOp Int
p PrimOp typs a
Diff = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"syn"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String -> [Doc] -> [Doc]
ppFun Int
11 String
"Diff"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
]]
ppPrimOp Int
p PrimOp typs a
Nand = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"nand" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p PrimOp typs a
Nor = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"nor" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
_ PrimOp typs a
Pi = \SArgs abt args
End -> [String -> Doc
PP.text String
"pi"]
ppPrimOp Int
p PrimOp typs a
Sin = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"sin" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Cos = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"cos" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Tan = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"tan" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Asin = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"asin" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Acos = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"acos" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Atan = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"atan" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Sinh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"sinh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Cosh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"cosh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Tanh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"tanh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Asinh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"asinh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Acosh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"acosh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Atanh = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"atanh" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
RealPow = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"**" Int
8 Associativity
RightAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p PrimOp typs a
Choose = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"choose" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p PrimOp typs a
Exp = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"exp" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Log = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"log" abt vars a
abt '[] a
e1
ppPrimOp Int
_ (Infinity HIntegrable a
_) = \SArgs abt args
End -> [String -> Doc
PP.text String
"infinity"]
ppPrimOp Int
p PrimOp typs a
GammaFunc = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"gammaFunc" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
BetaFunc = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"betaFunc" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p (Equal HEq a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"==" Int
4 Associativity
NonAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p (Less HOrd a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"<" Int
4 Associativity
NonAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p (NatPow HSemiring a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"^" Int
8 Associativity
RightAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppPrimOp Int
p (Negate HRing a
_) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"negate" abt vars a
abt '[] a
e1
ppPrimOp Int
p (Abs HRing a
_) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"abs_" abt vars a
abt '[] a
e1
ppPrimOp Int
p (Signum HRing a
_) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"signum" abt vars a
abt '[] a
e1
ppPrimOp Int
p (Recip HFractional a
_) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"recip" abt vars a
abt '[] a
e1
ppPrimOp Int
p (NatRoot HRadical a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"`thRootOf`" Int
9 Associativity
LeftAssoc Int
p abt vars a
abt '[] a
e2 abt vars a
abt '[] a
e1
ppPrimOp Int
p (Erf HContinuous a
_) = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"erf" abt vars a
abt '[] a
e1
ppPrimOp Int
p PrimOp typs a
Floor = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"floor" abt vars a
abt '[] a
e1
ppArrayOp
:: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
=> Int -> ArrayOp typs a -> SArgs abt args -> Docs
ppArrayOp :: Int -> ArrayOp typs a -> SArgs abt args -> [Doc]
ppArrayOp Int
p (Index Sing a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) ->
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
"!" Int
9 Associativity
LeftAssoc Int
p abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppArrayOp Int
p (Size Sing a
_) = \(abt vars a
e1 :* SArgs abt args
End) ->
Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"size" abt vars a
abt '[] a
e1
ppArrayOp Int
p (Reduce Sing a
_) = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) ->
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"reduce"
[ abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e1
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e2
, abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt vars a
abt '[] a
e3
]
ppMeasureOp
:: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
=> Int -> MeasureOp typs a -> SArgs abt args -> Docs
ppMeasureOp :: Int -> MeasureOp typs a -> SArgs abt args -> [Doc]
ppMeasureOp Int
p MeasureOp typs a
Lebesgue = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"lebesgue" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppMeasureOp Int
_ MeasureOp typs a
Counting = \SArgs abt args
End -> [String -> Doc
PP.text String
"counting"]
ppMeasureOp Int
p MeasureOp typs a
Categorical = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"categorical" abt vars a
abt '[] a
e1
ppMeasureOp Int
p MeasureOp typs a
Uniform = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"uniform" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppMeasureOp Int
p MeasureOp typs a
Normal = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"normal" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppMeasureOp Int
p MeasureOp typs a
Poisson = \(abt vars a
e1 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
"poisson" abt vars a
abt '[] a
e1
ppMeasureOp Int
p MeasureOp typs a
Gamma = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"gamma" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
ppMeasureOp Int
p MeasureOp typs a
Beta = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> Int -> String -> abt '[] a -> abt '[] a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
"beta" abt vars a
abt '[] a
e1 abt vars a
abt '[] a
e2
instance Pretty Literal where
prettyPrec_ :: Int -> Literal a -> [Doc]
prettyPrec_ Int
p (LNat Natural
n) = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"nat_" [Integer -> Doc
PP.integer (Natural -> Integer
fromNatural Natural
n)]
prettyPrec_ Int
p (LInt Integer
i) = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"int_" [Integer -> Doc
PP.integer Integer
i]
prettyPrec_ Int
p (LProb NonNegativeRational
l) = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"prob_" [Int -> NonNegativeRational -> Doc
forall a. (Show a, Integral a) => Int -> Ratio a -> Doc
ppRatio Int
11 NonNegativeRational
l]
prettyPrec_ Int
p (LReal Rational
r) = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"real_" [Int -> Rational -> Doc
forall a. (Show a, Integral a) => Int -> Ratio a -> Doc
ppRatio Int
11 Rational
r]
instance Pretty f => Pretty (Datum f) where
prettyPrec_ :: Int -> Datum f a -> [Doc]
prettyPrec_ Int
p (Datum Text
hint Sing (HData' t)
_typ DatumCode (Code t) f (HData' t)
d)
| Text -> Bool
Text.null Text
hint =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"datum_"
[String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: prettyPrec_@Datum"]
| Bool
otherwise =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"ann_"
[ Doc -> Doc
PP.parens (Doc -> Doc) -> (Sing (HData' t) -> Doc) -> Sing (HData' t) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
PP.text (String -> Doc)
-> (Sing (HData' t) -> String) -> Sing (HData' t) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing (HData' t) -> String
forall a. Show a => a -> String
show (Sing (HData' t) -> Doc) -> Sing (HData' t) -> Doc
forall a b. (a -> b) -> a -> b
$ Sing (HData' t)
_typ
, Doc -> Doc
PP.parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String -> [Doc] -> [Doc]
ppFun Int
p (Text -> String
Text.unpack Text
hint)
((forall (i :: Hakaru). f i -> [Doc])
-> DatumCode (Code t) f (HData' t) -> [Doc]
forall k1 k2 (f :: (k1 -> *) -> k2 -> *) m (a :: k1 -> *)
(j :: k2).
(Foldable11 f, Monoid m) =>
(forall (i :: k1). a i -> m) -> f a j -> m
foldMap11 ((Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[]) (Doc -> [Doc]) -> (f i -> Doc) -> f i -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
toDoc ([Doc] -> Doc) -> (f i -> [Doc]) -> f i -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f i -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11) DatumCode (Code t) f (HData' t)
d)
]
ppPattern :: Int -> Pattern xs a -> Docs
ppPattern :: Int -> Pattern xs a -> [Doc]
ppPattern Int
_ Pattern xs a
PWild = [String -> Doc
PP.text String
"PWild"]
ppPattern Int
_ Pattern xs a
PVar = [String -> Doc
PP.text String
"PVar"]
ppPattern Int
p (PDatum Text
hint PDatumCode (Code t) xs (HData' t)
d0)
| Text -> Bool
Text.null Text
hint = String -> [Doc]
forall a. HasCallStack => String -> a
error String
"TODO: prettyPrec_@Pattern"
| Bool
otherwise = Int -> String -> [Doc] -> [Doc]
ppFun Int
p (String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
hint) (PDatumCode (Code t) xs (HData' t) -> [Doc]
forall (xss :: [[HakaruFun]]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumCode xss vars a -> [Doc]
goCode PDatumCode (Code t) xs (HData' t)
d0)
where
goCode :: PDatumCode xss vars a -> Docs
goCode :: PDatumCode xss vars a -> [Doc]
goCode (PInr PDatumCode xss vars a
d) = PDatumCode xss vars a -> [Doc]
forall (xss :: [[HakaruFun]]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumCode xss vars a -> [Doc]
goCode PDatumCode xss vars a
d
goCode (PInl PDatumStruct xs vars a
d) = PDatumStruct xs vars a -> [Doc]
forall (xs :: [HakaruFun]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumStruct xs vars a -> [Doc]
goStruct PDatumStruct xs vars a
d
goStruct :: PDatumStruct xs vars a -> Docs
goStruct :: PDatumStruct xs vars a -> [Doc]
goStruct PDatumStruct xs vars a
PDone = []
goStruct (PEt PDatumFun x vars1 a
d1 PDatumStruct xs vars2 a
d2) = PDatumFun x vars1 a -> [Doc]
forall (x :: HakaruFun) (vars :: [Hakaru]) (a :: Hakaru).
PDatumFun x vars a -> [Doc]
goFun PDatumFun x vars1 a
d1 [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ PDatumStruct xs vars2 a -> [Doc]
forall (xs :: [HakaruFun]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumStruct xs vars a -> [Doc]
goStruct PDatumStruct xs vars2 a
d2
goFun :: PDatumFun x vars a -> Docs
goFun :: PDatumFun x vars a -> [Doc]
goFun (PKonst Pattern vars b
d) = [[Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pattern vars b -> [Doc]
forall (xs :: [Hakaru]) (a :: Hakaru). Int -> Pattern xs a -> [Doc]
ppPattern Int
11 Pattern vars b
d]
goFun (PIdent Pattern vars a
d) = [[Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pattern vars a -> [Doc]
forall (xs :: [Hakaru]) (a :: Hakaru). Int -> Pattern xs a -> [Doc]
ppPattern Int
11 Pattern vars a
d]
instance Pretty (Pattern xs) where
prettyPrec_ :: Int -> Pattern xs a -> [Doc]
prettyPrec_ = Int -> Pattern xs a -> [Doc]
forall (xs :: [Hakaru]) (a :: Hakaru). Int -> Pattern xs a -> [Doc]
ppPattern
instance (ABT Term abt) => Pretty (Branch a abt) where
prettyPrec_ :: Int -> Branch a abt a -> [Doc]
prettyPrec_ Int
p (Branch Pattern xs a
pat abt xs a
e) =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"branch"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pattern xs a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Pattern xs a
pat
, Doc -> Doc
PP.parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ abt xs a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder abt xs a
e
]
instance (ABT Term abt) => Pretty (Reducer abt xs) where
prettyPrec_ :: Int -> Reducer abt xs a -> [Doc]
prettyPrec_ Int
p (Red_Fanout Reducer abt xs a
r1 Reducer abt xs b
r2) =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"r_fanout"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Reducer abt xs a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Reducer abt xs a
r1
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Reducer abt xs b -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Reducer abt xs b
r2
]
prettyPrec_ Int
p (Red_Index abt xs 'HNat
n abt ('HNat : xs) 'HNat
o Reducer abt ('HNat : xs) a
e) =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"r_index"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ abt xs 'HNat -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppUncurryBinder abt xs 'HNat
n
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ abt ('HNat : xs) 'HNat -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppUncurryBinder abt ('HNat : xs) 'HNat
o
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Reducer abt ('HNat : xs) a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Reducer abt ('HNat : xs) a
e
]
prettyPrec_ Int
p (Red_Split abt ('HNat : xs) HBool
b Reducer abt xs a
r1 Reducer abt xs b
r2) =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"r_split"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (abt ('HNat : xs) HBool -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppUncurryBinder abt ('HNat : xs) HBool
b)
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Reducer abt xs a -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Reducer abt xs a
r1
, [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Reducer abt xs b -> [Doc]
forall (f :: Hakaru -> *) (a :: Hakaru).
Pretty f =>
Int -> f a -> [Doc]
prettyPrec_ Int
11 Reducer abt xs b
r2
]
prettyPrec_ Int
_ Reducer abt xs a
Red_Nop =
[ String -> Doc
PP.text String
"r_nop" ]
prettyPrec_ Int
p (Red_Add HSemiring a
_ abt ('HNat : xs) a
e) =
Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
"r_add"
[ [Doc] -> Doc
toDoc ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc] -> [Doc]
parens Bool
True (abt ('HNat : xs) a -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppUncurryBinder abt ('HNat : xs) a
e)]
adjustHead :: (Doc -> Doc) -> Docs -> Docs
adjustHead :: (Doc -> Doc) -> [Doc] -> [Doc]
adjustHead Doc -> Doc
f [] = [Doc -> Doc
f ([Doc] -> Doc
toDoc [])]
adjustHead Doc -> Doc
f (Doc
d:[Doc]
ds) = Doc -> Doc
f Doc
d Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
ds
parens :: Bool -> Docs -> Docs
parens :: Bool -> [Doc] -> [Doc]
parens Bool
True [Doc]
ds = [Doc -> Doc
PP.parens (Int -> Doc -> Doc
PP.nest Int
1 ([Doc] -> Doc
toDoc [Doc]
ds))]
parens Bool
False [Doc]
ds = [Doc]
ds
ppList :: [Doc] -> Docs
ppList :: [Doc] -> [Doc]
ppList = (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[]) (Doc -> [Doc]) -> ([Doc] -> Doc) -> [Doc] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
PP.brackets (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
PP.nest Int
1 (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.fsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
PP.punctuate Doc
PP.comma
ppTuple :: [Doc] -> Doc
ppTuple :: [Doc] -> Doc
ppTuple = Doc -> Doc
PP.parens (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
PP.sep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
PP.punctuate Doc
PP.comma
ppFun :: Int -> String -> [Doc] -> Docs
ppFun :: Int -> String -> [Doc] -> [Doc]
ppFun Int
_ String
f [] = [String -> Doc
PP.text String
f]
ppFun Int
p String
f [Doc]
ds =
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) [String -> Doc
PP.text String
f Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
PP.nest (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
f) ([Doc] -> Doc
PP.sep [Doc]
ds)]
ppArg :: (ABT Term abt) => abt '[] a -> Doc
ppArg :: abt '[] a -> Doc
ppArg = Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
11
ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Docs
ppApply1 :: Int -> String -> abt '[] a -> [Doc]
ppApply1 Int
p String
f abt '[] a
e1 = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
f [abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] a
e1]
ppApply2
:: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Docs
ppApply2 :: Int -> String -> abt '[] a -> abt '[] b -> [Doc]
ppApply2 Int
p String
f abt '[] a
e1 abt '[] b
e2 = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
f [abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] a
e1, abt '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
ppArg abt '[] b
e2]
ppApply
:: (ABT Term abt) => Int -> String -> SArgs abt as -> Docs
ppApply :: Int -> String -> SArgs abt as -> [Doc]
ppApply Int
p String
f SArgs abt as
es = Int -> String -> [Doc] -> [Doc]
ppFun Int
p String
f ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (forall (h :: [Hakaru]) (i :: Hakaru). abt h i -> [Doc])
-> SArgs abt as -> [Doc]
forall k1 k2 k3 (f :: (k1 -> k2 -> *) -> k3 -> *) m
(a :: k1 -> k2 -> *) (j :: k3).
(Foldable21 f, Monoid m) =>
(forall (h :: k1) (i :: k2). a h i -> m) -> f a j -> m
foldMap21 forall (h :: [Hakaru]) (i :: Hakaru). abt h i -> [Doc]
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
abt xs a -> [Doc]
ppBinder SArgs abt as
es
ppRatio :: (Show a, Integral a) => Int -> Ratio a -> Doc
ppRatio :: Int -> Ratio a -> Doc
ppRatio Int
p Ratio a
r
| a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = (String -> String) -> Doc
forall a. ([a] -> String) -> Doc
ppShowS ((String -> String) -> Doc) -> (String -> String) -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
p a
n
| a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 =
(String -> String) -> Doc
forall a. ([a] -> String) -> Doc
ppShowS
((String -> String) -> Doc)
-> ((String -> String) -> String -> String)
-> (String -> String)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7)
((String -> String) -> Doc) -> (String -> String) -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
showChar Char
'-'
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 (a -> a
forall a. Num a => a -> a
negate a
n)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'/'
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 a
d
| Bool
otherwise =
(String -> String) -> Doc
forall a. ([a] -> String) -> Doc
ppShowS
((String -> String) -> Doc)
-> ((String -> String) -> String -> String)
-> (String -> String)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7)
((String -> String) -> Doc) -> (String -> String) -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 a
n
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'/'
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
8 a
d
where
d :: a
d = Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
r
n :: a
n = Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
r
ppShowS :: ([a] -> String) -> Doc
ppShowS [a] -> String
s = String -> Doc
PP.text ([a] -> String
s [])
data Associativity = LeftAssoc | RightAssoc | NonAssoc
ppBinop
:: (ABT Term abt)
=> String -> Int -> Associativity
-> Int -> abt '[] a -> abt '[] b -> Docs
ppBinop :: String
-> Int -> Associativity -> Int -> abt '[] a -> abt '[] b -> [Doc]
ppBinop String
op Int
p0 Associativity
assoc =
let (Int
p1,Int
p2) =
case Associativity
assoc of
Associativity
LeftAssoc -> (Int
p0, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p0)
Associativity
RightAssoc -> (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p0, Int
p0)
Associativity
NonAssoc -> (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p0, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p0)
in \Int
p abt '[] a
e1 abt '[] b
e2 ->
Bool -> [Doc] -> [Doc]
parens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p0)
[ Int -> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
p1 abt '[] a
e1
, String -> Doc
PP.text String
op
Doc -> Doc -> Doc
<+> Int -> abt '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Int -> abt '[] a -> Doc
prettyPrec Int
p2 abt '[] b
e2
]
header :: [Text.Text]
=
[ Text
"{-# LANGUAGE DataKinds, NegativeLiterals #-}"
, Text
"module Prog where"
, Text
""
, Text
"import Data.Number.LogFloat (LogFloat)"
, Text
"import Prelude hiding (product, exp, log, (**), pi)"
, Text
"import Language.Hakaru.Runtime.LogFloatPrelude"
, Text
"import Language.Hakaru.Runtime.CmdLine"
, Text
"import Language.Hakaru.Types.Sing"
, Text
"import qualified System.Random.MWC as MWC"
, Text
"import Control.Monad"
, Text
"import System.Environment (getArgs)"
, Text
"" ]