{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
-- | Futhark prettyprinter.  This module defines 'Pretty' instances
-- for the AST defined in "Futhark.IR.Syntax",
-- but also a number of convenience functions if you don't want to use
-- the interface from 'Pretty'.
module Futhark.IR.Pretty
  ( prettyTuple
  , pretty
  , PrettyAnnot (..)
  , PrettyLore (..)
  , ppTuple'
  )
  where

import           Data.Foldable (toList)
import           Data.Maybe

import           Futhark.Util.Pretty
import           Futhark.IR.Prop.Patterns
import           Futhark.IR.Syntax

-- | Class for values that may have some prettyprinted annotation.
class PrettyAnnot a where
  ppAnnot :: a -> Maybe Doc

instance PrettyAnnot (PatElemT (TypeBase shape u)) where
  ppAnnot :: PatElemT (TypeBase shape u) -> Maybe Doc
ppAnnot = Maybe Doc -> PatElemT (TypeBase shape u) -> Maybe Doc
forall a b. a -> b -> a
const Maybe Doc
forall a. Maybe a
Nothing

instance PrettyAnnot (Param (TypeBase shape u)) where
  ppAnnot :: Param (TypeBase shape u) -> Maybe Doc
ppAnnot = Maybe Doc -> Param (TypeBase shape u) -> Maybe Doc
forall a b. a -> b -> a
const Maybe Doc
forall a. Maybe a
Nothing

instance PrettyAnnot () where
  ppAnnot :: () -> Maybe Doc
ppAnnot = Maybe Doc -> () -> Maybe Doc
forall a b. a -> b -> a
const Maybe Doc
forall a. Maybe a
Nothing

-- | The class of lores whose annotations can be prettyprinted.
class (Decorations lore,
       Pretty (RetType lore),
       Pretty (BranchType lore),
       Pretty (Param (FParamInfo lore)),
       Pretty (Param (LParamInfo lore)),
       Pretty (PatElemT (LetDec lore)),
       PrettyAnnot (PatElem lore),
       PrettyAnnot (FParam lore),
       PrettyAnnot (LParam lore),
       Pretty (Op lore)) => PrettyLore lore where
  ppExpLore :: ExpDec lore -> Exp lore -> Maybe Doc
  ppExpLore ExpDec lore
_ (If SubExp
_ BodyT lore
_ BodyT lore
_ (IfDec [BranchType lore]
ts IfSort
_)) =
    Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Doc
text ([Char] -> Doc) -> ([Char] -> [Char]) -> [Char] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) ([[Char]] -> [Doc]) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
"Branch returns:" Doc -> Doc -> Doc
<+> [BranchType lore] -> Doc
forall a. Pretty a => [a] -> Doc
ppTuple' [BranchType lore]
ts
  ppExpLore ExpDec lore
_ Exp lore
_ = Maybe Doc
forall a. Maybe a
Nothing

commastack :: [Doc] -> Doc
commastack :: [Doc] -> Doc
commastack = Doc -> Doc
align (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
stack ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma

instance Pretty VName where
  ppr :: VName -> Doc
ppr (VName Name
vn Int
i) = Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
vn Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
"_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

instance Pretty NoUniqueness where
  ppr :: NoUniqueness -> Doc
ppr NoUniqueness
_ = Doc
forall a. Monoid a => a
mempty

instance Pretty Commutativity where
  ppr :: Commutativity -> Doc
ppr Commutativity
Commutative    = [Char] -> Doc
text [Char]
"commutative"
  ppr Commutativity
Noncommutative = [Char] -> Doc
text [Char]
"noncommutative"

instance Pretty Shape where
  ppr :: Shape -> Doc
ppr = Doc -> Doc
brackets (Doc -> Doc) -> (Shape -> Doc) -> Shape -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
commasep ([Doc] -> Doc) -> (Shape -> [Doc]) -> Shape -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr ([SubExp] -> [Doc]) -> (Shape -> [SubExp]) -> Shape -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shape -> [SubExp]
forall d. ShapeBase d -> [d]
shapeDims

instance Pretty a => Pretty (Ext a) where
  ppr :: Ext a -> Doc
ppr (Free a
e) = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
e
  ppr (Ext Int
x)  = [Char] -> Doc
text [Char]
"?" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x)

instance Pretty ExtShape where
  ppr :: ExtShape -> Doc
ppr = Doc -> Doc
brackets (Doc -> Doc) -> (ExtShape -> Doc) -> ExtShape -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
commasep ([Doc] -> Doc) -> (ExtShape -> [Doc]) -> ExtShape -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtSize -> Doc) -> [ExtSize] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ExtSize -> Doc
forall a. Pretty a => a -> Doc
ppr ([ExtSize] -> [Doc])
-> (ExtShape -> [ExtSize]) -> ExtShape -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtShape -> [ExtSize]
forall d. ShapeBase d -> [d]
shapeDims

instance Pretty Space where
  ppr :: Space -> Doc
ppr Space
DefaultSpace = Doc
forall a. Monoid a => a
mempty
  ppr (Space [Char]
s) = [Char] -> Doc
text [Char]
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
s
  ppr (ScalarSpace [SubExp]
d PrimType
t) = [Char] -> Doc
text [Char]
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets (Doc -> Doc) -> (SubExp -> Doc) -> SubExp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr) [SubExp]
d) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t

instance Pretty u => Pretty (TypeBase Shape u) where
  ppr :: TypeBase Shape u -> Doc
ppr (Prim PrimType
et) = PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Array PrimType
et (Shape [SubExp]
ds) u
u) =
    u -> Doc
forall a. Pretty a => a -> Doc
ppr u
u Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets (Doc -> Doc) -> (SubExp -> Doc) -> SubExp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr) [SubExp]
ds) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Mem Space
s) = [Char] -> Doc
text [Char]
"mem" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
s

instance Pretty u => Pretty (TypeBase ExtShape u) where
  ppr :: TypeBase ExtShape u -> Doc
ppr (Prim PrimType
et) = PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Array PrimType
et (Shape [ExtSize]
ds) u
u) =
    u -> Doc
forall a. Pretty a => a -> Doc
ppr u
u Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((ExtSize -> Doc) -> [ExtSize] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets (Doc -> Doc) -> (ExtSize -> Doc) -> ExtSize -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtSize -> Doc
forall a. Pretty a => a -> Doc
ppr) [ExtSize]
ds) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Mem Space
s) = [Char] -> Doc
text [Char]
"mem" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
s

instance Pretty u => Pretty (TypeBase Rank u) where
  ppr :: TypeBase Rank u -> Doc
ppr (Prim PrimType
et) = PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Array PrimType
et (Rank Int
n) u
u) =
    u -> Doc
forall a. Pretty a => a -> Doc
ppr u
u Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate Int
n (Doc -> [Doc]) -> Doc -> [Doc]
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
brackets Doc
forall a. Monoid a => a
mempty) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et
  ppr (Mem Space
s) = [Char] -> Doc
text [Char]
"mem" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
s

instance Pretty Ident where
  ppr :: Ident -> Doc
ppr Ident
ident = Type -> Doc
forall a. Pretty a => a -> Doc
ppr (Ident -> Type
identType Ident
ident) Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr (Ident -> VName
identName Ident
ident)

instance Pretty SubExp where
  ppr :: SubExp -> Doc
ppr (Var VName
v)      = VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
v
  ppr (Constant PrimValue
v) = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v

instance Pretty Certificates where
  ppr :: Certificates -> Doc
ppr (Certificates []) = Doc
empty
  ppr (Certificates [VName]
cs) = [Char] -> Doc
text [Char]
"<" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
commasep ((VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
ppr [VName]
cs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
">"

instance PrettyLore lore => Pretty (Stms lore) where
  ppr :: Stms lore -> Doc
ppr = [Doc] -> Doc
stack ([Doc] -> Doc) -> (Stms lore -> [Doc]) -> Stms lore -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stm lore -> Doc) -> [Stm lore] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Stm lore -> Doc
forall a. Pretty a => a -> Doc
ppr ([Stm lore] -> [Doc])
-> (Stms lore -> [Stm lore]) -> Stms lore -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stms lore -> [Stm lore]
forall lore. Stms lore -> [Stm lore]
stmsToList

instance PrettyLore lore => Pretty (Body lore) where
  ppr :: Body lore -> Doc
ppr (Body BodyDec lore
_ Stms lore
stms [SubExp]
res)
    | Stms lore -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Stms lore
stms = Doc -> Doc
braces ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
res)
    | Bool
otherwise = [Doc] -> Doc
stack ((Stm lore -> Doc) -> [Stm lore] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Stm lore -> Doc
forall a. Pretty a => a -> Doc
ppr ([Stm lore] -> [Doc]) -> [Stm lore] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Stms lore -> [Stm lore]
forall lore. Stms lore -> [Stm lore]
stmsToList Stms lore
stms) Doc -> Doc -> Doc
</>
                  [Char] -> Doc
text [Char]
"in" Doc -> Doc -> Doc
<+> Doc -> Doc
braces ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
res)

instance Pretty Attr where
  ppr :: Attr -> Doc
ppr (AttrAtom Name
v) = Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
v
  ppr (AttrComp Name
f [Attr]
attrs) = Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
f Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Attr -> Doc) -> [Attr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> Doc
forall a. Pretty a => a -> Doc
ppr [Attr]
attrs)

attrAnnots :: Attrs -> [Doc]
attrAnnots :: Attrs -> [Doc]
attrAnnots = (Attr -> Doc) -> [Attr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> Doc
forall a. Pretty a => a -> Doc
f ([Attr] -> [Doc]) -> (Attrs -> [Attr]) -> Attrs -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Attr -> [Attr]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set Attr -> [Attr]) -> (Attrs -> Set Attr) -> Attrs -> [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attrs -> Set Attr
unAttrs
  where f :: a -> Doc
f a
v = [Char] -> Doc
text [Char]
"#[" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
"]"

stmAttrAnnots :: Stm lore -> [Doc]
stmAttrAnnots :: Stm lore -> [Doc]
stmAttrAnnots = Attrs -> [Doc]
attrAnnots (Attrs -> [Doc]) -> (Stm lore -> Attrs) -> Stm lore -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StmAux (ExpDec lore) -> Attrs
forall dec. StmAux dec -> Attrs
stmAuxAttrs (StmAux (ExpDec lore) -> Attrs)
-> (Stm lore -> StmAux (ExpDec lore)) -> Stm lore -> Attrs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stm lore -> StmAux (ExpDec lore)
forall lore. Stm lore -> StmAux (ExpDec lore)
stmAux

instance Pretty (PatElemT dec) => Pretty (PatternT dec) where
  ppr :: PatternT dec -> Doc
ppr PatternT dec
pat = [PatElemT dec] -> [PatElemT dec] -> Doc
forall a b. (Pretty a, Pretty b) => [a] -> [b] -> Doc
ppPattern (PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternContextElements PatternT dec
pat) (PatternT dec -> [PatElemT dec]
forall dec. PatternT dec -> [PatElemT dec]
patternValueElements PatternT dec
pat)

instance Pretty (PatElemT b) => Pretty (PatElemT (a,b)) where
  ppr :: PatElemT (a, b) -> Doc
ppr = PatElemT b -> Doc
forall a. Pretty a => a -> Doc
ppr (PatElemT b -> Doc)
-> (PatElemT (a, b) -> PatElemT b) -> PatElemT (a, b) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> b) -> PatElemT (a, b) -> PatElemT b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd

instance Pretty (PatElemT Type) where
  ppr :: PatElemT Type -> Doc
ppr (PatElem VName
name Type
t) = Type -> Doc
forall a. Pretty a => a -> Doc
ppr Type
t Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name

instance Pretty (Param b) => Pretty (Param (a,b)) where
  ppr :: Param (a, b) -> Doc
ppr = Param b -> Doc
forall a. Pretty a => a -> Doc
ppr (Param b -> Doc)
-> (Param (a, b) -> Param b) -> Param (a, b) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> b) -> Param (a, b) -> Param b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd

instance Pretty (Param DeclType) where
  ppr :: Param DeclType -> Doc
ppr (Param VName
name DeclType
t) =
    DeclType -> Doc
forall a. Pretty a => a -> Doc
ppr DeclType
t Doc -> Doc -> Doc
<+>
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name

instance Pretty (Param Type) where
  ppr :: Param Type -> Doc
ppr (Param VName
name Type
t) =
    Type -> Doc
forall a. Pretty a => a -> Doc
ppr Type
t Doc -> Doc -> Doc
<+>
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name

instance PrettyLore lore => Pretty (Stm lore) where
  ppr :: Stm lore -> Doc
ppr bnd :: Stm lore
bnd@(Let Pattern lore
pat (StmAux Certificates
cs Attrs
_ ExpDec lore
dec) Exp lore
e) =
    Doc -> Doc
stmannot (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
hang Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
"let" Doc -> Doc -> Doc
<+> Doc -> Doc
align (Pattern lore -> Doc
forall a. Pretty a => a -> Doc
ppr Pattern lore
pat) Doc -> Doc -> Doc
<+>
    case (Bool
linebreak, ExpDec lore -> Exp lore -> Maybe Doc
forall lore.
PrettyLore lore =>
ExpDec lore -> Exp lore -> Maybe Doc
ppExpLore ExpDec lore
dec Exp lore
e) of
      (Bool
True, Maybe Doc
Nothing) -> Doc
equals Doc -> Doc -> Doc
</> Doc
e'
      (Bool
_, Just Doc
ann) -> Doc
equals Doc -> Doc -> Doc
</> (Doc
ann Doc -> Doc -> Doc
</> Doc
e')
      (Bool
False, Maybe Doc
Nothing) -> Doc
equals Doc -> Doc -> Doc
<+/> Doc
e'
    where e' :: Doc
e' | Bool
linebreak = Certificates -> Doc
forall a. Pretty a => a -> Doc
ppr Certificates
cs Doc -> Doc -> Doc
</> Exp lore -> Doc
forall a. Pretty a => a -> Doc
ppr Exp lore
e
             | Bool
otherwise = Certificates -> Doc
forall a. Pretty a => a -> Doc
ppr Certificates
cs Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp lore -> Doc
forall a. Pretty a => a -> Doc
ppr Exp lore
e
          linebreak :: Bool
linebreak = case Exp lore
e of
                        DoLoop{}           -> Bool
True
                        Op{}               -> Bool
True
                        If{}               -> Bool
True
                        Apply{}            -> Bool
True
                        BasicOp ArrayLit{} -> Bool
False
                        BasicOp Assert{}   -> Bool
True
                        Exp lore
_                  -> Certificates
cs Certificates -> Certificates -> Bool
forall a. Eq a => a -> a -> Bool
/= Certificates
forall a. Monoid a => a
mempty

          stmannot :: Doc -> Doc
stmannot =
            case Stm lore -> [Doc]
forall lore. Stm lore -> [Doc]
stmAttrAnnots Stm lore
bnd [Doc] -> [Doc] -> [Doc]
forall a. Semigroup a => a -> a -> a
<>
                 (PatElemT (LetDec lore) -> Maybe Doc)
-> [PatElemT (LetDec lore)] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PatElemT (LetDec lore) -> Maybe Doc
forall a. PrettyAnnot a => a -> Maybe Doc
ppAnnot (Pattern lore -> [PatElemT (LetDec lore)]
forall dec. PatternT dec -> [PatElemT dec]
patternElements (Pattern lore -> [PatElemT (LetDec lore)])
-> Pattern lore -> [PatElemT (LetDec lore)]
forall a b. (a -> b) -> a -> b
$ Stm lore -> Pattern lore
forall lore. Stm lore -> Pattern lore
stmPattern Stm lore
bnd) of
              []     -> Doc -> Doc
forall a. a -> a
id
              [Doc]
annots -> (Doc -> Doc
align ([Doc] -> Doc
stack [Doc]
annots) Doc -> Doc -> Doc
</>)

instance Pretty BasicOp where
  ppr :: BasicOp -> Doc
ppr (SubExp SubExp
se) = SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
se
  ppr (Opaque SubExp
e) = [Char] -> Doc
text [Char]
"opaque" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
e]
  ppr (ArrayLit [] Type
rt) =
    [Char] -> Doc
text [Char]
"empty" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Type -> Doc
forall a. Pretty a => a -> Doc
ppr Type
rt)
  ppr (ArrayLit [SubExp]
es Type
rt) =
    case Type
rt of
      Array {} -> Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commastack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
es
      Type
_        -> Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep   ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
es
  ppr (BinOp BinOp
bop SubExp
x SubExp
y) = BinOp -> Doc
forall a. Pretty a => a -> Doc
ppr BinOp
bop Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
<+> SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
y)
  ppr (CmpOp CmpOp
op SubExp
x SubExp
y) = CmpOp -> Doc
forall a. Pretty a => a -> Doc
ppr CmpOp
op Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
<+> SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
y)
  ppr (ConvOp ConvOp
conv SubExp
x) =
    [Char] -> Doc
text (ConvOp -> [Char]
convOpFun ConvOp
conv) Doc -> Doc -> Doc
<+> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
fromtype Doc -> Doc -> Doc
<+> SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
x Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"to" Doc -> Doc -> Doc
<+> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
totype
    where (PrimType
fromtype, PrimType
totype) = ConvOp -> (PrimType, PrimType)
convOpType ConvOp
conv
  ppr (UnOp UnOp
op SubExp
e) = UnOp -> Doc
forall a. Pretty a => a -> Doc
ppr UnOp
op Doc -> Doc -> Doc
<+> Int -> SubExp -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
9 SubExp
e
  ppr (Index VName
v Slice SubExp
idxs) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets ([Doc] -> Doc
commasep ((DimIndex SubExp -> Doc) -> Slice SubExp -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndex SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr Slice SubExp
idxs))
  ppr (Update VName
src Slice SubExp
idxs SubExp
se) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
src Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"with" Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
commasep ((DimIndex SubExp -> Doc) -> Slice SubExp -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndex SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr Slice SubExp
idxs)) Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
"<-" Doc -> Doc -> Doc
<+> SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
se
  ppr (Iota SubExp
e SubExp
x SubExp
s IntType
et) = [Char] -> Doc
text [Char]
"iota" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
et' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
e, SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
x, SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
s]
    where et' :: Doc
et' = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ PrimType -> Int
primBitSize (PrimType -> Int) -> PrimType -> Int
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
IntType IntType
et
  ppr (Replicate Shape
ne SubExp
ve) =
    [Char] -> Doc
text [Char]
"replicate" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [Shape -> Doc
forall a. Pretty a => a -> Doc
ppr Shape
ne, Doc -> Doc
align (SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
ve)]
  ppr (Scratch PrimType
t [SubExp]
shape) =
    [Char] -> Doc
text [Char]
"scratch" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply (PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
shape)
  ppr (Reshape ShapeChange SubExp
shape VName
e) =
    [Char] -> Doc
text [Char]
"reshape" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [[Doc] -> Doc
apply ((DimChange SubExp -> Doc) -> ShapeChange SubExp -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimChange SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr ShapeChange SubExp
shape), VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
e]
  ppr (Rearrange [Int]
perm VName
e) =
    [Char] -> Doc
text [Char]
"rearrange" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [[Doc] -> Doc
apply ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
forall a. Pretty a => a -> Doc
ppr [Int]
perm), VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
e]
  ppr (Rotate [SubExp]
es VName
e) =
    [Char] -> Doc
text [Char]
"rotate" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [[Doc] -> Doc
apply ((SubExp -> Doc) -> [SubExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr [SubExp]
es), VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
e]
  ppr (Concat Int
i VName
x [VName]
ys SubExp
_) =
    [Char] -> Doc
text [Char]
"concat" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply (VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
ppr [VName]
ys)
  ppr (Copy VName
e) = [Char] -> Doc
text [Char]
"copy" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
e)
  ppr (Manifest [Int]
perm VName
e) = [Char] -> Doc
text [Char]
"manifest" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [[Doc] -> Doc
apply ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
forall a. Pretty a => a -> Doc
ppr [Int]
perm), VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
e]
  ppr (Assert SubExp
e ErrorMsg SubExp
msg (SrcLoc
loc, [SrcLoc]
_)) =
    [Char] -> Doc
text [Char]
"assert" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply [SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
e, ErrorMsg SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr ErrorMsg SubExp
msg, [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
forall a. Located a => a -> [Char]
locStr SrcLoc
loc]

instance Pretty a => Pretty (ErrorMsg a) where
  ppr :: ErrorMsg a -> Doc
ppr (ErrorMsg [ErrorMsgPart a]
parts) = [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ErrorMsgPart a -> Doc) -> [ErrorMsgPart a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ErrorMsgPart a -> Doc
forall a. Pretty a => ErrorMsgPart a -> Doc
p [ErrorMsgPart a]
parts
    where p :: ErrorMsgPart a -> Doc
p (ErrorString [Char]
s) = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s
          p (ErrorInt32 a
x) = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
x

instance PrettyLore lore => Pretty (Exp lore) where
  ppr :: Exp lore -> Doc
ppr (If SubExp
c BodyT lore
t BodyT lore
f (IfDec [BranchType lore]
_ IfSort
ifsort)) =
    [Char] -> Doc
text [Char]
"if" Doc -> Doc -> Doc
<+> Doc
info' Doc -> Doc -> Doc
<+> SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
c Doc -> Doc -> Doc
</>
    [Char] -> Doc
text [Char]
"then" Doc -> Doc -> Doc
<+> BodyT lore -> Doc
forall lore. PrettyLore lore => Body lore -> Doc
maybeNest BodyT lore
t Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
"else" Doc -> Doc -> Doc
<+> BodyT lore -> Doc
forall lore. PrettyLore lore => Body lore -> Doc
maybeNest BodyT lore
f
    where info' :: Doc
info' = case IfSort
ifsort of IfSort
IfNormal -> Doc
forall a. Monoid a => a
mempty
                                 IfSort
IfFallback -> [Char] -> Doc
text [Char]
"<fallback>"
                                 IfSort
IfEquiv -> [Char] -> Doc
text [Char]
"<equiv>"
          maybeNest :: BodyT lore -> Doc
maybeNest BodyT lore
b | Seq (Stm lore) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Seq (Stm lore) -> Bool) -> Seq (Stm lore) -> Bool
forall a b. (a -> b) -> a -> b
$ BodyT lore -> Seq (Stm lore)
forall lore. BodyT lore -> Stms lore
bodyStms BodyT lore
b = BodyT lore -> Doc
forall a. Pretty a => a -> Doc
ppr BodyT lore
b
                      | Bool
otherwise         = [Char] -> [Char] -> Doc -> Doc
nestedBlock [Char]
"{" [Char]
"}" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ BodyT lore -> Doc
forall a. Pretty a => a -> Doc
ppr BodyT lore
b
  ppr (BasicOp BasicOp
op) = BasicOp -> Doc
forall a. Pretty a => a -> Doc
ppr BasicOp
op
  ppr (Apply Name
fname [(SubExp, Diet)]
args [RetType lore]
_ (Safety
safety, SrcLoc
_, [SrcLoc]
_)) =
    [Char] -> Doc
text (Name -> [Char]
nameToString Name
fname) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
safety' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
apply (((SubExp, Diet) -> Doc) -> [(SubExp, Diet)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
align (Doc -> Doc) -> ((SubExp, Diet) -> Doc) -> (SubExp, Diet) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubExp, Diet) -> Doc
forall a. Pretty a => (a, Diet) -> Doc
pprArg) [(SubExp, Diet)]
args)
    where pprArg :: (a, Diet) -> Doc
pprArg (a
arg, Diet
Consume) = [Char] -> Doc
text [Char]
"*" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
arg
          pprArg (a
arg, Diet
_)       = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
arg
          safety' :: Doc
safety' = case Safety
safety of Safety
Unsafe -> [Char] -> Doc
text [Char]
"<unsafe>"
                                   Safety
Safe   -> Doc
forall a. Monoid a => a
mempty
  ppr (Op Op lore
op) = Op lore -> Doc
forall a. Pretty a => a -> Doc
ppr Op lore
op
  ppr (DoLoop [(FParam lore, SubExp)]
ctx [(FParam lore, SubExp)]
val LoopForm lore
form BodyT lore
loopbody) =
    [Doc] -> Doc -> Doc
annot ((FParam lore -> Maybe Doc) -> [FParam lore] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FParam lore -> Maybe Doc
forall a. PrettyAnnot a => a -> Maybe Doc
ppAnnot ([FParam lore]
ctxparams[FParam lore] -> [FParam lore] -> [FParam lore]
forall a. [a] -> [a] -> [a]
++[FParam lore]
valparams)) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
"loop" Doc -> Doc -> Doc
<+> [FParam lore] -> [FParam lore] -> Doc
forall a b. (Pretty a, Pretty b) => [a] -> [b] -> Doc
ppPattern [FParam lore]
ctxparams [FParam lore]
valparams Doc -> Doc -> Doc
<+>
    Doc
equals Doc -> Doc -> Doc
<+> [SubExp] -> Doc
forall a. Pretty a => [a] -> Doc
ppTuple' ([SubExp]
ctxinit[SubExp] -> [SubExp] -> [SubExp]
forall a. [a] -> [a] -> [a]
++[SubExp]
valinit) Doc -> Doc -> Doc
</>
    (case LoopForm lore
form of
      ForLoop VName
i IntType
it SubExp
bound [] ->
        [Char] -> Doc
text [Char]
"for" Doc -> Doc -> Doc
<+> Doc -> Doc
align (VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
it Doc -> Doc -> Doc
<+>
                              [Char] -> Doc
text [Char]
"<" Doc -> Doc -> Doc
<+> Doc -> Doc
align (SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
bound))
      ForLoop VName
i IntType
it SubExp
bound [(LParam lore, VName)]
loop_vars ->
        [Doc] -> Doc -> Doc
annot (((LParam lore, VName) -> Maybe Doc)
-> [(LParam lore, VName)] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LParam lore -> Maybe Doc
forall a. PrettyAnnot a => a -> Maybe Doc
ppAnnot (LParam lore -> Maybe Doc)
-> ((LParam lore, VName) -> LParam lore)
-> (LParam lore, VName)
-> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LParam lore, VName) -> LParam lore
forall a b. (a, b) -> a
fst) [(LParam lore, VName)]
loop_vars) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Char] -> Doc
text [Char]
"for" Doc -> Doc -> Doc
<+> Doc -> Doc
align (VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
it Doc -> Doc -> Doc
<+>
                              [Char] -> Doc
text [Char]
"<" Doc -> Doc -> Doc
<+> Doc -> Doc
align (SubExp -> Doc
forall a. Pretty a => a -> Doc
ppr SubExp
bound) Doc -> Doc -> Doc
</>
                             [Doc] -> Doc
stack (((LParam lore, VName) -> Doc) -> [(LParam lore, VName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (LParam lore, VName) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
pprLoopVar [(LParam lore, VName)]
loop_vars))
      WhileLoop VName
cond ->
        [Char] -> Doc
text [Char]
"while" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
cond
    ) Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"do" Doc -> Doc -> Doc
<+> [Char] -> [Char] -> Doc -> Doc
nestedBlock [Char]
"{" [Char]
"}" (BodyT lore -> Doc
forall a. Pretty a => a -> Doc
ppr BodyT lore
loopbody)
    where ([FParam lore]
ctxparams, [SubExp]
ctxinit) = [(FParam lore, SubExp)] -> ([FParam lore], [SubExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FParam lore, SubExp)]
ctx
          ([FParam lore]
valparams, [SubExp]
valinit) = [(FParam lore, SubExp)] -> ([FParam lore], [SubExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FParam lore, SubExp)]
val
          pprLoopVar :: (a, a) -> Doc
pprLoopVar (a
p,a
a) = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
p Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"in" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
a

instance PrettyLore lore => Pretty (Lambda lore) where
  ppr :: Lambda lore -> Doc
ppr (Lambda [] BodyT lore
_ []) = [Char] -> Doc
text [Char]
"nilFn"
  ppr (Lambda [LParam lore]
params BodyT lore
body [Type]
rettype) =
    [Doc] -> Doc -> Doc
annot ((LParam lore -> Maybe Doc) -> [LParam lore] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LParam lore -> Maybe Doc
forall a. PrettyAnnot a => a -> Maybe Doc
ppAnnot [LParam lore]
params) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
"fn" Doc -> Doc -> Doc
<+> [Type] -> Doc
forall a. Pretty a => [a] -> Doc
ppTuple' [Type]
rettype Doc -> Doc -> Doc
<+/>
    Doc -> Doc
align (Doc -> Doc
parens ([Doc] -> Doc
commasep ((LParam lore -> Doc) -> [LParam lore] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map LParam lore -> Doc
forall a. Pretty a => a -> Doc
ppr [LParam lore]
params))) Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
"=>" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (BodyT lore -> Doc
forall a. Pretty a => a -> Doc
ppr BodyT lore
body)

instance PrettyLore lore => Pretty (FunDef lore) where
  ppr :: FunDef lore -> Doc
ppr (FunDef Maybe EntryPoint
entry Attrs
attrs Name
name [RetType lore]
rettype [FParam lore]
fparams BodyT lore
body) =
    [Doc] -> Doc -> Doc
annot ((FParam lore -> Maybe Doc) -> [FParam lore] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FParam lore -> Maybe Doc
forall a. PrettyAnnot a => a -> Maybe Doc
ppAnnot [FParam lore]
fparams [Doc] -> [Doc] -> [Doc]
forall a. Semigroup a => a -> a -> a
<> Attrs -> [Doc]
attrAnnots Attrs
attrs) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
fun Doc -> Doc -> Doc
<+> [RetType lore] -> Doc
forall a. Pretty a => [a] -> Doc
ppTuple' [RetType lore]
rettype Doc -> Doc -> Doc
<+/>
    [Char] -> Doc
text (Name -> [Char]
nameToString Name
name) Doc -> Doc -> Doc
<+>
    [Doc] -> Doc
apply ((FParam lore -> Doc) -> [FParam lore] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FParam lore -> Doc
forall a. Pretty a => a -> Doc
ppr [FParam lore]
fparams) Doc -> Doc -> Doc
<+>
    Doc
equals Doc -> Doc -> Doc
<+> [Char] -> [Char] -> Doc -> Doc
nestedBlock [Char]
"{" [Char]
"}" (BodyT lore -> Doc
forall a. Pretty a => a -> Doc
ppr BodyT lore
body)
    where fun :: [Char]
fun | Maybe EntryPoint -> Bool
forall a. Maybe a -> Bool
isJust Maybe EntryPoint
entry = [Char]
"entry"
              | Bool
otherwise    = [Char]
"fun"

instance PrettyLore lore => Pretty (Prog lore) where
  ppr :: Prog lore -> Doc
ppr (Prog Stms lore
consts [FunDef lore]
funs) =
    [Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
line ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Stms lore -> Doc
forall a. Pretty a => a -> Doc
ppr Stms lore
consts Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (FunDef lore -> Doc) -> [FunDef lore] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FunDef lore -> Doc
forall a. Pretty a => a -> Doc
ppr [FunDef lore]
funs

instance Pretty d => Pretty (DimChange d) where
  ppr :: DimChange d -> Doc
ppr (DimCoercion d
se) = [Char] -> Doc
text [Char]
"~" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> d -> Doc
forall a. Pretty a => a -> Doc
ppr d
se
  ppr (DimNew      d
se) = d -> Doc
forall a. Pretty a => a -> Doc
ppr d
se

instance Pretty d => Pretty (DimIndex d) where
  ppr :: DimIndex d -> Doc
ppr (DimFix d
i)       = d -> Doc
forall a. Pretty a => a -> Doc
ppr d
i
  ppr (DimSlice d
i d
n d
s) = d -> Doc
forall a. Pretty a => a -> Doc
ppr d
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
":+" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> d -> Doc
forall a. Pretty a => a -> Doc
ppr d
n Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
"*" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> d -> Doc
forall a. Pretty a => a -> Doc
ppr d
s

ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc
ppPattern :: [a] -> [b] -> Doc
ppPattern [] [b]
bs = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (b -> Doc) -> [b] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map b -> Doc
forall a. Pretty a => a -> Doc
ppr [b]
bs
ppPattern [a]
as [b]
bs = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr [a]
as) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
semi Doc -> Doc -> Doc
</> [Doc] -> Doc
commasep ((b -> Doc) -> [b] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map b -> Doc
forall a. Pretty a => a -> Doc
ppr [b]
bs)

-- | Like 'prettyTuple', but produces a 'Doc'.
ppTuple' :: Pretty a => [a] -> Doc
ppTuple' :: [a] -> Doc
ppTuple' [a]
ets = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr [a]
ets