{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Futhark prettyprinter.  This module defines 'Pretty' instances
-- for the AST defined in "Language.Futhark.Syntax".
module Language.Futhark.Pretty
  ( pretty,
    prettyTuple,
    leadingOperator,
    IsName (..),
    prettyName,
    Annot (..),
  )
where

import Control.Monad
import Data.Array
import Data.Char (chr)
import Data.Functor
import Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid hiding (Sum)
import Data.Ord
import Data.Word
import Futhark.Util
import Futhark.Util.Pretty
import Language.Futhark.Prop
import Language.Futhark.Syntax
import Prelude

-- | A class for types that are variable names in the Futhark source
-- language.  This is used instead of a mere 'Pretty' instance because
-- in the compiler frontend we want to print VNames differently
-- depending on whether the FUTHARK_COMPILER_DEBUGGING environment
-- variable is set, yet in the backend we want to always print VNames
-- with the tag.  To avoid erroneously using the 'Pretty' instance for
-- VNames, we in fact only define it inside the modules for the core
-- language (as an orphan instance).
class IsName v where
  pprName :: v -> Doc

-- | Depending on the environment variable FUTHARK_COMPILER_DEBUGGING,
-- VNames are printed as either the name with an internal tag, or just
-- the base name.
instance IsName VName where
  pprName :: VName -> Doc
pprName
    | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
1 =
        \(VName Name
vn Int
i) -> forall a. Pretty a => a -> Doc
ppr Name
vn forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"_" forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (forall a. Show a => a -> String
show Int
i)
    | Bool
otherwise = forall a. Pretty a => a -> Doc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
baseName

instance IsName Name where
  pprName :: Name -> Doc
pprName = forall a. Pretty a => a -> Doc
ppr

-- | Prettyprint a name to a string.
prettyName :: IsName v => v -> String
prettyName :: forall v. IsName v => v -> String
prettyName = Int -> Doc -> String
prettyDoc Int
80 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Doc
pprName

-- | Class for type constructors that represent annotations.  Used in
-- the prettyprinter to either print the original AST, or the computed
-- decoration.
class Annot f where
  -- | Extract value, if any.
  unAnnot :: f a -> Maybe a

instance Annot NoInfo where
  unAnnot :: forall a. NoInfo a -> Maybe a
unAnnot = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

instance Annot Info where
  unAnnot :: forall a. Info a -> Maybe a
unAnnot = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Info a -> a
unInfo

instance Pretty Value where
  ppr :: Value -> Doc
ppr (PrimValue PrimValue
bv) = forall a. Pretty a => a -> Doc
ppr PrimValue
bv
  ppr (ArrayValue Array Int Value
a ValueType
t)
    | [] <- forall i e. Array i e -> [e]
elems Array Int Value
a = String -> Doc
text String
"empty" forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
ppr ValueType
t)
    | Array {} <- ValueType
t = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commastack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
elems Array Int Value
a
    | Bool
otherwise = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
elems Array Int Value
a

instance Pretty PrimValue where
  ppr :: PrimValue -> Doc
ppr (UnsignedValue (Int8Value Int8
v)) =
    String -> Doc
text (forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v :: Word8)) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u8"
  ppr (UnsignedValue (Int16Value Int16
v)) =
    String -> Doc
text (forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
v :: Word16)) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u16"
  ppr (UnsignedValue (Int32Value Int32
v)) =
    String -> Doc
text (forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v :: Word32)) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u32"
  ppr (UnsignedValue (Int64Value Int64
v)) =
    String -> Doc
text (forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
v :: Word64)) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u64"
  ppr (SignedValue IntValue
v) = forall a. Pretty a => a -> Doc
ppr IntValue
v
  ppr (BoolValue Bool
True) = String -> Doc
text String
"true"
  ppr (BoolValue Bool
False) = String -> Doc
text String
"false"
  ppr (FloatValue FloatValue
v) = forall a. Pretty a => a -> Doc
ppr FloatValue
v

instance Pretty Size where
  ppr :: Size -> Doc
ppr (AnySize Maybe VName
Nothing) = forall a. Monoid a => a
mempty
  ppr (AnySize (Just VName
v)) = String -> Doc
text String
"?" forall a. Semigroup a => a -> a -> a
<> forall v. IsName v => v -> Doc
pprName VName
v
  ppr (NamedSize QualName VName
v) = forall a. Pretty a => a -> Doc
ppr QualName VName
v
  ppr (ConstSize Int
n) = forall a. Pretty a => a -> Doc
ppr Int
n

instance IsName vn => Pretty (SizeExp vn) where
  ppr :: SizeExp vn -> Doc
ppr SizeExp vn
SizeExpAny = forall a. Monoid a => a
mempty
  ppr (SizeExpNamed QualName vn
v SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (SizeExpConst Int
n SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr Int
n

instance Pretty (Shape Size) where
  ppr :: Shape Size -> Doc
ppr (Shape [Size]
ds) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) [Size]
ds)

instance Pretty (Shape ()) where
  ppr :: Shape () -> Doc
ppr (Shape [()]
ds) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
ds) forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"[]"

instance Pretty (Shape Int64) where
  ppr :: Shape Int64 -> Doc
ppr (Shape [Int64]
ds) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) [Int64]
ds)

instance Pretty (Shape Bool) where
  ppr :: Shape Bool -> Doc
ppr (Shape [Bool]
ds) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) [Bool]
ds)

instance Pretty (Shape dim) => Pretty (RetTypeBase dim as) where
  ppr :: RetTypeBase dim as -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> RetTypeBase dim as -> Doc
pprPrec Int
p (RetType [] TypeBase dim as
t) = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
p TypeBase dim as
t
  pprPrec Int
_ (RetType [VName]
dims TypeBase dim as
t) =
    String -> Doc
text String
"?" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Doc
pprName) [VName]
dims) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr TypeBase dim as
t

instance Pretty (Shape dim) => Pretty (ScalarTypeBase dim as) where
  ppr :: ScalarTypeBase dim as -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> ScalarTypeBase dim as -> Doc
pprPrec Int
_ (Prim PrimType
et) = forall a. Pretty a => a -> Doc
ppr PrimType
et
  pprPrec Int
p (TypeVar as
_ Uniqueness
u QualName VName
v [TypeArg dim]
targs) =
    Bool -> Doc -> Doc
parensIf (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeArg dim]
targs) Bool -> Bool -> Bool
&& Int
p forall a. Ord a => a -> a -> Bool
> Int
3) forall a b. (a -> b) -> a -> b
$
      forall a. Pretty a => a -> Doc
ppr Uniqueness
u forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr QualName VName
v Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
pprPrec Int
3) [TypeArg dim]
targs)
  pprPrec Int
_ (Record Map Name (TypeBase dim as)
fs)
    | Just [TypeBase dim as]
ts <- forall a. Map Name a -> Maybe [a]
areTupleFields Map Name (TypeBase dim as)
fs =
        Doc -> Doc
oneLine (Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeBase dim as]
ts)
          Doc -> Doc -> Doc
<|> Doc -> Doc
parens (Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
"," forall a. Semigroup a => a -> a -> a
<> Doc
line) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeBase dim as]
ts)
    | Bool
otherwise =
        Doc -> Doc
oneLine (Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep [Doc]
fs')
          Doc -> Doc -> Doc
<|> Doc -> Doc
braces (Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
"," forall a. Semigroup a => a -> a -> a
<> Doc
line) [Doc]
fs')
    where
      ppField :: (Name, a) -> Doc
ppField (Name
name, a
t) = String -> Doc
text (Name -> String
nameToString Name
name) forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr a
t)
      fs' :: [Doc]
fs' = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => (Name, a) -> Doc
ppField forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Name (TypeBase dim as)
fs
  pprPrec Int
p (Arrow as
_ (Named VName
v) TypeBase dim ()
t1 RetTypeBase dim as
t2) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
      Doc -> Doc
parens (forall v. IsName v => v -> Doc
pprName VName
v forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr TypeBase dim ()
t1)) Doc -> Doc -> Doc
<+/> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
1 RetTypeBase dim as
t2
  pprPrec Int
p (Arrow as
_ PName
Unnamed TypeBase dim ()
t1 RetTypeBase dim as
t2) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
pprPrec Int
2 TypeBase dim ()
t1 Doc -> Doc -> Doc
<+/> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
1 RetTypeBase dim as
t2
  pprPrec Int
p (Sum Map Name [TypeBase dim as]
cs) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      Doc -> Doc
oneLine (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" | ") [Doc]
cs')
        Doc -> Doc -> Doc
<|> Doc -> Doc
align (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" |" forall a. Semigroup a => a -> a -> a
<> Doc
line) [Doc]
cs')
    where
      ppConstr :: (a, [a]) -> Doc
ppConstr (a
name, [a]
fs) = [Doc] -> Doc
sep forall a b. (a -> b) -> a -> b
$ (String -> Doc
text String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr a
name) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
pprPrec Int
2) [a]
fs
      cs' :: [Doc]
cs' = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Pretty a, Pretty a) => (a, [a]) -> Doc
ppConstr forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Name [TypeBase dim as]
cs

instance Pretty (Shape dim) => Pretty (TypeBase dim as) where
  ppr :: TypeBase dim as -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> TypeBase dim as -> Doc
pprPrec Int
_ (Array as
_ Uniqueness
u Shape dim
shape ScalarTypeBase dim ()
at) = forall a. Pretty a => a -> Doc
ppr Uniqueness
u forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Shape dim
shape forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
align (forall a. Pretty a => Int -> a -> Doc
pprPrec Int
1 ScalarTypeBase dim ()
at)
  pprPrec Int
p (Scalar ScalarTypeBase dim as
t) = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
p ScalarTypeBase dim as
t

instance Pretty (Shape dim) => Pretty (TypeArg dim) where
  ppr :: TypeArg dim -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> TypeArg dim -> Doc
pprPrec Int
_ (TypeArgDim dim
d SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr forall a b. (a -> b) -> a -> b
$ forall dim. [dim] -> Shape dim
Shape [dim
d]
  pprPrec Int
p (TypeArgType TypeBase dim ()
t SrcLoc
_) = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
p TypeBase dim ()
t

instance (Eq vn, IsName vn) => Pretty (TypeExp vn) where
  ppr :: TypeExp vn -> Doc
ppr (TEUnique TypeExp vn
t SrcLoc
_) = String -> Doc
text String
"*" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr TypeExp vn
t
  ppr (TEArray SizeExp vn
d TypeExp vn
at SrcLoc
_) = Doc -> Doc
brackets (forall a. Pretty a => a -> Doc
ppr SizeExp vn
d) forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr TypeExp vn
at
  ppr (TETuple [TypeExp vn]
ts SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeExp vn]
ts
  ppr (TERecord [(Name, TypeExp vn)]
fs SrcLoc
_) = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => (Name, a) -> Doc
ppField [(Name, TypeExp vn)]
fs
    where
      ppField :: (Name, a) -> Doc
ppField (Name
name, a
t) = String -> Doc
text (Name -> String
nameToString Name
name) forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr a
t
  ppr (TEVar QualName vn
name SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
name
  ppr (TEApply TypeExp vn
t TypeArgExp vn
arg SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr TypeExp vn
t Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeArgExp vn
arg
  ppr (TEArrow (Just vn
v) TypeExp vn
t1 TypeExp vn
t2 SrcLoc
_) = Doc -> Doc
parens Doc
v' Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeExp vn
t2
    where
      v' :: Doc
v' = forall v. IsName v => v -> Doc
pprName vn
v forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeExp vn
t1
  ppr (TEArrow Maybe vn
Nothing TypeExp vn
t1 TypeExp vn
t2 SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr TypeExp vn
t1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeExp vn
t2
  ppr (TESum [(Name, [TypeExp vn])]
cs SrcLoc
_) =
    Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
cat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" |" forall a. Semigroup a => a -> a -> a
<> Doc
softline) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Pretty a, Pretty a) => (a, [a]) -> Doc
ppConstr [(Name, [TypeExp vn])]
cs
    where
      ppConstr :: (a, [a]) -> Doc
ppConstr (a
name, [a]
fs) = String -> Doc
text String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr a
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [a]
fs)
  ppr (TEDim [vn]
dims TypeExp vn
te SrcLoc
_) =
    String -> Doc
text String
"?" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Doc
pprName) [vn]
dims) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr TypeExp vn
te

instance (Eq vn, IsName vn) => Pretty (TypeArgExp vn) where
  ppr :: TypeArgExp vn -> Doc
ppr (TypeArgExpDim SizeExp vn
d SrcLoc
_) = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr SizeExp vn
d
  ppr (TypeArgExpType TypeExp vn
t) = forall a. Pretty a => a -> Doc
ppr TypeExp vn
t

instance IsName vn => Pretty (QualName vn) where
  ppr :: QualName vn -> Doc
ppr (QualName [vn]
names vn
name) =
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
".") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall v. IsName v => v -> Doc
pprName [vn]
names forall a. [a] -> [a] -> [a]
++ [forall v. IsName v => v -> Doc
pprName vn
name]

instance IsName vn => Pretty (IdentBase f vn) where
  ppr :: IdentBase f vn -> Doc
ppr = forall v. IsName v => v -> Doc
pprName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) vn. IdentBase f vn -> vn
identName

hasArrayLit :: ExpBase ty vn -> Bool
hasArrayLit :: forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit ArrayLit {} = Bool
True
hasArrayLit (TupLit [ExpBase ty vn]
es2 SrcLoc
_) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit [ExpBase ty vn]
es2
hasArrayLit ExpBase ty vn
_ = Bool
False

instance (Eq vn, IsName vn, Annot f) => Pretty (DimIndexBase f vn) where
  ppr :: DimIndexBase f vn -> Doc
ppr (DimFix ExpBase f vn
e) = forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  ppr (DimSlice Maybe (ExpBase f vn)
i Maybe (ExpBase f vn)
j (Just ExpBase f vn
s)) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i
      forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
j
      forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
s
  ppr (DimSlice Maybe (ExpBase f vn)
i (Just ExpBase f vn
j) Maybe (ExpBase f vn)
s) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i
      forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
j
      forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ((String -> Doc
text String
":" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) Maybe (ExpBase f vn)
s
  ppr (DimSlice Maybe (ExpBase f vn)
i Maybe (ExpBase f vn)
Nothing Maybe (ExpBase f vn)
Nothing) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"

instance IsName vn => Pretty (SizeBinder vn) where
  ppr :: SizeBinder vn -> Doc
ppr (SizeBinder vn
v SrcLoc
_) = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall v. IsName v => v -> Doc
pprName vn
v

letBody :: (Eq vn, IsName vn, Annot f) => ExpBase f vn -> Doc
letBody :: forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody body :: ExpBase f vn
body@(AppExp LetPat {} f AppRes
_) = forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body
letBody body :: ExpBase f vn
body@(AppExp LetFun {} f AppRes
_) = forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body
letBody ExpBase f vn
body = String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body)

instance (Eq vn, IsName vn, Annot f) => Pretty (AppExpBase f vn) where
  ppr :: AppExpBase f vn -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec (-Int
1)
  pprPrec :: Int -> AppExpBase f vn -> Doc
pprPrec Int
p (Coerce ExpBase f vn
e TypeExp vn
t SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 ExpBase f vn
e Doc -> Doc -> Doc
<+> String -> Doc
text String
":>" Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 TypeExp vn
t)
  pprPrec Int
p (BinOp (QualName vn
bop, SrcLoc
_) f PatType
_ (ExpBase f vn
x, f (StructType, Maybe VName)
_) (ExpBase f vn
y, f (StructType, Maybe VName)
_) SrcLoc
_) = forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
Int -> QualName vn -> ExpBase f vn -> ExpBase f vn -> Doc
prettyBinOp Int
p QualName vn
bop ExpBase f vn
x ExpBase f vn
y
  pprPrec Int
_ (Match ExpBase f vn
e NonEmpty (CaseBase f vn)
cs SrcLoc
_) = String -> Doc
text String
"match" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e Doc -> Doc -> Doc
</> ([Doc] -> Doc
stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (CaseBase f vn)
cs)
  pprPrec Int
_ (DoLoop [VName]
sizeparams PatBase f vn
pat ExpBase f vn
initexp LoopFormBase f vn
form ExpBase f vn
loopbody SrcLoc
_) =
    String -> Doc
text String
"loop"
      Doc -> Doc -> Doc
<+> Doc -> Doc
align
        ( [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Doc
pprName) [VName]
sizeparams)
            Doc -> Doc -> Doc
<+/> forall a. Pretty a => a -> Doc
ppr PatBase f vn
pat
            Doc -> Doc -> Doc
<+> Doc
equals
            Doc -> Doc -> Doc
<+/> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
initexp
            Doc -> Doc -> Doc
<+/> forall a. Pretty a => a -> Doc
ppr LoopFormBase f vn
form
            Doc -> Doc -> Doc
<+> String -> Doc
text String
"do"
        )
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
loopbody)
  pprPrec Int
_ (Index ExpBase f vn
e SliceBase f vn
idxs SrcLoc
_) =
    forall a. Pretty a => Int -> a -> Doc
pprPrec Int
9 ExpBase f vn
e forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets ([Doc] -> Doc
commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr SliceBase f vn
idxs))
  pprPrec Int
p (LetPat [SizeBinder vn]
sizes PatBase f vn
pat ExpBase f vn
e ExpBase f vn
body SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$
      Doc -> Doc
align forall a b. (a -> b) -> a -> b
$
        String -> Doc
text String
"let"
          Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [SizeBinder vn]
sizes)
          Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr PatBase f vn
pat)
          Doc -> Doc -> Doc
<+> ( if Bool
linebreak
                  then Doc
equals Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
                  else Doc
equals Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
              )
          Doc -> Doc -> Doc
</> forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody ExpBase f vn
body
    where
      linebreak :: Bool
linebreak = case ExpBase f vn
e of
        AppExp {} -> Bool
True
        Attr {} -> Bool
True
        ArrayLit {} -> Bool
False
        ExpBase f vn
_ -> forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit ExpBase f vn
e
  pprPrec Int
_ (LetFun vn
fname ([TypeParamBase vn]
tparams, [PatBase f vn]
params, Maybe (TypeExp vn)
retdecl, f StructRetType
rettype, ExpBase f vn
e) ExpBase f vn
body SrcLoc
_) =
    String -> Doc
text String
"let"
      Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
fname
      Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [PatBase f vn]
params)
        forall a. Semigroup a => a -> a -> a
<> Doc
retdecl'
      Doc -> Doc -> Doc
<+> Doc
equals
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
      Doc -> Doc -> Doc
</> forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody ExpBase f vn
body
    where
      retdecl' :: Doc
retdecl' = case (forall a. Pretty a => a -> Doc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f StructRetType
rettype) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (forall a. Pretty a => a -> Doc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TypeExp vn)
retdecl) of
        Just Doc
rettype' -> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align Doc
rettype'
        Maybe Doc
Nothing -> forall a. Monoid a => a
mempty
  pprPrec Int
_ (LetWith IdentBase f vn
dest IdentBase f vn
src SliceBase f vn
idxs ExpBase f vn
ve ExpBase f vn
body SrcLoc
_)
    | IdentBase f vn
dest forall a. Eq a => a -> a -> Bool
== IdentBase f vn
src =
        String -> Doc
text String
"let"
          Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr IdentBase f vn
dest forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
list (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr SliceBase f vn
idxs)
          Doc -> Doc -> Doc
<+> Doc
equals
          Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
          Doc -> Doc -> Doc
</> forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody ExpBase f vn
body
    | Bool
otherwise =
        String -> Doc
text String
"let"
          Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr IdentBase f vn
dest
          Doc -> Doc -> Doc
<+> Doc
equals
          Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr IdentBase f vn
src
          Doc -> Doc -> Doc
<+> String -> Doc
text String
"with"
          Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr SliceBase f vn
idxs))
          Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
          Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
          Doc -> Doc -> Doc
</> forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody ExpBase f vn
body
  pprPrec Int
p (Range ExpBase f vn
start Maybe (ExpBase f vn)
maybe_step Inclusiveness (ExpBase f vn)
end SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$
      forall a. Pretty a => a -> Doc
ppr ExpBase f vn
start
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ((String -> Doc
text String
".." forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) Maybe (ExpBase f vn)
maybe_step
        forall a. Semigroup a => a -> a -> a
<> case Inclusiveness (ExpBase f vn)
end of
          DownToExclusive ExpBase f vn
end' -> String -> Doc
text String
"..>" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
end'
          ToInclusive ExpBase f vn
end' -> String -> Doc
text String
"..." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
end'
          UpToExclusive ExpBase f vn
end' -> String -> Doc
text String
"..<" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
end'
  pprPrec Int
_ (If ExpBase f vn
c ExpBase f vn
t ExpBase f vn
f SrcLoc
_) =
    String -> Doc
text String
"if"
      Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
c
      Doc -> Doc -> Doc
</> String -> Doc
text String
"then"
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
t)
      Doc -> Doc -> Doc
</> String -> Doc
text String
"else"
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
f)
  pprPrec Int
p (Apply ExpBase f vn
f ExpBase f vn
arg f (Diet, Maybe VName)
_ SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
>= Int
10) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 ExpBase f vn
f Doc -> Doc -> Doc
<+/> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
10 ExpBase f vn
arg

instance (Eq vn, IsName vn, Annot f) => Pretty (ExpBase f vn) where
  ppr :: ExpBase f vn -> Doc
ppr = forall a. Pretty a => Int -> a -> Doc
pprPrec (-Int
1)
  pprPrec :: Int -> ExpBase f vn -> Doc
pprPrec Int
_ (Var QualName vn
name f PatType
t SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
name forall a. Semigroup a => a -> a -> a
<> Doc
inst
    where
      inst :: Doc
inst = case forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatType
t of
        Just PatType
t'
          | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
2 ->
              String -> Doc
text String
"@" forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr PatType
t')
        Maybe PatType
_ -> forall a. Monoid a => a
mempty
  pprPrec Int
_ (Hole f PatType
t SrcLoc
_) = Doc
"???" forall a. Semigroup a => a -> a -> a
<> Doc
inst
    where
      inst :: Doc
inst = case forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatType
t of
        Just PatType
t'
          | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
2 ->
              String -> Doc
text String
"@" forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr PatType
t')
        Maybe PatType
_ -> forall a. Monoid a => a
mempty
  pprPrec Int
_ (Parens ExpBase f vn
e SrcLoc
_) = Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  pprPrec Int
_ (QualParens (QualName vn
v, SrcLoc
_) ExpBase f vn
e SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
v forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
align (Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
  pprPrec Int
p (Ascript ExpBase f vn
e TypeExp vn
t SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 ExpBase f vn
e Doc -> Doc -> Doc
<+> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 TypeExp vn
t)
  pprPrec Int
_ (Literal PrimValue
v SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr PrimValue
v
  pprPrec Int
_ (IntLit Integer
v f PatType
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr Integer
v
  pprPrec Int
_ (FloatLit Double
v f PatType
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr Double
v
  pprPrec Int
_ (TupLit [ExpBase f vn]
es SrcLoc
_)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit [ExpBase f vn]
es = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commastack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es
    | Bool
otherwise = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es
  pprPrec Int
_ (RecordLit [FieldBase f vn]
fs SrcLoc
_)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {ty :: * -> *} {vn}. FieldBase ty vn -> Bool
fieldArray [FieldBase f vn]
fs = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commastack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [FieldBase f vn]
fs
    | Bool
otherwise = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [FieldBase f vn]
fs
    where
      fieldArray :: FieldBase ty vn -> Bool
fieldArray (RecordFieldExplicit Name
_ ExpBase ty vn
e SrcLoc
_) = forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit ExpBase ty vn
e
      fieldArray RecordFieldImplicit {} = Bool
False
  pprPrec Int
_ (ArrayLit [ExpBase f vn]
es f PatType
info SrcLoc
_) =
    Doc -> Doc
brackets ([Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es) forall a. Semigroup a => a -> a -> a
<> Doc
info'
    where
      info' :: Doc
info' = case forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatType
info of
        Just PatType
t
          | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
2 ->
              String -> Doc
text String
"@" forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr PatType
t)
        Maybe PatType
_ -> forall a. Monoid a => a
mempty
  pprPrec Int
_ (StringLit [Word8]
s SrcLoc
_) =
    String -> Doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word8]
s
  pprPrec Int
_ (Project Name
k ExpBase f vn
e f PatType
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Name
k
  pprPrec Int
_ (Negate ExpBase f vn
e SrcLoc
_) = String -> Doc
text String
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  pprPrec Int
_ (Not ExpBase f vn
e SrcLoc
_) = String -> Doc
text String
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  pprPrec Int
_ (Update ExpBase f vn
src SliceBase f vn
idxs ExpBase f vn
ve SrcLoc
_) =
    forall a. Pretty a => a -> Doc
ppr ExpBase f vn
src
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"with"
      Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr SliceBase f vn
idxs))
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
  pprPrec Int
_ (RecordUpdate ExpBase f vn
src [Name]
fs ExpBase f vn
ve f PatType
_ SrcLoc
_) =
    forall a. Pretty a => a -> Doc
ppr ExpBase f vn
src
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"with"
      Doc -> Doc -> Doc
<+> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
".") (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [Name]
fs))
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
  pprPrec Int
_ (Assert ExpBase f vn
e1 ExpBase f vn
e2 f String
_ SrcLoc
_) = String -> Doc
text String
"assert" Doc -> Doc -> Doc
<+> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
10 ExpBase f vn
e1 Doc -> Doc -> Doc
<+> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
10 ExpBase f vn
e2
  pprPrec Int
p (Lambda [PatBase f vn]
params ExpBase f vn
body Maybe (TypeExp vn)
rettype f (Aliasing, StructRetType)
_ SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$
      String -> Doc
text String
"\\" forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [PatBase f vn]
params) forall a. Semigroup a => a -> a -> a
<> forall t. Pretty t => Maybe t -> Doc
ppAscription Maybe (TypeExp vn)
rettype
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
        Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body)
  pprPrec Int
_ (OpSection QualName vn
binop f PatType
_ SrcLoc
_) =
    Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr QualName vn
binop
  pprPrec Int
_ (OpSectionLeft QualName vn
binop f PatType
_ ExpBase f vn
x (f (PName, StructType, Maybe VName), f (PName, StructType))
_ (f PatRetType, f [VName])
_ SrcLoc
_) =
    Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr ExpBase f vn
x Doc -> Doc -> Doc
<+> forall vn. IsName vn => QualName vn -> Doc
ppBinOp QualName vn
binop
  pprPrec Int
_ (OpSectionRight QualName vn
binop f PatType
_ ExpBase f vn
x (f (PName, StructType), f (PName, StructType, Maybe VName))
_ f PatRetType
_ SrcLoc
_) =
    Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall vn. IsName vn => QualName vn -> Doc
ppBinOp QualName vn
binop Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
x
  pprPrec Int
_ (ProjectSection [Name]
fields f PatType
_ SrcLoc
_) =
    Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
p [Name]
fields
    where
      p :: a -> Doc
p a
name = String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr a
name
  pprPrec Int
_ (IndexSection SliceBase f vn
idxs f PatType
_ SrcLoc
_) =
    Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"." forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets ([Doc] -> Doc
commasep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr SliceBase f vn
idxs))
  pprPrec Int
_ (Constr Name
n [ExpBase f vn]
cs f PatType
_ SrcLoc
_) = String -> Doc
text String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
cs)
  pprPrec Int
_ (Attr AttrInfo vn
attr ExpBase f vn
e SrcLoc
_) =
    String -> Doc
text String
"#[" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr AttrInfo vn
attr forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"]" Doc -> Doc -> Doc
</> forall a. Pretty a => Int -> a -> Doc
pprPrec (-Int
1) ExpBase f vn
e
  pprPrec Int
i (AppExp AppExpBase f vn
e f AppRes
_) = forall a. Pretty a => Int -> a -> Doc
pprPrec Int
i AppExpBase f vn
e

instance IsName vn => Pretty (AttrAtom vn) where
  ppr :: AttrAtom vn -> Doc
ppr (AtomName Name
v) = forall a. Pretty a => a -> Doc
ppr Name
v
  ppr (AtomInt Integer
x) = forall a. Pretty a => a -> Doc
ppr Integer
x

instance IsName vn => Pretty (AttrInfo vn) where
  ppr :: AttrInfo vn -> Doc
ppr (AttrAtom AttrAtom vn
attr SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr AttrAtom vn
attr
  ppr (AttrComp Name
f [AttrInfo vn]
attrs SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr Name
f forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [AttrInfo vn]
attrs)

instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where
  ppr :: FieldBase f vn -> Doc
ppr (RecordFieldExplicit Name
name ExpBase f vn
e SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr Name
name forall a. Semigroup a => a -> a -> a
<> Doc
equals forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  ppr (RecordFieldImplicit vn
name f PatType
_ SrcLoc
_) = forall v. IsName v => v -> Doc
pprName vn
name

instance (Eq vn, IsName vn, Annot f) => Pretty (CaseBase f vn) where
  ppr :: CaseBase f vn -> Doc
ppr (CasePat PatBase f vn
p ExpBase f vn
e SrcLoc
_) = String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr PatBase f vn
p Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)

instance (Eq vn, IsName vn, Annot f) => Pretty (LoopFormBase f vn) where
  ppr :: LoopFormBase f vn -> Doc
ppr (For IdentBase f vn
i ExpBase f vn
ubound) =
    String -> Doc
text String
"for" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr IdentBase f vn
i Doc -> Doc -> Doc
<+> String -> Doc
text String
"<" Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ubound)
  ppr (ForIn PatBase f vn
x ExpBase f vn
e) =
    String -> Doc
text String
"for" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr PatBase f vn
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  ppr (While ExpBase f vn
cond) =
    String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ExpBase f vn
cond

instance Pretty PatLit where
  ppr :: PatLit -> Doc
ppr (PatLitInt Integer
x) = forall a. Pretty a => a -> Doc
ppr Integer
x
  ppr (PatLitFloat Double
f) = forall a. Pretty a => a -> Doc
ppr Double
f
  ppr (PatLitPrim PrimValue
v) = forall a. Pretty a => a -> Doc
ppr PrimValue
v

instance (Eq vn, IsName vn, Annot f) => Pretty (PatBase f vn) where
  ppr :: PatBase f vn -> Doc
ppr (PatAscription PatBase f vn
p TypeExp vn
t SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr PatBase f vn
p forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr TypeExp vn
t)
  ppr (PatParens PatBase f vn
p SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr PatBase f vn
p
  ppr (Id vn
v f PatType
t SrcLoc
_) = case forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatType
t of
    Just PatType
t' -> Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall v. IsName v => v -> Doc
pprName vn
v forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr PatType
t')
    Maybe PatType
Nothing -> forall v. IsName v => v -> Doc
pprName vn
v
  ppr (TuplePat [PatBase f vn]
pats SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [PatBase f vn]
pats
  ppr (RecordPat [(Name, PatBase f vn)]
fs SrcLoc
_) = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => (Name, a) -> Doc
ppField [(Name, PatBase f vn)]
fs
    where
      ppField :: (Name, a) -> Doc
ppField (Name
name, a
t) = String -> Doc
text (Name -> String
nameToString Name
name) forall a. Semigroup a => a -> a -> a
<> Doc
equals forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr a
t
  ppr (Wildcard f PatType
t SrcLoc
_) = case forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatType
t of
    Just PatType
t' -> Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"_" forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr PatType
t'
    Maybe PatType
Nothing -> String -> Doc
text String
"_"
  ppr (PatLit PatLit
e f PatType
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr PatLit
e
  ppr (PatConstr Name
n f PatType
_ [PatBase f vn]
ps SrcLoc
_) = String -> Doc
text String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [PatBase f vn]
ps)
  ppr (PatAttr AttrInfo vn
attr PatBase f vn
p SrcLoc
_) = String -> Doc
text String
"#[" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr AttrInfo vn
attr forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"]" Doc -> Doc -> Doc
<+/> forall a. Pretty a => a -> Doc
ppr PatBase f vn
p

ppAscription :: Pretty t => Maybe t -> Doc
ppAscription :: forall t. Pretty t => Maybe t -> Doc
ppAscription Maybe t
Nothing = forall a. Monoid a => a
mempty
ppAscription (Just t
t) = Doc
colon forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
align (forall a. Pretty a => a -> Doc
ppr t
t)

instance (Eq vn, IsName vn, Annot f) => Pretty (ProgBase f vn) where
  ppr :: ProgBase f vn -> Doc
ppr = [Doc] -> Doc
stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) vn. ProgBase f vn -> [DecBase f vn]
progDecs

instance (Eq vn, IsName vn, Annot f) => Pretty (DecBase f vn) where
  ppr :: DecBase f vn -> Doc
ppr (ValDec ValBindBase f vn
dec) = forall a. Pretty a => a -> Doc
ppr ValBindBase f vn
dec
  ppr (TypeDec TypeBindBase f vn
dec) = forall a. Pretty a => a -> Doc
ppr TypeBindBase f vn
dec
  ppr (SigDec SigBindBase f vn
sig) = forall a. Pretty a => a -> Doc
ppr SigBindBase f vn
sig
  ppr (ModDec ModBindBase f vn
sd) = forall a. Pretty a => a -> Doc
ppr ModBindBase f vn
sd
  ppr (OpenDec ModExpBase f vn
x SrcLoc
_) = String -> Doc
text String
"open" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
x
  ppr (LocalDec DecBase f vn
dec SrcLoc
_) = String -> Doc
text String
"local" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr DecBase f vn
dec
  ppr (ImportDec String
x f String
_ SrcLoc
_) = String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr String
x

instance (Eq vn, IsName vn, Annot f) => Pretty (ModExpBase f vn) where
  ppr :: ModExpBase f vn -> Doc
ppr (ModVar QualName vn
v SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (ModParens ModExpBase f vn
e SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
e
  ppr (ModImport String
v f String
_ SrcLoc
_) = String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr (forall a. Show a => a -> String
show String
v)
  ppr (ModDecs [DecBase f vn]
ds SrcLoc
_) = String -> String -> Doc -> Doc
nestedBlock String
"{" String
"}" ([Doc] -> Doc
stack forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
line forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [DecBase f vn]
ds)
  ppr (ModApply ModExpBase f vn
f ModExpBase f vn
a f (Map VName VName)
_ f (Map VName VName)
_ SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
f Doc -> Doc -> Doc
<+> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
a)
  ppr (ModAscript ModExpBase f vn
me SigExpBase f vn
se f (Map VName VName)
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
me forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
se
  ppr (ModLambda ModParamBase f vn
param Maybe (SigExpBase f vn, f (Map VName VName))
maybe_sig ModExpBase f vn
body SrcLoc
_) =
    String -> Doc
text String
"\\" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr ModParamBase f vn
param forall a. Semigroup a => a -> a -> a
<> Doc
maybe_sig'
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
body)
    where
      maybe_sig' :: Doc
maybe_sig' = case Maybe (SigExpBase f vn, f (Map VName VName))
maybe_sig of
        Maybe (SigExpBase f vn, f (Map VName VName))
Nothing -> forall a. Monoid a => a
mempty
        Just (SigExpBase f vn
sig, f (Map VName VName)
_) -> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
sig

instance Pretty Liftedness where
  ppr :: Liftedness -> Doc
ppr Liftedness
Unlifted = String -> Doc
text String
""
  ppr Liftedness
SizeLifted = String -> Doc
text String
"~"
  ppr Liftedness
Lifted = String -> Doc
text String
"^"

instance (Eq vn, IsName vn, Annot f) => Pretty (TypeBindBase f vn) where
  ppr :: TypeBindBase f vn -> Doc
ppr (TypeBind vn
name Liftedness
l [TypeParamBase vn]
params TypeExp vn
te f StructRetType
rt Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"type" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Liftedness
l
      Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name
      Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
params)
      Doc -> Doc -> Doc
<+> Doc
equals
      Doc -> Doc -> Doc
<+> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Pretty a => a -> Doc
ppr TypeExp vn
te) forall a. Pretty a => a -> Doc
ppr (forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f StructRetType
rt)

instance (Eq vn, IsName vn) => Pretty (TypeParamBase vn) where
  ppr :: TypeParamBase vn -> Doc
ppr (TypeParamDim vn
name SrcLoc
_) = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall v. IsName v => v -> Doc
pprName vn
name
  ppr (TypeParamType Liftedness
l vn
name SrcLoc
_) = String -> Doc
text String
"'" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Liftedness
l forall a. Semigroup a => a -> a -> a
<> forall v. IsName v => v -> Doc
pprName vn
name

instance (Eq vn, IsName vn, Annot f) => Pretty (ValBindBase f vn) where
  ppr :: ValBindBase f vn -> Doc
ppr (ValBind Maybe (f EntryPoint)
entry vn
name Maybe (TypeExp vn)
retdecl f StructRetType
rettype [TypeParamBase vn]
tparams [PatBase f vn]
args ExpBase f vn
body Maybe DocComment
_ [AttrInfo vn]
attrs SrcLoc
_) =
    forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> Doc
line) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
ppr) [AttrInfo vn]
attrs)
      forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
fun
      Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name
      Doc -> Doc -> Doc
<+> Doc -> Doc
align ([Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [PatBase f vn]
args))
        forall a. Semigroup a => a -> a -> a
<> Doc
retdecl'
        forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" ="
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body)
    where
      fun :: String
fun
        | forall a. Maybe a -> Bool
isJust Maybe (f EntryPoint)
entry = String
"entry"
        | Bool
otherwise = String
"def"
      retdecl' :: Doc
retdecl' = case (forall a. Pretty a => a -> Doc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f StructRetType
rettype) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (forall a. Pretty a => a -> Doc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TypeExp vn)
retdecl) of
        Just Doc
rettype' -> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align Doc
rettype'
        Maybe Doc
Nothing -> forall a. Monoid a => a
mempty

instance (Eq vn, IsName vn, Annot f) => Pretty (SpecBase f vn) where
  ppr :: SpecBase f vn -> Doc
ppr (TypeAbbrSpec TypeBindBase f vn
tpsig) = forall a. Pretty a => a -> Doc
ppr TypeBindBase f vn
tpsig
  ppr (TypeSpec Liftedness
l vn
name [TypeParamBase vn]
ps Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"type" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr Liftedness
l Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
ps)
  ppr (ValSpec vn
name [TypeParamBase vn]
tparams TypeExp vn
vtype f StructType
_ Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"val" Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams) forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeExp vn
vtype
  ppr (ModSpec vn
name SigExpBase f vn
sig Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
sig
  ppr (IncludeSpec SigExpBase f vn
e SrcLoc
_) =
    String -> Doc
text String
"include" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e

instance (Eq vn, IsName vn, Annot f) => Pretty (SigExpBase f vn) where
  ppr :: SigExpBase f vn -> Doc
ppr (SigVar QualName vn
v f (Map VName VName)
_ SrcLoc
_) = forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (SigParens SigExpBase f vn
e SrcLoc
_) = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e
  ppr (SigSpecs [SpecBase f vn]
ss SrcLoc
_) = String -> String -> Doc -> Doc
nestedBlock String
"{" String
"}" ([Doc] -> Doc
stack forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
line forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [SpecBase f vn]
ss)
  ppr (SigWith SigExpBase f vn
s (TypeRef QualName vn
v [TypeParamBase vn]
ps TypeExp vn
td SrcLoc
_) SrcLoc
_) =
    forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
s Doc -> Doc -> Doc
<+> String -> Doc
text String
"with" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr QualName vn
v Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
ps) forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" =" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr TypeExp vn
td
  ppr (SigArrow (Just vn
v) SigExpBase f vn
e1 SigExpBase f vn
e2 SrcLoc
_) =
    Doc -> Doc
parens (forall v. IsName v => v -> Doc
pprName vn
v forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e1) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e2
  ppr (SigArrow Maybe vn
Nothing SigExpBase f vn
e1 SigExpBase f vn
e2 SrcLoc
_) =
    forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e2

instance (Eq vn, IsName vn, Annot f) => Pretty (SigBindBase f vn) where
  ppr :: SigBindBase f vn -> Doc
ppr (SigBind vn
name SigExpBase f vn
e Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"module type" Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e

instance (Eq vn, IsName vn, Annot f) => Pretty (ModParamBase f vn) where
  ppr :: ModParamBase f vn -> Doc
ppr (ModParam vn
pname SigExpBase f vn
psig f [VName]
_ SrcLoc
_) =
    Doc -> Doc
parens (forall v. IsName v => v -> Doc
pprName vn
pname forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
psig)

instance (Eq vn, IsName vn, Annot f) => Pretty (ModBindBase f vn) where
  ppr :: ModBindBase f vn -> Doc
ppr (ModBind vn
name [ModParamBase f vn]
ps Maybe (SigExpBase f vn, f (Map VName VName))
sig ModExpBase f vn
e Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
ppr [ModParamBase f vn]
ps) Doc -> Doc -> Doc
<+> Doc
sig' forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" =" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
e
    where
      sig' :: Doc
sig' = case Maybe (SigExpBase f vn, f (Map VName VName))
sig of
        Maybe (SigExpBase f vn, f (Map VName VName))
Nothing -> forall a. Monoid a => a
mempty
        Just (SigExpBase f vn
s, f (Map VName VName)
_) -> Doc
colon Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
s forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" "

ppBinOp :: IsName v => QualName v -> Doc
ppBinOp :: forall vn. IsName vn => QualName vn -> Doc
ppBinOp QualName v
bop =
  case BinOp
leading of
    BinOp
Backtick -> String -> Doc
text String
"`" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr QualName v
bop forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"`"
    BinOp
_ -> forall a. Pretty a => a -> Doc
ppr QualName v
bop
  where
    leading :: BinOp
leading =
      Name -> BinOp
leadingOperator forall a b. (a -> b) -> a -> b
$ String -> Name
nameFromString forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
pretty forall a b. (a -> b) -> a -> b
$ forall v. IsName v => v -> Doc
pprName forall a b. (a -> b) -> a -> b
$ forall vn. QualName vn -> vn
qualLeaf QualName v
bop

prettyBinOp ::
  (Eq vn, IsName vn, Annot f) =>
  Int ->
  QualName vn ->
  ExpBase f vn ->
  ExpBase f vn ->
  Doc
prettyBinOp :: forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
Int -> QualName vn -> ExpBase f vn -> ExpBase f vn -> Doc
prettyBinOp Int
p QualName vn
bop ExpBase f vn
x ExpBase f vn
y =
  Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
symPrecedence) forall a b. (a -> b) -> a -> b
$
    forall a. Pretty a => Int -> a -> Doc
pprPrec Int
symPrecedence ExpBase f vn
x
      Doc -> Doc -> Doc
<+/> Doc
bop'
      Doc -> Doc -> Doc
<+> forall a. Pretty a => Int -> a -> Doc
pprPrec Int
symRPrecedence ExpBase f vn
y
  where
    bop' :: Doc
bop' = case BinOp
leading of
      BinOp
Backtick -> String -> Doc
text String
"`" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
ppr QualName vn
bop forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"`"
      BinOp
_ -> forall a. Pretty a => a -> Doc
ppr QualName vn
bop
    leading :: BinOp
leading = Name -> BinOp
leadingOperator forall a b. (a -> b) -> a -> b
$ String -> Name
nameFromString forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
pretty forall a b. (a -> b) -> a -> b
$ forall v. IsName v => v -> Doc
pprName forall a b. (a -> b) -> a -> b
$ forall vn. QualName vn -> vn
qualLeaf QualName vn
bop
    symPrecedence :: Int
symPrecedence = forall {a}. Num a => BinOp -> a
precedence BinOp
leading
    symRPrecedence :: Int
symRPrecedence = forall {a}. Num a => BinOp -> a
rprecedence BinOp
leading
    precedence :: BinOp -> a
precedence BinOp
PipeRight = -a
1
    precedence BinOp
PipeLeft = -a
1
    precedence BinOp
LogAnd = a
0
    precedence BinOp
LogOr = a
0
    precedence BinOp
Band = a
1
    precedence BinOp
Bor = a
1
    precedence BinOp
Xor = a
1
    precedence BinOp
Equal = a
2
    precedence BinOp
NotEqual = a
2
    precedence BinOp
Less = a
2
    precedence BinOp
Leq = a
2
    precedence BinOp
Greater = a
2
    precedence BinOp
Geq = a
2
    precedence BinOp
ShiftL = a
3
    precedence BinOp
ShiftR = a
3
    precedence BinOp
Plus = a
4
    precedence BinOp
Minus = a
4
    precedence BinOp
Times = a
5
    precedence BinOp
Divide = a
5
    precedence BinOp
Mod = a
5
    precedence BinOp
Quot = a
5
    precedence BinOp
Rem = a
5
    precedence BinOp
Pow = a
6
    precedence BinOp
Backtick = a
9
    rprecedence :: BinOp -> a
rprecedence BinOp
Minus = a
10
    rprecedence BinOp
Divide = a
10
    rprecedence BinOp
op = forall {a}. Num a => BinOp -> a
precedence BinOp
op