{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}

module Gibbon.Pretty
  ( Pretty(..), PPStyle(..), HasPretty, render, pprintHsWithEnv, pprender ) where

import           Prelude hiding ((<>))
import           Text.PrettyPrint
import           Text.PrettyPrint.GenericPretty
import qualified Data.Map as M

import qualified Gibbon.L0.Syntax as L0
import           Gibbon.L1.Syntax as L1
import           Gibbon.L2.Syntax as L2
import qualified Gibbon.NewL2.Syntax as NewL2
import           Gibbon.L3.Syntax as L3
import           Gibbon.Common
import           Gibbon.HaskellFrontend ( primMap )
import qualified Gibbon.L4.Syntax as L4

--------------------------------------------------------------------------------

-- | Rendering style.
data PPStyle
    = PPHaskell  -- ^ Prefer compatibility with GHC over anything else.
    | PPInternal -- ^ Noisiest, useful for Gibbon developers.
    deriving (Eq PPStyle
Eq PPStyle
-> (PPStyle -> PPStyle -> Ordering)
-> (PPStyle -> PPStyle -> Bool)
-> (PPStyle -> PPStyle -> Bool)
-> (PPStyle -> PPStyle -> Bool)
-> (PPStyle -> PPStyle -> Bool)
-> (PPStyle -> PPStyle -> PPStyle)
-> (PPStyle -> PPStyle -> PPStyle)
-> Ord PPStyle
PPStyle -> PPStyle -> Bool
PPStyle -> PPStyle -> Ordering
PPStyle -> PPStyle -> PPStyle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PPStyle -> PPStyle -> Ordering
compare :: PPStyle -> PPStyle -> Ordering
$c< :: PPStyle -> PPStyle -> Bool
< :: PPStyle -> PPStyle -> Bool
$c<= :: PPStyle -> PPStyle -> Bool
<= :: PPStyle -> PPStyle -> Bool
$c> :: PPStyle -> PPStyle -> Bool
> :: PPStyle -> PPStyle -> Bool
$c>= :: PPStyle -> PPStyle -> Bool
>= :: PPStyle -> PPStyle -> Bool
$cmax :: PPStyle -> PPStyle -> PPStyle
max :: PPStyle -> PPStyle -> PPStyle
$cmin :: PPStyle -> PPStyle -> PPStyle
min :: PPStyle -> PPStyle -> PPStyle
Ord, PPStyle -> PPStyle -> Bool
(PPStyle -> PPStyle -> Bool)
-> (PPStyle -> PPStyle -> Bool) -> Eq PPStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PPStyle -> PPStyle -> Bool
== :: PPStyle -> PPStyle -> Bool
$c/= :: PPStyle -> PPStyle -> Bool
/= :: PPStyle -> PPStyle -> Bool
Eq, Int -> PPStyle -> ShowS
[PPStyle] -> ShowS
PPStyle -> String
(Int -> PPStyle -> ShowS)
-> (PPStyle -> String) -> ([PPStyle] -> ShowS) -> Show PPStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PPStyle -> ShowS
showsPrec :: Int -> PPStyle -> ShowS
$cshow :: PPStyle -> String
show :: PPStyle -> String
$cshowList :: [PPStyle] -> ShowS
showList :: [PPStyle] -> ShowS
Show, ReadPrec [PPStyle]
ReadPrec PPStyle
Int -> ReadS PPStyle
ReadS [PPStyle]
(Int -> ReadS PPStyle)
-> ReadS [PPStyle]
-> ReadPrec PPStyle
-> ReadPrec [PPStyle]
-> Read PPStyle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PPStyle
readsPrec :: Int -> ReadS PPStyle
$creadList :: ReadS [PPStyle]
readList :: ReadS [PPStyle]
$creadPrec :: ReadPrec PPStyle
readPrec :: ReadPrec PPStyle
$creadListPrec :: ReadPrec [PPStyle]
readListPrec :: ReadPrec [PPStyle]
Read)


class Pretty e where
    pprintWithStyle :: PPStyle -> e -> Doc

    pprint :: e -> Doc
    pprint = PPStyle -> e -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
PPInternal

    {-# MINIMAL pprintWithStyle  #-}

pprender :: Pretty e => e -> String
pprender :: forall e. Pretty e => e -> String
pprender = Doc -> String
render (Doc -> String) -> (e -> Doc) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Doc
forall e. Pretty e => e -> Doc
pprint

doublecolon :: Doc
doublecolon :: Doc
doublecolon = Doc
colon Doc -> Doc -> Doc
<> Doc
colon

indentLevel :: Int
indentLevel :: Int
indentLevel = Int
4

--------------------------------------------------------------------------------

-- A convenience wrapper over some of the constraints.
type HasPretty ex = (Pretty ex, Pretty (TyOf ex), Pretty (ArrowTy (TyOf ex)))

-- Program:
instance HasPretty ex => Pretty (Prog ex) where
    pprintWithStyle :: PPStyle -> Prog ex -> Doc
pprintWithStyle PPStyle
sty (Prog DDefs (TyOf ex)
ddefs FunDefs ex
funs Maybe (ex, TyOf ex)
me) =
        let meDoc :: Doc
meDoc = case Maybe (ex, TyOf ex)
me of
                      Maybe (ex, TyOf ex)
Nothing -> Doc
empty
                      -- Uh, we need versions of hasBenchE for L0, L2 and L3 too :
                      -- Assume False for now.
                      Just (ex
e,TyOf ex
ty) -> Bool -> Doc -> Doc -> Doc
renderMain Bool
False (PPStyle -> ex -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ex
e) (PPStyle -> TyOf ex -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty TyOf ex
ty)
            ddefsDoc :: Doc
ddefsDoc = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (DDef (TyOf ex) -> Doc) -> [DDef (TyOf ex)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> DDef (TyOf ex) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) ([DDef (TyOf ex)] -> [Doc]) -> [DDef (TyOf ex)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf ex) -> [DDef (TyOf ex)]
forall k a. Map k a -> [a]
M.elems DDefs (TyOf ex)
ddefs
            funsDoc :: Doc
funsDoc = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (FunDef ex -> Doc) -> [FunDef ex] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> FunDef ex -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) ([FunDef ex] -> [Doc]) -> [FunDef ex] -> [Doc]
forall a b. (a -> b) -> a -> b
$ FunDefs ex -> [FunDef ex]
forall k a. Map k a -> [a]
M.elems FunDefs ex
funs
        in case PPStyle
sty of
             PPStyle
PPInternal -> Doc
ddefsDoc Doc -> Doc -> Doc
$+$ Doc
funsDoc Doc -> Doc -> Doc
$+$ Doc
meDoc
             PPStyle
PPHaskell  -> Bool -> Doc
ghc_compat_prefix Bool
False Doc -> Doc -> Doc
$+$ Doc
ddefsDoc Doc -> Doc -> Doc
$+$ Doc
funsDoc Doc -> Doc -> Doc
$+$ Doc
meDoc Doc -> Doc -> Doc
$+$ Bool -> Doc
ghc_compat_suffix Bool
False

renderMain :: Bool -> Doc -> Doc -> Doc
renderMain :: Bool -> Doc -> Doc -> Doc
renderMain Bool
has_bench Doc
m Doc
ty =
  if Bool
has_bench
  then (String -> Doc
text String
"gibbon_main" Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> Doc
"IO ()" Doc -> Doc -> Doc
$+$
        String -> Doc
text String
"gibbon_main" Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> String -> Doc
text String
"do" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
indentLevel Doc
m)
  else (String -> Doc
text String
"gibbon_main" Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> Doc
ty Doc -> Doc -> Doc
$+$
        String -> Doc
text String
"gibbon_main" Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
indentLevel Doc
m)


-- Things we need to make this a valid compilation unit for GHC:
ghc_compat_prefix, ghc_compat_suffix :: Bool -> Doc
ghc_compat_prefix :: Bool -> Doc
ghc_compat_prefix Bool
has_bench =
  String -> Doc
text String
"{-# LANGUAGE ScopedTypeVariables #-}" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"{-# LANGUAGE DeriveGeneric       #-}" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"{-# LANGUAGE DeriveAnyClass      #-}" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"{-# LANGUAGE DerivingStrategies  #-}" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"module Main where" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"-- Gibbon Prelude --" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"import Prelude as P ( (==), id, print, lookup, ($)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"                    , Int, (+), (-), (*), quot, (<), (>), (<=), (>=), (^), mod" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"                    , Bool(..), (||), (&&)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"                    , String, (++)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"                    , Show, Eq, IO)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"import Data.Maybe (fromJust, isJust)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  (if Bool
has_bench
   then (String -> Doc
text String
"import Criterion (nf, benchmark, bench)" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"import Control.DeepSeq (force, NFData)" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"import GHC.Generics" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"import System.Mem (performMajorGC)" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"import Data.Time.Clock (getCurrentTime, diffUTCTime)" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"import Prelude as P ( (.), return )" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"gibbon_bench :: (NFData a, NFData b) => String -> (a -> b) -> a -> IO ()" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"gibbon_bench str fn arg = benchmark (nf fn (force arg))" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"")
   else (String -> Doc
text String
"gibbon_bench :: String -> (a -> b) -> a -> b" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"gibbon_bench _str fn arg = fn arg" Doc -> Doc -> Doc
$+$
         String -> Doc
text String
"" Doc -> Doc -> Doc
$+$ Doc
empty)) Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"type Sym = String" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"type Dict a = [(Sym,a)]" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"timeit :: a -> a" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"timeit = id" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"rand :: Int" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"rand = 10" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"(/) :: Int -> Int -> Int" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"(/) = quot" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"eqsym :: Sym -> Sym -> Bool" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"eqsym = (==)" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"mod :: Int -> Int -> Int" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"mod = P.mod" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"sizeParam :: Int" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"sizeParam = 4" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"dictEmpty _a = []" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"dictInsert _a d x v = (x,v):d" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"dictLookup d k = fromJust $ lookup k d" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"dictHaskey d k = isJust $ lookup k d" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
"-- Gibbon Prelude ends --" Doc -> Doc -> Doc
$+$
  String -> Doc
text String
""

    -- text "{-# LANGUAGE ScopedTypeVariables #-}\n" $+$
    --                 text "module Main where\n" $+$
    --                 text "timeit = id\n" $+$
    --                 text "sizeParam = 4"

ghc_compat_suffix :: Bool -> Doc
ghc_compat_suffix Bool
has_bench =
  if Bool
has_bench
  then Doc
"\nmain = gibbon_main"
  else String -> Doc
text String
"\nmain = print gibbon_main"

instance Pretty FunRec where
    pprintWithStyle :: PPStyle -> FunRec -> Doc
pprintWithStyle PPStyle
_sty = String -> Doc
text (String -> Doc) -> (FunRec -> String) -> FunRec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunRec -> String
forall a. Show a => a -> String
show

instance Pretty FunInline where
    pprintWithStyle :: PPStyle -> FunInline -> Doc
pprintWithStyle PPStyle
_sty = String -> Doc
text (String -> Doc) -> (FunInline -> String) -> FunInline -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunInline -> String
forall a. Show a => a -> String
show

instance Pretty FunMeta where
    pprintWithStyle :: PPStyle -> FunMeta -> Doc
pprintWithStyle PPStyle
_sty = String -> Doc
text (String -> Doc) -> (FunMeta -> String) -> FunMeta -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunMeta -> String
forall a. Show a => a -> String
show

-- Functions:
instance HasPretty ex => Pretty (FunDef ex) where
    pprintWithStyle :: PPStyle -> FunDef ex -> Doc
pprintWithStyle PPStyle
sty FunDef{Var
funName :: Var
funName :: forall ex. FunDef ex -> Var
funName,[Var]
funArgs :: [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs,ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf ex)
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy,ex
funBody :: ex
funBody :: forall ex. FunDef ex -> ex
funBody,FunMeta
funMeta :: FunMeta
funMeta :: forall ex. FunDef ex -> FunMeta
funMeta} =
        Doc -> Doc
braces (String -> Doc
text String
"meta:" Doc -> Doc -> Doc
<+> PPStyle -> FunMeta -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty FunMeta
funMeta) Doc -> Doc -> Doc
$$
          String -> Doc
text (Var -> String
fromVar Var
funName) Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> ArrowTy (TyOf ex) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ArrowTy (TyOf ex)
funTy
            Doc -> Doc -> Doc
$$ Doc
renderBod Doc -> Doc -> Doc
<> String -> Doc
text String
"\n"
      where
        renderBod :: Doc
        renderBod :: Doc
renderBod = String -> Doc
text (Var -> String
fromVar Var
funName) Doc -> Doc -> Doc
<+> (PPStyle -> [Var] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [Var]
funArgs) Doc -> Doc -> Doc
<+> Doc
equals
                      Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
indentLevel (PPStyle -> ex -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ex
funBody)

-- Datatypes
instance Pretty ex => Pretty (DDef ex) where
    pprintWithStyle :: PPStyle -> DDef ex -> Doc
pprintWithStyle PPStyle
sty DDef{Var
tyName :: Var
tyName :: forall a. DDef a -> Var
tyName,[TyVar]
tyArgs :: [TyVar]
tyArgs :: forall a. DDef a -> [TyVar]
tyArgs,[(String, [(Bool, ex)])]
dataCons :: [(String, [(Bool, ex)])]
dataCons :: forall a. DDef a -> [(String, [(Bool, a)])]
dataCons} =
        String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
tyName Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVar -> Doc) -> [TyVar] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> TyVar -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [TyVar]
tyArgs)
          Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
punctuate Doc
" | " ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
                                 ((String, [(Bool, ex)]) -> Doc)
-> [(String, [(Bool, ex)])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
d,[(Bool, ex)]
args) ->
                                        String -> Doc
text String
d Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (((Bool, ex) -> Doc) -> [(Bool, ex)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_,ex
b) -> PPStyle -> ex -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ex
b) [(Bool, ex)]
args))
                                   [(String, [(Bool, ex)])]
dataCons)
          Doc -> Doc -> Doc
<+> (if PPStyle
sty PPStyle -> PPStyle -> Bool
forall a. Eq a => a -> a -> Bool
== PPStyle
PPHaskell
               then String -> Doc
text String
"\n  deriving Show"
               else Doc
empty)


-- Primitives
instance (Show d, Pretty d, Ord d) => Pretty (Prim d) where
    pprintWithStyle :: PPStyle -> Prim d -> Doc
pprintWithStyle PPStyle
sty Prim d
pr =
        let renderPrim :: Map (Prim d) String
renderPrim = [(Prim d, String)] -> Map (Prim d) String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((String, Prim d) -> (Prim d, String))
-> [(String, Prim d)] -> [(Prim d, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
a,Prim d
b) -> (Prim d
b,String
a)) (Map String (Prim d) -> [(String, Prim d)]
forall k a. Map k a -> [(k, a)]
M.toList Map String (Prim d)
forall a. Map String (Prim a)
primMap))
        in case Prim d -> Map (Prim d) String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Prim d
pr Map (Prim d) String
renderPrim of
              Maybe String
Nothing  ->
                  let wty :: d -> Doc
wty d
ty = String -> Doc
text String
"<" Doc -> Doc -> Doc
<> PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty Doc -> Doc -> Doc
<> String -> Doc
text String
">"
                  in
                    case PPStyle
sty of
                      PPStyle
PPInternal -> case Prim d
pr of
                                      DictEmptyP d
ty  -> String -> Doc
text String
"DictEmpty"  Doc -> Doc -> Doc
<> d -> Doc
wty d
ty
                                      DictHasKeyP d
ty -> String -> Doc
text String
"DictHasKey" Doc -> Doc -> Doc
<> d -> Doc
wty d
ty
                                      DictInsertP d
ty -> String -> Doc
text String
"DictInsert" Doc -> Doc -> Doc
<> d -> Doc
wty d
ty
                                      DictLookupP d
ty -> String -> Doc
text String
"DictLookup" Doc -> Doc -> Doc
<> d -> Doc
wty d
ty
                                      Prim d
RequestSizeOf  -> String -> Doc
text String
"RequestSizeOf"
                                      ErrorP String
str d
ty  -> String -> Doc
text String
"ErrorP" Doc -> Doc -> Doc
<> d -> Doc
wty d
ty Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
str) Doc -> Doc -> Doc
<> Doc
space
                                      VAllocP d
ty -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"valloc" Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty)
                                      VFreeP d
_ty -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"vfree"
                                      VFree2P d
_ty-> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"vfree2"
                                      VLengthP{} -> String -> Doc
text String
"vlength"
                                      VNthP{}    -> String -> Doc
text String
"vnth"
                                      VSliceP{}   -> String -> Doc
text String
"vslice"
                                      InplaceVUpdateP{} -> String -> Doc
text String
"inplacevupdate"
                                      VConcatP{} -> String -> Doc
text String
"vconcat"
                                      VSortP{}   -> String -> Doc
text String
"vsort"
                                      InplaceVSortP{} -> String -> Doc
text String
"inplacevsort"
                                      VMergeP{} -> String -> Doc
text String
"vmerge"
                                      PDictAllocP{} -> String -> Doc
text String
"alloc_pdict"
                                      PDictInsertP{} -> String -> Doc
text String
"insert_pdict"
                                      PDictLookupP{} -> String -> Doc
text String
"lookup_pdict"
                                      PDictHasKeyP{} -> String -> Doc
text String
"member_pdict"
                                      PDictForkP{} -> String -> Doc
text String
"fork_pdict"
                                      PDictJoinP{} -> String -> Doc
text String
"join_pdict"
                                      LLAllocP{} -> String -> Doc
text String
"alloc_ll"
                                      LLIsEmptyP{} -> String -> Doc
text String
"is_empty_ll"
                                      LLConsP{} -> String -> Doc
text String
"cons_ll"
                                      LLHeadP{} -> String -> Doc
text String
"head_ll"
                                      LLTailP{} -> String -> Doc
text String
"tail_ll"
                                      LLFreeP{} -> String -> Doc
text String
"free_ll"
                                      LLFree2P{} -> String -> Doc
text String
"free2_ll"
                                      LLCopyP{} -> String -> Doc
text String
"copy_ll"
                                      ReadPackedFile Maybe String
mb_fp String
tycon Maybe Var
_ d
_ ->
                                        Doc -> Doc
parens (String -> Doc
text String
"readPackedFile " Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (Maybe String -> String
forall a. Out a => a -> String
pretty Maybe String
mb_fp))) Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> String -> Doc
text String
tycon
                                      ReadArrayFile Maybe (String, Int)
mb_fp d
ty ->
                                        Doc -> Doc
parens (String -> Doc
text String
"readArrayFile " Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe (String, Int) -> String
forall a. Out a => a -> String
pretty Maybe (String, Int)
mb_fp)) Doc -> Doc -> Doc
<+>
                                        Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty
                                      WritePackedFile String
fp d
ty ->
                                        Doc -> Doc
parens (String -> Doc
text String
"writePackedFile " Doc -> Doc -> Doc
<+> String -> Doc
text String
fp) Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty
                                      EqBenchProgP String
str -> String -> Doc
text String
"eqBenchProg" Doc -> Doc -> Doc
<+> String -> Doc
text String
str
                                      Prim d
_ -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"pprint: Unknown primitive: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim d -> String
forall a. Show a => a -> String
show Prim d
pr
                      PPStyle
PPHaskell  -> case Prim d
pr of
                                      DictEmptyP d
_ty  -> String -> Doc
text String
"dictEmpty"
                                      DictHasKeyP d
_ty -> String -> Doc
text String
"dictHasKey"
                                      DictInsertP d
_ty -> String -> Doc
text String
"dictInsert"
                                      DictLookupP d
_ty -> String -> Doc
text String
"dictLookup"
                                      ErrorP String
str d
_ty -> String -> Doc
text String
"error" Doc -> Doc -> Doc
<> Doc -> Doc
doubleQuotes (String -> Doc
text String
str)
                                      ReadPackedFile Maybe String
mb_fp String
tycon Maybe Var
_ d
_ ->
                                        Doc -> Doc
parens (String -> Doc
text String
"readPackedFile " Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (Maybe String -> String
forall a. Out a => a -> String
pretty Maybe String
mb_fp))) Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> String -> Doc
text String
tycon
                                      ReadArrayFile Maybe (String, Int)
mb_fp d
ty ->
                                        Doc -> Doc
parens (String -> Doc
text String
"readArrayFile " Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe (String, Int) -> String
forall a. Out a => a -> String
pretty Maybe (String, Int)
mb_fp)) Doc -> Doc -> Doc
<+>
                                        Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty
                                      Prim d
_ -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"pprint: Unknown primitive: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Prim d -> String
forall a. Show a => a -> String
show Prim d
pr
              Just String
str -> String -> Doc
text String
str


-- Types:
instance Pretty () where
    pprintWithStyle :: PPStyle -> () -> Doc
pprintWithStyle PPStyle
_ ()
_ = Doc
empty

instance Pretty Bool where
    pprintWithStyle :: PPStyle -> Bool -> Doc
pprintWithStyle PPStyle
_ = String -> Doc
text (String -> Doc) -> (Bool -> String) -> Bool -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show


instance Pretty Var where
    pprintWithStyle :: PPStyle -> Var -> Doc
pprintWithStyle PPStyle
_ Var
v = String -> Doc
text (Var -> String
fromVar Var
v)

instance Pretty [Var] where
    pprintWithStyle :: PPStyle -> [Var] -> Doc
pprintWithStyle PPStyle
_ [Var]
ls = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Var -> Doc) -> [Var] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (Var -> String) -> Var -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> String
fromVar) [Var]
ls

instance Pretty TyVar where
    pprintWithStyle :: PPStyle -> TyVar -> Doc
pprintWithStyle PPStyle
sty TyVar
tyvar =
      case PPStyle
sty of
        PPStyle
PPHaskell -> case TyVar
tyvar of
                       BoundTv Var
v  -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Var -> String
fromVar Var
v
                       SkolemTv{} -> TyVar -> Doc
forall a. Out a => a -> Doc
doc TyVar
tyvar
                       UserTv Var
v   -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Var -> String
fromVar Var
v
        PPStyle
PPInternal -> TyVar -> Doc
forall a. Out a => a -> Doc
doc TyVar
tyvar

instance (Pretty l) => Pretty (UrTy l) where
    pprintWithStyle :: PPStyle -> UrTy l -> Doc
pprintWithStyle PPStyle
sty UrTy l
ty =
        case UrTy l
ty of
          UrTy l
IntTy  -> String -> Doc
text String
"Int"
          UrTy l
CharTy -> String -> Doc
text String
"Char"
          UrTy l
FloatTy-> String -> Doc
text String
"Float"
          UrTy l
SymTy  -> String -> Doc
text String
"Sym"
          UrTy l
BoolTy -> String -> Doc
text String
"Bool"
          ProdTy [UrTy l]
tys    -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"," ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (UrTy l -> Doc) -> [UrTy l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> UrTy l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [UrTy l]
tys
          SymDictTy (Just Var
var) UrTy ()
ty1 -> case PPStyle
sty of
                                        PPStyle
PPHaskell  -> String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty1
                                        PPStyle
PPInternal -> String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
var Doc -> Doc -> Doc
<+> PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty1
          SymDictTy Maybe Var
Nothing UrTy ()
ty1 -> case PPStyle
sty of
                                     PPStyle
PPHaskell  ->String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty1
                                     PPStyle
PPInternal -> String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> String -> Doc
text String
"_" Doc -> Doc -> Doc
<+> PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty1
          PDictTy UrTy l
k UrTy l
v -> String -> Doc
text String
"PDict" Doc -> Doc -> Doc
<+> PPStyle -> UrTy l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy l
k Doc -> Doc -> Doc
<+> PPStyle -> UrTy l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy l
v
          PackedTy String
tc l
loc ->
              case PPStyle
sty of
                PPStyle
PPHaskell  -> String -> Doc
text String
tc
                PPStyle
PPInternal -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Packed" Doc -> Doc -> Doc
<+> String -> Doc
text String
tc Doc -> Doc -> Doc
<+> PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty l
loc
          VectorTy UrTy l
el_ty1 -> String -> Doc
text String
"Vector" Doc -> Doc -> Doc
<+> PPStyle -> UrTy l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy l
el_ty1
          ListTy UrTy l
el_ty1 -> String -> Doc
text String
"List" Doc -> Doc -> Doc
<+> PPStyle -> UrTy l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy l
el_ty1
          UrTy l
PtrTy     -> String -> Doc
text String
"Ptr"
          UrTy l
CursorTy  -> String -> Doc
text String
"Cursor"
          UrTy l
ArenaTy   -> case PPStyle
sty of
                         PPStyle
PPHaskell  -> String -> Doc
text String
"()"
                         PPStyle
PPInternal -> String -> Doc
text String
"Arena"
          UrTy l
SymSetTy  -> String -> Doc
text String
"SymSet"
          UrTy l
SymHashTy -> String -> Doc
text String
"SymHash"
          UrTy l
IntHashTy -> String -> Doc
text String
"IntHash"

-- Function type for L1 and L3
instance Pretty ([UrTy ()], UrTy ()) where
    pprintWithStyle :: PPStyle -> ([UrTy ()], UrTy ()) -> Doc
pprintWithStyle PPStyle
sty ([UrTy ()]
as,UrTy ()
b) = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
" ->" ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (UrTy () -> Doc) -> [UrTy ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) ([UrTy ()]
as [UrTy ()] -> [UrTy ()] -> [UrTy ()]
forall a. [a] -> [a] -> [a]
++ [UrTy ()
b])

instance Pretty ty2 => Pretty (ArrowTy2 ty2) where
    -- TODO: start metadata at column 0 instead of aligning it with the type
    pprintWithStyle :: PPStyle -> ArrowTy2 ty2 -> Doc
pprintWithStyle PPStyle
sty ArrowTy2 ty2
fnty =
        case PPStyle
sty of
          PPStyle
PPHaskell ->
            ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
" ->" ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ty2 -> Doc) -> [ty2] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> ty2 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) (ArrowTy2 ty2 -> [ty2]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy2 ty2
fnty)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> PPStyle -> ty2 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty (ArrowTy2 ty2 -> ty2
forall ty2. ArrowTy2 ty2 -> ty2
arrOut ArrowTy2 ty2
fnty)
          PPStyle
PPInternal ->
            PPStyle -> ArrowTy2 ty2 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
PPHaskell ArrowTy2 ty2
fnty Doc -> Doc -> Doc
$$
              Doc -> Doc
braces (String -> Doc
text String
"locvars" Doc -> Doc -> Doc
<+> [LRM] -> Doc
forall a. Out a => a -> Doc
doc (ArrowTy2 ty2 -> [LRM]
forall ty2. ArrowTy2 ty2 -> [LRM]
locVars ArrowTy2 ty2
fnty) Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
$$
                      String -> Doc
text String
"effs: " Doc -> Doc -> Doc
<+> Set Effect -> Doc
forall a. Out a => a -> Doc
doc (ArrowTy2 ty2 -> Set Effect
forall ty2. ArrowTy2 ty2 -> Set Effect
arrEffs ArrowTy2 ty2
fnty) Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
$$
                      String -> Doc
text String
"locrets: " Doc -> Doc -> Doc
<+> [LocRet] -> Doc
forall a. Out a => a -> Doc
doc (ArrowTy2 ty2 -> [LocRet]
forall ty2. ArrowTy2 ty2 -> [LocRet]
locRets ArrowTy2 ty2
fnty) Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
$$
                      String -> Doc
text String
"parallel: " Doc -> Doc -> Doc
<+> Bool -> Doc
forall a. Out a => a -> Doc
doc (ArrowTy2 ty2 -> Bool
forall ty2. ArrowTy2 ty2 -> Bool
hasParallelism ArrowTy2 ty2
fnty))


-- Expressions

-- CSK: Needs a better name.
type HasPrettyToo e l d = (Show d, Ord d, Eq d, Pretty d, Pretty l, Pretty (e l d), TyOf (e l (UrTy l)) ~ TyOf (PreExp e l (UrTy l)))


instance Pretty (PreExp e l d) => Pretty [(PreExp e l d)] where
    pprintWithStyle :: PPStyle -> [PreExp e l d] -> Doc
pprintWithStyle PPStyle
sty [PreExp e l d]
ls = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> Doc) -> [PreExp e l d] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp e l d]
ls

instance HasPrettyToo e l d => Pretty (PreExp e l d) where
    pprintWithStyle :: PPStyle -> PreExp e l d -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
ex0 =
        case PreExp e l d
ex0 of
          VarE Var
v -> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v
          LitE Int
i -> Int -> Doc
int Int
i
          CharE Char
i -> Doc -> Doc
quotes (Char -> Doc
char Char
i)
          FloatE Double
i  -> Double -> Doc
double Double
i
          LitSymE Var
v -> String -> Doc
text String
"\"" Doc -> Doc -> Doc
<> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<> String -> Doc
text String
"\""
          AppE Var
v [l]
locs [PreExp e l d]
ls -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                             PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+>
                             (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ((l -> Doc) -> [l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map l -> Doc
forall e. Pretty e => e -> Doc
pprint [l]
locs))) Doc -> Doc -> Doc
<+>
                             (PPStyle -> [PreExp e l d] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [PreExp e l d]
ls)
          PrimAppE Prim d
pr [PreExp e l d]
es ->
              case Prim d
pr of
                  Prim d
_ | Prim d
pr Prim d -> [Prim d] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim d
forall ty. Prim ty
AddP, Prim d
forall ty. Prim ty
SubP, Prim d
forall ty. Prim ty
MulP, Prim d
forall ty. Prim ty
DivP, Prim d
forall ty. Prim ty
ModP, Prim d
forall ty. Prim ty
ExpP, Prim d
forall ty. Prim ty
EqSymP, Prim d
forall ty. Prim ty
EqIntP, Prim d
forall ty. Prim ty
LtP, Prim d
forall ty. Prim ty
GtP] ->
                      let [PreExp e l d
a1,PreExp e l d
a2] = [PreExp e l d]
es
                      in PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
a1 Doc -> Doc -> Doc
<+> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr Doc -> Doc -> Doc
<+> PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
a2

                  Prim d
_ | Prim d
pr Prim d -> [Prim d] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim d
forall ty. Prim ty
MkTrue, Prim d
forall ty. Prim ty
MkFalse, Prim d
forall ty. Prim ty
SizeParam] -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr

                  ReadPackedFile{} -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr
                  WritePackedFile{} -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr Doc -> Doc -> Doc
<+> PPStyle -> [PreExp e l d] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [PreExp e l d]
es
                  ReadArrayFile{}  -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr

                  Prim d
_ -> case PPStyle
sty of
                         PPStyle
PPHaskell  -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
" " ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> Doc) -> [PreExp e l d] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp e l d]
es)
                         PPStyle
PPInternal -> PPStyle -> Prim d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim d
pr Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"," ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (PreExp e l d -> Doc) -> [PreExp e l d] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp e l d]
es)

          LetE (Var
v,[l]
ls,d
ty,PreExp e l d
e1) PreExp e l d
e2 -> (String -> Doc
text String
"let") Doc -> Doc -> Doc
<+>
                                  PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+>
                                  (if [l] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [l]
ls
                                   then Doc
empty
                                   else Doc -> Doc
brackets ([Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((l -> Doc) -> [l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [l]
ls)))) Doc -> Doc -> Doc
<+>
                                  PPStyle -> d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty d
ty Doc -> Doc -> Doc
<+>
                                  Doc
equals Doc -> Doc -> Doc
<+>
                                  PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e1 Doc -> Doc -> Doc
<+>
                                  String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$
                                  PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e2
          IfE PreExp e l d
e1 PreExp e l d
e2 PreExp e l d
e3 -> String -> Doc
text String
"if" Doc -> Doc -> Doc
<+>
                          PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e1 Doc -> Doc -> Doc
$+$
                          String -> Doc
text String
"then" Doc -> Doc -> Doc
<+>
                          PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e2 Doc -> Doc -> Doc
$+$
                          String -> Doc
text String
"else" Doc -> Doc -> Doc
<+>
                          PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e3
          MkProdE [PreExp e l d]
es -> Doc
lparen Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
", ") ((PreExp e l d -> Doc) -> [PreExp e l d] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp e l d]
es)) Doc -> Doc -> Doc
<> Doc
rparen
          ProjE Int
i PreExp e l d
e ->
              let edoc :: Doc
edoc = PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e
              in case PPStyle
sty of
                PPStyle
PPInternal -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"#" Doc -> Doc -> Doc
<> Int -> Doc
int Int
i Doc -> Doc -> Doc
<+> Doc
edoc
                PPStyle
PPHaskell  ->
                    case Int
i of
                      Int
0 -> String -> Doc
text String
"fst" Doc -> Doc -> Doc
<+> Doc
edoc
                      Int
1 -> String -> Doc
text String
"snd" Doc -> Doc -> Doc
<+> Doc
edoc
                      Int
_ -> String -> Doc
forall a. HasCallStack => String -> a
error (Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
PPInternal PreExp e l d
ex0) -- text "#" <> int i <+> edoc
          CaseE PreExp e l d
e [(String, [(Var, l)], PreExp e l d)]
bnds -> String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"of" Doc -> Doc -> Doc
$+$
                          Int -> Doc -> Doc
nest Int
indentLevel ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((String, [(Var, l)], PreExp e l d) -> Doc)
-> [(String, [(Var, l)], PreExp e l d)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, [(Var, l)], PreExp e l d) -> Doc
dobinds [(String, [(Var, l)], PreExp e l d)]
bnds)
          DataConE l
loc String
dc [PreExp e l d]
es -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
dc Doc -> Doc -> Doc
<+>
                                (if Doc -> Bool
isEmpty (PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty l
loc)
                                 then Doc
empty
                                 else PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty l
loc) Doc -> Doc -> Doc
<+>
                                [Doc] -> Doc
hsep ((PreExp e l d -> Doc) -> [PreExp e l d] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp e l d]
es)
                              -- lparen <> hcat (punctuate (text ",") (map (pprintWithStyle sty) es)) <> rparen
          TimeIt PreExp e l d
e d
_ty Bool
_b -> String -> Doc
text String
"timeit" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e)
          SpawnE Var
v [l]
locs [PreExp e l d]
ls -> String -> Doc
text String
"spawn" Doc -> Doc -> Doc
<+>
                                Doc -> Doc
parens (PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+>
                                         (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ((l -> Doc) -> [l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map l -> Doc
forall e. Pretty e => e -> Doc
pprint [l]
locs))) Doc -> Doc -> Doc
<+>
                                         (PPStyle -> [PreExp e l d] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [PreExp e l d]
ls))
          PreExp e l d
SyncE -> String -> Doc
text String
"sync"
          WithArenaE Var
v PreExp e l d
e -> case PPStyle
sty of
                              PPStyle
PPHaskell  -> (String -> Doc
text String
"let") Doc -> Doc -> Doc
<+>
                                            PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+>
                                            Doc
equals Doc -> Doc -> Doc
<+>
                                            String -> Doc
text String
"()" Doc -> Doc -> Doc
<+>
                                            String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$
                                            PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e
                              PPStyle
PPInternal -> String -> Doc
text String
"letarena" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
v Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$ PreExp e l d -> Doc
forall e. Pretty e => e -> Doc
pprint PreExp e l d
e
          Ext e l d
ext -> PPStyle -> e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty e l d
ext
          MapE{} -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected form in program: MapE"
          FoldE{} -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected form in program: FoldE"
        where
          dobinds :: (String, [(Var, l)], PreExp e l d) -> Doc
dobinds (String
dc,[(Var, l)]
vls,PreExp e l d
e) = String -> Doc
text String
dc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" ")
                                                           (((Var, l) -> Doc) -> [(Var, l)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,l
loc) -> if Doc -> Bool
isEmpty (PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty l
loc)
                                                                             then PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v
                                                                             else PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<> Doc
doublecolon Doc -> Doc -> Doc
<> PPStyle -> l -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty l
loc)
                                                            [(Var, l)]
vls))
                               Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
indentLevel (PPStyle -> PreExp e l d -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp e l d
e)
-- L1
instance (Pretty l, Pretty d, Ord d, Show d) => Pretty (E1Ext l d) where
    pprintWithStyle :: PPStyle -> E1Ext l d -> Doc
pprintWithStyle PPStyle
sty E1Ext l d
ext =
      case E1Ext l d
ext of
        L1.AddFixed Var
v Int
i   -> String -> Doc
text String
"addFixed" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+> Int -> Doc
int Int
i
        L1.StartOfPkdCursor Var
cur -> String -> Doc
text String
"startOfPkdCursor" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
cur
        BenchE Var
fn [l]
tyapps [PreExp E1Ext l d]
args Bool
b -> String -> Doc
text String
"gibbon_bench" Doc -> Doc -> Doc
<+> (Doc -> Doc
doubleQuotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"") Doc -> Doc -> Doc
<+> String -> Doc
text (Var -> String
fromVar Var
fn) Doc -> Doc -> Doc
<+>
                                   (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ((l -> Doc) -> [l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map l -> Doc
forall e. Pretty e => e -> Doc
pprint [l]
tyapps))) Doc -> Doc -> Doc
<+>
                                   (PPStyle -> [PreExp E1Ext l d] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [PreExp E1Ext l d]
args) Doc -> Doc -> Doc
<+> String -> Doc
text (if Bool
b then String
"true" else String
"false")

-- L2
instance Pretty l => Pretty (L2.PreLocExp l) where
    pprintWithStyle :: PPStyle -> PreLocExp l -> Doc
pprintWithStyle PPStyle
_ PreLocExp l
le =
        case PreLocExp l
le of
          StartOfRegionLE Region
r -> Doc
lparen Doc -> Doc -> Doc
<> String -> Doc
text String
"startOfRegion" Doc -> Doc -> Doc
<+> String -> Doc
text (Region -> String
forall a. Out a => a -> String
sdoc Region
r) Doc -> Doc -> Doc
<> Doc
rparen
          AfterConstantLE Int
i l
loc   -> Doc
lparen Doc -> Doc -> Doc
<> l -> Doc
forall e. Pretty e => e -> Doc
pprint l
loc Doc -> Doc -> Doc
<+> String -> Doc
text String
"+" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
i Doc -> Doc -> Doc
<> Doc
rparen
          AfterVariableLE Var
v l
loc Bool
b -> if Bool
b
                                     then String -> Doc
text String
"fresh" Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ l -> Doc
forall e. Pretty e => e -> Doc
pprint l
loc Doc -> Doc -> Doc
<+> String -> Doc
text String
"+" Doc -> Doc -> Doc
<+> Var -> Doc
forall a. Out a => a -> Doc
doc Var
v)
                                     else Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ l -> Doc
forall e. Pretty e => e -> Doc
pprint l
loc Doc -> Doc -> Doc
<+> String -> Doc
text String
"+" Doc -> Doc -> Doc
<+> Var -> Doc
forall a. Out a => a -> Doc
doc Var
v
          InRegionLE Region
r  -> Doc
lparen Doc -> Doc -> Doc
<> String -> Doc
text String
"inRegion" Doc -> Doc -> Doc
<+> String -> Doc
text (Region -> String
forall a. Out a => a -> String
sdoc Region
r) Doc -> Doc -> Doc
<> Doc
rparen
          FromEndLE l
loc -> Doc
lparen Doc -> Doc -> Doc
<> String -> Doc
text String
"fromEnd" Doc -> Doc -> Doc
<+> l -> Doc
forall e. Pretty e => e -> Doc
pprint l
loc Doc -> Doc -> Doc
<> Doc
rparen
          PreLocExp l
FreeLE -> Doc
lparen Doc -> Doc -> Doc
<> String -> Doc
text String
"free" Doc -> Doc -> Doc
<> Doc
rparen

instance Pretty RegionSize where
    pprintWithStyle :: PPStyle -> RegionSize -> Doc
pprintWithStyle PPStyle
_ (BoundedSize Int
x) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Bounded" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
x
    pprintWithStyle PPStyle
_ RegionSize
Undefined       = String -> Doc
text String
"Unbounded"

instance HasPrettyToo E2Ext l d => Pretty (L2.E2Ext l d) where
    pprintWithStyle :: PPStyle -> E2Ext l d -> Doc
pprintWithStyle PPStyle
_ E2Ext l d
ex0 =
        case E2Ext l d
ex0 of
          L2.AddFixed Var
v Int
i -> String -> Doc
text String
"addfixed" Doc -> Doc -> Doc
<+>
                               Var -> Doc
forall a. Out a => a -> Doc
doc Var
v Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Out a => a -> Doc
doc Int
i
          LetRegionE Region
r RegionSize
sz Maybe RegionType
_ E2 l d
e -> String -> Doc
text String
"letregion" Doc -> Doc -> Doc
<+> RegionSize -> Doc
forall e. Pretty e => e -> Doc
pprint RegionSize
sz Doc -> Doc -> Doc
<+>
                                 Region -> Doc
forall a. Out a => a -> Doc
doc Region
r Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$ E2 l d -> Doc
forall e. Pretty e => e -> Doc
pprint E2 l d
e
          LetParRegionE Region
r RegionSize
_ Maybe RegionType
_ E2 l d
e -> String -> Doc
text String
"letparregion" Doc -> Doc -> Doc
<+>
                                 Region -> Doc
forall a. Out a => a -> Doc
doc Region
r Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$ E2 l d -> Doc
forall e. Pretty e => e -> Doc
pprint E2 l d
e
          LetLocE Var
loc PreLocExp l
le E2 l d
e -> String -> Doc
text String
"letloc" Doc -> Doc -> Doc
<+>
                                Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
loc Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> PreLocExp l -> Doc
forall e. Pretty e => e -> Doc
pprint PreLocExp l
le Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$ E2 l d -> Doc
forall e. Pretty e => e -> Doc
pprint E2 l d
e
          L2.RetE [l]
ls Var
v -> String -> Doc
text String
"return" Doc -> Doc -> Doc
<+>
                            Doc
lbrack Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") ((l -> Doc) -> [l] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map l -> Doc
forall e. Pretty e => e -> Doc
pprint [l]
ls)) Doc -> Doc -> Doc
<> Doc
rbrack Doc -> Doc -> Doc
<+>
                          Var -> Doc
forall a. Out a => a -> Doc
doc Var
v
          FromEndE l
loc -> String -> Doc
text String
"fromende" Doc -> Doc -> Doc
<+> l -> Doc
forall e. Pretty e => e -> Doc
pprint l
loc
          L2.StartOfPkdCursor Var
c -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"startOfPkdCursor" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
c
          L2.TagCursor Var
a Var
b -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"tagCursor" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
a Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
b
          L2.BoundsCheck Int
i l
l1 l
l2 -> String -> Doc
text String
"boundscheck" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
i Doc -> Doc -> Doc
<+> l -> Doc
forall e. Pretty e => e -> Doc
pprint l
l1 Doc -> Doc -> Doc
<+> l -> Doc
forall e. Pretty e => e -> Doc
pprint l
l2
          IndirectionE String
tc String
dc (l
l1,l
v1) (l
l2,l
v2) E2 l d
e -> String -> Doc
text String
"indirection" Doc -> Doc -> Doc
<+>
                                                     String -> Doc
forall a. Out a => a -> Doc
doc String
tc Doc -> Doc -> Doc
<+>
                                                     String -> Doc
forall a. Out a => a -> Doc
doc String
dc Doc -> Doc -> Doc
<+>
                                                     Doc
lparen Doc -> Doc -> Doc
<>
                                                     [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") [l -> Doc
forall e. Pretty e => e -> Doc
pprint l
l1, l -> Doc
forall e. Pretty e => e -> Doc
pprint l
v1]) Doc -> Doc -> Doc
<>
                                                     Doc
rparen Doc -> Doc -> Doc
<+>
                                                     Doc
lparen Doc -> Doc -> Doc
<>
                                                     [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") [l -> Doc
forall e. Pretty e => e -> Doc
pprint l
l2, l -> Doc
forall e. Pretty e => e -> Doc
pprint l
v2]) Doc -> Doc -> Doc
<>
                                                     Doc
rparen Doc -> Doc -> Doc
<+>
                                                     E2 l d -> Doc
forall e. Pretty e => e -> Doc
pprint E2 l d
e
          E2Ext l d
L2.GetCilkWorkerNum -> String -> Doc
text String
"__cilkrts_get_worker_number()"
          L2.LetAvail [Var]
vs E2 l d
e    -> String -> Doc
text String
"letavail " Doc -> Doc -> Doc
<+> [Var] -> Doc
forall e. Pretty e => e -> Doc
pprint [Var]
vs Doc -> Doc -> Doc
$+$ E2 l d -> Doc
forall e. Pretty e => e -> Doc
pprint E2 l d
e
          L2.AllocateTagHere Var
loc String
tycon -> String -> Doc
text String
"allocateTagHere" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
loc Doc -> Doc -> Doc
<+> String -> Doc
text String
tycon
          L2.AllocateScalarsHere Var
loc -> String -> Doc
text String
"allocateScalarsHere" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
loc
          L2.SSPush SSModality
mode Var
loc Var
endloc String
tycon -> String -> Doc
text String
"ss_push" Doc -> Doc -> Doc
<+> SSModality -> Doc
forall a. Out a => a -> Doc
doc SSModality
mode Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
loc Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
endloc Doc -> Doc -> Doc
<+> String -> Doc
forall a. Out a => a -> Doc
doc String
tycon
          L2.SSPop SSModality
mode Var
loc Var
endloc -> String -> Doc
text String
"ss_pop" Doc -> Doc -> Doc
<+> SSModality -> Doc
forall a. Out a => a -> Doc
doc SSModality
mode Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
loc Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
endloc

instance Pretty L2.Region where
  pprintWithStyle :: PPStyle -> Region -> Doc
pprintWithStyle PPStyle
_ Region
reg = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Region -> String
forall a. Out a => a -> String
sdoc Region
reg

instance Pretty L2.Modality where
  pprintWithStyle :: PPStyle -> Modality -> Doc
pprintWithStyle PPStyle
_ Modality
mode = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Modality -> String
forall a. Show a => a -> String
show Modality
mode

instance Pretty L2.LRM where
  pprintWithStyle :: PPStyle -> LRM -> Doc
pprintWithStyle PPStyle
sty (LRM Var
loc Region
reg Modality
mode) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"LRM" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
loc Doc -> Doc -> Doc
<+> PPStyle -> Region -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Region
reg Doc -> Doc -> Doc
<+> PPStyle -> Modality -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Modality
mode

instance Pretty NewL2.LREM where
  pprintWithStyle :: PPStyle -> LREM -> Doc
pprintWithStyle PPStyle
sty (NewL2.LREM Var
loc Var
reg Var
end_reg Modality
mode) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"LRM" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
loc Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
reg Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
end_reg Doc -> Doc -> Doc
<+> PPStyle -> Modality -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Modality
mode

instance Pretty NewL2.LocArg where
  pprintWithStyle :: PPStyle -> LocArg -> Doc
pprintWithStyle PPStyle
sty LocArg
locarg =
    case LocArg
locarg of
      NewL2.Loc LREM
lrm ->
        String -> Doc
text String
"Loc" Doc -> Doc -> Doc
<+> PPStyle -> LREM -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty LREM
lrm
      NewL2.EndWitness LREM
lrm Var
v ->
        String -> Doc
text String
"EndWitness" Doc -> Doc -> Doc
<+> PPStyle -> LREM -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty LREM
lrm Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v
      NewL2.Reg Var
v Modality
mode ->
        String -> Doc
text String
"Reg" Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+> PPStyle -> Modality -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Modality
mode
      NewL2.EndOfReg Var
v Modality
mode Var
w ->
        String -> Doc
text String
"EndOfReg"Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+> PPStyle -> Modality -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Modality
mode Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
w
      NewL2.EndOfReg_Tagged Var
v ->
        String -> Doc
text String
"EndOfReg_Tagged"Doc -> Doc -> Doc
<+> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v

instance Pretty NewL2.Ty2 where
  pprintWithStyle :: PPStyle -> Ty2 -> Doc
pprintWithStyle PPStyle
sty (NewL2.MkTy2 UrTy Var
ty2) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"MkTy2 " Doc -> Doc -> Doc
<+> PPStyle -> UrTy Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy Var
ty2

-- L3
instance (Out l, HasPrettyToo E3Ext l (UrTy l)) => Pretty (L3.E3Ext l (UrTy l)) where
    pprintWithStyle :: PPStyle -> E3Ext l (UrTy l) -> Doc
pprintWithStyle PPStyle
_ (L3.LetAvail [Var]
vs PreExp E3Ext l (UrTy l)
bod) = String -> Doc
text String
"letavail " Doc -> Doc -> Doc
<+> [Var] -> Doc
forall e. Pretty e => e -> Doc
pprint [Var]
vs Doc -> Doc -> Doc
$+$ PreExp E3Ext l (UrTy l) -> Doc
forall e. Pretty e => e -> Doc
pprint PreExp E3Ext l (UrTy l)
bod
    pprintWithStyle PPStyle
_ E3Ext l (UrTy l)
ex0 = E3Ext l (UrTy l) -> Doc
forall a. Out a => a -> Doc
doc E3Ext l (UrTy l)
ex0 -- TODO: replace this with actual pretty printing for L3 forms

-- L4
instance Pretty L4.Prog where
   pprintWithStyle :: PPStyle -> Prog -> Doc
pprintWithStyle PPStyle
_ = Prog -> Doc
forall a. Out a => a -> Doc
doc -- TODO: replace this with actual pretty printing for L4 forms

--------------------------------------------------------------------------------

-- Oh no, all other generic PreExp things are defined over (PreExp e l (UrTy l)).
-- We have to redefine this for L0 (which doesn't use UrTy).

instance Pretty L0.Ty0 where
  pprintWithStyle :: PPStyle -> Ty0 -> Doc
pprintWithStyle PPStyle
sty Ty0
ty =
      case Ty0
ty of
        Ty0
L0.IntTy      -> String -> Doc
text String
"Int"
        Ty0
L0.CharTy     -> String -> Doc
text String
"Char"
        Ty0
L0.FloatTy    -> String -> Doc
text String
"Float"
        Ty0
L0.SymTy0     -> String -> Doc
text String
"Sym"
        Ty0
L0.BoolTy     -> String -> Doc
text String
"Bool"
        L0.TyVar TyVar
v    -> TyVar -> Doc
forall a. Out a => a -> Doc
doc TyVar
v
        L0.MetaTv MetaTv
v   -> MetaTv -> Doc
forall a. Out a => a -> Doc
doc MetaTv
v
        L0.ProdTy [Ty0]
tys -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"," ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Ty0 -> Doc) -> [Ty0] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [Ty0]
tys
        L0.SymDictTy (Just Var
v) Ty0
ty1 -> String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> Var -> Doc
forall e. Pretty e => e -> Doc
pprint Var
v Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
ty1
        L0.SymDictTy Maybe Var
Nothing  Ty0
ty1 -> String -> Doc
text String
"Dict" Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
ty1
        L0.PDictTy Ty0
k Ty0
v -> String -> Doc
text String
"PDict" Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
k Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
v
        L0.ArrowTy [Ty0]
as Ty0
b  -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc -> Doc
<+> Doc
"->") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Ty0 -> Doc) -> [Ty0] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [Ty0]
as) Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
b
        L0.PackedTy String
tc [Ty0]
loc -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Packed" Doc -> Doc -> Doc
<+> String -> Doc
text String
tc Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
hcat ((Ty0 -> Doc) -> [Ty0] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [Ty0]
loc))
        L0.VectorTy Ty0
el_ty1 -> String -> Doc
text String
"Vector" Doc -> Doc -> Doc
<+> (PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Ty0
el_ty1)
        L0.ListTy Ty0
el_ty1 -> String -> Doc
text String
"List" Doc -> Doc -> Doc
<+> (PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Ty0
el_ty1)
        Ty0
L0.ArenaTy    -> String -> Doc
text String
"Arena"
        Ty0
L0.SymSetTy   -> String -> Doc
text String
"SymSet"
        Ty0
L0.SymHashTy  -> String -> Doc
text String
"SymHash"
        Ty0
L0.IntHashTy  -> String -> Doc
text String
"IntHash"


instance Pretty L0.TyScheme where
  pprintWithStyle :: PPStyle -> TyScheme -> Doc
pprintWithStyle PPStyle
_ (L0.ForAll [TyVar]
tvs Ty0
ty) = String -> Doc
text String
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVar -> Doc) -> [TyVar] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Doc
forall a. Out a => a -> Doc
doc [TyVar]
tvs) Doc -> Doc -> Doc
<> String -> Doc
text String
"." Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
ty

instance (Out a, Pretty a) => Pretty (L0.E0Ext a L0.Ty0) where
  pprintWithStyle :: PPStyle -> E0Ext a Ty0 -> Doc
pprintWithStyle PPStyle
sty E0Ext a Ty0
ex0 =
    case E0Ext a Ty0
ex0 of
      L0.LambdaE [(Var, Ty0)]
args PreExp E0Ext a Ty0
bod -> Doc -> Doc
parens (String -> Doc
text String
"\\" Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (((Var, Ty0) -> Doc) -> [(Var, Ty0)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,Ty0
ty) -> Var -> Doc
forall a. Out a => a -> Doc
doc Var
v Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint Ty0
ty) [(Var, Ty0)]
args))) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
                                         Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
indentLevel (PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => e -> Doc
pprint PreExp E0Ext a Ty0
bod))
      L0.FunRefE [a]
tyapps Var
f -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"fn:" Doc -> Doc -> Doc
<> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
f Doc -> Doc -> Doc
<+> (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall e. Pretty e => e -> Doc
pprint [a]
tyapps)))
      L0.PolyAppE{} -> E0Ext a Ty0 -> Doc
forall a. Out a => a -> Doc
doc E0Ext a Ty0
ex0
      L0.BenchE Var
fn [a]
tyapps [PreExp E0Ext a Ty0]
args Bool
b -> String -> Doc
text String
"bench" Doc -> Doc -> Doc
<+> String -> Doc
text (Var -> String
fromVar Var
fn) Doc -> Doc -> Doc
<+>
                                    (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall e. Pretty e => e -> Doc
pprint [a]
tyapps))) Doc -> Doc -> Doc
<+>
                                    (PPStyle -> [PreExp E0Ext a Ty0] -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty [PreExp E0Ext a Ty0]
args) Doc -> Doc -> Doc
<+> String -> Doc
text (if Bool
b then String
"true" else String
"false")
      L0.ParE0 [PreExp E0Ext a Ty0]
ls -> String -> Doc
text String
"par" Doc -> Doc -> Doc
<+> Doc
lparen Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
", ") ((PreExp E0Ext a Ty0 -> Doc) -> [PreExp E0Ext a Ty0] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) [PreExp E0Ext a Ty0]
ls)) Doc -> Doc -> Doc
<> Doc
rparen
      L0.L Loc
_ PreExp E0Ext a Ty0
e    -> PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
e
      L0.PrintPacked Ty0
ty PreExp E0Ext a Ty0
arg -> String -> Doc
text String
"printPacked" Doc -> Doc -> Doc
<+>
                               Doc -> Doc
parens (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
arg Doc -> Doc -> Doc
<> String -> Doc
text String
"::" Doc -> Doc -> Doc
<> PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Ty0
ty)
      L0.CopyPacked Ty0
ty PreExp E0Ext a Ty0
arg -> String -> Doc
text String
"copyPacked" Doc -> Doc -> Doc
<+>
                              Doc -> Doc
parens (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
arg Doc -> Doc -> Doc
<> String -> Doc
text String
"::" Doc -> Doc -> Doc
<> PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Ty0
ty)
      L0.TravPacked Ty0
ty PreExp E0Ext a Ty0
arg -> String -> Doc
text String
"travPacked" Doc -> Doc -> Doc
<+>
                              Doc -> Doc
parens (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
arg Doc -> Doc -> Doc
<> String -> Doc
text String
"::" Doc -> Doc -> Doc
<> PPStyle -> Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Ty0
ty)
      L0.LinearExt LinearExt a Ty0
ext ->
        case LinearExt a Ty0
ext of
          L0.ReverseAppE PreExp E0Ext a Ty0
fn PreExp E0Ext a Ty0
arg -> (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
arg Doc -> Doc -> Doc
<+> String -> Doc
text String
"&") Doc -> Doc -> Doc
$$ PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
fn
          L0.LseqE PreExp E0Ext a Ty0
a PreExp E0Ext a Ty0
b   -> String -> Doc
text String
"lseq" Doc -> Doc -> Doc
<+> PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
a Doc -> Doc -> Doc
<+> PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
b
          L0.AliasE PreExp E0Ext a Ty0
a    -> String -> Doc
text String
"unsafeAlias" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
a)
          L0.ToLinearE PreExp E0Ext a Ty0
a -> String -> Doc
text String
"unsafeToLinear" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PPStyle -> PreExp E0Ext a Ty0 -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty PreExp E0Ext a Ty0
a)


--------------------------------------------------------------------------------

{-

'pprintWithStyle' does not have enough information to translate 'ProjE' to
valid Haskell. In Gibbon, 'ProjE' can project a value out of an *arbitrary*
tuple. It works like the Haskell list index op (!!), rather than tuples. In
Haskell, we must pattern match on a tuple to extract elements out of it. And
we need to know the size of the tuple in order to generate a proper pattern.
'pprintHsWithEnv' carries a type environemt around for this purpose.

Another way to solve this would be to update Gibbon's AST to store this info:

    ... | ProjE (Int, Int) EXP | ...

But that would be  a big refactor.

-}

pprintHsWithEnv :: Prog1 -> Doc
pprintHsWithEnv :: Prog1 -> Doc
pprintHsWithEnv p :: Prog1
p@Prog{DDefs (TyOf (PreExp E1Ext () (UrTy ())))
ddefs :: DDefs (TyOf (PreExp E1Ext () (UrTy ())))
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs,FunDefs (PreExp E1Ext () (UrTy ()))
fundefs :: FunDefs (PreExp E1Ext () (UrTy ()))
fundefs :: forall ex. Prog ex -> FunDefs ex
fundefs,Maybe (PreExp E1Ext () (UrTy ()), TyOf (PreExp E1Ext () (UrTy ())))
mainExp :: Maybe (PreExp E1Ext () (UrTy ()), TyOf (PreExp E1Ext () (UrTy ())))
mainExp :: forall ex. Prog ex -> Maybe (ex, TyOf ex)
mainExp} =
  let env2 :: Env2 (TyOf (PreExp E1Ext () (UrTy ())))
env2 = Prog1 -> Env2 (TyOf (PreExp E1Ext () (UrTy ())))
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog1
p
      (Doc
meDoc,Doc
sfx, Bool
main_has_bench) =
        case Maybe (PreExp E1Ext () (UrTy ()), TyOf (PreExp E1Ext () (UrTy ())))
mainExp of
          Maybe (PreExp E1Ext () (UrTy ()), TyOf (PreExp E1Ext () (UrTy ())))
Nothing     -> (Doc
empty, Doc
empty, Bool
False)
          Just (PreExp E1Ext () (UrTy ())
e,TyOf (PreExp E1Ext () (UrTy ()))
ty) -> let main_has_bench1 :: Bool
main_has_bench1 = PreExp E1Ext () (UrTy ()) -> Bool
hasBenchE PreExp E1Ext () (UrTy ())
e in
                         (Bool -> Doc -> Doc -> Doc
renderMain Bool
main_has_bench1 (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
main_has_bench1 Env2 (TyOf (PreExp E1Ext () (UrTy ())))
Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e) (PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty TyOf (PreExp E1Ext () (UrTy ()))
UrTy ()
ty)
                         , Bool -> Doc
ghc_compat_suffix Bool
main_has_bench1
                         , Bool
main_has_bench1)
      mb_derive_more :: Doc -> Doc
mb_derive_more Doc
d = if Bool
main_has_bench
                         then Doc
d Doc -> Doc -> Doc
$$ (String -> Doc
text String
"  deriving (Generic, NFData)" Doc -> Doc -> Doc
$$ String -> Doc
text String
"")
                         else Doc
d
      ddefsDoc :: Doc
ddefsDoc = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (DDef (UrTy ()) -> Doc) -> [DDef (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
mb_derive_more (Doc -> Doc) -> (DDef (UrTy ()) -> Doc) -> DDef (UrTy ()) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPStyle -> DDef (UrTy ()) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty) ([DDef (UrTy ())] -> [Doc]) -> [DDef (UrTy ())] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Map Var (DDef (UrTy ())) -> [DDef (UrTy ())]
forall k a. Map k a -> [a]
M.elems DDefs (TyOf (PreExp E1Ext () (UrTy ())))
Map Var (DDef (UrTy ()))
ddefs
      funsDoc :: Doc
funsDoc  = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (FunDef1 -> Doc) -> [FunDef1] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Env2 (UrTy ()) -> FunDef1 -> Doc
ppFun Env2 (TyOf (PreExp E1Ext () (UrTy ())))
Env2 (UrTy ())
env2) ([FunDef1] -> [Doc]) -> [FunDef1] -> [Doc]
forall a b. (a -> b) -> a -> b
$ FunDefs (PreExp E1Ext () (UrTy ())) -> [FunDef1]
forall k a. Map k a -> [a]
M.elems FunDefs (PreExp E1Ext () (UrTy ()))
fundefs
  in (Bool -> Doc
ghc_compat_prefix Bool
main_has_bench) Doc -> Doc -> Doc
$+$ Doc
ddefsDoc Doc -> Doc -> Doc
$+$ Doc
funsDoc Doc -> Doc -> Doc
$+$ Doc
meDoc Doc -> Doc -> Doc
$+$ Doc
sfx
  where
    -- | Verify some assumptions about BenchE.
    hasBenchE :: Exp1 -> Bool
    hasBenchE :: PreExp E1Ext () (UrTy ()) -> Bool
hasBenchE PreExp E1Ext () (UrTy ())
ex =
      case PreExp E1Ext () (UrTy ())
ex of
        Ext (BenchE{})   -> Bool
True
        Ext (L1.AddFixed{}) -> Bool
False
        Ext (L1.StartOfPkdCursor{}) -> Bool
False
        -- Straightforward recursion ...
        VarE{}     -> Bool
False
        LitE{}     -> Bool
False
        CharE{}    -> Bool
False
        FloatE{}   -> Bool
False
        LitSymE{}  -> Bool
False
        AppE{}     -> Bool
False
        PrimAppE{} -> Bool
False
        DataConE{} -> Bool
False
        ProjE Int
_ PreExp E1Ext () (UrTy ())
_  -> Bool
False
        IfE PreExp E1Ext () (UrTy ())
_ PreExp E1Ext () (UrTy ())
b PreExp E1Ext () (UrTy ())
c  -> (PreExp E1Ext () (UrTy ()) -> Bool
go PreExp E1Ext () (UrTy ())
b) Bool -> Bool -> Bool
|| (PreExp E1Ext () (UrTy ()) -> Bool
go PreExp E1Ext () (UrTy ())
c)
        MkProdE [PreExp E1Ext () (UrTy ())]
_  -> Bool
False
        LetE (Var, [()], UrTy (), PreExp E1Ext () (UrTy ()))
_ PreExp E1Ext () (UrTy ())
bod -> PreExp E1Ext () (UrTy ()) -> Bool
go PreExp E1Ext () (UrTy ())
bod
        CaseE PreExp E1Ext () (UrTy ())
_ [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))]
mp -> (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True) ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((String, [(Var, ())], PreExp E1Ext () (UrTy ())) -> Bool)
-> [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
_,[(Var, ())]
_,PreExp E1Ext () (UrTy ())
c) -> PreExp E1Ext () (UrTy ()) -> Bool
go PreExp E1Ext () (UrTy ())
c) [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))]
mp
        TimeIt{}   -> Bool
False
        WithArenaE Var
_ PreExp E1Ext () (UrTy ())
e -> (PreExp E1Ext () (UrTy ()) -> Bool
go PreExp E1Ext () (UrTy ())
e)
        SpawnE{}-> Bool
False
        PreExp E1Ext () (UrTy ())
SyncE   -> Bool
False
        MapE{}  -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"hasBenchE: TODO MapE"
        FoldE{} -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"hasBenchE: TODO FoldE"
      where go :: PreExp E1Ext () (UrTy ()) -> Bool
go = PreExp E1Ext () (UrTy ()) -> Bool
hasBenchE

    sty :: PPStyle
sty = PPStyle
PPHaskell

    ppFun :: Env2 Ty1 -> FunDef1 -> Doc
    ppFun :: Env2 (UrTy ()) -> FunDef1 -> Doc
ppFun Env2 (UrTy ())
env2 FunDef{Var
funName :: forall ex. FunDef ex -> Var
funName :: Var
funName, [Var]
funArgs :: forall ex. FunDef ex -> [Var]
funArgs :: [Var]
funArgs, ArrowTy (TyOf (PreExp E1Ext () (UrTy ())))
funTy :: forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy :: ArrowTy (TyOf (PreExp E1Ext () (UrTy ())))
funTy, PreExp E1Ext () (UrTy ())
funBody :: forall ex. FunDef ex -> ex
funBody :: PreExp E1Ext () (UrTy ())
funBody} =
      String -> Doc
text (Var -> String
fromVar Var
funName) Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> ([UrTy ()], UrTy ()) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ([UrTy ()], UrTy ())
ArrowTy (TyOf (PreExp E1Ext () (UrTy ())))
funTy
             Doc -> Doc -> Doc
$$ Doc
renderBod Doc -> Doc -> Doc
<> String -> Doc
text String
"\n"
      where
        env2' :: Env2 (UrTy ())
env2' = Map Var (UrTy ()) -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, UrTy ())] -> Map Var (UrTy ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, UrTy ())] -> Map Var (UrTy ()))
-> [(Var, UrTy ())] -> Map Var (UrTy ())
forall a b. (a -> b) -> a -> b
$ [Var] -> [UrTy ()] -> [(Var, UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
funArgs (ArrowTy (UrTy ()) -> [UrTy ()]
forall ty. FunctionTy ty => ArrowTy ty -> [ty]
inTys ArrowTy (TyOf (PreExp E1Ext () (UrTy ())))
ArrowTy (UrTy ())
funTy)) Env2 (UrTy ())
env2
        renderBod :: Doc
        renderBod :: Doc
renderBod = String -> Doc
text (Var -> String
fromVar Var
funName) Doc -> Doc -> Doc
<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Var -> Doc) -> [Var] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (Var -> String) -> Var -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> String
fromVar) [Var]
funArgs) Doc -> Doc -> Doc
<+> Doc
equals
                      Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
indentLevel (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
False Env2 (UrTy ())
env2' PreExp E1Ext () (UrTy ())
funBody)

    ppExp :: Bool -> Env2 Ty1 -> Exp1 -> Doc
    ppExp :: Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
ex0 =
      case PreExp E1Ext () (UrTy ())
ex0 of
          VarE Var
v -> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v
          LitE Int
i -> Int -> Doc
int Int
i
          CharE Char
i -> Char -> Doc
char Char
i
          FloatE Double
i -> Double -> Doc
double Double
i
          LitSymE Var
v -> String -> Doc
text String
"\"" Doc -> Doc -> Doc
<> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<> String -> Doc
text String
"\""
          AppE Var
v [()]
_locs [PreExp E1Ext () (UrTy ())]
ls -> PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+>
                            ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PreExp E1Ext () (UrTy ()) -> Doc)
-> [PreExp E1Ext () (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2) [PreExp E1Ext () (UrTy ())]
ls)
          PrimAppE Prim (UrTy ())
pr [PreExp E1Ext () (UrTy ())]
es ->
              case Prim (UrTy ())
pr of
                  Prim (UrTy ())
_ | Prim (UrTy ())
pr Prim (UrTy ()) -> [Prim (UrTy ())] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim (UrTy ())
forall ty. Prim ty
AddP, Prim (UrTy ())
forall ty. Prim ty
SubP, Prim (UrTy ())
forall ty. Prim ty
MulP, Prim (UrTy ())
forall ty. Prim ty
DivP, Prim (UrTy ())
forall ty. Prim ty
ModP, Prim (UrTy ())
forall ty. Prim ty
ExpP, Prim (UrTy ())
forall ty. Prim ty
EqSymP, Prim (UrTy ())
forall ty. Prim ty
EqIntP, Prim (UrTy ())
forall ty. Prim ty
LtP, Prim (UrTy ())
forall ty. Prim ty
GtP] ->
                      let [PreExp E1Ext () (UrTy ())
a1,PreExp E1Ext () (UrTy ())
a2] = [PreExp E1Ext () (UrTy ())]
es
                      in Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
a1 Doc -> Doc -> Doc
<+> PPStyle -> Prim (UrTy ()) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim (UrTy ())
pr Doc -> Doc -> Doc
<+> Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
a2

                  Prim (UrTy ())
_ | Prim (UrTy ())
pr Prim (UrTy ()) -> [Prim (UrTy ())] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim (UrTy ())
forall ty. Prim ty
MkTrue, Prim (UrTy ())
forall ty. Prim ty
MkFalse, Prim (UrTy ())
forall ty. Prim ty
SizeParam] -> PPStyle -> Prim (UrTy ()) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim (UrTy ())
pr

                  Prim (UrTy ())
_ -> PPStyle -> Prim (UrTy ()) -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Prim (UrTy ())
pr Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((PreExp E1Ext () (UrTy ()) -> Doc)
-> [PreExp E1Ext () (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2) [PreExp E1Ext () (UrTy ())]
es)

          -- See #111.
          LetE (Var
v,[()]
_, ty :: UrTy ()
ty@(ProdTy [UrTy ()]
tys),PreExp E1Ext () (UrTy ())
e1) PreExp E1Ext () (UrTy ())
e2 ->
            let -- Still avoiding 'PassM'.
                indexed_vars :: [(Int, Var)]
indexed_vars = (Int -> (Int, Var)) -> [Int] -> [(Int, Var)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int
i, Var -> Var -> Var
varAppend Var
v (String -> Var
toVar (String -> Var) -> String -> Var
forall a b. (a -> b) -> a -> b
$ String
"_proj_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i))) [Int
0..([UrTy ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UrTy ()]
tys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
                -- Substitute projections with variables bound by the pattern match.
                e2' :: PreExp E1Ext () (UrTy ())
e2' = ((Int, Var)
 -> PreExp E1Ext () (UrTy ()) -> PreExp E1Ext () (UrTy ()))
-> PreExp E1Ext () (UrTy ())
-> [(Int, Var)]
-> PreExp E1Ext () (UrTy ())
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Var
w) PreExp E1Ext () (UrTy ())
acc -> PreExp E1Ext () (UrTy ())
-> PreExp E1Ext () (UrTy ())
-> PreExp E1Ext () (UrTy ())
-> PreExp E1Ext () (UrTy ())
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE (Int -> PreExp E1Ext () (UrTy ()) -> PreExp E1Ext () (UrTy ())
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> PreExp E1Ext () (UrTy ())
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) (Var -> PreExp E1Ext () (UrTy ())
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
w) PreExp E1Ext () (UrTy ())
acc) PreExp E1Ext () (UrTy ())
e2 [(Int, Var)]
indexed_vars

                bind_rhs :: Doc -> Doc -> Doc
                bind_rhs :: Doc -> Doc -> Doc
bind_rhs Doc
d Doc
rhs = Doc
d Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+> PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Doc
rhs

                env2' :: Env2 (UrTy ())
env2' = (((Int, Var), UrTy ()) -> Env2 (UrTy ()) -> Env2 (UrTy ()))
-> Env2 (UrTy ()) -> [((Int, Var), UrTy ())] -> Env2 (UrTy ())
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\((Int
_,Var
w),UrTy ()
t) Env2 (UrTy ())
acc -> Var -> UrTy () -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
w UrTy ()
t Env2 (UrTy ())
acc) Env2 (UrTy ())
env2 ([(Int, Var)] -> [UrTy ()] -> [((Int, Var), UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Var)]
indexed_vars [UrTy ()]
tys)

            in (String -> Doc
text String
"let") Doc -> Doc -> Doc
<+>
               [Doc] -> Doc
vcat [Doc -> Doc -> Doc
bind_rhs (PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v) (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e1),
                     Doc -> Doc -> Doc
bind_rhs (Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") (((Int, Var) -> Doc) -> [(Int, Var)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty (Var -> Doc) -> ((Int, Var) -> Var) -> (Int, Var) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Var) -> Var
forall a b. (a, b) -> b
snd) [(Int, Var)]
indexed_vars)) (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 (Var -> PreExp E1Ext () (UrTy ())
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v))] Doc -> Doc -> Doc
<+>
               (if Bool
monadic
                then Doc
empty
                else String -> Doc
text String
"in") Doc -> Doc -> Doc
$+$
               Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic (Var -> UrTy () -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v UrTy ()
ty Env2 (UrTy ())
env2') PreExp E1Ext () (UrTy ())
e2'

          LetE (Var
v,[()]
_,UrTy ()
ty,PreExp E1Ext () (UrTy ())
e1) PreExp E1Ext () (UrTy ())
e2  -> (String -> Doc
text String
"let") Doc -> Doc -> Doc
<+>
                                  PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+> Doc
doublecolon Doc -> Doc -> Doc
<+>
                                  Doc
empty Doc -> Doc -> Doc
<+>
                                  PPStyle -> UrTy () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty UrTy ()
ty Doc -> Doc -> Doc
<+>
                                  Doc
equals Doc -> Doc -> Doc
<+>
                                  Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e1 Doc -> Doc -> Doc
<+>
                                  (if Bool
monadic
                                   then Doc
empty
                                   else String -> Doc
text String
"in") Doc -> Doc -> Doc
$+$
                                  Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic (Var -> UrTy () -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v UrTy ()
ty Env2 (UrTy ())
env2) PreExp E1Ext () (UrTy ())
e2
          IfE PreExp E1Ext () (UrTy ())
e1 PreExp E1Ext () (UrTy ())
e2 PreExp E1Ext () (UrTy ())
e3 -> String -> Doc
text String
"if" Doc -> Doc -> Doc
<+>
                          Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e1 Doc -> Doc -> Doc
$+$
                          String -> Doc
text String
"then" Doc -> Doc -> Doc
<+>
                          Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e2 Doc -> Doc -> Doc
$+$
                          String -> Doc
text String
"else" Doc -> Doc -> Doc
<+>
                          Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e3
          MkProdE [PreExp E1Ext () (UrTy ())]
es -> Doc
lparen Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
", ") ((PreExp E1Ext () (UrTy ()) -> Doc)
-> [PreExp E1Ext () (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2) [PreExp E1Ext () (UrTy ())]
es)) Doc -> Doc -> Doc
<> Doc
rparen
          ProjE Int
i PreExp E1Ext () (UrTy ())
e ->
              case DDefs (TyOf (PreExp E1Ext () (UrTy ())))
-> Env2 (TyOf (PreExp E1Ext () (UrTy ())))
-> PreExp E1Ext () (UrTy ())
-> TyOf (PreExp E1Ext () (UrTy ()))
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp E1Ext () (UrTy ())))
ddefs Env2 (TyOf (PreExp E1Ext () (UrTy ())))
Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e of
                ProdTy [UrTy ()]
tys -> let edoc :: Doc
edoc = Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e
                                  n :: Int
n    = [UrTy ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UrTy ()]
tys
                                  -- Gosh, do we also need a gensym here...
                                  v :: String
v    = (String
"tup_proj_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
                                  pat :: Doc
pat  = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
                                           Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") ([if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then String -> Doc
text String
v else String -> Doc
text String
"_" | Int
j <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]])
                              in Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"let " Doc -> Doc -> Doc
<+> Doc
pat Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Doc
edoc Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> String -> Doc
text String
v
                TyOf (PreExp E1Ext () (UrTy ()))
ty -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"pprintHsWithEnv: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UrTy () -> String
forall a. Out a => a -> String
sdoc TyOf (PreExp E1Ext () (UrTy ()))
UrTy ()
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"is not a product. In " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PreExp E1Ext () (UrTy ()) -> String
forall a. Out a => a -> String
sdoc PreExp E1Ext () (UrTy ())
ex0
          CaseE PreExp E1Ext () (UrTy ())
e [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))]
bnds -> String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"of" Doc -> Doc -> Doc
$+$
                          Int -> Doc -> Doc
nest Int
indentLevel ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((String, [(Var, ())], PreExp E1Ext () (UrTy ())) -> Doc)
-> [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Env2 (UrTy ())
-> (String, [(Var, ())], PreExp E1Ext () (UrTy ())) -> Doc
dobinds Env2 (UrTy ())
env2) [(String, [(Var, ())], PreExp E1Ext () (UrTy ()))]
bnds)
          DataConE ()
_loc String
dc [PreExp E1Ext () (UrTy ())]
es ->
                              Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
dc Doc -> Doc -> Doc
<+>
                              [Doc] -> Doc
hsep ((PreExp E1Ext () (UrTy ()) -> Doc)
-> [PreExp E1Ext () (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2) [PreExp E1Ext () (UrTy ())]
es)
          TimeIt PreExp E1Ext () (UrTy ())
e UrTy ()
_ty Bool
_b -> String -> Doc
text String
"timeit" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e)
          WithArenaE Var
v PreExp E1Ext () (UrTy ())
e -> (String -> Doc
text String
"let") Doc -> Doc -> Doc
<+>
                            PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<+>
                            Doc
equals Doc -> Doc -> Doc
<+>
                            String -> Doc
text String
"()" Doc -> Doc -> Doc
<+>
                            String -> Doc
text String
"in" Doc -> Doc -> Doc
$+$
                            Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2 PreExp E1Ext () (UrTy ())
e

          SpawnE{} -> String -> Doc
forall a. HasCallStack => String -> a
error String
"ppHsWithEnv: SpawnE not handled."
          SyncE{}  -> String -> Doc
forall a. HasCallStack => String -> a
error String
"ppHsWithEnv: SyncE not handled."
          Ext(L1.AddFixed{}) -> String -> Doc
forall a. HasCallStack => String -> a
error String
"ppHsWithEnv: AddFixed not handled."
          Ext(L1.StartOfPkdCursor{}) -> String -> Doc
forall a. HasCallStack => String -> a
error String
"ppHsWithEnv: AddFixed not handled."
          Ext (BenchE Var
fn [()]
_locs [PreExp E1Ext () (UrTy ())]
args Bool
_b) ->
             --  -- Criterion
             -- let args_doc = hsep $ map (ppExp env2) args
             -- in text "gibbon_bench" <+> (doubleQuotes (text (fromVar fn) <+> args_doc)) <+> text (fromVar fn) <+> args_doc
            let args_doc :: Doc
args_doc = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PreExp E1Ext () (UrTy ()) -> Doc)
-> [PreExp E1Ext () (UrTy ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((\Doc
x -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"force" Doc -> Doc -> Doc
<+> Doc
x) (Doc -> Doc)
-> (PreExp E1Ext () (UrTy ()) -> Doc)
-> PreExp E1Ext () (UrTy ())
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env2) [PreExp E1Ext () (UrTy ())]
args
            in String -> Doc
text String
"performMajorGC" Doc -> Doc -> Doc
$+$
               String -> Doc
text String
"t1 <- getCurrentTime" Doc -> Doc -> Doc
$+$
               String -> Doc
text String
"let x" Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> String -> Doc
text (Var -> String
fromVar Var
fn) Doc -> Doc -> Doc
<+> Doc
args_doc Doc -> Doc -> Doc
$+$
               String -> Doc
text String
"t2 <- getCurrentTime" Doc -> Doc -> Doc
$+$
               String -> Doc
text String
"print (diffUTCTime t2 t1)" Doc -> Doc -> Doc
$+$
               String -> Doc
text String
"print x"
          MapE{} -> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected form in program: MapE"
          FoldE{}-> String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected form in program: FoldE"
        where
          dobinds :: Env2 (UrTy ())
-> (String, [(Var, ())], PreExp E1Ext () (UrTy ())) -> Doc
dobinds Env2 (UrTy ())
env21 (String
dc,[(Var, ())]
vls,PreExp E1Ext () (UrTy ())
e) =
                           let tys :: [UrTy ()]
tys    = Map Var (DDef (UrTy ())) -> String -> [UrTy ()]
forall a. Out a => DDefs a -> String -> [a]
lookupDataCon DDefs (TyOf (PreExp E1Ext () (UrTy ())))
Map Var (DDef (UrTy ()))
ddefs String
dc
                               vars :: [Var]
vars   = ((Var, ()) -> Var) -> [(Var, ())] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, ()) -> Var
forall a b. (a, b) -> a
fst [(Var, ())]
vls
                               env21' :: Env2 (UrTy ())
env21' = Map Var (UrTy ()) -> Env2 (UrTy ()) -> Env2 (UrTy ())
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, UrTy ())] -> Map Var (UrTy ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, UrTy ())] -> Map Var (UrTy ()))
-> [(Var, UrTy ())] -> Map Var (UrTy ())
forall a b. (a -> b) -> a -> b
$ [Var] -> [UrTy ()] -> [(Var, UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vars [UrTy ()]
tys) Env2 (UrTy ())
env21
                           in  String -> Doc
text String
dc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" ")
                                                           (((Var, ()) -> Doc) -> [(Var, ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
v,()
loc) -> if Doc -> Bool
isEmpty (PPStyle -> () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ()
loc)
                                                                             then PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v
                                                                             else PPStyle -> Var -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty Var
v Doc -> Doc -> Doc
<> Doc
doublecolon Doc -> Doc -> Doc
<> PPStyle -> () -> Doc
forall e. Pretty e => PPStyle -> e -> Doc
pprintWithStyle PPStyle
sty ()
loc)
                                                            [(Var, ())]
vls))
                               Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
indentLevel (Bool -> Env2 (UrTy ()) -> PreExp E1Ext () (UrTy ()) -> Doc
ppExp Bool
monadic Env2 (UrTy ())
env21' PreExp E1Ext () (UrTy ())
e)