{-# 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.Unification
import Control.Unification.IntVar
import Data.Bool (bool)
import Data.Functor.Fixedpoint (Fix, unFix)
import Data.Map.Strict qualified as M
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.Language.Capability
import Swarm.Language.Context
import Swarm.Language.Parse (getLocRange)
import Swarm.Language.Syntax
import Swarm.Language.Typecheck
import Swarm.Language.Types
import Swarm.Util (showLowT)
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 = 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 -> Text
docToText = forall ann. SimpleDocStream ann -> Text
RT.renderStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Pretty-print something and render it as @Text@.
prettyText :: (PrettyPrec a) => a -> Text
prettyText :: forall a. PrettyPrec a => a -> Text
prettyText = forall a. Doc a -> Text
docToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall ann. SimpleDocStream ann -> String
RS.renderString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Doc a -> String
docToString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Optionally surround a document with parentheses depending on the
--   @Bool@ argument.
pparens :: Bool -> Doc ann -> Doc ann
pparens :: forall ann. Bool -> Doc ann -> Doc ann
pparens Bool
True = forall ann. Doc ann -> Doc ann
parens
pparens Bool
False = forall a. a -> a
id

-- | Surround a document with backticks.
bquote :: Doc ann -> Doc ann
bquote :: forall ann. Doc ann -> Doc ann
bquote Doc ann
d = Doc ann
"`" forall a. Semigroup a => a -> a -> a
<> Doc ann
d forall a. Semigroup a => a -> a -> a
<> 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 = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showLowT

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

data BulletList i = BulletList
  { forall i. BulletList i -> forall a. Doc a
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 a. Doc a
hdr [i]
items) =
    forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$ forall a. Doc a
hdr forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
"-" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Text -> Doc ann
prettyPrec Int
_ = forall a ann. Pretty a => a -> Doc ann
pretty

instance PrettyPrec BaseTy where
  prettyPrec :: forall ann. Int -> BaseTy -> Doc ann
prettyPrec Int
_ BaseTy
BVoid = Doc ann
"void"
  prettyPrec Int
_ BaseTy
BUnit = Doc ann
"unit"
  prettyPrec Int
_ BaseTy
BInt = Doc ann
"int"
  prettyPrec Int
_ BaseTy
BDir = Doc ann
"dir"
  prettyPrec Int
_ BaseTy
BText = Doc ann
"text"
  prettyPrec Int
_ BaseTy
BBool = Doc ann
"bool"
  prettyPrec Int
_ BaseTy
BActor = Doc ann
"actor"
  prettyPrec Int
_ BaseTy
BKey = Doc ann
"key"

instance PrettyPrec IntVar where
  prettyPrec :: forall ann. Int -> IntVar -> Doc ann
prettyPrec Int
_ = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IntVar -> Text
mkVarName Text
"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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Wildcard -> Wildcard -> Bool
$c/= :: Wildcard -> Wildcard -> Bool
== :: Wildcard -> Wildcard -> Bool
$c== :: Wildcard -> Wildcard -> Bool
Eq, Eq 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
min :: Wildcard -> Wildcard -> Wildcard
$cmin :: Wildcard -> Wildcard -> Wildcard
max :: Wildcard -> Wildcard -> Wildcard
$cmax :: Wildcard -> Wildcard -> Wildcard
>= :: Wildcard -> Wildcard -> Bool
$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
compare :: Wildcard -> Wildcard -> Ordering
$ccompare :: Wildcard -> Wildcard -> Ordering
Ord, Int -> Wildcard -> ShowS
[Wildcard] -> ShowS
Wildcard -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Wildcard] -> ShowS
$cshowList :: [Wildcard] -> ShowS
show :: Wildcard -> String
$cshow :: Wildcard -> String
showsPrec :: Int -> Wildcard -> ShowS
$cshowsPrec :: Int -> Wildcard -> ShowS
Show)

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

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

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

instance (PrettyPrec t) => PrettyPrec (TypeF t) where
  prettyPrec :: forall ann. Int -> TypeF t -> Doc ann
prettyPrec Int
_ (TyBaseF BaseTy
b) = forall a ann. PrettyPrec a => a -> Doc ann
ppr BaseTy
b
  prettyPrec Int
_ (TyVarF Text
v) = forall a ann. Pretty a => a -> Doc ann
pretty Text
v
  prettyPrec Int
p (TySumF t
ty1 t
ty2) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
      forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"+" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 t
ty2
  prettyPrec Int
p (TyProdF t
ty1 t
ty2) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
2) forall a b. (a -> b) -> a -> b
$
      forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
3 t
ty1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"*" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
2 t
ty2
  prettyPrec Int
p (TyCmdF t
ty) = forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$ Doc ann
"cmd" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
10 t
ty
  prettyPrec Int
_ (TyDelayF t
ty) = forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall a ann. PrettyPrec a => a -> Doc ann
ppr t
ty
  prettyPrec Int
p (TyFunF t
ty1 t
ty2) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 t
ty1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 t
ty2
  prettyPrec Int
_ (TyRcdF Map Text t
m) = forall ann. Doc ann -> Doc ann
brackets forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a b ann. (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding (forall k a. Map k a -> [(k, a)]
M.assocs Map Text t
m)))

instance PrettyPrec Polytype where
  prettyPrec :: forall ann. Int -> Polytype -> Doc ann
prettyPrec Int
_ (Forall [] Type
t) = forall a ann. PrettyPrec a => a -> Doc ann
ppr Type
t
  prettyPrec Int
_ (Forall [Text]
xs Type
t) = forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"∀" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
xs) forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall ann. Doc ann -> Doc ann -> 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) = forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
t
  prettyPrec Int
_ (Forall [Text]
xs UType
t) = forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"∀" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
xs) forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall ann. Doc ann -> Doc ann -> 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 = forall a. Doc a
emptyDoc
  prettyPrec Int
_ (forall t. Ctx t -> [(Text, t)]
assocs -> [(Text, t)]
bs) = forall ann. Doc ann -> Doc ann
brackets (forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a b ann. (Pretty a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding [(Text, 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) = forall a ann. Pretty a => a -> Doc ann
pretty a
x forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> 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
_ = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Text
directionSyntax

instance PrettyPrec Capability where
  prettyPrec :: forall ann. Int -> Capability -> Doc ann
prettyPrec Int
_ Capability
c = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (forall source target. From source target => source -> target
from (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Capability
c))

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

instance PrettyPrec (Syntax' ty) where
  prettyPrec :: forall ann. Int -> Syntax' ty -> Doc ann
prettyPrec Int
p = forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ty. Syntax' ty -> Term
eraseS

instance PrettyPrec Term where
  prettyPrec :: forall ann. Int -> Term -> Doc ann
prettyPrec Int
_ Term
TUnit = Doc ann
"()"
  prettyPrec Int
p (TConst Const
c) = forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Const
c
  prettyPrec Int
_ (TDir Direction
d) = forall a ann. PrettyPrec a => a -> Doc ann
ppr Direction
d
  prettyPrec Int
_ (TInt Integer
n) = forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
  prettyPrec Int
_ (TAntiInt Text
v) = Doc ann
"$int:" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
v
  prettyPrec Int
_ (TText Text
s) = forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Text
s)
  prettyPrec Int
_ (TAntiText Text
v) = Doc ann
"$str:" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
v
  prettyPrec Int
_ (TBool Bool
b) = forall a. a -> a -> Bool -> a
bool Doc ann
"false" Doc ann
"true" Bool
b
  prettyPrec Int
_ (TRobot Int
r) = Doc ann
"<a" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Int
r forall a. Semigroup a => a -> a -> a
<> Doc ann
">"
  prettyPrec Int
_ (TRef Int
r) = Doc ann
"@" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Int
r
  prettyPrec Int
p (TRequireDevice Text
d) = forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"require" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr @Term (forall ty. Text -> Term' ty
TText Text
d)
  prettyPrec Int
p (TRequire Int
n Text
e) = forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"require" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Int
n forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr @Term (forall ty. Text -> Term' ty
TText Text
e)
  prettyPrec Int
p (TRequirements Text
_ Term
e) = forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"requirements" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
e
  prettyPrec Int
_ (TVar Text
s) = forall a ann. Pretty a => a -> Doc ann
pretty Text
s
  prettyPrec Int
_ (TDelay DelayType
_ Term
t) = forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ t :: Term
t@TPair {} = forall a. Term -> Doc a
prettyTuple Term
t
  prettyPrec Int
_ (TLam Text
x Maybe Type
mty Term
body) =
    Doc ann
"\\" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
x forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" ((Doc ann
":" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. PrettyPrec a => a -> Doc ann
ppr) Maybe Type
mty forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
body
  -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3
  prettyPrec Int
p (TApp t :: Term
t@(TApp (TConst Const
c) Term
l) Term
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 ->
            forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
pC) forall a b. (a -> b) -> a -> b
$
              forall ann. [Doc ann] -> Doc ann
hsep
                [ forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc forall a. Eq a => a -> a -> Bool
== MBinAssoc
R)) Term
l
                , forall a ann. PrettyPrec a => a -> Doc ann
ppr Const
c
                , forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc forall a. Eq a => a -> a -> Bool
== MBinAssoc
L)) Term
r
                ]
          ConstMeta
_ -> forall a. Int -> Term -> Term -> Doc a
prettyPrecApp Int
p Term
t Term
r
  prettyPrec Int
p (TApp Term
t1 Term
t2) = case Term
t1 of
    TConst Const
c ->
      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 -> forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
pC) forall a b. (a -> b) -> a -> b
$ forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t1 forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (forall a. Enum a => a -> a
succ Int
pC) Term
t2
            ConstMUnOp MUnAssoc
S -> forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
pC) forall a b. (a -> b) -> a -> b
$ forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (forall a. Enum a => a -> a
succ Int
pC) Term
t2 forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t1
            ConstMeta
_ -> forall a. Int -> Term -> Term -> Doc a
prettyPrecApp Int
p Term
t1 Term
t2
    Term
_ -> forall a. Int -> Term -> Term -> Doc a
prettyPrecApp Int
p Term
t1 Term
t2
  prettyPrec Int
_ (TLet Bool
_ Text
x Maybe Polytype
mty Term
t1 Term
t2) =
    forall ann. [Doc ann] -> Doc ann
hsep forall a b. (a -> b) -> a -> b
$
      [Doc ann
"let", forall a ann. Pretty a => a -> Doc ann
pretty Text
x]
        forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Polytype
ty -> [Doc ann
":", forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
ty]) Maybe Polytype
mty
        forall a. [a] -> [a] -> [a]
++ [Doc ann
"=", forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t1, Doc ann
"in", forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t2]
  prettyPrec Int
_ (TDef Bool
_ Text
x Maybe Polytype
mty Term
t1) =
    forall ann. [Doc ann] -> Doc ann
hsep forall a b. (a -> b) -> a -> b
$
      [Doc ann
"def", forall a ann. Pretty a => a -> Doc ann
pretty Text
x]
        forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Polytype
ty -> [Doc ann
":", forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
ty]) Maybe Polytype
mty
        forall a. [a] -> [a] -> [a]
++ [Doc ann
"=", forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t1, Doc ann
"end"]
  prettyPrec Int
p (TBind Maybe Text
Nothing Term
t1 Term
t2) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Term
t1 forall a. Semigroup a => a -> a -> a
<> Doc ann
";" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Term
t2
  prettyPrec Int
p (TBind (Just Text
x) Term
t1 Term
t2) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall a ann. Pretty a => a -> Doc ann
pretty Text
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Term
t1 forall a. Semigroup a => a -> a -> a
<> Doc ann
";" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Term
t2
  prettyPrec Int
_ (TRcd Map Text (Maybe Term)
m) = forall ann. Doc ann -> Doc ann
brackets forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a b ann. (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyEquality (forall k a. Map k a -> [(k, a)]
M.assocs Map Text (Maybe Term)
m)))
  prettyPrec Int
_ (TProj Term
t Text
x) = forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Term
t forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
x
  prettyPrec Int
p (TAnnotate Term
t Polytype
pt) =
    forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Term
t forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Polytype
pt

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) = forall a ann. Pretty a => a -> Doc ann
pretty a
x
prettyEquality (a
x, Just b
t) = forall a ann. Pretty a => a -> Doc ann
pretty a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr b
t

prettyTuple :: Term -> Doc a
prettyTuple :: forall a. Term -> Doc a
prettyTuple = forall ann. Bool -> Doc ann -> Doc ann
pparens Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc a
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. PrettyPrec a => a -> Doc ann
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> [Term]
unnestTuple
 where
  unnestTuple :: Term -> [Term]
unnestTuple (TPair Term
t1 Term
t2) = Term
t1 forall a. a -> [a] -> [a]
: Term -> [Term]
unnestTuple Term
t2
  unnestTuple Term
t = [Term
t]

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

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

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

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

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

instance PrettyPrec TypeErr where
  prettyPrec :: forall ann. Int -> TypeErr -> Doc ann
prettyPrec Int
_ (UnifyErr TypeF UType
ty1 TypeF UType
ty2) =
    Doc ann
"Can't unify" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeF UType
ty1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"and" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr TypeF UType
ty2
  prettyPrec Int
_ (Mismatch Maybe Syntax
Nothing (forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2))) =
    Doc ann
"Type mismatch: expected" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty1 forall a. Semigroup a => a -> a -> a
<> Doc ann
", but got" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty2
  prettyPrec Int
_ (Mismatch (Just Syntax
t) (forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2))) =
    forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$
      [ Doc ann
"Type mismatch:"
      , Doc ann
"From context, expected" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
bquote (forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax
t) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"to" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Source -> UType -> Doc a
typeDescription Source
Expected UType
ty1 forall a. Semigroup a => a -> a -> a
<> Doc ann
","
      , Doc ann
"but it" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Source -> UType -> Doc a
typeDescription Source
Actual UType
ty2
      ]
  prettyPrec Int
_ (LambdaArgMismatch (forall a. Join a -> (a, a)
getJoin -> (UType
ty1, UType
ty2))) =
    Doc ann
"Lambda argument has type annotation" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
bquote (forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty2) forall a. Semigroup a => a -> a -> a
<> Doc ann
", but expected argument type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
bquote (forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty1)
  prettyPrec Int
_ (FieldsMismatch (forall a. Join a -> (a, a)
getJoin -> (Set Text
expFs, Set Text
actFs))) = forall a. Set Text -> Set Text -> Doc a
fieldMismatchMsg Set Text
expFs Set Text
actFs
  prettyPrec Int
_ (EscapedSkolem Text
x) =
    Doc ann
"Skolem variable" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"would escape its scope"
  prettyPrec Int
_ (UnboundVar Text
x) =
    Doc ann
"Unbound variable" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
x
  prettyPrec Int
_ (Infinite IntVar
x UType
uty) =
    Doc ann
"Infinite type:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr IntVar
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
uty
  prettyPrec Int
_ (DefNotTopLevel Term
t) =
    Doc ann
"Definitions may only be at the top level:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ (CantInfer Term
t) =
    Doc ann
"Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ (CantInferProj Term
t) =
    Doc ann
"Can't infer the type of a record projection:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ (UnknownProj Text
x Term
t) =
    Doc ann
"Record does not have a field with name" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
x forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ (InvalidAtomic InvalidAtomicReason
reason Term
t) =
    Doc ann
"Invalid atomic block:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr InvalidAtomicReason
reason forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t
  prettyPrec Int
_ 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 ."

-- | 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) =
      forall a. Source -> a -> a -> a
withSource Source
src Doc a
"have" Doc a
"actually has" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
"type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
bquote (forall a ann. PrettyPrec a => a -> Doc ann
ppr UType
ty)
  | Just TypeF ()
f <- UType -> Maybe (TypeF ())
isTopLevelConstructor UType
ty =
      forall a. Source -> a -> a -> a
withSource Source
src Doc a
"be" Doc a
"is actually" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. TypeF () -> Doc a
tyNounPhrase TypeF ()
f
  | Bool
otherwise =
      forall a. Source -> a -> a -> a
withSource Source
src Doc a
"have" Doc a
"actually has" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
"a type like" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
bquote (forall a ann. PrettyPrec a => a -> Doc ann
ppr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall (t :: * -> *) v a.
Functor t =>
(v -> a) -> (t a -> a) -> UTerm t v -> a
ucata (forall a b. a -> b -> a
const Bool
True) 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 (UTyCmd (UVar {})) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. t -> TypeF t
TyCmdF ()
isTopLevelConstructor (UTyDelay (UVar {})) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. t -> TypeF t
TyDelayF ()
isTopLevelConstructor (UTySum (UVar {}) (UVar {})) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. t -> t -> TypeF t
TySumF () ()
isTopLevelConstructor (UTyProd (UVar {}) (UVar {})) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. t -> t -> TypeF t
TyProdF () ()
isTopLevelConstructor (UTyFun (UVar {}) (UVar {})) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. t -> t -> TypeF t
TyFunF () ()
isTopLevelConstructor UType
_ = forall a. Maybe a
Nothing

-- | 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
  TyBaseF BaseTy
b -> forall a. BaseTy -> Doc a
baseTyNounPhrase BaseTy
b
  TyVarF {} -> Doc a
"a type variable"
  TyCmdF {} -> Doc a
"a command"
  TyDelayF {} -> Doc a
"a delayed expression"
  TySumF {} -> Doc a
"a sum"
  TyProdF {} -> Doc a
"a pair"
  TyFunF {} -> Doc a
"a function"
  TyRcdF {} -> Doc a
"a record"

-- | 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 Text -> Set Text -> Doc a
fieldMismatchMsg Set Text
expFs Set Text
actFs =
  forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$
    [Doc a
"Field mismatch; record literal has:"]
      forall a. [a] -> [a] -> [a]
++ [Doc a
"- Extra field(s)" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Set Text -> Doc ann
prettyFieldSet Set Text
extraFs | Bool -> Bool
not (forall a. Set a -> Bool
S.null Set Text
extraFs)]
      forall a. [a] -> [a] -> [a]
++ [Doc a
"- Missing field(s)" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Set Text -> Doc ann
prettyFieldSet Set Text
missingFs | Bool -> Bool
not (forall a. Set a -> Bool
S.null Set Text
missingFs)]
 where
  extraFs :: Set Text
extraFs = Set Text
actFs forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Text
expFs
  missingFs :: Set Text
missingFs = Set Text
expFs forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Text
actFs
  prettyFieldSet :: Set Text -> Doc ann
prettyFieldSet = forall ann. [Doc ann] -> Doc ann
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
bquote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList

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

instance PrettyPrec LocatedTCFrame where
  prettyPrec :: forall ann. Int -> LocatedTCFrame -> Doc ann
prettyPrec Int
p (LocatedTCFrame SrcLoc
_ TCFrame
f) = 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
_ (TCDef Text
x) = Doc ann
"While checking the definition of" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
x
  prettyPrec Int
_ TCFrame
TCBindL = Doc ann
"While checking the left-hand side of a semicolon"
  prettyPrec Int
_ TCFrame
TCBindR = Doc ann
"While checking the right-hand side of a semicolon"