{-# OPTIONS_GHC -Wno-orphans #-}
-- | Pretty printer for types and terms.
module Type.Check.HM.Pretty(
    HasPrefix(..)
  , PrintCons(..)
  , OpFix(..)
  , Fixity(..)
) 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

-- | Class to querry fixity of infix operations.
class IsVar v => HasPrefix v where
  getFixity :: v -> Maybe OpFix

instance HasPrefix Text where
  getFixity :: Text -> Maybe OpFix
getFixity = Maybe OpFix -> Text -> Maybe OpFix
forall a b. a -> b -> a
const Maybe OpFix
forall a. Maybe a
Nothing

instance HasPrefix String where
  getFixity :: String -> Maybe OpFix
getFixity = Maybe OpFix -> String -> Maybe OpFix
forall a b. a -> b -> a
const Maybe OpFix
forall a. Maybe a
Nothing

instance HasPrefix Int where
  getFixity :: Int -> Maybe OpFix
getFixity = Maybe OpFix -> Int -> Maybe OpFix
forall a b. a -> b -> a
const Maybe OpFix
forall a. Maybe a
Nothing

-- | This class is useful to define the way to print special cases
-- like constructors for tuples or lists.
class PrintCons v where
  printCons :: v -> [Doc ann] -> Doc ann

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 :: HasPrefix v => v -> Bool
isPrefix :: v -> Bool
isPrefix = 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
forall v. HasPrefix v => v -> Maybe OpFix
getFixity

isInfix :: HasPrefix v => v -> Bool
isInfix :: v -> Bool
isInfix  = Bool -> Bool
not (Bool -> Bool) -> (v -> Bool) -> v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Bool
forall v. HasPrefix v => v -> Bool
isPrefix

instance (Pretty v, PrintCons v, HasPrefix v) => Pretty (Signature loc v) where
  pretty :: Signature loc v -> Doc ann
pretty = (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
forall loc ann. SignatureF loc v (Doc ann) -> Doc ann
go (Fix (SignatureF loc v) -> Doc ann)
-> (Signature loc v -> Fix (SignatureF loc v))
-> Signature loc v
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature loc v -> Fix (SignatureF loc v)
forall loc var. Signature loc var -> Fix (SignatureF loc var)
unSignature
    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      -> Type loc v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type loc v
ty

instance (HasPrefix v, PrintCons v, Pretty v) => Pretty (Type loc v) where
  pretty :: Type loc v -> Doc ann
pretty = 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)
-> (Type loc v -> Fix (TypeF loc v)) -> Type loc v -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type loc v -> Fix (TypeF loc v)
forall loc var. Type loc var -> Fix (TypeF loc var)
unType
    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 -> Bool
forall v. HasPrefix v => v -> Bool
isInfix 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
forall var loc ann.
(HasPrefix var, PrintCons var, Pretty var) =>
[Fix (TypeF loc var)] -> Doc ann
fromTuple [Fix (TypeF loc v)]
as
        ListT loc
_ Fix (TypeF loc v)
a -> Fix (TypeF loc v) -> Doc ann
forall var loc ann.
(HasPrefix var, PrintCons var, Pretty var) =>
Fix (TypeF loc var) -> 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
&& FixityContext v -> Operator v -> Bool
forall v. HasPrefix v => FixityContext v -> Operator v -> Bool
needsParens 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 (FixityContext v -> Operator v -> Bool
forall v. HasPrefix v => FixityContext v -> Operator v -> Bool
needsParens 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 (FixityContext v -> Operator v -> Bool
forall v. HasPrefix v => FixityContext v -> Operator v -> Bool
needsParens 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 var)] -> Doc ann
fromTuple [Fix (TypeF loc var)]
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 var) -> Doc ann)
-> [Fix (TypeF loc var)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type loc var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type loc var -> Doc ann)
-> (Fix (TypeF loc var) -> Type loc var)
-> Fix (TypeF loc var)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix (TypeF loc var) -> Type loc var
forall loc var. Fix (TypeF loc var) -> Type loc var
Type) [Fix (TypeF loc var)]
as

          fromList :: Fix (TypeF loc var) -> Doc ann
fromList Fix (TypeF loc var)
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
$ Type loc var -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type loc var -> Doc ann) -> Type loc var -> Doc ann
forall a b. (a -> b) -> a -> b
$ Fix (TypeF loc var) -> Type loc var
forall loc var. Fix (TypeF loc var) -> Type loc var
Type Fix (TypeF loc var)
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 :: HasPrefix v => FixityContext v -> Operator v -> Bool
needsParens :: FixityContext v -> Operator v -> Bool
needsParens = \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
forall v. HasPrefix v => Operator v -> Operator v -> Bool
fcLeft Operator v
ctx
  FcRight Operator v
ctx -> Operator v -> Operator v -> Bool
forall v. HasPrefix v => 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
forall v.
HasPrefix v =>
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
forall v.
HasPrefix v =>
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
forall v.
HasPrefix v =>
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
      -- otherwise the two operators have the same precedence
      | Operator v -> Fixity
forall v. HasPrefix v => Operator v -> Fixity
fixity Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Operator v -> Fixity
forall v. HasPrefix v => Operator v -> Fixity
fixity Operator v
op = Bool
True
      | Operator v -> Fixity
forall v. HasPrefix v => 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
forall v.
HasPrefix v =>
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
forall v.
HasPrefix v =>
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
forall v.
HasPrefix v =>
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
      -- otherwise the two operators have the same precedence
      | Operator v -> Fixity
forall v. HasPrefix v => Operator v -> Fixity
fixity Operator v
ctxt Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Operator v -> Fixity
forall v. HasPrefix v => Operator v -> Fixity
fixity Operator v
op = Bool
True
      | Operator v -> Fixity
forall v. HasPrefix v => 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

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

-- | Defines fixity type and order of infix operation
data OpFix = OpFix
  { OpFix -> Fixity
opFix'fixity :: !Fixity
  -- ^ fixity type
  , OpFix -> Int
opFix'prec   :: !Int
  -- ^ fixity order
  }

-- | Infix operation can be left or right associative or associativity is not known.
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)

{-
initEnv :: FixityEnv
initEnv = Map.fromList
  [ (Op "->", OpFix FixRight 2) ]
-}

getFixityEnv :: HasPrefix v => Operator v -> Maybe OpFix
getFixityEnv :: Operator v -> Maybe OpFix
getFixityEnv = \case
  Operator v
OpFunAp -> Maybe OpFix
forall a. Maybe a
Nothing
  Op v
v    -> v -> Maybe OpFix
forall v. HasPrefix 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 :: HasPrefix v => Operator v -> Operator v -> PartialOrdering
comparePrec :: Operator v -> Operator v -> PartialOrdering
comparePrec Operator v
a Operator v
b = case (Operator v -> Maybe OpFix
forall v. HasPrefix v => Operator v -> Maybe OpFix
getFixityEnv Operator v
a, Operator v -> Maybe OpFix
forall v. HasPrefix v => Operator v -> Maybe OpFix
getFixityEnv 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 :: HasPrefix v => Operator v -> Fixity
fixity :: Operator v -> Fixity
fixity 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
$ Operator v -> Maybe OpFix
forall v. HasPrefix v => Operator v -> Maybe OpFix
getFixityEnv Operator v
op

---------------------------------------

instance (HasPrefix v, PrintCons v, Pretty v, Pretty prim) => Pretty (Term prim loc v) where
  pretty :: Term prim loc v -> Doc ann
pretty (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
forall a ann. TermF prim a v (Doc ann) -> Doc ann
prettyTermF Fix (TermF prim loc v)
x
    where
      prettyTermF :: TermF prim a v (Doc ann) -> Doc ann
prettyTermF = \case
        Var a
_ v
v            -> v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
v
        Prim a
_ prim
p           -> prim -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty prim
p
        App a
_ 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 a
_ 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 a
_ Bind a v (Doc ann)
v Doc ann
a          -> [Bind a v (Doc ann)] -> Doc ann -> Doc ann
forall a loc ann.
Pretty a =>
[Bind loc a (Doc ann)] -> Doc ann -> Doc ann
onLet [Bind a v (Doc ann)
v] Doc ann
a
        LetRec a
_ [Bind a v (Doc ann)]
vs Doc ann
a      -> [Bind a v (Doc ann)] -> Doc ann -> Doc ann
forall a loc ann.
Pretty a =>
[Bind loc a (Doc ann)] -> Doc ann -> Doc ann
onLet [Bind a v (Doc ann)]
vs Doc ann
a
        AssertType a
_ Doc ann
r Type a 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
"::", Type a v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type a v
sig]
        Constr a
_ Type a v
_ v
tag     -> v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty v
tag
        Case a
_ Doc ann
e [CaseAlt a 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 a v (Doc ann) -> Doc ann)
-> [CaseAlt a v (Doc ann)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CaseAlt a v (Doc ann) -> Doc ann
forall a a ann. Pretty a => CaseAlt a a (Doc ann) -> Doc ann
onAlt [CaseAlt a v (Doc ann)]
alts]
        Bottom a
_           -> 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 r. Bind loc var r -> r
bind'lhs :: forall loc var r. Bind loc var r -> var
bind'loc :: forall loc var r. Bind loc var r -> 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
[Typed a a (a, a)]
Doc ann
Type a a
caseAlt'rhs :: forall loc v a. CaseAlt loc v a -> a
caseAlt'constrType :: forall loc v a. CaseAlt loc v a -> Type loc v
caseAlt'args :: forall loc v a. CaseAlt loc v a -> [Typed loc v (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'constrType :: Type a a
caseAlt'args :: [Typed a a (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
$ (Typed a a (a, a) -> Doc ann) -> [Typed a a (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)
-> (Typed a a (a, a) -> a) -> Typed 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) -> a)
-> (Typed a a (a, a) -> (a, a)) -> Typed a a (a, a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed a a (a, a) -> (a, a)
forall loc v a. Typed loc v a -> a
typed'value) [Typed a a (a, a)]
caseAlt'args
            , Doc ann
"->"
            , Doc ann
caseAlt'rhs ]