{-# LANGUAGE GADTs
           , OverloadedStrings
           , KindSignatures
           , DataKinds
           , FlexibleContexts
           , UndecidableInstances
           , LambdaCase
           #-}

{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
----------------------------------------------------------------
--                                                    2016.02.21
-- |
-- Module      :  Language.Hakaru.Pretty.Haskell
-- Copyright   :  Copyright (c) 2016 the Hakaru team
-- License     :  BSD3
-- Maintainer  :  wren@community.haskell.org
-- Stability   :  experimental
-- Portability :  GHC-only
--
--
----------------------------------------------------------------
module Language.Hakaru.Pretty.Haskell
    (
    -- * The user-facing API
      pretty
    , prettyString
    , prettyPrec
    , prettyAssoc
    , prettyPrecAssoc
    , prettyType

    -- * Helper functions (semi-public internal API)
    , 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 -- Because older versions of "Data.Foldable" do not export 'null' apparently...
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-print a term.
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)] )

-- | Pretty-print a term at a given precendence level.
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_


-- | Pretty-print a variable\/term association pair.
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


-- | Pretty-print an association at a given precendence level.
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
        ]


-- | Pretty-print a Hakaru type as a Haskell type.
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
    -- | A polymorphic variant if 'prettyPrec', for internal use.
    prettyPrec_ :: Int -> f a -> Docs

type Docs = [Doc]

-- So far as I can tell from the documentation, if the input is a singleton list then the result is the same as that singleton.
toDoc :: Docs -> Doc
toDoc :: [Doc] -> Doc
toDoc = [Doc] -> Doc
PP.sep


-- | Pretty-print a variable.
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' -- We used to use '_' but...
        | 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

-- | Pretty-print a list of variables as a list of variables. N.B., the output is not valid Haskell code since it uses the special built-in list syntax rather than using the 'List1' constructors...
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


-- | Pretty-print Hakaru binders as a Haskell lambda, as per our HOAS API.
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) =
        -- HACK: how can we avoid calling 'unviewABT' here?
        let x' :: Doc
x' = if Bool
True -- x `memberVarSet` freeVars (unviewABT v)
                 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


-- TODO: since switching to ABT2, this instance requires -XFlexibleContexts; we should fix that if we can
-- BUG: since switching to ABT2, this instance requires -XUndecidableInstances; must be fixed!
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 ->
            -- TODO: make sure these ops actually have those precedences in the Prelude!!
            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")
                -- BUG: even though 'Iff' is associative (in Boolean algebras), we should not support n-ary uses in our *surface* syntax. Because it's too easy for folks to confuse "a <=> b <=> c" with "(a <=> b) /\ (b <=> c)".
                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)
                -- TODO: pretty print @(+ negate)@ as @(-)@ and @(* recip)@ as @(/)@
                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  ->
            -- TODO: should we also add hints to the 'Case_' constructor to know whether it came from 'if_', 'unpair', etc?
             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.:| [] ->
                -- Or we could print it as @weight e1 *> e2@ excepting that has an extra redex in it compared to the AST itself.
                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"]

-- | Pretty-print @(:$)@ nodes in the AST.
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 -- BUG: this puts extraneous parentheses around e2 when it's a function application...
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 p (Ann_ typ) = \(e1 :* End) ->
    ppFun p "ann_"
        [ PP.text (showsPrec 11 typ "") -- TODO: make this prettier. Add hints to the singletons?
        , ppArg e1
        ]
-}
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 =
    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
    \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 =
    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
    \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
""


-- | Pretty-print a 'PrimOp' @(:$)@ node in the AST.
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) ->
    -- TODO: make prettier
    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) ->
    -- TODO: make prettier
    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 -- TODO: make infix...
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 -- TODO: make infix...
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) ->
    -- N.B., argument order is swapped!
    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


-- | Pretty-print a 'ArrayOp' @(:$)@ node in the AST.
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 -- N.B., @e1@ uses lambdas rather than being a binding form!
        , 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
        ]


-- | Pretty-print a 'MeasureOp' @(:$)@ node in the AST.
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)
            ]

-- HACK: need to pull this out in order to get polymorphic recursion over @xs@
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
            -- BUG: we can't actually use the HOAS API here, since we aren't using a Prelude-defined @branch@...
            -- HACK: don't *always* print parens; pass down the precedence to 'ppBinder' to
            --       have them decide if they need to or not.
            ]

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)]

----------------------------------------------------------------
-- | For the \"@lam $ \x ->\n@\"  style layout.
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

{- -- unused
-- | For the \"@lam (\x ->\n\t...)@\"  style layout.
nestTail :: Int -> Docs -> Docs
nestTail _ []     = []
nestTail n (d:ds) = [d, PP.nest n (toDoc 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

-- | Something prettier than 'PP.rational'. This works correctly
-- for both 'Rational' and 'NonNegativeRational', though it may not
-- work for other @a@ types.
--
-- N.B., the resulting string assumes prefix negation and the
-- 'Fractional' @(/)@ operator are both in scope.
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
'-' -- TODO: is this guaranteed valid no matter @a@?
            (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 [])

    {-
    -- TODO: we might prefer to use something like:
    PP.cat [ppIntegral n, PP.char '/' <> ppIntegral d ]
    where ppIntegral = PP.text . show
    -}


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]
header :: [Text]
header  =
  [ 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
"" ]

----------------------------------------------------------------
----------------------------------------------------------- fin.