{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
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
class PrettyPrec a where
prettyPrec :: Int -> a -> Doc ann
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
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
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
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
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
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
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)
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
"`"
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
data Prec a = Prec Int a
data BulletList i = BulletList
{ :: 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
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"
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
"_"
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
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
"."
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
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
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))
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
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
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"
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"
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"