{-# OPTIONS_GHC -Wno-orphans #-}
module Type.Check.HM.Pretty(
PrettyVar
, FixityCtx(..)
, PrintCons(..)
, OpFix(..)
, Fixity(..)
, Pretty(..)
) where
import Data.Bool
import Data.Fix
import Data.Maybe
import Data.Text (Text)
import Data.Text.Prettyprint.Doc
import Type.Check.HM.Type
import Type.Check.HM.Term
import Type.Check.HM.TypeError
data FixityCtx var a = FixityCtx
{ FixityCtx var a -> var -> Maybe OpFix
fixity'context :: var -> Maybe OpFix
, FixityCtx var a -> a
fixity'data :: a
}
noFixity :: forall v a . a -> FixityCtx v a
noFixity :: a -> FixityCtx v a
noFixity = (v -> Maybe OpFix) -> a -> FixityCtx v a
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx (Maybe OpFix -> v -> Maybe OpFix
forall a b. a -> b -> a
const Maybe OpFix
forall a. Maybe a
Nothing)
class PrintCons v where
printCons :: v -> [Doc ann] -> Doc ann
instance PrintCons Int where
printCons :: Int -> [Doc ann] -> Doc ann
printCons Int
name [Doc ann]
args = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
name Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
args
instance PrintCons String where
printCons :: String -> [Doc ann] -> Doc ann
printCons String
name [Doc ann]
args = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
args
instance PrintCons Text where
printCons :: Text -> [Doc ann] -> Doc ann
printCons Text
name [Doc ann]
args = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
name Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
args
isPrefix :: (v -> Maybe OpFix) -> v -> Bool
isPrefix :: (v -> Maybe OpFix) -> v -> Bool
isPrefix v -> Maybe OpFix
getFixity = Maybe OpFix -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe OpFix -> Bool) -> (v -> Maybe OpFix) -> v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe OpFix
getFixity
isInfix :: (v -> Maybe OpFix) -> v -> Bool
isInfix :: (v -> Maybe OpFix) -> v -> Bool
isInfix v -> Maybe OpFix
a = Bool -> Bool
not (Bool -> Bool) -> (v -> Bool) -> v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Maybe OpFix) -> v -> Bool
forall v. (v -> Maybe OpFix) -> v -> Bool
isPrefix v -> Maybe OpFix
a
type PrettyVar a = (Pretty a, PrintCons a, IsVar a)
instance (PrettyVar v) => Pretty (Signature loc v) where
pretty :: Signature loc v -> Doc ann
pretty = FixityCtx v (Signature loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Signature loc v) -> Doc ann)
-> (Signature loc v -> FixityCtx v (Signature loc v))
-> Signature loc v
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FixityCtx v a
forall v a. a -> FixityCtx v a
noFixity @v
instance (PrettyVar v) => Pretty (FixityCtx v (Signature loc v)) where
pretty :: FixityCtx v (Signature loc v) -> Doc ann
pretty (FixityCtx v -> Maybe OpFix
getFixity Signature loc v
sign) = (SignatureF loc v (Doc ann) -> Doc ann)
-> Fix (SignatureF loc v) -> Doc ann
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix SignatureF loc v (Doc ann) -> Doc ann
go (Fix (SignatureF loc v) -> Doc ann)
-> Fix (SignatureF loc v) -> Doc ann
forall a b. (a -> b) -> a -> b
$ Signature loc v -> Fix (SignatureF loc v)
forall loc var. Signature loc var -> Fix (SignatureF loc var)
unSignature Signature loc v
sign
where
go :: SignatureF loc v (Doc ann) -> Doc ann
go = \case
ForAllT loc
_ v
_ Doc ann
r -> Doc ann
r
MonoT Type loc v
ty -> FixityCtx v (Type loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((v -> Maybe OpFix) -> Type loc v -> FixityCtx v (Type loc v)
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx v -> Maybe OpFix
getFixity Type loc v
ty)
instance (PrettyVar v) => Pretty (Type loc v) where
pretty :: Type loc v -> Doc ann
pretty = FixityCtx v (Type loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Type loc v) -> Doc ann)
-> (Type loc v -> FixityCtx v (Type loc v))
-> Type loc v
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FixityCtx v a
forall v a. a -> FixityCtx v a
noFixity @v
instance (PrettyVar v) => Pretty (FixityCtx v (Type loc v)) where
pretty :: FixityCtx v (Type loc v) -> Doc ann
pretty (FixityCtx v -> Maybe OpFix
getFixity Type loc v
ty) = Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
False FixityContext v
forall v. FixityContext v
initCtx (Fix (TypeF loc v) -> Doc ann) -> Fix (TypeF loc v) -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type loc v -> Fix (TypeF loc v)
forall loc var. Type loc var -> Fix (TypeF loc var)
unType Type loc v
ty
where
go :: Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go :: Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
isArrPrev FixityContext v
ctx (Fix TypeF loc v (Fix (TypeF loc v))
expr) = case TypeF loc v (Fix (TypeF loc v))
expr of
VarT loc
_ v
name -> v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
name
ConT loc
_ v
name [Fix (TypeF loc v)
a, Fix (TypeF loc v)
b] | (v -> Maybe OpFix) -> v -> Bool
forall v. (v -> Maybe OpFix) -> v -> Bool
isInfix v -> Maybe OpFix
getFixity v
name -> v -> Fix (TypeF loc v) -> Fix (TypeF loc v) -> Doc ann
fromBin v
name Fix (TypeF loc v)
a Fix (TypeF loc v)
b
ConT loc
_ v
name [Fix (TypeF loc v)]
as -> Bool -> v -> [Fix (TypeF loc v)] -> Doc ann
fromCon Bool
isArrPrev v
name [Fix (TypeF loc v)]
as
ArrowT loc
_ Fix (TypeF loc v)
a Fix (TypeF loc v)
b -> Fix (TypeF loc v) -> Fix (TypeF loc v) -> Doc ann
fromArrow Fix (TypeF loc v)
a Fix (TypeF loc v)
b
TupleT loc
_ [Fix (TypeF loc v)]
as -> [Fix (TypeF loc v)] -> Doc ann
fromTuple [Fix (TypeF loc v)]
as
ListT loc
_ Fix (TypeF loc v)
a -> Fix (TypeF loc v) -> Doc ann
fromList Fix (TypeF loc v)
a
where
fromCon :: Bool -> v -> [Fix (TypeF loc v)] -> Doc ann
fromCon Bool
isArr v
name [Fix (TypeF loc v)]
args = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens (Bool -> Bool
not ([Fix (TypeF loc v)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Fix (TypeF loc v)]
args) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isArr Bool -> Bool -> Bool
&& (v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
forall v.
(v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
needsParens v -> Maybe OpFix
getFixity FixityContext v
ctx Operator v
forall v. Operator v
OpFunAp) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
v -> [Doc ann] -> Doc ann
forall v ann. PrintCons v => v -> [Doc ann] -> Doc ann
printCons v
name ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Fix (TypeF loc v) -> Doc ann) -> [Fix (TypeF loc v)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
False (Operator v -> FixityContext v
forall v. Operator v -> FixityContext v
FcRight Operator v
forall v. Operator v
OpFunAp)) [Fix (TypeF loc v)]
args
fromBin :: v -> Fix (TypeF loc v) -> Fix (TypeF loc v) -> Doc ann
fromBin v
op Fix (TypeF loc v)
a Fix (TypeF loc v)
b = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens ((v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
forall v.
(v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
needsParens v -> Maybe OpFix
getFixity FixityContext v
ctx (v -> Operator v
forall v. v -> Operator v
Op v
op)) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
[ Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
True (Operator v -> FixityContext v
forall v. Operator v -> FixityContext v
FcLeft (Operator v -> FixityContext v) -> Operator v -> FixityContext v
forall a b. (a -> b) -> a -> b
$ v -> Operator v
forall v. v -> Operator v
Op v
op) Fix (TypeF loc v)
a
, v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
op
, Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
True (Operator v -> FixityContext v
forall v. Operator v -> FixityContext v
FcRight (Operator v -> FixityContext v) -> Operator v -> FixityContext v
forall a b. (a -> b) -> a -> b
$ v -> Operator v
forall v. v -> Operator v
Op v
op) Fix (TypeF loc v)
b
]
fromArrow :: Fix (TypeF loc v) -> Fix (TypeF loc v) -> Doc ann
fromArrow Fix (TypeF loc v)
a Fix (TypeF loc v)
b = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens ((v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
forall v.
(v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
needsParens v -> Maybe OpFix
getFixity FixityContext v
ctx Operator v
forall v. Operator v
ArrowOp) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
[ Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
True (Operator v -> FixityContext v
forall v. Operator v -> FixityContext v
FcLeft Operator v
forall v. Operator v
ArrowOp ) Fix (TypeF loc v)
a
, Doc ann
"->"
, Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
forall ann. Bool -> FixityContext v -> Fix (TypeF loc v) -> Doc ann
go Bool
True (Operator v -> FixityContext v
forall v. Operator v -> FixityContext v
FcRight Operator v
forall v. Operator v
ArrowOp) Fix (TypeF loc v)
b
]
fromTuple :: [Fix (TypeF loc v)] -> Doc ann
fromTuple [Fix (TypeF loc v)]
as = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Fix (TypeF loc v) -> Doc ann) -> [Fix (TypeF loc v)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FixityCtx v (Type loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Type loc v) -> Doc ann)
-> (Fix (TypeF loc v) -> FixityCtx v (Type loc v))
-> Fix (TypeF loc v)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Maybe OpFix) -> Type loc v -> FixityCtx v (Type loc v)
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx v -> Maybe OpFix
getFixity (Type loc v -> FixityCtx v (Type loc v))
-> (Fix (TypeF loc v) -> Type loc v)
-> Fix (TypeF loc v)
-> FixityCtx v (Type loc v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix (TypeF loc v) -> Type loc v
forall loc var. Fix (TypeF loc var) -> Type loc var
Type) [Fix (TypeF loc v)]
as
fromList :: Fix (TypeF loc v) -> Doc ann
fromList Fix (TypeF loc v)
a = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ FixityCtx v (Type loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Type loc v) -> Doc ann)
-> FixityCtx v (Type loc v) -> Doc ann
forall a b. (a -> b) -> a -> b
$ (v -> Maybe OpFix) -> Type loc v -> FixityCtx v (Type loc v)
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx v -> Maybe OpFix
getFixity (Type loc v -> FixityCtx v (Type loc v))
-> Type loc v -> FixityCtx v (Type loc v)
forall a b. (a -> b) -> a -> b
$ Fix (TypeF loc v) -> Type loc v
forall loc var. Fix (TypeF loc var) -> Type loc var
Type Fix (TypeF loc v)
a
initCtx :: FixityContext v
initCtx = FixityContext v
forall v. FixityContext v
FcNone
maybeParens :: Bool -> Doc ann -> Doc ann
maybeParens :: Bool -> Doc ann -> Doc ann
maybeParens Bool
cond = (Doc ann -> Doc ann)
-> (Doc ann -> Doc ann) -> Bool -> Doc ann -> Doc ann
forall a. a -> a -> Bool -> a
bool Doc ann -> Doc ann
forall a. a -> a
id Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Bool
cond
needsParens :: (v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
needsParens :: (v -> Maybe OpFix) -> FixityContext v -> Operator v -> Bool
needsParens v -> Maybe OpFix
getFixity = \case
FixityContext v
FcNone -> Bool -> Operator v -> Bool
forall a b. a -> b -> a
const Bool
False
FcLeft Operator v
ctx -> Operator v -> Operator v -> Bool
fcLeft Operator v
ctx
FcRight Operator v
ctx -> Operator v -> Operator v -> Bool
fcRight Operator v
ctx
where
fcLeft :: Operator v -> Operator v -> Bool
fcLeft Operator v
ctxt Operator v
op
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoLT = Bool
False
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoGT = Bool
True
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoNC = Bool
True
| Operator v -> Fixity
fixity' Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Operator v -> Fixity
fixity' Operator v
op = Bool
True
| Operator v -> Fixity
fixity' Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
FixLeft = Bool
False
| Bool
otherwise = Bool
True
fcRight :: Operator v -> Operator v -> Bool
fcRight Operator v
ctxt Operator v
op
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoLT = Bool
False
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoGT = Bool
True
| Operator v -> Operator v -> PartialOrdering
comparePrec' Operator v
ctxt Operator v
op PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
PoNC = Bool
True
| Operator v -> Fixity
fixity' Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Operator v -> Fixity
fixity' Operator v
op = Bool
True
| Operator v -> Fixity
fixity' Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
FixRight = Bool
False
| Bool
otherwise = Bool
True
comparePrec' :: Operator v -> Operator v -> PartialOrdering
comparePrec' = (v -> Maybe OpFix) -> Operator v -> Operator v -> PartialOrdering
forall v.
(v -> Maybe OpFix) -> Operator v -> Operator v -> PartialOrdering
comparePrec v -> Maybe OpFix
getFixity
fixity' :: Operator v -> Fixity
fixity' = (v -> Maybe OpFix) -> Operator v -> Fixity
forall v. (v -> Maybe OpFix) -> Operator v -> Fixity
fixity v -> Maybe OpFix
getFixity
data PartialOrdering = PoLT | PoGT | PoEQ | PoNC
deriving PartialOrdering -> PartialOrdering -> Bool
(PartialOrdering -> PartialOrdering -> Bool)
-> (PartialOrdering -> PartialOrdering -> Bool)
-> Eq PartialOrdering
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartialOrdering -> PartialOrdering -> Bool
$c/= :: PartialOrdering -> PartialOrdering -> Bool
== :: PartialOrdering -> PartialOrdering -> Bool
$c== :: PartialOrdering -> PartialOrdering -> Bool
Eq
data OpFix = OpFix
{ OpFix -> Fixity
opFix'fixity :: !Fixity
, OpFix -> Int
opFix'prec :: !Int
}
data Fixity = FixLeft | FixRight | FixNone
deriving Fixity -> Fixity -> Bool
(Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool) -> Eq Fixity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fixity -> Fixity -> Bool
$c/= :: Fixity -> Fixity -> Bool
== :: Fixity -> Fixity -> Bool
$c== :: Fixity -> Fixity -> Bool
Eq
data Operator v = OpFunAp | Op v | ArrowOp
deriving (Operator v -> Operator v -> Bool
(Operator v -> Operator v -> Bool)
-> (Operator v -> Operator v -> Bool) -> Eq (Operator v)
forall v. Eq v => Operator v -> Operator v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Operator v -> Operator v -> Bool
$c/= :: forall v. Eq v => Operator v -> Operator v -> Bool
== :: Operator v -> Operator v -> Bool
$c== :: forall v. Eq v => Operator v -> Operator v -> Bool
Eq, Eq (Operator v)
Eq (Operator v)
-> (Operator v -> Operator v -> Ordering)
-> (Operator v -> Operator v -> Bool)
-> (Operator v -> Operator v -> Bool)
-> (Operator v -> Operator v -> Bool)
-> (Operator v -> Operator v -> Bool)
-> (Operator v -> Operator v -> Operator v)
-> (Operator v -> Operator v -> Operator v)
-> Ord (Operator v)
Operator v -> Operator v -> Bool
Operator v -> Operator v -> Ordering
Operator v -> Operator v -> Operator v
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
forall v. Ord v => Eq (Operator v)
forall v. Ord v => Operator v -> Operator v -> Bool
forall v. Ord v => Operator v -> Operator v -> Ordering
forall v. Ord v => Operator v -> Operator v -> Operator v
min :: Operator v -> Operator v -> Operator v
$cmin :: forall v. Ord v => Operator v -> Operator v -> Operator v
max :: Operator v -> Operator v -> Operator v
$cmax :: forall v. Ord v => Operator v -> Operator v -> Operator v
>= :: Operator v -> Operator v -> Bool
$c>= :: forall v. Ord v => Operator v -> Operator v -> Bool
> :: Operator v -> Operator v -> Bool
$c> :: forall v. Ord v => Operator v -> Operator v -> Bool
<= :: Operator v -> Operator v -> Bool
$c<= :: forall v. Ord v => Operator v -> Operator v -> Bool
< :: Operator v -> Operator v -> Bool
$c< :: forall v. Ord v => Operator v -> Operator v -> Bool
compare :: Operator v -> Operator v -> Ordering
$ccompare :: forall v. Ord v => Operator v -> Operator v -> Ordering
$cp1Ord :: forall v. Ord v => Eq (Operator v)
Ord)
data FixityContext v = FcNone | FcLeft (Operator v) | FcRight (Operator v)
getFixityEnv :: (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
getFixityEnv :: (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
getFixityEnv v -> Maybe OpFix
getFixity = \case
Operator v
OpFunAp -> Maybe OpFix
forall a. Maybe a
Nothing
Op v
v -> v -> Maybe OpFix
getFixity v
v
Operator v
ArrowOp -> OpFix -> Maybe OpFix
forall a. a -> Maybe a
Just (OpFix -> Maybe OpFix) -> OpFix -> Maybe OpFix
forall a b. (a -> b) -> a -> b
$ Fixity -> Int -> OpFix
OpFix Fixity
FixRight Int
2
comparePrec :: (v -> Maybe OpFix) -> Operator v -> Operator v -> PartialOrdering
comparePrec :: (v -> Maybe OpFix) -> Operator v -> Operator v -> PartialOrdering
comparePrec v -> Maybe OpFix
getFixity Operator v
a Operator v
b = case ((v -> Maybe OpFix) -> Operator v -> Maybe OpFix
forall v. (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
getFixityEnv v -> Maybe OpFix
getFixity Operator v
a, (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
forall v. (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
getFixityEnv v -> Maybe OpFix
getFixity Operator v
b) of
(Just OpFix
opA, Just OpFix
opB) -> Int -> Int -> PartialOrdering
forall a. Ord a => a -> a -> PartialOrdering
toPo (OpFix -> Int
opFix'prec OpFix
opA) (OpFix -> Int
opFix'prec OpFix
opB)
(Maybe OpFix, Maybe OpFix)
_ -> PartialOrdering
PoNC
where
toPo :: a -> a -> PartialOrdering
toPo a
m a
n
| a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
n = PartialOrdering
PoLT
| a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
n = PartialOrdering
PoGT
| Bool
otherwise = PartialOrdering
PoEQ
fixity :: (v -> Maybe OpFix) -> Operator v -> Fixity
fixity :: (v -> Maybe OpFix) -> Operator v -> Fixity
fixity v -> Maybe OpFix
getFixity Operator v
op = Fixity -> (OpFix -> Fixity) -> Maybe OpFix -> Fixity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fixity
FixNone OpFix -> Fixity
opFix'fixity (Maybe OpFix -> Fixity) -> Maybe OpFix -> Fixity
forall a b. (a -> b) -> a -> b
$ (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
forall v. (v -> Maybe OpFix) -> Operator v -> Maybe OpFix
getFixityEnv v -> Maybe OpFix
getFixity Operator v
op
instance (PrettyVar v, Pretty prim) => Pretty (Term prim loc v) where
pretty :: Term prim loc v -> Doc ann
pretty = FixityCtx v (Term prim loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Term prim loc v) -> Doc ann)
-> (Term prim loc v -> FixityCtx v (Term prim loc v))
-> Term prim loc v
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FixityCtx v a
forall v a. a -> FixityCtx v a
noFixity @v
instance (PrettyVar v, Pretty prim) => Pretty (FixityCtx v (Term prim loc v)) where
pretty :: FixityCtx v (Term prim loc v) -> Doc ann
pretty (FixityCtx v -> Maybe OpFix
getFixity (Term Fix (TermF prim loc v)
x)) = (TermF prim loc v (Doc ann) -> Doc ann)
-> Fix (TermF prim loc v) -> Doc ann
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix TermF prim loc v (Doc ann) -> Doc ann
prettyTermF Fix (TermF prim loc v)
x
where
prettyTermF :: TermF prim loc v (Doc ann) -> Doc ann
prettyTermF = \case
Var loc
_ v
v -> v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
v
Prim loc
_ prim
p -> prim -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty prim
p
App loc
_ Doc ann
a Doc ann
b -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
a, Doc ann
b]
Lam loc
_ v
v Doc ann
a -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [Doc ann
"\\", v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
v], Doc ann
"->", Doc ann
a]
Let loc
_ Bind loc v (Doc ann)
v Doc ann
a -> [Bind loc v (Doc ann)] -> Doc ann -> Doc ann
forall a loc ann.
Pretty a =>
[Bind loc a (Doc ann)] -> Doc ann -> Doc ann
onLet [Bind loc v (Doc ann)
v] Doc ann
a
LetRec loc
_ [Bind loc v (Doc ann)]
vs Doc ann
a -> [Bind loc v (Doc ann)] -> Doc ann -> Doc ann
forall a loc ann.
Pretty a =>
[Bind loc a (Doc ann)] -> Doc ann -> Doc ann
onLet [Bind loc v (Doc ann)]
vs Doc ann
a
AssertType loc
_ Doc ann
r Type loc v
sig -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
r, Doc ann
"::", FixityCtx v (Type loc v) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx v (Type loc v) -> Doc ann)
-> FixityCtx v (Type loc v) -> Doc ann
forall a b. (a -> b) -> a -> b
$ (v -> Maybe OpFix) -> Type loc v -> FixityCtx v (Type loc v)
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx v -> Maybe OpFix
getFixity Type loc v
sig]
Constr loc
_ v
tag -> v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
tag
Case loc
_ Doc ann
e [CaseAlt loc v (Doc ann)]
alts -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"case", Doc ann
e, Doc ann
"of"], Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (CaseAlt loc v (Doc ann) -> Doc ann)
-> [CaseAlt loc v (Doc ann)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CaseAlt loc v (Doc ann) -> Doc ann
forall a a ann. Pretty a => CaseAlt a a (Doc ann) -> Doc ann
onAlt [CaseAlt loc v (Doc ann)]
alts]
Bottom loc
_ -> Doc ann
"_|_"
where
onLet :: [Bind loc a (Doc ann)] -> Doc ann -> Doc ann
onLet [Bind loc a (Doc ann)]
vs Doc ann
body =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"let", Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Bind loc a (Doc ann) -> Doc ann)
-> [Bind loc a (Doc ann)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bind{loc
a
Doc ann
bind'rhs :: forall loc var a. Bind loc var a -> a
bind'lhs :: forall loc var a. Bind loc var a -> var
bind'loc :: forall loc var a. Bind loc var a -> loc
bind'rhs :: Doc ann
bind'lhs :: a
bind'loc :: loc
..} -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
bind'lhs, Doc ann
"=", Doc ann
bind'rhs]) [Bind loc a (Doc ann)]
vs]
, [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"in ", Doc ann
body]]
onAlt :: CaseAlt a a (Doc ann) -> Doc ann
onAlt CaseAlt{a
a
[(a, a)]
Doc ann
caseAlt'rhs :: forall loc v a. CaseAlt loc v a -> a
caseAlt'args :: forall loc v a. CaseAlt loc v a -> [(loc, v)]
caseAlt'tag :: forall loc v a. CaseAlt loc v a -> v
caseAlt'loc :: forall loc v a. CaseAlt loc v a -> loc
caseAlt'rhs :: Doc ann
caseAlt'args :: [(a, a)]
caseAlt'tag :: a
caseAlt'loc :: a
..} = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep
[ a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
caseAlt'tag, [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Doc ann) -> [(a, a)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc ann) -> ((a, a) -> a) -> (a, a) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> b
snd) [(a, a)]
caseAlt'args
, Doc ann
"->"
, Doc ann
caseAlt'rhs ]
instance (Pretty loc, PrettyVar var) => Pretty (TypeError loc var) where
pretty :: TypeError loc var -> Doc ann
pretty = FixityCtx var (TypeError loc var) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx var (TypeError loc var) -> Doc ann)
-> (TypeError loc var -> FixityCtx var (TypeError loc var))
-> TypeError loc var
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FixityCtx var a
forall v a. a -> FixityCtx v a
noFixity @var
instance (Pretty loc, PrettyVar var) => Pretty (FixityCtx var (TypeError loc var)) where
pretty :: FixityCtx var (TypeError loc var) -> Doc ann
pretty (FixityCtx var -> Maybe OpFix
getFixity TypeError loc var
tyErr) = case TypeError loc var
tyErr of
OccursErr loc
src Type loc var
name -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"Occurs error", Type loc var -> Doc ann
prettyTy Type loc var
name]
UnifyErr loc
src Type loc var
tyA Type loc var
tyB -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"Type mismatch got", Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
inTicks (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type loc var -> Doc ann
prettyTy Type loc var
tyB, Doc ann
"expected", Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
inTicks (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type loc var -> Doc ann
prettyTy Type loc var
tyA]
NotInScopeErr loc
src var
name -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"Not in scope", var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty var
name]
SubtypeErr loc
src Type loc var
tyA Type loc var
tyB -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"Subtype error", Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
inTicks (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type loc var -> Doc ann
prettyTy Type loc var
tyB, Doc ann
"expected", Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
inTicks (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type loc var -> Doc ann
prettyTy Type loc var
tyA]
EmptyCaseExpr loc
src -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Case-expression should have at least one alternative case"
TypeError loc var
FreshNameFound -> Doc ann
"Impossible happened: failed to eliminate fresh name on type-checker stage"
ConsArityMismatch loc
src var
tag Int
expected Int
actual -> loc -> Doc ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann -> Doc ann
err loc
src (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"Case-expression arguments mismatch for ", var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty var
tag, Doc ann
". Expected ", Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
expected, Doc ann
" arguments, but got ", Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
actual]
where
err :: a -> Doc ann -> Doc ann
err a
src Doc ann
msg = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
src, Doc ann
": error: "], Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ann
msg]
inTicks :: Doc ann -> Doc ann
inTicks Doc ann
x = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [Doc ann
"'", Doc ann
x, Doc ann
"'"]
prettyTy :: Type loc var -> Doc ann
prettyTy = FixityCtx var (Type loc var) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FixityCtx var (Type loc var) -> Doc ann)
-> (Type loc var -> FixityCtx var (Type loc var))
-> Type loc var
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (var -> Maybe OpFix)
-> Type loc var -> FixityCtx var (Type loc var)
forall var a. (var -> Maybe OpFix) -> a -> FixityCtx var a
FixityCtx var -> Maybe OpFix
getFixity