{-# OPTIONS_GHC -Wno-orphans #-}
-- | Pretty printer for types and terms.
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

-- | Type to querry fixity of infix operations in type variables.
data FixityCtx var a = FixityCtx
  { FixityCtx var a -> var -> Maybe OpFix
fixity'context :: var -> Maybe OpFix   -- ^ Function that provides fixity-type for a given variable
  , FixityCtx var a -> a
fixity'data    :: a                    -- ^ content
  }

-- | Ignores fixity information
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)

-- | 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 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
      -- otherwise the two operators have the same precedence
      | 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
      -- otherwise the two operators have the same precedence
      | 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

-- | 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 :: (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

-----------------------------------------------------------------
-- pretty terms

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 ]

-----------------------------------------------------------------
-- pretty errors

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