{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Pretty-printing for the Swarm language.
module Swarm.Language.Pretty where

import Control.Lens.Combinators (pattern Empty)
import Control.Monad.Free (Free (..))
import Data.Bool (bool)
import Data.Fix
import Data.Foldable qualified as F
import Data.List.NonEmpty ((<|))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Sequence qualified as Seq
import Data.Set (Set)
import Data.Set qualified as S
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as T
import Prettyprinter
import Prettyprinter.Render.String qualified as RS
import Prettyprinter.Render.Text qualified as RT
import Swarm.Effect.Unify (UnificationError (..))
import Swarm.Language.Capability
import Swarm.Language.Context
import Swarm.Language.Kindcheck (KindError (..))
import Swarm.Language.Parser.Util (getLocRange)
import Swarm.Language.Syntax
import Swarm.Language.Syntax.Direction
import Swarm.Language.Typecheck
import Swarm.Language.Types
import Swarm.Util (number, showEnum, showLowT, unsnocNE)
import Text.Show.Unicode (ushow)
import Witch

------------------------------------------------------------
-- PrettyPrec class + utilities

-- | Type class for things that can be pretty-printed, given a
--   precedence level of their context.
class PrettyPrec a where
  prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired

-- | Pretty-print a thing, with a context precedence level of zero.
ppr :: (PrettyPrec a) => a -> Doc ann
ppr :: forall a ann. PrettyPrec a => a -> Doc ann
ppr = Int -> a -> Doc ann
forall ann. Int -> a -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0

-- | Render a pretty-printed document as @Text@.
docToText :: Doc a -> Text
docToText :: forall a. Doc a -> Var
docToText = SimpleDocStream a -> Var
forall ann. SimpleDocStream ann -> Var
RT.renderStrict (SimpleDocStream a -> Var)
-> (Doc a -> SimpleDocStream a) -> Doc a -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Render a pretty-printed document as @Text@.
--   This function consumes number of allowed characters in a
--   line before introducing a line break. In other words, it
--   expects the space of the layouter to be supplied.
docToTextWidth :: Doc a -> Int -> Text
docToTextWidth :: forall a. Doc a -> Int -> Var
docToTextWidth Doc a
doc Int
layoutWidth =
  SimpleDocStream a -> Var
forall ann. SimpleDocStream ann -> Var
RT.renderStrict (SimpleDocStream a -> Var) -> SimpleDocStream a -> Var
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
layoutWidth Double
1.0)) Doc a
doc

-- | Pretty-print something and render it as @Text@.
prettyText :: (PrettyPrec a) => a -> Text
prettyText :: forall a. PrettyPrec a => a -> Var
prettyText = Doc Any -> Var
forall a. Doc a -> Var
docToText (Doc Any -> Var) -> (a -> Doc Any) -> a -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Pretty-print something and render it as @Text@.
--   This is different than @prettyText@ in the sense that it also
--   consumes number of allowed characters in a line before introducing
--   a line break.
prettyTextWidth :: (PrettyPrec a) => a -> Int -> Text
prettyTextWidth :: forall a. PrettyPrec a => a -> Int -> Var
prettyTextWidth = Doc Any -> Int -> Var
forall a. Doc a -> Int -> Var
docToTextWidth (Doc Any -> Int -> Var) -> (a -> Doc Any) -> a -> Int -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Pretty-print something and render it as (preferably) one line @Text@.
prettyTextLine :: (PrettyPrec a) => a -> Text
prettyTextLine :: forall a. PrettyPrec a => a -> Var
prettyTextLine = SimpleDocStream Any -> Var
forall ann. SimpleDocStream ann -> Var
RT.renderStrict (SimpleDocStream Any -> Var)
-> (a -> SimpleDocStream Any) -> a -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions PageWidth
Unbounded) (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann
group (Doc Any -> Doc Any) -> (a -> Doc Any) -> a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Render a pretty-printed document as a @String@.
docToString :: Doc a -> String
docToString :: forall a. Doc a -> String
docToString = SimpleDocStream a -> String
forall ann. SimpleDocStream ann -> String
RS.renderString (SimpleDocStream a -> String)
-> (Doc a -> SimpleDocStream a) -> Doc a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Pretty-print something and render it as a @String@.
prettyString :: (PrettyPrec a) => a -> String
prettyString :: forall a. PrettyPrec a => a -> String
prettyString = Doc Any -> String
forall a. Doc a -> String
docToString (Doc Any -> String) -> (a -> Doc Any) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Optionally surround a document with parentheses depending on the
--   @Bool@ argument and if it does not fit on line, indent the lines,
--   with the parens on separate lines.
pparens :: Bool -> Doc ann -> Doc ann
pparens :: forall ann. Bool -> Doc ann -> Doc ann
pparens Bool
True = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 Doc ann
forall ann. Doc ann
lparen Doc ann
forall ann. Doc ann
rparen
pparens Bool
False = Doc ann -> Doc ann
forall a. a -> a
id

-- | Same as pparens but does not indent the lines. Only encloses
--   the document with parantheses.
pparens' :: Bool -> Doc ann -> Doc ann
pparens' :: forall ann. Bool -> Doc ann -> Doc ann
pparens' Bool
True = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
forall ann. Doc ann
lparen Doc ann
forall ann. Doc ann
rparen
pparens' Bool
False = Doc ann -> Doc ann
forall a. a -> a
id

encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent :: forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
i Doc ann
l Doc ann
r = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
i (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line') (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest (-Int
2) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
forall ann. Doc ann
line' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
r)

-- | Surround a document with backticks.
bquote :: Doc ann -> Doc ann
bquote :: forall ann. Doc ann -> Doc ann
bquote = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"`" Doc ann
"`"

-- | Turn a 'Show' instance into a @Doc@, lowercasing it in the
--   process.
prettyShowLow :: Show a => a -> Doc ann
prettyShowLow :: forall a ann. Show a => a -> Doc ann
prettyShowLow = Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Var -> Doc ann) -> (a -> Var) -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Var
forall a. Show a => a -> Var
showLowT

-- | An invitation to report an error as a bug.
reportBug :: Doc ann
reportBug :: forall ann. Doc ann
reportBug = Doc ann
"This should never happen; please report this as a bug: https://github.com/swarm-game/swarm/issues/new"

--------------------------------------------------
-- Bullet lists

data Prec a = Prec Int a

data BulletList i = BulletList
  { forall i. BulletList i -> forall ann. Doc ann
bulletListHeader :: forall a. Doc a
  , forall i. BulletList i -> [i]
bulletListItems :: [i]
  }

instance (PrettyPrec i) => PrettyPrec (BulletList i) where
  prettyPrec :: forall ann. Int -> BulletList i -> Doc ann
prettyPrec Int
_ (BulletList forall ann. Doc ann
hdr [i]
items) =
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
forall ann. Doc ann
hdr Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (i -> Doc ann) -> [i] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
"-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (i -> Doc ann) -> i -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr) [i]
items

------------------------------------------------------------
-- PrettyPrec instances for terms, types, etc.

instance PrettyPrec Text where
  prettyPrec :: forall ann. Int -> Var -> Doc ann
prettyPrec Int
_ = Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance PrettyPrec BaseTy where
  prettyPrec :: forall ann. Int -> BaseTy -> Doc ann
prettyPrec Int
_ = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (BaseTy -> String) -> BaseTy -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (BaseTy -> String) -> BaseTy -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseTy -> String
forall a. Show a => a -> String
show

instance PrettyPrec IntVar where
  prettyPrec :: forall ann. Int -> IntVar -> Doc ann
prettyPrec Int
_ = Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Var -> Doc ann) -> (IntVar -> Var) -> IntVar -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> IntVar -> Var
mkVarName Var
"u"

-- | We can use the 'Wildcard' value to replace unification variables
--   when we don't care about them, e.g. to print out the shape of a
--   type like @(_ -> _) * _@
data Wildcard = Wildcard
  deriving (Wildcard -> Wildcard -> Bool
(Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool) -> Eq Wildcard
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Wildcard -> Wildcard -> Bool
== :: Wildcard -> Wildcard -> Bool
$c/= :: Wildcard -> Wildcard -> Bool
/= :: Wildcard -> Wildcard -> Bool
Eq, Eq Wildcard
Eq Wildcard =>
(Wildcard -> Wildcard -> Ordering)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Wildcard)
-> (Wildcard -> Wildcard -> Wildcard)
-> Ord Wildcard
Wildcard -> Wildcard -> Bool
Wildcard -> Wildcard -> Ordering
Wildcard -> Wildcard -> Wildcard
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Wildcard -> Wildcard -> Ordering
compare :: Wildcard -> Wildcard -> Ordering
$c< :: Wildcard -> Wildcard -> Bool
< :: Wildcard -> Wildcard -> Bool
$c<= :: Wildcard -> Wildcard -> Bool
<= :: Wildcard -> Wildcard -> Bool
$c> :: Wildcard -> Wildcard -> Bool
> :: Wildcard -> Wildcard -> Bool
$c>= :: Wildcard -> Wildcard -> Bool
>= :: Wildcard -> Wildcard -> Bool
$cmax :: Wildcard -> Wildcard -> Wildcard
max :: Wildcard -> Wildcard -> Wildcard
$cmin :: Wildcard -> Wildcard -> Wildcard
min :: Wildcard -> Wildcard -> Wildcard
Ord, Int -> Wildcard -> String -> String
[Wildcard] -> String -> String
Wildcard -> String
(Int -> Wildcard -> String -> String)
-> (Wildcard -> String)
-> ([Wildcard] -> String -> String)
-> Show Wildcard
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Wildcard -> String -> String
showsPrec :: Int -> Wildcard -> String -> String
$cshow :: Wildcard -> String
show :: Wildcard -> String
$cshowList :: [Wildcard] -> String -> String
showList :: [Wildcard] -> String -> String
Show)

instance PrettyPrec Wildcard where
  prettyPrec :: forall ann. Int -> Wildcard -> Doc ann
prettyPrec Int
_ Wildcard
_ = Doc ann
"_"

instance PrettyPrec TyCon where
  prettyPrec :: forall ann. Int -> TyCon -> Doc ann
prettyPrec Int
_ = \case
    TCBase BaseTy
b -> BaseTy -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr BaseTy
b
    TyCon
TCCmd -> Doc ann
"Cmd"
    TyCon
TCDelay -> Doc ann
"Delay"
    TyCon
TCSum -> Doc ann
"Sum"
    TyCon
TCProd -> Doc ann
"Prod"
    TyCon
TCFun -> Doc ann
"Fun"
    TCUser Var
t -> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
t

-- | Split a function type chain, so that we can pretty print
--   the type parameters aligned on each line when they don't fit.
class UnchainableFun t where
  unchainFun :: t -> NE.NonEmpty t

instance UnchainableFun Type where
  unchainFun :: Type -> NonEmpty Type
unchainFun (Type
a :->: Type
ty) = Type
a Type -> NonEmpty Type -> NonEmpty Type
forall a. a -> NonEmpty a -> NonEmpty a
<| Type -> NonEmpty Type
forall t. UnchainableFun t => t -> NonEmpty t
unchainFun Type
ty
  unchainFun Type
ty = Type -> NonEmpty Type
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty

instance UnchainableFun (Free TypeF ty) where
  unchainFun :: Free TypeF ty -> NonEmpty (Free TypeF ty)
unchainFun (Free (TyConF TyCon
TCFun [Free TypeF ty
ty1, Free TypeF ty
ty2])) = Free TypeF ty
ty1 Free TypeF ty
-> NonEmpty (Free TypeF ty) -> NonEmpty (Free TypeF ty)
forall a. a -> NonEmpty a -> NonEmpty a
<| Free TypeF ty -> NonEmpty (Free TypeF ty)
forall t. UnchainableFun t => t -> NonEmpty t
unchainFun Free TypeF ty
ty2
  unchainFun Free TypeF ty
ty = Free TypeF ty -> NonEmpty (Free TypeF ty)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Free TypeF ty
ty

instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where
  prettyPrec :: forall ann. Int -> Fix t -> Doc ann
prettyPrec Int
p = Int -> t (Fix t) -> Doc ann
forall ann. Int -> t (Fix t) -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p (t (Fix t) -> Doc ann) -> (Fix t -> t (Fix t)) -> Fix t -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix t -> t (Fix t)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance (PrettyPrec (t (Free t v)), PrettyPrec v) => PrettyPrec (Free t v) where
  prettyPrec :: forall ann. Int -> Free t v -> Doc ann
prettyPrec Int
p (Free t (Free t v)
t) = Int -> t (Free t v) -> Doc ann
forall ann. Int -> t (Free t v) -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p t (Free t v)
t
  prettyPrec Int
p (Pure v
v) = Int -> v -> Doc ann
forall ann. Int -> v -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p v
v

instance (UnchainableFun t, PrettyPrec t, SubstRec t) => PrettyPrec (TypeF t) where
  prettyPrec :: forall ann. Int -> TypeF t -> Doc ann
prettyPrec Int
p = \case
    TyVarF Var
v -> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
v
    TyRcdF Map Var t
m -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((Var, t) -> Doc ann) -> [(Var, t)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Var, t) -> Doc ann
forall a b ann. (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding (Map Var t -> [(Var, t)]
forall k a. Map k a -> [(k, a)]
M.assocs Map Var t
m)))
    -- Special cases for type constructors with special syntax.
    -- Always use parentheses around sum and product types, see #1625
    TyConF TyCon
TCSum [t
ty1, t
ty2] ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"+" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty2
    TyConF TyCon
TCProd [t
ty1, t
ty2] ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"*" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty2
    TyConF TyCon
TCDelay [t
ty] -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ t -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr t
ty
    TyConF TyCon
TCFun [t
ty1, t
ty2] ->
      let ([t]
iniF, t
lastF) = NonEmpty t -> ([t], t)
forall a. NonEmpty a -> ([a], a)
unsnocNE (NonEmpty t -> ([t], t)) -> NonEmpty t -> ([t], t)
forall a b. (a -> b) -> a -> b
$ t
ty1 t -> NonEmpty t -> NonEmpty t
forall a. a -> NonEmpty a -> NonEmpty a
<| t -> NonEmpty t
forall t. UnchainableFun t => t -> NonEmpty t
unchainFun t
ty2
          funs :: [Doc ann]
funs = (Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 (t -> Doc ann) -> [t] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t]
iniF) [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 t
lastF]
          inLine :: Doc ann -> Doc ann -> Doc ann
inLine Doc ann
l Doc ann
r = Doc ann
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
r
          multiLine :: Doc ann -> Doc ann -> Doc ann
multiLine Doc ann
l Doc ann
r = Doc ann
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
r
       in Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens' (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt ((Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
multiLine [Doc ann]
forall {ann}. [Doc ann]
funs) ((Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
inLine [Doc ann]
forall {ann}. [Doc ann]
funs)
    TyRecF Var
x t
ty ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"rec" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 (TypeF t -> t -> Nat -> t
forall t. SubstRec t => TypeF t -> t -> Nat -> t
substRec (Var -> TypeF t
forall t. Var -> TypeF t
TyVarF Var
x) t
ty Nat
NZ)
    -- This case shouldn't be possible, since TyRecVar should only occur inside a TyRec,
    -- and pretty-printing the TyRec (above) will substitute a variable name for
    -- any bound TyRecVars before recursing.
    TyRecVarF Nat
i -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> String
forall a. Show a => a -> String
show (Nat -> Int
natToInt Nat
i))
    -- Fallthrough cases for type constructor application.  Handles base
    -- types, Cmd, user-defined types, or ill-kinded things like 'Int
    -- Bool'.
    TyConF TyCon
c [] -> TyCon -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TyCon
c
    TyConF TyCon
c [t]
tys -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ TyCon -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TyCon
c Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((t -> Doc ann) -> [t] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> t -> Doc ann
forall ann. Int -> t -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
10) [t]
tys)

instance PrettyPrec Polytype where
  prettyPrec :: forall ann. Int -> Polytype -> Doc ann
prettyPrec Int
_ (Forall [] Type
t) = Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Type
t
  prettyPrec Int
_ (Forall [Var]
xs Type
t) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"∀" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Var -> Doc ann) -> [Var] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Var]
xs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Type
t

instance PrettyPrec UPolytype where
  prettyPrec :: forall ann. Int -> UPolytype -> Doc ann
prettyPrec Int
_ (Forall [] UType
t) = UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
t
  prettyPrec Int
_ (Forall [Var]
xs UType
t) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"∀" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Var -> Doc ann) -> [Var] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Var]
xs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
t

instance (PrettyPrec t) => PrettyPrec (Ctx t) where
  prettyPrec :: forall ann. Int -> Ctx t -> Doc ann
prettyPrec Int
_ Ctx t
Empty = Doc ann
forall ann. Doc ann
emptyDoc
  prettyPrec Int
_ (Ctx t -> [(Var, t)]
forall t. Ctx t -> [(Var, t)]
assocs -> [(Var, t)]
bs) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((Var, t) -> Doc ann) -> [(Var, t)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Var, t) -> Doc ann
forall a b ann. (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding [(Var, t)]
bs)))

prettyBinding :: (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding :: forall a b ann. (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding (a
x, b
ty) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> b -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr b
ty

instance PrettyPrec Direction where
  prettyPrec :: forall ann. Int -> Direction -> Doc ann
prettyPrec Int
_ = Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Var -> Doc ann) -> (Direction -> Var) -> Direction -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Var
directionSyntax

instance PrettyPrec Capability where
  prettyPrec :: forall ann. Int -> Capability -> Doc ann
prettyPrec Int
_ Capability
c = Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Var -> Doc ann) -> Var -> Doc ann
forall a b. (a -> b) -> a -> b
$ Var -> Var
T.toLower (String -> Var
forall source target. From source target => source -> target
from (NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NE.tail (NonEmpty Char -> String) -> NonEmpty Char -> String
forall a b. (a -> b) -> a -> b
$ Capability -> NonEmpty Char
forall e. (Show e, Enum e) => e -> NonEmpty Char
showEnum Capability
c))

instance PrettyPrec Const where
  prettyPrec :: forall ann. Int -> Const -> Doc ann
prettyPrec Int
p Const
c = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ConstInfo -> Int
fixity (Const -> ConstInfo
constInfo Const
c)) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Var -> Doc ann) -> (Const -> Var) -> Const -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> Var
syntax (ConstInfo -> Var) -> (Const -> ConstInfo) -> Const -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> ConstInfo
constInfo (Const -> Doc ann) -> Const -> Doc ann
forall a b. (a -> b) -> a -> b
$ Const
c

-- | Pretty-print a syntax node with comments.
instance PrettyPrec (Syntax' ty) where
  prettyPrec :: forall ann. Int -> Syntax' ty -> Doc ann
prettyPrec Int
p (Syntax' SrcLoc
_ Term' ty
t (Comments Seq Comment
before Seq Comment
after) ty
_) = case Seq Comment
before of
    Seq Comment
Empty -> Doc ann
forall ann. Doc ann
t'
    Seq Comment
_ ->
      -- Print out any comments before the node, with a blank line before
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
forall ann. Doc ann
hardline
        , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((Comment -> Doc ann) -> [Comment] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Seq Comment -> [Comment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Comment
before))
        , Doc ann
forall ann. Doc ann
hardline
        , Doc ann
forall ann. Doc ann
t'
        ]
   where
    -- Print the node itself, possibly with suffix comments on the same line
    t' :: Doc ann
t' = case Seq Comment -> ViewR Comment
forall a. Seq a -> ViewR a
Seq.viewr Seq Comment
after of
      ViewR Comment
Seq.EmptyR -> Int -> Term' ty -> Doc ann
forall ann. Int -> Term' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Term' ty
t
      Seq Comment
_ Seq.:> Comment
lst -> case Comment -> CommentType
commentType Comment
lst of
        -- Output a newline after a line comment, but not after a block comment
        CommentType
BlockComment -> Doc ann
forall ann. Doc ann
tWithComments
        CommentType
LineComment -> Doc ann
forall ann. Doc ann
tWithComments Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
     where
      -- The pretty-printed node with suffix comments
      tWithComments :: Doc ann
tWithComments = Int -> Term' ty -> Doc ann
forall ann. Int -> Term' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Term' ty
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Comment -> Doc ann) -> [Comment] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Seq Comment -> [Comment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Comment
after))

instance PrettyPrec Comment where
  prettyPrec :: forall ann. Int -> Comment -> Doc ann
prettyPrec Int
_ (Comment SrcLoc
_ CommentType
LineComment CommentSituation
_ Var
txt) = Doc ann
"//" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
txt
  prettyPrec Int
_ (Comment SrcLoc
_ CommentType
BlockComment CommentSituation
_ Var
txt) = Doc ann
"/*" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
txt Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"*/"

instance PrettyPrec (Term' ty) where
  prettyPrec :: forall ann. Int -> Term' ty -> Doc ann
prettyPrec Int
p = \case
    Term' ty
TUnit -> Doc ann
"()"
    TConst Const
c -> Int -> Const -> Doc ann
forall ann. Int -> Const -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Const
c
    TDir Direction
d -> Direction -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Direction
d
    TInt Integer
n -> Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
    TAntiInt Var
v -> Doc ann
"$int:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
v
    TText Var
s -> String -> Doc ann
forall a. IsString a => String -> a
fromString (Var -> String
forall a. Show a => a -> String
ushow Var
s)
    TAntiText Var
v -> Doc ann
"$str:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
v
    TBool Bool
b -> Doc ann -> Doc ann -> Bool -> Doc ann
forall a. a -> a -> Bool -> a
bool Doc ann
"false" Doc ann
"true" Bool
b
    TRobot Int
r -> Doc ann
"<a" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
r Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
">"
    TRef Int
r -> Doc ann
"@" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
r
    TRequireDevice Var
d -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"require" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr @Term (Var -> Term
forall ty. Var -> Term' ty
TText Var
d)
    TRequire Int
n Var
e -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"require" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr @Term (Var -> Term
forall ty. Var -> Term' ty
TText Var
e)
    SRequirements Var
_ Syntax' ty
e -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"requirements" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
e
    TVar Var
s -> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
s
    SDelay (Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_) -> Doc ann
"{}"
    SDelay Syntax' ty
t -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 Doc ann
forall ann. Doc ann
lbrace Doc ann
forall ann. Doc ann
rbrace (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t
    t :: Term' ty
t@SPair {} -> Term' ty -> Doc ann
forall ty a. Term' ty -> Doc a
prettyTuple Term' ty
t
    t :: Term' ty
t@SLam {} ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Term' ty -> Doc ann
forall ty a. Term' ty -> Doc a
prettyLambdas Term' ty
t
    -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3
    SApp t :: Syntax' ty
t@(Syntax' SrcLoc
_ (SApp (Syntax' SrcLoc
_ (TConst Const
c) Comments
_ ty
_) Syntax' ty
l) Comments
_ ty
_) Syntax' ty
r ->
      let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
          pC :: Int
pC = ConstInfo -> Int
fixity ConstInfo
ci
       in case ConstInfo -> ConstMeta
constMeta ConstInfo
ci of
            ConstMBinOp MBinAssoc
assoc ->
              Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
                [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
                  [ Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc MBinAssoc -> MBinAssoc -> Bool
forall a. Eq a => a -> a -> Bool
== MBinAssoc
R)) Syntax' ty
l
                  , Const -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Const
c
                  , Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc MBinAssoc -> MBinAssoc -> Bool
forall a. Eq a => a -> a -> Bool
== MBinAssoc
L)) Syntax' ty
r
                  ]
            ConstMeta
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t Syntax' ty
r
    SApp Syntax' ty
t1 Syntax' ty
t2 -> case Syntax' ty
t1 of
      Syntax' SrcLoc
_ (TConst Const
c) Comments
_ ty
_ ->
        let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
            pC :: Int
pC = ConstInfo -> Int
fixity ConstInfo
ci
         in case ConstInfo -> ConstMeta
constMeta ConstInfo
ci of
              ConstMUnOp MUnAssoc
P -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int -> Int
forall a. Enum a => a -> a
succ Int
pC) Syntax' ty
t2
              ConstMUnOp MUnAssoc
S -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int -> Int
forall a. Enum a => a -> a
succ Int
pC) Syntax' ty
t2 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1
              ConstMeta
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2
      Syntax' ty
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2
    SLet LetSyntax
LSLet Bool
_ (LV SrcLoc
_ Var
x) Maybe Polytype
mty Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep
        [ Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
forall ann ty.
Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
"let" Var
x Maybe Polytype
mty Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in"
        , Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t2
        ]
    SLet LetSyntax
LSDef Bool
_ (LV SrcLoc
_ Var
x) Maybe Polytype
mty Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
forall ann ty.
Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
"def" Var
x Maybe Polytype
mty Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end"
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: case Syntax' ty
t2 of
            Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_ -> []
            Syntax' ty
_ -> [Doc ann
forall ann. Doc ann
hardline, Doc ann
forall ann. Doc ann
hardline, Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t2]
    STydef (LV SrcLoc
_ Var
x) Polytype
pty Maybe TydefInfo
_ Syntax' ty
t1 ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Var -> Polytype -> Doc ann
forall ann. Var -> Polytype -> Doc ann
prettyTydef Var
x Polytype
pty
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: case Syntax' ty
t1 of
            Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_ -> []
            Syntax' ty
_ -> [Doc ann
forall ann. Doc ann
hardline, Doc ann
forall ann. Doc ann
hardline, Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1]
    SBind Maybe LocVar
Nothing Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Syntax' ty
t2
    SBind (Just (LV SrcLoc
_ Var
x)) Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Syntax' ty
t2
    SRcd Map Var (Maybe (Syntax' ty))
m -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((Var, Maybe (Syntax' ty)) -> Doc ann)
-> [(Var, Maybe (Syntax' ty))] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Maybe (Syntax' ty)) -> Doc ann
forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyEquality (Map Var (Maybe (Syntax' ty)) -> [(Var, Maybe (Syntax' ty))]
forall k a. Map k a -> [(k, a)]
M.assocs Map Var (Maybe (Syntax' ty))
m)))
    SProj Syntax' ty
t Var
x -> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x
    SAnnotate Syntax' ty
t Polytype
pt ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Polytype -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
pt
    SSuspend Syntax' ty
t ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"suspend" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t

prettyEquality :: (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyEquality :: forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyEquality (a
x, Maybe b
Nothing) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x
prettyEquality (a
x, Just b
t) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> b -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr b
t

prettyDefinition :: Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
prettyDefinition :: forall ann ty.
Doc ann -> Var -> Maybe Polytype -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
defName Var
x Maybe Polytype
mty Syntax' ty
t1 =
  Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
    [ Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt
        (Doc ann
defHead Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group Doc ann
forall ann. Doc ann
defType Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
eqAndLambdaLine)
        (Doc ann
defHead Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group Doc ann
forall ann. Doc ann
defType' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
defEqLambdas)
    , Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
defBody
    ]
 where
  (Syntax' ty
defBody, [(Var, Maybe Type)]
defLambdaList) = Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas Syntax' ty
t1
  defHead :: Doc ann
defHead = Doc ann
defName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x
  defType :: Doc ann
defType = Doc ann -> (Polytype -> Doc ann) -> Maybe Polytype -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" (\Polytype
ty -> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Polytype -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
ty)) (Polytype -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
ty)) Maybe Polytype
mty
  defType' :: Doc ann
defType' = Doc ann -> (Polytype -> Doc ann) -> Maybe Polytype -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" (\Polytype
ty -> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Polytype -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
ty) Maybe Polytype
mty
  defEqLambdas :: Doc ann
defEqLambdas = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"=" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((Var, Maybe Type) -> Doc ann) -> [(Var, Maybe Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Maybe Type) -> Doc ann
forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyLambda [(Var, Maybe Type)]
defLambdaList)
  eqAndLambdaLine :: Doc ann
eqAndLambdaLine = if [(Var, Maybe Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, Maybe Type)]
defLambdaList then Doc ann
"=" else Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
defEqLambdas

prettyTydef :: Var -> Polytype -> Doc ann
prettyTydef :: forall ann. Var -> Polytype -> Doc ann
prettyTydef Var
x (Forall [] Type
ty) = Doc ann
"tydef" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end"
prettyTydef Var
x (Forall [Var]
xs Type
ty) = Doc ann
"tydef" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Var -> Doc ann) -> [Var] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Var]
xs) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end"

prettyPrecApp :: Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp :: forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2 =
  Bool -> Doc a -> Doc a
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$
    Int -> Syntax' ty -> Doc a
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
10 Syntax' ty
t1 Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Syntax' ty -> Doc a
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t2

appliedTermPrec :: Term -> Int
appliedTermPrec :: Term -> Int
appliedTermPrec (TApp Term
f Term
_) = case Term
f of
  TConst Const
c -> ConstInfo -> Int
fixity (ConstInfo -> Int) -> ConstInfo -> Int
forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
constInfo Const
c
  Term
_ -> Term -> Int
appliedTermPrec Term
f
appliedTermPrec Term
_ = Int
10

prettyTuple :: Term' ty -> Doc a
prettyTuple :: forall ty a. Term' ty -> Doc a
prettyTuple = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
tupled ([Doc a] -> Doc a) -> (Term' ty -> [Doc a]) -> Term' ty -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Syntax' () -> Doc a) -> [Syntax' ()] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Syntax' () -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr ([Syntax' ()] -> [Doc a])
-> (Term' ty -> [Syntax' ()]) -> Term' ty -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syntax' () -> [Syntax' ()]
forall ty. Syntax' ty -> [Syntax' ty]
unTuple (Syntax' () -> [Syntax' ()])
-> (Term' ty -> Syntax' ()) -> Term' ty -> [Syntax' ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Syntax' ()
STerm (Term -> Syntax' ())
-> (Term' ty -> Term) -> Term' ty -> Syntax' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' ty -> Term
forall (t :: * -> *) ty. Functor t => t ty -> t ()
erase

prettyLambdas :: Term' ty -> Doc a
prettyLambdas :: forall ty a. Term' ty -> Doc a
prettyLambdas Term' ty
t = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
hsep ((Var, Maybe Type) -> Doc a
forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyLambda ((Var, Maybe Type) -> Doc a) -> [(Var, Maybe Type)] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Maybe Type)]
lms) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
softline Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Syntax' () -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ()
rest
 where
  (Syntax' ()
rest, [(Var, Maybe Type)]
lms) = Syntax' () -> (Syntax' (), [(Var, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas (Term -> Syntax' ()
STerm (Term' ty -> Term
forall (t :: * -> *) ty. Functor t => t ty -> t ()
erase Term' ty
t))

unchainLambdas :: Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas :: forall ty. Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas = \case
  Syntax' SrcLoc
_ (SLam (LV SrcLoc
_ Var
x) Maybe Type
mty Syntax' ty
body) Comments
_ ty
_ -> ((Var
x, Maybe Type
mty) (Var, Maybe Type) -> [(Var, Maybe Type)] -> [(Var, Maybe Type)]
forall a. a -> [a] -> [a]
:) ([(Var, Maybe Type)] -> [(Var, Maybe Type)])
-> (Syntax' ty, [(Var, Maybe Type)])
-> (Syntax' ty, [(Var, Maybe Type)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas Syntax' ty
body
  Syntax' ty
body -> (Syntax' ty
body, [])

prettyLambda :: (Pretty a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann
prettyLambda :: forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyLambda (a1
x, Maybe a2
mty) = Doc ann
"\\" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a1 -> Doc ann
forall ann. a1 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a1
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> (a2 -> Doc ann) -> Maybe a2 -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" ((Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann) -> (a2 -> Doc ann) -> a2 -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a2 -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr) Maybe a2
mty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."

------------------------------------------------------------
-- Error messages

-- | Format a 'ContextualTypeError' for the user and render it as
--   @Text@.
prettyTypeErrText :: Text -> ContextualTypeErr -> Text
prettyTypeErrText :: Var -> ContextualTypeErr -> Var
prettyTypeErrText Var
code = Doc Any -> Var
forall a. Doc a -> Var
docToText (Doc Any -> Var)
-> (ContextualTypeErr -> Doc Any) -> ContextualTypeErr -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> ContextualTypeErr -> Doc Any
forall ann. Var -> ContextualTypeErr -> Doc ann
prettyTypeErr Var
code

-- | Format a 'ContextualTypeError' for the user.
prettyTypeErr :: Text -> ContextualTypeErr -> Doc ann
prettyTypeErr :: forall ann. Var -> ContextualTypeErr -> Doc ann
prettyTypeErr Var
code (CTE SrcLoc
l TCStack
tcStack TypeErr
te) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
    [ Doc ann
forall ann. Doc ann
teLoc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> TypeErr -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeErr
te
    , BulletList LocatedTCFrame -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr ((forall ann. Doc ann) -> TCStack -> BulletList LocatedTCFrame
forall i. (forall ann. Doc ann) -> [i] -> BulletList i
BulletList Doc a
forall ann. Doc ann
"" (TCStack -> TCStack
filterTCStack TCStack
tcStack))
    ]
 where
  teLoc :: Doc ann
teLoc = case SrcLoc
l of
    SrcLoc Int
s Int
e -> ((Int, Int) -> Doc ann
forall {a} {a} {ann}. (Pretty a, Pretty a) => (a, a) -> Doc ann
showLoc ((Int, Int) -> Doc ann)
-> (((Int, Int), (Int, Int)) -> (Int, Int))
-> ((Int, Int), (Int, Int))
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int), (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> a
fst (((Int, Int), (Int, Int)) -> Doc ann)
-> ((Int, Int), (Int, Int)) -> Doc ann
forall a b. (a -> b) -> a -> b
$ Var -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange Var
code (Int
s, Int
e)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
": "
    SrcLoc
NoLoc -> Doc ann
forall ann. Doc ann
emptyDoc
  showLoc :: (a, a) -> Doc ann
showLoc (a
r, a
c) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
r Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
c

-- | Filter the TCStack of extravagant Binds.
filterTCStack :: TCStack -> TCStack
filterTCStack :: TCStack -> TCStack
filterTCStack TCStack
tcStack = case TCStack
tcStack of
  [] -> []
  t :: LocatedTCFrame
t@(LocatedTCFrame SrcLoc
_ (TCLet Var
_)) : TCStack
_ -> [LocatedTCFrame
t]
  t :: LocatedTCFrame
t@(LocatedTCFrame SrcLoc
_ TCFrame
TCBindR) : TCStack
xs -> LocatedTCFrame
t LocatedTCFrame -> TCStack -> TCStack
forall a. a -> [a] -> [a]
: TCStack -> TCStack
filterTCStack TCStack
xs
  t :: LocatedTCFrame
t@(LocatedTCFrame SrcLoc
_ TCFrame
TCBindL) : TCStack
xs -> LocatedTCFrame
t LocatedTCFrame -> TCStack -> TCStack
forall a. a -> [a] -> [a]
: TCStack -> TCStack
filterTCStack TCStack
xs

instance PrettyPrec TypeErr where
  prettyPrec :: forall ann. Int -> TypeErr -> Doc ann
prettyPrec Int
_ = \case
    UnificationErr UnificationError
ue -> UnificationError -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UnificationError
ue
    KindErr KindError
ke -> KindError -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr KindError
ke
    Mismatch Maybe (Syntax' ())
Nothing (TypeJoin -> (UType, UType)
forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2)) ->
      Doc ann
"Type mismatch: expected" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", but got" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty2
    Mismatch (Just Syntax' ()
t) (TypeJoin -> (UType, UType)
forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2)) ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Type mismatch:"
        , Doc ann
"From context, expected" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Syntax' () -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Syntax' ()
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Source -> UType -> Doc ann
forall a. Source -> UType -> Doc a
typeDescription Source
Expected UType
ty1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
","
        , Doc ann
"but it" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Source -> UType -> Doc ann
forall a. Source -> UType -> Doc a
typeDescription Source
Actual UType
ty2
        ]
    LambdaArgMismatch (TypeJoin -> (UType, UType)
forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2)) ->
      Doc ann
"Lambda argument has type annotation" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode UType
ty2 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", but expected argument type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode UType
ty1
    FieldsMismatch (Join (Set Var) -> (Set Var, Set Var)
forall a. Join a -> (a, a)
getJoin -> (Set Var
expFs, Set Var
actFs)) ->
      Set Var -> Set Var -> Doc ann
forall a. Set Var -> Set Var -> Doc a
fieldMismatchMsg Set Var
expFs Set Var
actFs
    EscapedSkolem Var
x ->
      Doc ann
"Skolem variable" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"would escape its scope"
    UnboundVar Var
x ->
      Doc ann
"Unbound variable" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x
    DefNotTopLevel Term
t ->
      Doc ann
"Definitions may only be at the top level:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Term
t
    CantInfer Term
t ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
"Couldn't infer the type of term:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Term
t
        , Doc ann
forall ann. Doc ann
reportBug
        ]
    CantInferProj Term
t ->
      Doc ann
"Can't infer the type of a record projection:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Term
t
    UnknownProj Var
x Term
t ->
      Doc ann
"Record does not have a field with name" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Term
t
    InvalidAtomic InvalidAtomicReason
reason Term
t ->
      Doc ann
"Invalid atomic block:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> InvalidAtomicReason -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr InvalidAtomicReason
reason Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
pprCode Term
t
    TypeErr
Impredicative ->
      Doc ann
"Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ."
   where
    pprCode :: PrettyPrec a => a -> Doc ann
    pprCode :: forall a ann. PrettyPrec a => a -> Doc ann
pprCode = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
bquote (Doc ann -> Doc ann) -> (a -> Doc ann) -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr

instance PrettyPrec UnificationError where
  prettyPrec :: forall ann. Int -> UnificationError -> Doc ann
prettyPrec Int
_ = \case
    Infinite IntVar
x UType
uty ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
"Encountered infinite type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IntVar -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr IntVar
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
uty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
        , Doc ann
"Swarm will not infer recursive types; if you want a recursive type, add an explicit type annotation."
        ]
    UnifyErr TypeF UType
ty1 TypeF UType
ty2 ->
      Doc ann
"Can't unify" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeF UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeF UType
ty1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"and" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeF UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeF UType
ty2
    UndefinedUserType UType
ty ->
      Doc ann
"Undefined user type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty
    UnexpandedRecTy TypeF UType
ty ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
"Unexpanded recursive type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeF UType -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeF UType
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"encountered in unifyF."
        , Doc ann
forall ann. Doc ann
reportBug
        ]

instance PrettyPrec Arity where
  prettyPrec :: forall ann. Int -> Arity -> Doc ann
prettyPrec Int
_ (Arity Int
a) = Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
a

instance PrettyPrec KindError where
  prettyPrec :: forall ann. Int -> KindError -> Doc ann
prettyPrec Int
_ = \case
    ArityMismatch TyCon
c Int
a [Type]
tys ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Kind error:"
        , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
            [ TyCon -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TyCon
c
            , Doc ann
"requires"
            , Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
a
            , Doc ann
"type"
            , Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Var -> Var
number Int
a Var
"argument" Var -> Var -> Var
forall a. Semigroup a => a -> a -> a
<> Var
",")
            , Doc ann
"but was given"
            , Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys)
            ]
        ]
          [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann
"in the type:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (TyCon -> [Type] -> Type
TyConApp TyCon
c [Type]
tys) | Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys)]
    UndefinedTyCon TyCon
tc Type
_ty -> Doc ann
"Undefined type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TyCon -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TyCon
tc
    TrivialRecTy Var
x Type
ty ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Encountered trivial recursive type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Var -> Type -> Type
TyRec Var
x Type
ty)
        , Doc ann
"Did you forget to use" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in the body of the type?"
        ]
    VacuousRecTy Var
x Type
ty ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [ Doc ann
"Encountered vacuous recursive type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Var -> Type -> Type
TyRec Var
x Type
ty)
        , Doc ann
"Recursive types must be productive, i.e. must not expand to themselves."
        ]

-- | Given a type and its source, construct an appropriate description
--   of it to go in a type mismatch error message.
typeDescription :: Source -> UType -> Doc a
typeDescription :: forall a. Source -> UType -> Doc a
typeDescription Source
src UType
ty
  | Bool -> Bool
not (UType -> Bool
hasAnyUVars UType
ty) =
      Source -> Doc a -> Doc a -> Doc a
forall a. Source -> a -> a -> a
withSource Source
src Doc a
"have" Doc a
"actually has" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
"type" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a -> Doc a
forall ann. Doc ann -> Doc ann
bquote (UType -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty)
  | Just TypeF ()
f <- UType -> Maybe (TypeF ())
isTopLevelConstructor UType
ty =
      Source -> Doc a -> Doc a -> Doc a
forall a. Source -> a -> a -> a
withSource Source
src Doc a
"be" Doc a
"is actually" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeF () -> Doc a
forall a. TypeF () -> Doc a
tyNounPhrase TypeF ()
f
  | Bool
otherwise =
      Source -> Doc a -> Doc a -> Doc a
forall a. Source -> a -> a -> a
withSource Source
src Doc a
"have" Doc a
"actually has" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
"a type like" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a -> Doc a
forall ann. Doc ann -> Doc ann
bquote (Free TypeF Wildcard -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr ((IntVar -> Wildcard) -> UType -> Free TypeF Wildcard
forall a b. (a -> b) -> Free TypeF a -> Free TypeF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Wildcard -> IntVar -> Wildcard
forall a b. a -> b -> a
const Wildcard
Wildcard) UType
ty))

-- | Check whether a type contains any unification variables at all.
hasAnyUVars :: UType -> Bool
hasAnyUVars :: UType -> Bool
hasAnyUVars = (IntVar -> Bool) -> (TypeF Bool -> Bool) -> UType -> Bool
forall (t :: * -> *) v a.
Functor t =>
(v -> a) -> (t a -> a) -> Free t v -> a
ucata (Bool -> IntVar -> Bool
forall a b. a -> b -> a
const Bool
True) TypeF Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or

-- | Check whether a type consists of a top-level type constructor
--   immediately applied to unification variables.
isTopLevelConstructor :: UType -> Maybe (TypeF ())
isTopLevelConstructor :: UType -> Maybe (TypeF ())
isTopLevelConstructor = \case
  Free (TyRcdF Map Var UType
m) | (UType -> Bool) -> Map Var UType -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all UType -> Bool
forall (f :: * -> *) a. Free f a -> Bool
isPure Map Var UType
m -> TypeF () -> Maybe (TypeF ())
forall a. a -> Maybe a
Just (Map Var () -> TypeF ()
forall t. Map Var t -> TypeF t
TyRcdF Map Var ()
forall k a. Map k a
M.empty)
  UTyConApp TyCon
c [UType]
ts | (UType -> Bool) -> [UType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all UType -> Bool
forall (f :: * -> *) a. Free f a -> Bool
isPure [UType]
ts -> TypeF () -> Maybe (TypeF ())
forall a. a -> Maybe a
Just (TyCon -> [()] -> TypeF ()
forall t. TyCon -> [t] -> TypeF t
TyConF TyCon
c [])
  UType
_ -> Maybe (TypeF ())
forall a. Maybe a
Nothing

isPure :: Free f a -> Bool
isPure :: forall (f :: * -> *) a. Free f a -> Bool
isPure (Pure {}) = Bool
True
isPure Free f a
_ = Bool
False

-- | Return an English noun phrase describing things with the given
--   top-level type constructor.
tyNounPhrase :: TypeF () -> Doc a
tyNounPhrase :: forall a. TypeF () -> Doc a
tyNounPhrase = \case
  TyConF TyCon
c [()]
_ -> TyCon -> Doc a
forall a. TyCon -> Doc a
tyConNounPhrase TyCon
c
  TyVarF {} -> Doc a
"a type variable"
  TyRcdF {} -> Doc a
"a record"
  TyRecF {} -> Doc a
"a recursive type"
  TyRecVarF {} -> Doc a
"a recursive type variable"

tyConNounPhrase :: TyCon -> Doc a
tyConNounPhrase :: forall a. TyCon -> Doc a
tyConNounPhrase = \case
  TCBase BaseTy
b -> BaseTy -> Doc a
forall a. BaseTy -> Doc a
baseTyNounPhrase BaseTy
b
  TyCon
TCCmd -> Doc a
"a command"
  TyCon
TCDelay -> Doc a
"a delayed expression"
  TyCon
TCSum -> Doc a
"a sum"
  TyCon
TCProd -> Doc a
"a pair"
  TyCon
TCFun -> Doc a
"a function"
  TCUser Var
t -> Var -> Doc a
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
t

-- | Return an English noun phrase describing things with the given
--   base type.
baseTyNounPhrase :: BaseTy -> Doc a
baseTyNounPhrase :: forall a. BaseTy -> Doc a
baseTyNounPhrase = \case
  BaseTy
BVoid -> Doc a
"void"
  BaseTy
BUnit -> Doc a
"the unit value"
  BaseTy
BInt -> Doc a
"an integer"
  BaseTy
BText -> Doc a
"text"
  BaseTy
BDir -> Doc a
"a direction"
  BaseTy
BBool -> Doc a
"a boolean"
  BaseTy
BActor -> Doc a
"an actor"
  BaseTy
BKey -> Doc a
"a key"

-- | Generate an appropriate message when the sets of fields in two
--   record types do not match, explaining which fields are extra and
--   which are missing.
fieldMismatchMsg :: Set Var -> Set Var -> Doc a
fieldMismatchMsg :: forall a. Set Var -> Set Var -> Doc a
fieldMismatchMsg Set Var
expFs Set Var
actFs =
  Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vcat ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
    [Doc a
"Field mismatch; record literal has:"]
      [Doc a] -> [Doc a] -> [Doc a]
forall a. [a] -> [a] -> [a]
++ [Doc a
"- Extra field(s)" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Set Var -> Doc a
forall {ann}. Set Var -> Doc ann
prettyFieldSet Set Var
extraFs | Bool -> Bool
not (Set Var -> Bool
forall a. Set a -> Bool
S.null Set Var
extraFs)]
      [Doc a] -> [Doc a] -> [Doc a]
forall a. [a] -> [a] -> [a]
++ [Doc a
"- Missing field(s)" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Set Var -> Doc a
forall {ann}. Set Var -> Doc ann
prettyFieldSet Set Var
missingFs | Bool -> Bool
not (Set Var -> Bool
forall a. Set a -> Bool
S.null Set Var
missingFs)]
 where
  extraFs :: Set Var
extraFs = Set Var
actFs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Var
expFs
  missingFs :: Set Var
missingFs = Set Var
expFs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Var
actFs
  prettyFieldSet :: Set Var -> Doc ann
prettyFieldSet = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann)
-> (Set Var -> [Doc ann]) -> Set Var -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," ([Doc ann] -> [Doc ann])
-> (Set Var -> [Doc ann]) -> Set Var -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> Doc ann) -> [Var] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
bquote (Doc ann -> Doc ann) -> (Var -> Doc ann) -> Var -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) ([Var] -> [Doc ann]) -> (Set Var -> [Var]) -> Set Var -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Var -> [Var]
forall a. Set a -> [a]
S.toList

instance PrettyPrec InvalidAtomicReason where
  prettyPrec :: forall ann. Int -> InvalidAtomicReason -> Doc ann
prettyPrec Int
_ = \case
    TooManyTicks Int
n -> Doc ann
"block could take too many ticks (" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
n Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
    InvalidAtomicReason
AtomicDupingThing -> Doc ann
"def, let, and lambda are not allowed"
    NonSimpleVarType Var
_ UPolytype
ty ->
      Doc ann
"reference to variable with non-simple type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (UPolytype -> Var
forall a. PrettyPrec a => a -> Var
prettyTextLine UPolytype
ty)
    InvalidAtomicReason
NestedAtomic -> Doc ann
"nested atomic block"
    InvalidAtomicReason
LongConst -> Doc ann
"commands that can take multiple ticks to execute are not allowed"
    InvalidAtomicReason
AtomicSuspend ->
      Doc ann
"encountered a suspend command inside an atomic block" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
reportBug

instance PrettyPrec LocatedTCFrame where
  prettyPrec :: forall ann. Int -> LocatedTCFrame -> Doc ann
prettyPrec Int
p (LocatedTCFrame SrcLoc
_ TCFrame
f) = Int -> TCFrame -> Doc ann
forall ann. Int -> TCFrame -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p TCFrame
f

instance PrettyPrec TCFrame where
  prettyPrec :: forall ann. Int -> TCFrame -> Doc ann
prettyPrec Int
_ = \case
    TCLet Var
x -> Doc ann
"While checking the definition of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Var -> Doc ann
forall ann. Var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Var
x
    TCFrame
TCBindL -> Doc ann
"While checking the left-hand side of a semicolon"
    TCFrame
TCBindR -> Doc ann
"While checking the right-hand side of a semicolon"