{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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 Codec.Binary.UTF8.String (decode)
import Control.Monad
import Data.Array
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) -> Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
vn Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
i)
    | Bool
otherwise = Name -> Doc
forall a. Pretty a => a -> Doc
ppr (Name -> Doc) -> (VName -> Name) -> VName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
baseName

instance IsName Name where
  pprName :: Name -> Doc
pprName = Name -> Doc
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 (Doc -> String) -> (v -> Doc) -> v -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Doc
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 = Maybe a -> NoInfo a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing

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

pprAnnot :: (Annot f, Pretty a, Pretty b) => a -> f b -> Doc
pprAnnot :: forall (f :: * -> *) a b.
(Annot f, Pretty a, Pretty b) =>
a -> f b -> Doc
pprAnnot a
a f b
b = Doc -> (b -> Doc) -> Maybe b -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
a) b -> Doc
forall a. Pretty a => a -> Doc
ppr (Maybe b -> Doc) -> Maybe b -> Doc
forall a b. (a -> b) -> a -> b
$ f b -> Maybe b
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f b
b

instance Pretty Value where
  ppr :: Value -> Doc
ppr (PrimValue PrimValue
bv) = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
bv
  ppr (ArrayValue Array Int Value
a ValueType
t)
    | [] <- Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
a = String -> Doc
text String
"empty" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (ValueType -> Doc
forall a. Pretty a => a -> Doc
ppr ValueType
t)
    | Array {} <- ValueType
t = 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
$ (Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
forall a. Pretty a => a -> Doc
ppr ([Value] -> [Doc]) -> [Value] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
a
    | Bool
otherwise = 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
$ (Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
forall a. Pretty a => a -> Doc
ppr ([Value] -> [Doc]) -> [Value] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> [Value]
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 (Word8 -> String
forall a. Show a => a -> String
show (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v :: Word8)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u8"
  ppr (UnsignedValue (Int16Value Int16
v)) =
    String -> Doc
text (Word16 -> String
forall a. Show a => a -> String
show (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
v :: Word16)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u16"
  ppr (UnsignedValue (Int32Value Int32
v)) =
    String -> Doc
text (Word32 -> String
forall a. Show a => a -> String
show (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v :: Word32)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u32"
  ppr (UnsignedValue (Int64Value Int64
v)) =
    String -> Doc
text (Word64 -> String
forall a. Show a => a -> String
show (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
v :: Word64)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"u64"
  ppr (SignedValue IntValue
v) = IntValue -> Doc
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) = FloatValue -> Doc
forall a. Pretty a => a -> Doc
ppr FloatValue
v

instance IsName vn => Pretty (DimDecl vn) where
  ppr :: DimDecl vn -> Doc
ppr (AnyDim Maybe vn
Nothing) = Doc
forall a. Monoid a => a
mempty
  ppr (AnyDim (Just vn
v)) = String -> Doc
text String
"?" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
v
  ppr (NamedDim QualName vn
v) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (ConstDim Int
n) = Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
n

instance IsName vn => Pretty (DimExp vn) where
  ppr :: DimExp vn -> Doc
ppr DimExp vn
DimExpAny = Doc
forall a. Monoid a => a
mempty
  ppr (DimExpNamed QualName vn
v SrcLoc
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (DimExpConst Int
n SrcLoc
_) = Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
n

instance IsName vn => Pretty (ShapeDecl (DimDecl vn)) where
  ppr :: ShapeDecl (DimDecl vn) -> Doc
ppr (ShapeDecl [DimDecl vn]
ds) = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((DimDecl vn -> Doc) -> [DimDecl vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets (Doc -> Doc) -> (DimDecl vn -> Doc) -> DimDecl vn -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DimDecl vn -> Doc
forall a. Pretty a => a -> Doc
ppr) [DimDecl vn]
ds)

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

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

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

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

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

instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim) where
  ppr :: TypeArg dim -> Doc
ppr = Int -> TypeArg dim -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> TypeArg dim -> Doc
pprPrec Int
_ (TypeArgDim dim
d SrcLoc
_) = ShapeDecl dim -> Doc
forall a. Pretty a => a -> Doc
ppr (ShapeDecl dim -> Doc) -> ShapeDecl dim -> Doc
forall a b. (a -> b) -> a -> b
$ [dim] -> ShapeDecl dim
forall dim. [dim] -> ShapeDecl dim
ShapeDecl [dim
d]
  pprPrec Int
p (TypeArgType TypeBase dim ()
t SrcLoc
_) = Int -> TypeBase dim () -> Doc
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
"*" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t
  ppr (TEArray TypeExp vn
at DimExp vn
d SrcLoc
_) = Doc -> Doc
brackets (DimExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr DimExp vn
d) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
at
  ppr (TETuple [TypeExp vn]
ts SrcLoc
_) = Doc -> Doc
parens (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
$ (TypeExp vn -> Doc) -> [TypeExp vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeExp vn]
ts
  ppr (TERecord [(Name, TypeExp vn)]
fs SrcLoc
_) = 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
$ ((Name, TypeExp vn) -> Doc) -> [(Name, TypeExp vn)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TypeExp vn) -> Doc
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) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
t
  ppr (TEVar QualName vn
name SrcLoc
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
name
  ppr (TEApply TypeExp vn
t TypeArgExp vn
arg SrcLoc
_) = TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t Doc -> Doc -> Doc
<+> TypeArgExp vn -> 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
<+> TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t2
    where
      v' :: Doc
v' = vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t1
  ppr (TEArrow Maybe vn
Nothing TypeExp vn
t1 TypeExp vn
t2 SrcLoc
_) = TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeExp vn
t2
  ppr (TESum [(Name, [TypeExp vn])]
cs SrcLoc
_) =
    Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
cat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" |" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
softline) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((Name, [TypeExp vn]) -> Doc) -> [(Name, [TypeExp vn])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [TypeExp vn]) -> Doc
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
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr [a]
fs)

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

instance (Eq vn, IsName vn, Annot f) => Pretty (TypeDeclBase f vn) where
  ppr :: TypeDeclBase f vn -> Doc
ppr TypeDeclBase f vn
x = TypeExp vn -> f StructType -> Doc
forall (f :: * -> *) a b.
(Annot f, Pretty a, Pretty b) =>
a -> f b -> Doc
pprAnnot (TypeDeclBase f vn -> TypeExp vn
forall (f :: * -> *) vn. TypeDeclBase f vn -> TypeExp vn
declaredType TypeDeclBase f vn
x) (TypeDeclBase f vn -> f StructType
forall (f :: * -> *) vn. TypeDeclBase f vn -> f StructType
expandedType TypeDeclBase f vn
x)

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

instance IsName vn => Pretty (IdentBase f vn) where
  ppr :: IdentBase f vn -> Doc
ppr = vn -> Doc
forall v. IsName v => v -> Doc
pprName (vn -> Doc) -> (IdentBase f vn -> vn) -> IdentBase f vn -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentBase f vn -> vn
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
_) = (ExpBase ty vn -> Bool) -> [ExpBase ty vn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExpBase ty vn -> Bool
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) = ExpBase f vn -> Doc
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)) =
    Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
j
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
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) =
    Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
j
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ((String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> (ExpBase f vn -> Doc) -> ExpBase f vn -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpBase f vn -> Doc
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) =
    Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe (ExpBase f vn)
i Doc -> Doc -> Doc
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 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ vn -> Doc
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
_) = ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body
letBody body :: ExpBase f vn
body@(AppExp LetFun {} f AppRes
_) = ExpBase f vn -> Doc
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 (ExpBase f vn -> Doc
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 = Int -> AppExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec (-Int
1)
  pprPrec :: Int -> AppExpBase f vn -> Doc
pprPrec Int
p (Coerce ExpBase f vn
e TypeDeclBase f vn
t SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> ExpBase f vn -> Doc
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 (Int -> TypeDeclBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 TypeDeclBase f vn
t)
  pprPrec Int
p (BinOp (QualName vn
bop, SrcLoc
_) f PatternType
_ (ExpBase f vn
x, f (StructType, Maybe VName)
_) (ExpBase f vn
y, f (StructType, Maybe VName)
_) SrcLoc
_) = Int -> QualName vn -> ExpBase f vn -> ExpBase f vn -> Doc
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
<+> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e Doc -> Doc -> Doc
</> ([Doc] -> Doc
stack ([Doc] -> Doc)
-> ([CaseBase f vn] -> [Doc]) -> [CaseBase f vn] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CaseBase f vn -> Doc) -> [CaseBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map CaseBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr) (NonEmpty (CaseBase f vn) -> [CaseBase f vn]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (CaseBase f vn)
cs)
  pprPrec Int
_ (DoLoop [VName]
sizeparams PatternBase 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 ((VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
brackets (Doc -> Doc) -> (VName -> Doc) -> VName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Doc
forall v. IsName v => v -> Doc
pprName) [VName]
sizeparams)
            Doc -> Doc -> Doc
<+/> PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
pat Doc -> Doc -> Doc
<+> Doc
equals
            Doc -> Doc -> Doc
<+/> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
initexp
            Doc -> Doc -> Doc
<+/> LoopFormBase f vn -> 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 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
loopbody)
  pprPrec Int
_ (Index ExpBase f vn
e [DimIndexBase f vn]
idxs SrcLoc
_) =
    Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
9 ExpBase f vn
e Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets ([Doc] -> Doc
commasep ((DimIndexBase f vn -> Doc) -> [DimIndexBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndexBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [DimIndexBase f vn]
idxs))
  pprPrec Int
p (LetPat [SizeBinder vn]
sizes PatternBase f vn
pat ExpBase f vn
e ExpBase f vn
body SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) (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
$
        String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((SizeBinder vn -> Doc) -> [SizeBinder vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SizeBinder vn -> Doc
forall a. Pretty a => a -> Doc
ppr [SizeBinder vn]
sizes) Doc -> Doc -> Doc
<+> Doc -> Doc
align (PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
pat)
          Doc -> Doc -> Doc
<+> ( if Bool
linebreak
                  then Doc
equals Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
                  else Doc
equals Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
              )
          Doc -> Doc -> Doc
</> ExpBase f vn -> 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
_ -> ExpBase f vn -> Bool
forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit ExpBase f vn
e
  pprPrec Int
_ (LetFun vn
fname ([TypeParamBase vn]
tparams, [PatternBase f vn]
params, Maybe (TypeExp vn)
retdecl, f StructType
rettype, ExpBase f vn
e) ExpBase f vn
body SrcLoc
_) =
    String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
fname Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (PatternBase f vn -> Doc) -> [PatternBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [PatternBase f vn]
params)
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
retdecl' Doc -> Doc -> Doc
<+> Doc
equals
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
      Doc -> Doc -> Doc
</> ExpBase f vn -> Doc
forall vn (f :: * -> *).
(Eq vn, IsName vn, Annot f) =>
ExpBase f vn -> Doc
letBody ExpBase f vn
body
    where
      retdecl' :: Doc
retdecl' = case (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr (StructType -> Doc) -> Maybe StructType -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f StructType -> Maybe StructType
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f StructType
rettype) Maybe Doc -> Maybe Doc -> Maybe Doc
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr (TypeExp vn -> Doc) -> Maybe (TypeExp vn) -> Maybe Doc
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 -> Doc
forall a. Monoid a => a
mempty
  pprPrec Int
_ (LetWith IdentBase f vn
dest IdentBase f vn
src [DimIndexBase f vn]
idxs ExpBase f vn
ve ExpBase f vn
body SrcLoc
_)
    | IdentBase f vn
dest IdentBase f vn -> IdentBase f vn -> Bool
forall a. Eq a => a -> a -> Bool
== IdentBase f vn
src =
      String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> IdentBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr IdentBase f vn
dest Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
list ((DimIndexBase f vn -> Doc) -> [DimIndexBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndexBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [DimIndexBase f vn]
idxs)
        Doc -> Doc -> Doc
<+> Doc
equals
        Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
        Doc -> Doc -> Doc
</> ExpBase f vn -> 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
<+> IdentBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr IdentBase f vn
dest Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> IdentBase f vn -> 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 ((DimIndexBase f vn -> Doc) -> [DimIndexBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndexBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [DimIndexBase f vn]
idxs))
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
        Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ve)
        Doc -> Doc -> Doc
</> ExpBase f vn -> 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
start
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (ExpBase f vn -> Doc) -> Maybe (ExpBase f vn) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ((String -> Doc
text String
".." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> (ExpBase f vn -> Doc) -> ExpBase f vn -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr) Maybe (ExpBase f vn)
maybe_step
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> case Inclusiveness (ExpBase f vn)
end of
          DownToExclusive ExpBase f vn
end' -> String -> Doc
text String
"..>" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
end'
          ToInclusive ExpBase f vn
end' -> String -> Doc
text String
"..." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
end'
          UpToExclusive ExpBase f vn
end' -> String -> Doc
text String
"..<" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
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
<+> ExpBase f vn -> 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 (ExpBase f vn -> Doc
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 (ExpBase f vn -> Doc
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 ExpBase f vn
f Doc -> Doc -> Doc
<+/> Int -> ExpBase f vn -> 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 = Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec (-Int
1)
  pprPrec :: Int -> ExpBase f vn -> Doc
pprPrec Int
_ (Var QualName vn
name f PatternType
t SrcLoc
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
inst
    where
      inst :: Doc
inst = case f PatternType -> Maybe PatternType
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatternType
t of
        Just PatternType
t'
          | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
2 ->
            String -> Doc
text String
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PatternType -> Doc
forall a. Pretty a => a -> Doc
ppr PatternType
t')
        Maybe PatternType
_ -> Doc
forall a. Monoid a => a
mempty
  pprPrec Int
_ (Parens ExpBase f vn
e SrcLoc
_) = Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  pprPrec Int
_ (QualParens (QualName vn
v, SrcLoc
_) ExpBase f vn
e SrcLoc
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
align (Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e)
  pprPrec Int
p (Ascript ExpBase f vn
e TypeDeclBase f vn
t SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> ExpBase f vn -> Doc
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 (Int -> TypeDeclBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0 TypeDeclBase f vn
t)
  pprPrec Int
_ (Literal PrimValue
v SrcLoc
_) = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v
  pprPrec Int
_ (IntLit Integer
v f PatternType
_ SrcLoc
_) = Integer -> Doc
forall a. Pretty a => a -> Doc
ppr Integer
v
  pprPrec Int
_ (FloatLit Double
v f PatternType
_ SrcLoc
_) = Double -> Doc
forall a. Pretty a => a -> Doc
ppr Double
v
  pprPrec Int
_ (TupLit [ExpBase f vn]
es SrcLoc
_)
    | (ExpBase f vn -> Bool) -> [ExpBase f vn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExpBase f vn -> Bool
forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit [ExpBase f vn]
es = Doc -> Doc
parens (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
$ (ExpBase f vn -> Doc) -> [ExpBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es
    | Bool
otherwise = Doc -> Doc
parens (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
$ (ExpBase f vn -> Doc) -> [ExpBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es
  pprPrec Int
_ (RecordLit [FieldBase f vn]
fs SrcLoc
_)
    | (FieldBase f vn -> Bool) -> [FieldBase f vn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FieldBase f vn -> Bool
forall {ty :: * -> *} {vn}. FieldBase ty vn -> Bool
fieldArray [FieldBase f vn]
fs = Doc -> Doc
braces (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
$ (FieldBase f vn -> Doc) -> [FieldBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FieldBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [FieldBase f vn]
fs
    | Bool
otherwise = 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
$ (FieldBase f vn -> Doc) -> [FieldBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FieldBase f vn -> Doc
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
_) = ExpBase ty vn -> Bool
forall (ty :: * -> *) vn. ExpBase ty vn -> Bool
hasArrayLit ExpBase ty vn
e
      fieldArray RecordFieldImplicit {} = Bool
False
  pprPrec Int
_ (ArrayLit [ExpBase f vn]
es f PatternType
info SrcLoc
_) =
    Doc -> Doc
brackets ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ExpBase f vn -> Doc) -> [ExpBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
es) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
info'
    where
      info' :: Doc
info' = case f PatternType -> Maybe PatternType
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatternType
info of
        Just PatternType
t
          | String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
2 ->
            String -> Doc
text String
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PatternType -> Doc
forall a. Pretty a => a -> Doc
ppr PatternType
t)
        Maybe PatternType
_ -> Doc
forall a. Monoid a => a
mempty
  pprPrec Int
_ (StringLit [Word8]
s SrcLoc
_) =
    String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Word8] -> String
decode [Word8]
s
  pprPrec Int
_ (Project Name
k ExpBase f vn
e f PatternType
_ SrcLoc
_) = ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
k
  pprPrec Int
_ (Negate ExpBase f vn
e SrcLoc
_) = String -> Doc
text String
"-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  pprPrec Int
_ (Update ExpBase f vn
src [DimIndexBase f vn]
idxs ExpBase f vn
ve SrcLoc
_) =
    ExpBase f vn -> Doc
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 ((DimIndexBase f vn -> Doc) -> [DimIndexBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndexBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [DimIndexBase f vn]
idxs))
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase f vn -> Doc
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 PatternType
_ SrcLoc
_) =
    ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
src Doc -> Doc -> Doc
<+> String -> Doc
text String
"with"
      Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
".") ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
ppr [Name]
fs))
      Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
      Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase f vn -> Doc
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
<+> Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
10 ExpBase f vn
e1 Doc -> Doc -> Doc
<+> Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
10 ExpBase f vn
e2
  pprPrec Int
p (Lambda [PatternBase f vn]
params ExpBase f vn
body Maybe (TypeExp vn)
rettype f (Aliasing, StructType)
_ SrcLoc
_) =
    Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      String -> Doc
text String
"\\" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
spread ((PatternBase f vn -> Doc) -> [PatternBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [PatternBase f vn]
params) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Maybe (TypeExp vn) -> Doc
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 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body)
  pprPrec Int
_ (OpSection QualName vn
binop f PatternType
_ SrcLoc
_) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
binop
  pprPrec Int
_ (OpSectionLeft QualName vn
binop f PatternType
_ ExpBase f vn
x (f (PName, StructType, Maybe VName), f (PName, StructType))
_ (f PatternType, f [VName])
_ SrcLoc
_) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
x Doc -> Doc -> Doc
<+> QualName vn -> Doc
forall vn. IsName vn => QualName vn -> Doc
ppBinOp QualName vn
binop
  pprPrec Int
_ (OpSectionRight QualName vn
binop f PatternType
_ ExpBase f vn
x (f (PName, StructType), f (PName, StructType, Maybe VName))
_ f PatternType
_ SrcLoc
_) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QualName vn -> Doc
forall vn. IsName vn => QualName vn -> Doc
ppBinOp QualName vn
binop Doc -> Doc -> Doc
<+> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
x
  pprPrec Int
_ (ProjectSection [Name]
fields f PatternType
_ SrcLoc
_) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
p [Name]
fields
    where
      p :: a -> Doc
p a
name = String -> Doc
text String
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
name
  pprPrec Int
_ (IndexSection [DimIndexBase f vn]
idxs f PatternType
_ SrcLoc
_) =
    Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets ([Doc] -> Doc
commasep ((DimIndexBase f vn -> Doc) -> [DimIndexBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DimIndexBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [DimIndexBase f vn]
idxs))
  pprPrec Int
_ (Constr Name
n [ExpBase f vn]
cs f PatternType
_ SrcLoc
_) = String -> Doc
text String
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((ExpBase f vn -> Doc) -> [ExpBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [ExpBase f vn]
cs)
  pprPrec Int
_ (Attr AttrInfo
attr ExpBase f vn
e SrcLoc
_) =
    String -> Doc
text String
"#[" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> AttrInfo -> Doc
forall a. Pretty a => a -> Doc
ppr AttrInfo
attr Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"]" Doc -> Doc -> Doc
</> Int -> ExpBase f vn -> 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
_) = Int -> AppExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
i AppExpBase f vn
e

instance Pretty AttrInfo where
  ppr :: AttrInfo -> Doc
ppr (AttrAtom Name
attr) = Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
attr
  ppr (AttrComp Name
f [AttrInfo]
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
$ (AttrInfo -> Doc) -> [AttrInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map AttrInfo -> Doc
forall a. Pretty a => a -> Doc
ppr [AttrInfo]
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
_) = Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
equals Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
e
  ppr (RecordFieldImplicit vn
name f PatternType
_ SrcLoc
_) = vn -> Doc
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 PatternBase f vn
p ExpBase f vn
e SrcLoc
_) = String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
p Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (ExpBase f vn -> Doc
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
<+> IdentBase f vn -> 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 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
ubound)
  ppr (ForIn PatternBase f vn
x ExpBase f vn
e) =
    String -> Doc
text String
"for" Doc -> Doc -> Doc
<+> PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> ExpBase f vn -> 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
<+> ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
cond

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

instance (Eq vn, IsName vn, Annot f) => Pretty (PatternBase f vn) where
  ppr :: PatternBase f vn -> Doc
ppr (PatternAscription PatternBase f vn
p TypeDeclBase f vn
t SrcLoc
_) = PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (TypeDeclBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeDeclBase f vn
t)
  ppr (PatternParens PatternBase f vn
p SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr PatternBase f vn
p
  ppr (Id vn
v f PatternType
t SrcLoc
_) = case f PatternType -> Maybe PatternType
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatternType
t of
    Just PatternType
t' -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (PatternType -> Doc
forall a. Pretty a => a -> Doc
ppr PatternType
t')
    Maybe PatternType
Nothing -> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
v
  ppr (TuplePattern [PatternBase f vn]
pats SrcLoc
_) = Doc -> Doc
parens (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
$ (PatternBase f vn -> Doc) -> [PatternBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [PatternBase f vn]
pats
  ppr (RecordPattern [(Name, PatternBase f vn)]
fs SrcLoc
_) = 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
$ ((Name, PatternBase f vn) -> Doc)
-> [(Name, PatternBase f vn)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PatternBase f vn) -> Doc
forall {a}. Pretty a => (Name, a) -> Doc
ppField [(Name, PatternBase f vn)]
fs
    where
      ppField :: (Name, a) -> Doc
ppField (Name
name, a
t) = String -> Doc
text (Name -> String
nameToString Name
name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
equals Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
t
  ppr (Wildcard f PatternType
t SrcLoc
_) = case f PatternType -> Maybe PatternType
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f PatternType
t of
    Just PatternType
t' -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> PatternType -> Doc
forall a. Pretty a => a -> Doc
ppr PatternType
t'
    Maybe PatternType
Nothing -> String -> Doc
text String
"_"
  ppr (PatternLit PatLit
e f PatternType
_ SrcLoc
_) = PatLit -> Doc
forall a. Pretty a => a -> Doc
ppr PatLit
e
  ppr (PatternConstr Name
n f PatternType
_ [PatternBase f vn]
ps SrcLoc
_) = String -> Doc
text String
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((PatternBase f vn -> Doc) -> [PatternBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [PatternBase f vn]
ps)

ppAscription :: Pretty t => Maybe t -> Doc
ppAscription :: forall t. Pretty t => Maybe t -> Doc
ppAscription Maybe t
Nothing = Doc
forall a. Monoid a => a
mempty
ppAscription (Just t
t) = Doc
colon Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
align (t -> Doc
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 ([Doc] -> Doc) -> (ProgBase f vn -> [Doc]) -> ProgBase f vn -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
line ([Doc] -> [Doc])
-> (ProgBase f vn -> [Doc]) -> ProgBase f vn -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecBase f vn -> Doc) -> [DecBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DecBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ([DecBase f vn] -> [Doc])
-> (ProgBase f vn -> [DecBase f vn]) -> ProgBase f vn -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgBase f vn -> [DecBase f vn]
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) = ValBindBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ValBindBase f vn
dec
  ppr (TypeDec TypeBindBase f vn
dec) = TypeBindBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeBindBase f vn
dec
  ppr (SigDec SigBindBase f vn
sig) = SigBindBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr SigBindBase f vn
sig
  ppr (ModDec ModBindBase f vn
sd) = ModBindBase f vn -> Doc
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
<+> ModExpBase f vn -> 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
<+> DecBase f vn -> 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
<+> String -> 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
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (ModParens ModExpBase f vn
e SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ModExpBase f vn -> Doc
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
<+> String -> Doc
forall a. Pretty a => a -> Doc
ppr (String -> String
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 ([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
$ (DecBase f vn -> Doc) -> [DecBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DecBase f vn -> Doc
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 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ModExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
f Doc -> Doc -> Doc
<+> Doc -> Doc
parens (ModExpBase f vn -> Doc
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
_) = ModExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ModExpBase f vn
me Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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
"\\" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ModParamBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ModParamBase f vn
param Doc -> Doc -> Doc
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 (ModExpBase f vn -> Doc
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 -> Doc
forall a. Monoid a => a
mempty
        Just (SigExpBase f vn
sig, f (Map VName VName)
_) -> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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 TypeDeclBase f vn
usertype Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"type" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Doc
forall a. Pretty a => a -> Doc
ppr Liftedness
l Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name
      Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
params)
      Doc -> Doc -> Doc
<+> Doc
equals
      Doc -> Doc -> Doc
<+> TypeDeclBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeDeclBase f vn
usertype

instance (Eq vn, IsName vn) => Pretty (TypeParamBase vn) where
  ppr :: TypeParamBase vn -> Doc
ppr (TypeParamDim vn
name SrcLoc
_) = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name
  ppr (TypeParamType Liftedness
l vn
name SrcLoc
_) = String -> Doc
text String
"'" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Doc
forall a. Pretty a => a -> Doc
ppr Liftedness
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> vn -> Doc
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 (StructType, [VName])
rettype [TypeParamBase vn]
tparams [PatternBase f vn]
args ExpBase f vn
body Maybe DocComment
_ [AttrInfo]
attrs SrcLoc
_) =
    [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((AttrInfo -> Doc) -> [AttrInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
line) (Doc -> Doc) -> (AttrInfo -> Doc) -> AttrInfo -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrInfo -> Doc
forall a. Pretty a => a -> Doc
ppr) [AttrInfo]
attrs)
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
fun
      Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name
      Doc -> Doc -> Doc
<+> Doc -> Doc
align ([Doc] -> Doc
sep ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (PatternBase f vn -> Doc) -> [PatternBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatternBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [PatternBase f vn]
args))
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
retdecl'
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" ="
      Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (ExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase f vn
body)
    where
      fun :: String
fun
        | Maybe (f EntryPoint) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (f EntryPoint)
entry = String
"entry"
        | Bool
otherwise = String
"let"
      retdecl' :: Doc
retdecl' = case (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr (StructType -> Doc)
-> ((StructType, [VName]) -> StructType)
-> (StructType, [VName])
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StructType, [VName]) -> StructType
forall a b. (a, b) -> a
fst ((StructType, [VName]) -> Doc)
-> Maybe (StructType, [VName]) -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (StructType, [VName]) -> Maybe (StructType, [VName])
forall (f :: * -> *) a. Annot f => f a -> Maybe a
unAnnot f (StructType, [VName])
rettype) Maybe Doc -> Maybe Doc -> Maybe Doc
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (TypeExp vn -> Doc
forall a. Pretty a => a -> Doc
ppr (TypeExp vn -> Doc) -> Maybe (TypeExp vn) -> Maybe Doc
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 -> Doc
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) = TypeBindBase f vn -> Doc
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" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Doc
forall a. Pretty a => a -> Doc
ppr Liftedness
l Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
ps)
  ppr (ValSpec vn
name [TypeParamBase vn]
tparams TypeDeclBase f vn
vtype Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"val" Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
tparams) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> TypeDeclBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeDeclBase f vn
vtype
  ppr (ModSpec vn
name SigExpBase f vn
sig Maybe DocComment
_ SrcLoc
_) =
    String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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
<+> SigExpBase f vn -> 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
_) = QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v
  ppr (SigParens SigExpBase f vn
e SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ SigExpBase f vn -> Doc
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 ([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
$ (SpecBase f vn -> Doc) -> [SpecBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SpecBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [SpecBase f vn]
ss)
  ppr (SigWith SigExpBase f vn
s (TypeRef QualName vn
v [TypeParamBase vn]
ps TypeDeclBase f vn
td SrcLoc
_) SrcLoc
_) =
    SigExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
s Doc -> Doc -> Doc
<+> String -> Doc
text String
"with" Doc -> Doc -> Doc
<+> QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
v Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((TypeParamBase vn -> Doc) -> [TypeParamBase vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Doc
forall a. Pretty a => a -> Doc
ppr [TypeParamBase vn]
ps) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" =" Doc -> Doc -> Doc
<+> TypeDeclBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr TypeDeclBase f vn
td
  ppr (SigArrow (Just vn
v) SigExpBase f vn
e1 SigExpBase f vn
e2 SrcLoc
_) =
    Doc -> Doc
parens (vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e1) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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
_) =
    SigExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
e1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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 (vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
pname Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> 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
<+> vn -> Doc
forall v. IsName v => v -> Doc
pprName vn
name Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((ModParamBase f vn -> Doc) -> [ModParamBase f vn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModParamBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr [ModParamBase f vn]
ps) Doc -> Doc -> Doc
<+> Doc
sig' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
" =" Doc -> Doc -> Doc
<+> ModExpBase f vn -> 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 -> Doc
forall a. Monoid a => a
mempty
        Just (SigExpBase f vn
s, f (Map VName VName)
_) -> Doc
colon Doc -> Doc -> Doc
<+> SigExpBase f vn -> Doc
forall a. Pretty a => a -> Doc
ppr SigExpBase f vn
s Doc -> Doc -> Doc
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
"`" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> QualName v -> Doc
forall a. Pretty a => a -> Doc
ppr QualName v
bop Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"`"
    BinOp
_ -> QualName v -> Doc
forall a. Pretty a => a -> Doc
ppr QualName v
bop
  where
    leading :: BinOp
leading =
      Name -> BinOp
leadingOperator (Name -> BinOp) -> Name -> BinOp
forall a b. (a -> b) -> a -> b
$ String -> Name
nameFromString (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ v -> Doc
forall v. IsName v => v -> Doc
pprName (v -> Doc) -> v -> Doc
forall a b. (a -> b) -> a -> b
$ QualName v -> v
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
symPrecedence) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Int -> ExpBase f vn -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
symPrecedence ExpBase f vn
x
      Doc -> Doc -> Doc
<+/> Doc
bop'
      Doc -> Doc -> Doc
<+> Int -> ExpBase f vn -> 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
"`" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
bop Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"`"
      BinOp
_ -> QualName vn -> Doc
forall a. Pretty a => a -> Doc
ppr QualName vn
bop
    leading :: BinOp
leading = Name -> BinOp
leadingOperator (Name -> BinOp) -> Name -> BinOp
forall a b. (a -> b) -> a -> b
$ String -> Name
nameFromString (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ vn -> Doc
forall v. IsName v => v -> Doc
pprName (vn -> Doc) -> vn -> Doc
forall a b. (a -> b) -> a -> b
$ QualName vn -> vn
forall vn. QualName vn -> vn
qualLeaf QualName vn
bop
    symPrecedence :: Int
symPrecedence = BinOp -> Int
forall {a}. Num a => BinOp -> a
precedence BinOp
leading
    symRPrecedence :: Int
symRPrecedence = BinOp -> Int
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 -> p
rprecedence BinOp
Minus = p
10
    rprecedence BinOp
Divide = p
10
    rprecedence BinOp
op = BinOp -> p
forall {a}. Num a => BinOp -> a
precedence BinOp
op