{-# 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.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
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
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
parens
pparens Bool
False = forall a. a -> a
id
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
"`"
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 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 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
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
"_"
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
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
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 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 ."
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 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"