{-# LANGUAGE CPP
           , GADTs
           , KindSignatures
           , DataKinds
           , ScopedTypeVariables
           , PatternGuards
           , Rank2Types
           , TypeOperators
           , FlexibleContexts
           , UndecidableInstances
           #-}
module Language.Hakaru.Pretty.SExpression where

#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (foldMap)
import Control.Applicative ((<$>))
#endif

import Data.Ratio
import Data.Text (Text)
import Data.Sequence (Seq)

import qualified Data.Text as Text
import Data.Number.Nat (fromNat)
import Data.Number.Natural (fromNonNegativeRational)
import qualified Data.List.NonEmpty as L
import Data.Text.IO as IO
import Language.Hakaru.Command (parseAndInfer)
import Language.Hakaru.Syntax.IClasses (jmEq1, TypeEq(..))
import Language.Hakaru.Types.Coercion
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Types.HClasses
import Language.Hakaru.Types.Sing

import Language.Hakaru.Summary
import Language.Hakaru.Syntax.ABT
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Syntax.AST.Transforms
import Language.Hakaru.Syntax.Datum
import Language.Hakaru.Syntax.Reducer
import Language.Hakaru.Syntax.TypeCheck
import Language.Hakaru.Syntax.TypeOf
import Prelude hiding ((<>))
import Text.PrettyPrint (Doc, (<>), (<+>))
import Text.PrettyPrint as PP

pretty :: (ABT Term abt) => abt '[] a -> Doc
pretty :: abt '[] a -> Doc
pretty abt '[] a
a =
  Doc -> Doc
PP.brackets (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
a Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Term abt a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Term abt a -> Doc
prettyTerm Doc -> Doc -> Doc
<+>
               Doc
PP.colon Doc -> Doc -> Doc
<+> Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType (abt '[] a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt '[] a
a))

prettyTerm :: (ABT Term abt) => Term abt a -> Doc
prettyTerm :: Term abt a -> Doc
prettyTerm (SCon args a
o :$ SArgs abt args
es) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ SCon args a -> SArgs abt args -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *)
       (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
ABT Term abt =>
SCon args a -> SArgs abt args -> Doc
prettySCons SCon args a
o SArgs abt args
es
prettyTerm (NaryOp_ NaryOp a
op Seq (abt '[] a)
es) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ NaryOp a -> Seq (abt '[] a) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
NaryOp a -> Seq (abt '[] a) -> Doc
prettyNary NaryOp a
op Seq (abt '[] a)
es
prettyTerm (Literal_ Literal a
v) = Literal a -> Doc
forall (a :: Hakaru). Literal a -> Doc
prettyLiteral Literal a
v
prettyTerm (Array_ abt '[] 'HNat
e1 abt '[ 'HNat] a
e2) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc
PP.text String
"array") Doc -> Doc -> Doc
<+>
  (abt '[ 'HNat] a -> (Variable 'HNat -> abt '[] a -> Doc) -> Doc
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt '[ 'HNat] a
e2 ((Variable 'HNat -> abt '[] a -> Doc) -> Doc)
-> (Variable 'HNat -> abt '[] a -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
x abt '[] a
e2' ->
                   Doc -> Doc
PP.parens (Variable 'HNat -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable 'HNat
x Doc -> Doc -> Doc
<+> abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HNat
e1) Doc -> Doc -> Doc
<+>
                   abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e2')
prettyTerm (Case_ abt '[] a
e1 [Branch a abt a]
bs) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"match" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e1 Doc -> Doc -> Doc
<+>
  (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Doc -> Doc -> Doc
(<+>) Doc
PP.empty (Branch a abt a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
       (b :: Hakaru).
ABT Term abt =>
Branch a abt b -> Doc
prettyBranch (Branch a abt a -> Doc) -> [Branch a abt a] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch a abt a]
bs)
prettyTerm (Bucket abt '[] 'HNat
b abt '[] 'HNat
e Reducer abt '[] a
r) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ( String -> Doc
PP.text String
"bucket" Doc -> Doc -> Doc
<+> abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HNat
b Doc -> Doc -> Doc
<+> abt '[] 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HNat
e Doc -> Doc -> Doc
<+> Reducer abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt '[] a
r)
prettyTerm (Reject_ Sing ('HMeasure a)
_) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"reject"
prettyTerm (Empty_ Sing ('HArray a)
_) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"empty"
prettyTerm (ArrayLiteral_ [abt '[] a]
es) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc
PP.text String
"array-literal" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> [abt '[] a] -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty [abt '[] a]
es)
prettyTerm (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.:| [] ->
      Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      (String -> Doc
PP.text String
"pose" Doc -> Doc -> Doc
<+> abt '[] 'HProb -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HProb
e1 Doc -> Doc -> Doc
<+> abt '[] ('HMeasure a) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] ('HMeasure a)
e2)
    NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
_ ->
      Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      (String -> Doc
PP.text String
"superpose" Doc -> Doc -> Doc
<+> ((abt '[] 'HProb, abt '[] ('HMeasure a)) -> Doc)
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))] -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(abt '[] 'HProb
e1,abt '[] ('HMeasure a)
e2) -> Doc -> Doc
PP.parens (abt '[] 'HProb -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] 'HProb
e1 Doc -> Doc -> Doc
<+> abt '[] ('HMeasure a) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] ('HMeasure a)
e2)) (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))

-- prettyTerm (Datum_ (Datum "true" _typ (Inl Done))) = PP.text "#t"
-- prettyTerm (Datum_ (Datum "false" _typ (Inr (Inl Done)))) = PP.text "#f"
prettyTerm (Datum_ Datum (abt '[]) (HData' t)
d) = Datum (abt '[]) (HData' t) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (t :: Hakaru).
ABT Term abt =>
Datum (abt '[]) t -> Doc
prettyDatum Datum (abt '[]) (HData' t)
d

prettyDatum :: (ABT Term abt) => Datum (abt '[]) t -> Doc
prettyDatum :: Datum (abt '[]) t -> Doc
prettyDatum (Datum Text
hint Sing (HData' t)
_ DatumCode (Code t) (abt '[]) (HData' t)
d) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
  String -> Doc
PP.text String
"datum" Doc -> Doc -> Doc
<+>
  (String -> Doc
PP.text (Text -> String
Text.unpack Text
hint)) Doc -> Doc -> Doc
<+>
  (DatumCode (Code t) (abt '[]) (HData' t) -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xss :: [[HakaruFun]])
       (a :: Hakaru).
ABT Term abt =>
DatumCode xss (abt '[]) a -> Doc
prettyDatumCode DatumCode (Code t) (abt '[]) (HData' t)
d)

prettyDatumCode :: (ABT Term abt) => DatumCode xss (abt '[]) a -> Doc
prettyDatumCode :: DatumCode xss (abt '[]) a -> Doc
prettyDatumCode (Inr DatumCode xss (abt '[]) a
d) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"inr" Doc -> Doc -> Doc
<+> (DatumCode xss (abt '[]) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xss :: [[HakaruFun]])
       (a :: Hakaru).
ABT Term abt =>
DatumCode xss (abt '[]) a -> Doc
prettyDatumCode DatumCode xss (abt '[]) a
d)
prettyDatumCode (Inl DatumStruct xs (abt '[]) a
d) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"inl" Doc -> Doc -> Doc
<+> (DatumStruct xs (abt '[]) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [HakaruFun])
       (a :: Hakaru).
ABT Term abt =>
DatumStruct xs (abt '[]) a -> Doc
prettyDatumStruct DatumStruct xs (abt '[]) a
d)

prettyDatumStruct :: (ABT Term abt) => DatumStruct xs (abt '[]) a -> Doc
prettyDatumStruct :: DatumStruct xs (abt '[]) a -> Doc
prettyDatumStruct DatumStruct xs (abt '[]) a
Done       = String -> Doc
PP.text String
"done"
prettyDatumStruct (Et DatumFun x (abt '[]) a
d1 DatumStruct xs (abt '[]) a
d2) =
    Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"et" Doc -> Doc -> Doc
<+> (DatumFun x (abt '[]) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (x :: HakaruFun)
       (a :: Hakaru).
ABT Term abt =>
DatumFun x (abt '[]) a -> Doc
prettyDatumFun DatumFun x (abt '[]) a
d1) Doc -> Doc -> Doc
<+> (DatumStruct xs (abt '[]) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [HakaruFun])
       (a :: Hakaru).
ABT Term abt =>
DatumStruct xs (abt '[]) a -> Doc
prettyDatumStruct DatumStruct xs (abt '[]) a
d2)

prettyDatumFun :: (ABT Term abt) => DatumFun x (abt '[]) a -> Doc
prettyDatumFun :: DatumFun x (abt '[]) a -> Doc
prettyDatumFun (Konst abt '[] b
a) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"konst" Doc -> Doc -> Doc
<+> abt '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] b
a
prettyDatumFun (Ident abt '[] a
a) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"ident" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
a



prettyReducer :: (ABT Term abt) => Reducer abt xs a -> Doc
prettyReducer :: Reducer abt xs a -> Doc
prettyReducer (Red_Fanout Reducer abt xs a
red_a Reducer abt xs b
red_b) =
  Doc -> Doc
PP.parens (String -> Doc
PP.text String
"r_fanout" Doc -> Doc -> Doc
<+> Reducer abt xs a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt xs a
red_a Doc -> Doc -> Doc
<+> Reducer abt xs b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt xs b
red_b)
prettyReducer (Red_Index abt xs 'HNat
i abt ('HNat : xs) 'HNat
red_i Reducer abt ('HNat : xs) a
red_a) =
  Doc -> Doc
PP.parens (String -> Doc
PP.text String
"r_index" Doc -> Doc -> Doc
<+> abt xs 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt xs 'HNat
i Doc -> Doc -> Doc
<+>
             abt ('HNat : xs) 'HNat -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt ('HNat : xs) 'HNat
red_i Doc -> Doc -> Doc
<+> Reducer abt ('HNat : xs) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt ('HNat : xs) a
red_a)
prettyReducer (Red_Split abt ('HNat : xs) HBool
i Reducer abt xs a
red_a Reducer abt xs b
red_b) =
  Doc -> Doc
PP.parens (String -> Doc
PP.text String
"r_split" Doc -> Doc -> Doc
<+> abt ('HNat : xs) HBool -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt ('HNat : xs) HBool
i Doc -> Doc -> Doc
<+>
            Reducer abt xs a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt xs a
red_a Doc -> Doc -> Doc
<+> Reducer abt xs b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
Reducer abt xs a -> Doc
prettyReducer Reducer abt xs b
red_b)
prettyReducer (Reducer abt xs a
Red_Nop) = String -> Doc
PP.text String
"r_nop"
prettyReducer (Red_Add HSemiring a
_ abt ('HNat : xs) a
a) =
  Doc -> Doc
PP.parens (String -> Doc
PP.text String
"r_add" Doc -> Doc -> Doc
<+> abt ('HNat : xs) a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt ('HNat : xs) a
a)

prettyBranch :: (ABT Term abt) => Branch a abt b -> Doc
prettyBranch :: Branch a abt b -> Doc
prettyBranch (Branch Pattern xs a
pat abt xs b
e) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Pattern xs a -> Doc
forall (xs :: [Hakaru]) (a :: Hakaru). Pattern xs a -> Doc
prettyPattern Pattern xs a
pat Doc -> Doc -> Doc
<+> abt xs b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt xs b
e

prettyPattern :: Pattern xs a -> Doc
prettyPattern :: Pattern xs a -> Doc
prettyPattern Pattern xs a
PWild = String -> Doc
PP.text String
"*"
prettyPattern Pattern xs a
PVar = String -> Doc
PP.text String
"var"
prettyPattern (PDatum Text
hint PDatumCode (Code t) xs (HData' t)
c) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"pdatum" Doc -> Doc -> Doc
<+> String -> Doc
PP.text (Text -> String
Text.unpack Text
hint) Doc -> Doc -> Doc
<+> 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)
c
goCode :: PDatumCode xss vars a -> Doc
goCode :: PDatumCode xss vars a -> Doc
goCode PDatumCode xss vars a
c = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ case PDatumCode xss vars a
c of
  (PInr PDatumCode xss vars a
d) -> String -> Doc
PP.text String
"pc_inr" Doc -> Doc -> Doc
<+> PDatumCode xss vars a -> Doc
forall (xss :: [[HakaruFun]]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumCode xss vars a -> Doc
goCode PDatumCode xss vars a
d
  (PInl PDatumStruct xs vars a
s) -> String -> Doc
PP.text String
"pc_inl" Doc -> Doc -> Doc
<+> PDatumStruct xs vars a -> Doc
forall (xs :: [HakaruFun]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumStruct xs vars a -> Doc
goStruct PDatumStruct xs vars a
s
goStruct :: PDatumStruct xs vars a -> Doc
goStruct :: PDatumStruct xs vars a -> Doc
goStruct PDatumStruct xs vars a
s = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ case PDatumStruct xs vars a
s of
  (PDatumStruct xs vars a
PDone) -> String -> Doc
PP.text String
"ps_done"
  (PEt PDatumFun x vars1 a
f PDatumStruct xs vars2 a
s') -> String -> Doc
PP.text String
"ps_et" Doc -> Doc -> Doc
<+> PDatumFun x vars1 a -> Doc
forall (x :: HakaruFun) (vars :: [Hakaru]) (a :: Hakaru).
PDatumFun x vars a -> Doc
goFun PDatumFun x vars1 a
f Doc -> Doc -> Doc
<+> PDatumStruct xs vars2 a -> Doc
forall (xs :: [HakaruFun]) (vars :: [Hakaru]) (a :: Hakaru).
PDatumStruct xs vars a -> Doc
goStruct PDatumStruct xs vars2 a
s'
goFun :: PDatumFun x vars a -> Doc
goFun :: PDatumFun x vars a -> Doc
goFun PDatumFun x vars a
f = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ case PDatumFun x vars a
f of
  (PKonst Pattern vars b
p) -> String -> Doc
PP.text String
"pf_konst" Doc -> Doc -> Doc
<+> Pattern vars b -> Doc
forall (xs :: [Hakaru]) (a :: Hakaru). Pattern xs a -> Doc
prettyPattern Pattern vars b
p
  (PIdent Pattern vars a
p) -> String -> Doc
PP.text String
"pf_ident" Doc -> Doc -> Doc
<+> Pattern vars a -> Doc
forall (xs :: [Hakaru]) (a :: Hakaru). Pattern xs a -> Doc
prettyPattern Pattern vars a
p


prettyViewABT :: (ABT Term abt) => abt xs a -> Doc
prettyViewABT :: abt xs a -> Doc
prettyViewABT = View (Term abt) xs a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
View (Term abt) xs a -> Doc
prettyView (View (Term abt) xs a -> Doc)
-> (abt xs a -> View (Term abt) xs a) -> abt xs a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

prettyView :: (ABT Term abt) => View (Term abt) xs a -> Doc
prettyView :: View (Term abt) xs a -> Doc
prettyView (Bind Variable a
x View (Term abt) xs a
v) =
  Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"bind" Doc -> Doc -> Doc
<+> Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x Doc -> Doc -> Doc
<+> View (Term abt) xs a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
View (Term abt) xs a -> Doc
prettyView View (Term abt) xs a
v
prettyView (Var Variable a
x) = Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x
prettyView (Syn Term abt a
t) = abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty (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)

prettyShow :: (Show a) => a -> Doc
prettyShow :: a -> Doc
prettyShow = String -> Doc
PP.text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

prettyLiteral :: Literal a -> Doc
prettyLiteral :: Literal a -> Doc
prettyLiteral (LNat Natural
v) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"nat_" Doc -> Doc -> Doc
<+> Natural -> Doc
forall a. Show a => a -> Doc
prettyShow Natural
v
prettyLiteral (LInt Integer
i) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"int_" Doc -> Doc -> Doc
<+> Integer -> Doc
forall a. Show a => a -> Doc
prettyShow Integer
i
prettyLiteral (LProb NonNegativeRational
p) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"prob_" Doc -> Doc -> Doc
<+> Rational -> Doc
PP.rational (NonNegativeRational -> Rational
fromNonNegativeRational NonNegativeRational
p)
prettyLiteral (LReal Rational
p) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"real_" Doc -> Doc -> Doc
<+> Rational -> Doc
PP.rational Rational
p


prettyRatio :: (Show a, Integral a) => Ratio a -> Doc
prettyRatio :: Ratio a -> Doc
prettyRatio Ratio a
r
  | a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a -> Doc
forall a. Show a => a -> Doc
prettyShow a
n
  | Bool
otherwise = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"/" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Show a => a -> Doc
prettyShow a
n Doc -> Doc -> Doc
<+> a -> Doc
forall a. Show a => a -> Doc
prettyShow 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

prettyVariable :: Variable (a :: Hakaru) -> Doc
prettyVariable :: Variable a -> Doc
prettyVariable Variable a
x | Text -> Bool
Text.null (Variable a -> Text
forall k (a :: k). Variable a -> Text
varHint Variable a
x) = String -> Doc
PP.text String
"_" 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
                 | 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

prettySCons :: (ABT Term abt) => SCon args a -> SArgs abt args -> Doc
prettySCons :: SCon args a -> SArgs abt args -> Doc
prettySCons SCon args a
Lam_ (abt vars a
e1 :* SArgs abt args
End) = abt '[a] a -> (Variable a -> abt '[] a -> Doc) -> Doc
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e1 ((Variable a -> abt '[] a -> Doc) -> Doc)
-> (Variable a -> abt '[] a -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e1' ->
  String -> Doc
PP.text String
"fn" Doc -> Doc -> Doc
<+> Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x  Doc -> Doc -> Doc
<+> (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType (Sing a -> Doc) -> Sing a -> Doc
forall a b. (a -> b) -> a -> b
$ abt '[] a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt '[] a
e1')
  Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e1'
prettySCons (PrimOp_ PrimOp typs a
o) SArgs abt args
es = 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) =>
PrimOp typs a -> SArgs abt args -> Doc
prettyPrimOp PrimOp typs a
o SArgs abt args
es
prettySCons (ArrayOp_ ArrayOp typs a
o) SArgs abt args
es = 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) =>
ArrayOp typs a -> SArgs abt args -> Doc
prettyArrayOp ArrayOp typs a
o SArgs abt args
es
prettySCons (CoerceTo_ Coercion a a
o) (abt vars a
e1 :* SArgs abt args
End) = String -> Doc
PP.text (Coercion a a -> String
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> String
pCoerce Coercion a a
o) Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettySCons (Summate HDiscrete a
_ HSemiring a
_) (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) =
  abt '[a] a -> (Variable a -> abt '[] a -> Doc) -> Doc
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e3 ((Variable a -> abt '[] a -> Doc) -> Doc)
-> (Variable a -> abt '[] a -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e3' -> String -> Doc
PP.text String
"summate" Doc -> Doc -> Doc
<+>
                          Doc -> Doc
PP.parens (Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2) Doc -> Doc -> Doc
<+>
                          abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e3'
prettySCons (Product HDiscrete a
_ HSemiring a
_) (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) =
  abt '[a] a -> (Variable a -> abt '[] a -> Doc) -> Doc
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e3 ((Variable a -> abt '[] a -> Doc) -> Doc)
-> (Variable a -> abt '[] a -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e3' -> String -> Doc
PP.text String
"product" Doc -> Doc -> Doc
<+>
                          Doc -> Doc
PP.parens (Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2) Doc -> Doc -> Doc
<+>
                          abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e3'
prettySCons SCon args a
App_ (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"app" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettySCons SCon args a
Let_ (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = abt '[a] a -> (Variable a -> abt '[] a -> Doc) -> Doc
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e2 ((Variable a -> abt '[] a -> Doc) -> Doc)
-> (Variable a -> abt '[] a -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e2' ->
  String -> Doc
PP.text String
"let" Doc -> Doc -> Doc
<+>
  Doc -> Doc
PP.parens (Variable a -> Doc
forall (a :: Hakaru). Variable a -> Doc
prettyVariable Variable a
x Doc -> Doc -> Doc
<+> (Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType (Sing a -> Doc) -> Sing a -> Doc
forall a b. (a -> b) -> a -> b
$ abt '[] a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt vars a
abt '[] a
e1) Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1)
  Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt '[] a
e2'
prettySCons (UnsafeFrom_ Coercion a b
o) (abt vars a
e :* SArgs abt args
End) = String -> Doc
PP.text (Coercion a b -> String
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> String
pUnsafeCoerce Coercion a b
o) Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e
prettySCons (MeasureOp_ MeasureOp typs a
o) SArgs abt args
es = 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) =>
MeasureOp typs a -> SArgs abt args -> Doc
prettyMeasureOp MeasureOp typs a
o SArgs abt args
es
prettySCons SCon args a
Dirac (abt vars a
e1 :* SArgs abt args
End) = String -> Doc
PP.text String
"dirac" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettySCons SCon args a
MBind (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"mbind" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt vars a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt vars a
e2
prettySCons SCon args a
Plate (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"plate" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt vars a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt vars a
e2
prettySCons SCon args a
Chain (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) = String -> Doc
PP.text String
"chain" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2 Doc -> Doc -> Doc
<+> abt vars a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt vars a
e3
prettySCons SCon args a
Integrate (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) = String -> Doc
PP.text String
"integrate" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2 Doc -> Doc -> Doc
<+> abt vars a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
ABT Term abt =>
abt xs a -> Doc
prettyViewABT abt vars a
e3
prettySCons (Transform_ Transform args a
t) SArgs abt args
_ = String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
     [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat [ String
"SCons{", Transform args a -> String
forall a. Show a => a -> String
show Transform args a
t, String
"}: TODO" ]

prettyMeasureOp
    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
    => MeasureOp typs a -> SArgs abt args -> Doc
prettyMeasureOp :: MeasureOp typs a -> SArgs abt args -> Doc
prettyMeasureOp MeasureOp typs a
Lebesgue    = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End)          -> String -> Doc
PP.text String
"lebesgue" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyMeasureOp MeasureOp typs a
Counting    = \SArgs abt args
End           -> String -> Doc
PP.text String
"counting"
prettyMeasureOp MeasureOp typs a
Categorical = \(abt vars a
e1 :* SArgs abt args
End)   -> String -> Doc
PP.text String
"categorical" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyMeasureOp MeasureOp typs a
Uniform = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String -> Doc
PP.text String
"uniform"     Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyMeasureOp MeasureOp typs a
Normal  = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String -> Doc
PP.text String
"normal"      Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyMeasureOp MeasureOp typs a
Poisson = \(abt vars a
e1 :* SArgs abt args
End)       -> String -> Doc
PP.text String
"poisson"     Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyMeasureOp MeasureOp typs a
Gamma   = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String -> Doc
PP.text String
"gamma"       Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyMeasureOp MeasureOp typs a
Beta    = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) -> String -> Doc
PP.text String
"beta"        Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2

pUnsafeCoerce :: Coercion a b -> String
pUnsafeCoerce :: Coercion a b -> String
pUnsafeCoerce (CCons (Signed HRing b
HRing_Real) Coercion b b
CNil) = String
"real2prob"
pUnsafeCoerce (CCons (Signed HRing b
HRing_Int)  Coercion b b
CNil) = String
"int2nat"
pUnsafeCoerce Coercion a b
c = String
"unsafeFrom_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Coercion a b -> String
forall a. Show a => a -> String
show Coercion a b
c

pCoerce :: Coercion a b -> String
pCoerce :: Coercion a b -> String
pCoerce (CCons (Signed HRing b
HRing_Real) Coercion b b
CNil)             = String
"prob2real"
pCoerce (CCons (Signed HRing b
HRing_Int)  Coercion b b
CNil)             = String
"nat2int"
pCoerce (CCons (Continuous HContinuous b
HContinuous_Real) Coercion b b
CNil)   = String
"int2real"
pCoerce (CCons (Continuous HContinuous b
HContinuous_Prob) Coercion b b
CNil)   = String
"nat2prob"
pCoerce (CCons (Continuous HContinuous b
HContinuous_Prob)
         (CCons (Signed HRing b
HRing_Real) Coercion b b
CNil))           = String
"nat2real"
pCoerce (CCons (Signed HRing b
HRing_Int)
         (CCons (Continuous HContinuous b
HContinuous_Real) Coercion b b
CNil)) = String
"nat2real"
pCoerce Coercion a b
c = String
"coerceTo_"String -> String -> String
forall a. [a] -> [a] -> [a]
++Coercion a b -> String
forall a. Show a => a -> String
show Coercion a b
c


prettyNary :: (ABT Term abt) => NaryOp a -> Seq (abt '[] a) -> Doc
prettyNary :: NaryOp a -> Seq (abt '[] a) -> Doc
prettyNary NaryOp a
And       Seq (abt '[] a)
es      = String -> Doc
PP.text String
"and" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary NaryOp a
Or        Seq (abt '[] a)
es      = String -> Doc
PP.text String
"or" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary NaryOp a
Xor       Seq (abt '[] a)
es      = String -> Doc
PP.text String
"xor" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary (Sum  HSemiring a
_)  Seq (abt '[] a)
es      = String -> Doc
PP.text String
"+" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary (Prod  HSemiring a
_) Seq (abt '[] a)
es      = String -> Doc
PP.text String
"*" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary (Min  HOrd a
_)  Seq (abt '[] a)
es      = String -> Doc
PP.text String
"min" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary (Max  HOrd a
_)  Seq (abt '[] a)
es      = String -> Doc
PP.text String
"max" Doc -> Doc -> Doc
<+> (abt '[] a -> Doc) -> Seq (abt '[] a) -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty Seq (abt '[] a)
es
prettyNary NaryOp a
_         Seq (abt '[] a)
_       = String -> Doc
forall a. HasCallStack => String -> a
error String
"Pretty.SExpression - prettyNary missing cases"

prettyType :: Sing (a :: Hakaru) -> Doc
prettyType :: Sing a -> Doc
prettyType Sing a
SNat         = String -> Doc
PP.text String
"nat"
prettyType Sing a
SInt         = String -> Doc
PP.text String
"int"
prettyType Sing a
SProb        = String -> Doc
PP.text String
"prob"
prettyType Sing a
SReal        = String -> Doc
PP.text String
"real"
prettyType (SArray a)   = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"array" Doc -> Doc -> Doc
<+> Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
a
prettyType (SMeasure a) = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"measure" Doc -> Doc -> Doc
<+> Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
a
prettyType (SFun a b)   = Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Sing a -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing a
a Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"->" Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
b
prettyType Sing a
typ =
    case Sing a
typ of
    SData (STyCon sym `STyApp` a `STyApp` b) _
      | Just TypeEq s "Pair"
Refl <- Sing s -> Sing "Pair" -> Maybe (TypeEq s "Pair")
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing s
sym Sing "Pair"
sSymbol_Pair
      -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"pair" Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
a Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
b
      | Just TypeEq s "Either"
Refl <- Sing s -> Sing "Either" -> Maybe (TypeEq s "Either")
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing s
sym Sing "Either"
sSymbol_Either
      -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"either" Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
a Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
b
    SData (STyCon sym `STyApp` a) _
      | Just TypeEq s "Maybe"
Refl <- Sing s -> Sing "Maybe" -> Maybe (TypeEq s "Maybe")
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing s
sym Sing "Maybe"
sSymbol_Maybe
      -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"maybe" Doc -> Doc -> Doc
<+> Sing b -> Doc
forall (a :: Hakaru). Sing a -> Doc
prettyType Sing b
a
    SData (STyCon sym) _
      | Just TypeEq s "Bool"
Refl <- Sing s -> Sing "Bool" -> Maybe (TypeEq s "Bool")
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing s
sym Sing "Bool"
sSymbol_Bool
      -> String -> Doc
PP.text String
"bool"
      | Just TypeEq s "Unit"
Refl <- Sing s -> Sing "Unit" -> Maybe (TypeEq s "Unit")
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing s
sym Sing "Unit"
sSymbol_Unit
      -> String -> Doc
PP.text String
"unit"
    Sing a
_ -> String -> Doc
PP.text (Int -> Sing a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Sing a
typ String
"")

prettyPrimOp
    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
    => PrimOp typs a -> SArgs abt args -> Doc
prettyPrimOp :: PrimOp typs a -> SArgs abt args -> Doc
prettyPrimOp PrimOp typs a
Not              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"not" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
Pi               SArgs abt args
End               = String -> Doc
PP.text String
"pi"
prettyPrimOp PrimOp typs a
Sin              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"sin" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
Cos              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"cos" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
Tan              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"tan" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
RealPow          (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"realpow" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp PrimOp typs a
Choose           (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"choose" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp PrimOp typs a
Exp              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"exp"  Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
Log              (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"log"  Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp (Infinity  HIntegrable a
_)    SArgs abt args
End               = String -> Doc
PP.text String
"infinity"
prettyPrimOp PrimOp typs a
GammaFunc        (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"gammafunc" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
BetaFunc         (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"betafunc" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp (Equal HEq a
_)        (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"==" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp (Less HOrd a
_)         (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"<" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp (NatPow HSemiring a
_)       (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"natpow" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp (Negate HRing a
_)       (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"negate" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp (Abs HRing a
_)          (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"abs"  Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp (Recip   HFractional a
_)      (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"recip" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp (NatRoot HRadical a
_)      (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"root" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyPrimOp PrimOp typs a
Floor            (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"floor" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyPrimOp PrimOp typs a
_                SArgs abt args
_                 = String -> Doc
forall a. HasCallStack => String -> a
error String
"prettyPrimop: a bunch of cases still need done!"

prettyArrayOp
    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
    => ArrayOp typs a -> SArgs abt args -> Doc
prettyArrayOp :: ArrayOp typs a -> SArgs abt args -> Doc
prettyArrayOp (Index Sing a
_) (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) = String -> Doc
PP.text String
"index" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1 Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e2
prettyArrayOp (Size  Sing a
_) (abt vars a
e1 :* SArgs abt args
End)       = String -> Doc
PP.text String
"size" Doc -> Doc -> Doc
<+> abt '[] a -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty abt vars a
abt '[] a
e1
prettyArrayOp (Reduce Sing a
_) SArgs abt args
_                 = String -> Doc
forall a. HasCallStack => String -> a
error String
"prettyArrayOp doesn't know how to print Reduce"

prettyFile' :: [Char] -> [Char] -> IO ()
prettyFile' :: String -> String -> IO ()
prettyFile' String
fname String
outFname = do
  Text
fileText <- String -> IO Text
IO.readFile String
fname
  String
prettyText <- Text -> IO String
runPretty' Text
fileText
  String -> Text -> IO ()
IO.writeFile String
outFname (String -> Text
Text.pack String
prettyText)
  String -> IO ()
forall a. Show a => a -> IO ()
print String
prettyText

runPretty' :: Text -> IO String
runPretty' :: Text -> IO String
runPretty' Text
prog =
    case Text -> Either Text (TypedAST (TrivialABT Term))
parseAndInfer Text
prog of
    Left  Text
_                -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"err"
    Right (TypedAST Sing b
_ TrivialABT Term '[] b
ast) -> do
      TrivialABT Term '[] b
summarised <- TrivialABT Term '[] b -> IO (TrivialABT Term '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> IO (abt '[] a)
summary (TrivialABT Term '[] b -> IO (TrivialABT Term '[] b))
-> (TrivialABT Term '[] b -> TrivialABT Term '[] b)
-> TrivialABT Term '[] b
-> IO (TrivialABT Term '[] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrivialABT Term '[] b -> TrivialABT Term '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> abt '[] a
expandTransformations (TrivialABT Term '[] b -> IO (TrivialABT Term '[] b))
-> TrivialABT Term '[] b -> IO (TrivialABT Term '[] b)
forall a b. (a -> b) -> a -> b
$ TrivialABT Term '[] b
ast
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> (TrivialABT Term '[] b -> String)
-> TrivialABT Term '[] b
-> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String)
-> (TrivialABT Term '[] b -> Doc)
-> TrivialABT Term '[] b
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrivialABT Term '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty (TrivialABT Term '[] b -> IO String)
-> TrivialABT Term '[] b -> IO String
forall a b. (a -> b) -> a -> b
$ TrivialABT Term '[] b
summarised

fromAst :: Either Text (TypedAST (TrivialABT Term)) -> String
fromAst :: Either Text (TypedAST (TrivialABT Term)) -> String
fromAst Either Text (TypedAST (TrivialABT Term))
prog =
    case Either Text (TypedAST (TrivialABT Term))
prog of
    Left  Text
err              -> Text -> String
Text.unpack Text
err
    Right (TypedAST Sing b
_ TrivialABT Term '[] b
ast) -> Doc -> String
render (Doc -> String)
-> (TrivialABT Term '[] b -> Doc)
-> TrivialABT Term '[] b
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrivialABT Term '[] b -> Doc
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Doc
pretty (TrivialABT Term '[] b -> Doc)
-> (TrivialABT Term '[] b -> TrivialABT Term '[] b)
-> TrivialABT Term '[] b
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrivialABT Term '[] b -> TrivialABT Term '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> abt '[] a
expandTransformations (TrivialABT Term '[] b -> String)
-> TrivialABT Term '[] b -> String
forall a b. (a -> b) -> a -> b
$ TrivialABT Term '[] b
ast