{-# 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.List.NonEmpty qualified as NE
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 (showEnum, showLowT, unsnocNE)
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

-- | Pretty-print something and render it as (preferably) one line @Text@.
prettyTextLine :: (PrettyPrec a) => a -> Text
prettyTextLine :: forall a. PrettyPrec a => a -> Text
prettyTextLine = 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 (PageWidth -> LayoutOptions
LayoutOptions PageWidth
Unbounded) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann
group 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 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 = forall ann. Doc ann -> Doc ann
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 forall ann. Doc ann
lparen forall ann. Doc ann
rparen
pparens Bool
False = 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 = forall ann. Int -> Doc ann -> Doc ann
nest Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (Doc ann
l forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line') (forall ann. Int -> Doc ann -> Doc ann
nest (-Int
2) forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann
line' 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 = forall ann. Doc ann -> Doc ann
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 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) =
    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 ann. Doc ann
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
"_"

-- | 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 -> [t]

instance UnchainableFun Type where
  unchainFun :: Type -> [Type]
unchainFun (Type
a :->: Type
ty) = Type
a forall a. a -> [a] -> [a]
: forall t. UnchainableFun t => t -> [t]
unchainFun Type
ty
  unchainFun Type
ty = [Type
ty]

instance UnchainableFun (UTerm TypeF ty) where
  unchainFun :: UTerm TypeF ty -> [UTerm TypeF ty]
unchainFun (UTerm (TyFunF UTerm TypeF ty
ty1 UTerm TypeF ty
ty2)) = UTerm TypeF ty
ty1 forall a. a -> [a] -> [a]
: forall t. UnchainableFun t => t -> [t]
unchainFun UTerm TypeF ty
ty2
  unchainFun UTerm TypeF ty
ty = [UTerm TypeF ty
ty]

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 ((UnchainableFun t), (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) =
    let ([t]
iniF, t
lastF) = forall a. NonEmpty a -> ([a], a)
unsnocNE forall a b. (a -> b) -> a -> b
$ t
ty1 forall a. a -> [a] -> NonEmpty a
NE.:| forall t. UnchainableFun t => t -> [t]
unchainFun t
ty2
        funs :: [Doc ann]
funs = (forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t]
iniF) forall a. Semigroup a => a -> a -> a
<> [forall a ann. PrettyPrec a => a -> Doc ann
ppr t
lastF]
        inLine :: Doc ann -> Doc ann -> Doc ann
inLine Doc ann
l Doc ann
r = Doc ann
l forall 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 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline forall a. Semigroup a => a -> a -> a
<> Doc ann
r
     in forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$
          forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith forall ann. Doc ann -> Doc ann -> Doc ann
multiLine forall {ann}. [Doc ann]
funs) (forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith forall ann. Doc ann -> Doc ann -> Doc ann
inLine forall {ann}. [Doc ann]
funs)
  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 ann. Doc ann
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. NonEmpty a -> [a]
NE.tail forall a b. (a -> b) -> a -> b
$ 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 = 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
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 forall ann. Doc ann
lbrace forall ann. Doc ann
rbrace 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
p t :: Term
t@(TLam {}) =
    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
$
      forall a. Term -> Doc a
prettyLambdas Term
t
  -- 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
sep
      [ forall ann. Doc ann -> Text -> Maybe Polytype -> Term -> Doc ann
prettyDefinition Doc ann
"let" Text
x Maybe Polytype
mty Term
t1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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
sep
      [ forall ann. Doc ann -> Text -> Maybe Polytype -> Term -> Doc ann
prettyDefinition Doc ann
"def" Text
x Maybe Polytype
mty 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 a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> 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 a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> 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. [Doc ann] -> Doc ann
tupled 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]

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

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

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

unchainLambdas :: Term -> (Term, [(Var, Maybe Type)])
unchainLambdas :: Term -> (Term, [(Text, Maybe Type)])
unchainLambdas = \case
  TLam Text
x Maybe Type
mty Term
body -> ((Text
x, Maybe Type
mty) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> (Term, [(Text, Maybe Type)])
unchainLambdas Term
body
  Term
body -> (Term
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
"\\" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty a1
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 a2
mty 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 :: 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 ann. Doc ann
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 ann. Doc ann) -> [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 ann. Doc ann
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
_ = \case
    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
    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
    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 a ann. PrettyPrec a => a -> Doc ann
pprCode 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
        ]
    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 a ann. PrettyPrec a => a -> Doc ann
pprCode UType
ty2 forall a. Semigroup a => a -> a -> a
<> Doc ann
", but expected argument type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
pprCode UType
ty1
    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
    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"
    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
    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
    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
pprCode Term
t
    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
pprCode Term
t
    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
pprCode Term
t
    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
pprCode Term
t
    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
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 = forall ann. Doc ann -> Doc ann
bquote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | 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 (forall a. PrettyPrec a => a -> Text
prettyTextLine 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"