{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Typechecker.Context
  ( synthesizeClosed,
    ErrorNote (..),
    CompilerBug (..),
    InfoNote (..),
    Cause (..),
    Context (..),
    ActualArgCount,
    ExpectedArgCount,
    ConstructorId,
    Element (..),
    PathElement (..),
    Term,
    Type,
    TypeVar,
    Result (..),
    PatternMatchCoverageCheckAndKindInferenceSwitch (..),
    errorTerms,
    innermostErrorTerm,
    lookupAnn,
    lookupSolved,
    apply,
    isEqual,
    isSubtype,
    fitsScheme,
    isRedundant,
    Suggestion (..),
    Replacement (..),
    SuggestionMatch (..),
    isExact,
    typeErrors,
    infoNotes,
    Unknown (..),
    relax,
    generalizeAndUnTypeVar,
  )
where

import Control.Lens (_2)
import Control.Monad.Fail qualified as MonadFail
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.State
  ( MonadState,
    StateT,
    evalState,
    evalStateT,
    get,
    gets,
    put,
    runStateT,
  )
import Data.Foldable qualified as Foldable
import Data.Function (on)
import Data.Functor.Compose
import Data.List
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as Nel
import Data.Map qualified as Map
import Data.Monoid (Ap (..))
import Data.Sequence qualified as Seq
import Data.Sequence.NonEmpty (NESeq)
import Data.Sequence.NonEmpty qualified as NESeq
import Data.Set qualified as Set
import Data.Text qualified as Text
import Unison.ABT qualified as ABT
import Unison.Blank qualified as B
import Unison.Builtin.Decls qualified as DDB
import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation)
import Unison.ConstructorReference
  ( ConstructorReference,
    GConstructorReference (..),
    reference_,
  )
import Unison.DataDeclaration
  ( DataDeclaration,
    EffectDeclaration,
  )
import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.KindInference qualified as KindInference
import Unison.Name (Name)
import Unison.Pattern (Pattern)
import Unison.Pattern qualified as Pattern
import Unison.PatternMatchCoverage (checkMatch)
import Unison.PatternMatchCoverage.Class (EnumeratedConstructors (..), Pmc, traverseConstructorTypes)
import Unison.PatternMatchCoverage.Class qualified as Pmc
import Unison.PatternMatchCoverage.ListPat qualified as ListPat
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv)
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Syntax.TypePrinter qualified as TP
import Unison.Term qualified as Term
import Unison.Type qualified as Type
import Unison.Typechecker.Components (minimize')
import Unison.Typechecker.TypeLookup qualified as TL
import Unison.Typechecker.TypeVar qualified as TypeVar
import Unison.Var (Var)
import Unison.Var qualified as Var

type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v

type Type v loc = Type.Type (TypeVar v loc) loc

type Term v loc = Term.Term' (TypeVar v loc) v loc

type Monotype v loc = Type.Monotype (TypeVar v loc) loc

type RedundantTypeAnnotation = Bool

type Wanted v loc = [(Maybe (Term v loc), Type v loc)]

pattern Universal :: v -> Element v loc
pattern $mUniversal :: forall {r} {v} {loc}.
Element v loc -> (v -> r) -> ((# #) -> r) -> r
$bUniversal :: forall v loc. v -> Element v loc
Universal v = Var (TypeVar.Universal v)

pattern Existential :: B.Blank loc -> v -> Element v loc
pattern $mExistential :: forall {r} {loc} {v}.
Element v loc -> (Blank loc -> v -> r) -> ((# #) -> r) -> r
Existential b v <- Var (TypeVar.Existential b v)

existential :: v -> Element v loc
existential :: forall v loc. v -> Element v loc
existential v
v = TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (Blank loc -> v -> TypeVar v loc
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v)

existential' :: (Ord v) => a -> B.Blank loc -> v -> Type.Type (TypeVar v loc) a
existential' :: forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' a
a Blank loc
blank v
v = a -> TypeVar v loc -> Term F (TypeVar v loc) a
forall a v (f :: * -> *). a -> v -> Term f v a
ABT.annotatedVar a
a (Blank loc -> v -> TypeVar v loc
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
blank v
v)

existentialp :: (Ord v) => a -> v -> Type v a
existentialp :: forall v a. Ord v => a -> v -> Type v a
existentialp a
a = a -> Blank a -> v -> Type (TypeVar v a) a
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' a
a Blank a
forall loc. Blank loc
B.Blank

universal' :: (Ord v) => a -> v -> Type.Type (TypeVar v loc) a
universal' :: forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' a
a v
v = a -> TypeVar v loc -> Term F (TypeVar v loc) a
forall a v (f :: * -> *). a -> v -> Term f v a
ABT.annotatedVar a
a (v -> TypeVar v loc
forall b v. v -> TypeVar b v
TypeVar.Universal v
v)

-- | Elements of an ordered algorithmic context
data Element v loc
  = -- | A variable declaration
    Var (TypeVar v loc)
  | -- | `v` is solved to some monotype
    Solved (B.Blank loc) v (Monotype v loc)
  | -- | `v` has type `a`, maybe quantified
    Ann v (Type v loc)
  | -- | used for scoping
    Marker v

instance (Ord loc, Var v) => Eq (Element v loc) where
  Var TypeVar v loc
v == :: Element v loc -> Element v loc -> Bool
== Var TypeVar v loc
v2 = TypeVar v loc
v TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVar v loc
v2
  Solved Blank loc
_ v
v Monotype v loc
t == Solved Blank loc
_ v
v2 Monotype v loc
t2 = v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2 Bool -> Bool -> Bool
&& Monotype v loc
t Monotype v loc -> Monotype v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Monotype v loc
t2
  Ann v
v Type v loc
t == Ann v
v2 Type v loc
t2 = v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2 Bool -> Bool -> Bool
&& Type v loc
t Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Type v loc
t2
  Marker v
v == Marker v
v2 = v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2
  Element v loc
_ == Element v loc
_ = Bool
False

-- The typechecking state
data Env v loc = Env {forall v loc. Env v loc -> Word64
freshId :: Word64, forall v loc. Env v loc -> Context v loc
ctx :: Context v loc}

type DataDeclarations v loc = Map Reference (DataDeclaration v loc)

type EffectDeclarations v loc = Map Reference (EffectDeclaration v loc)

data Result v loc a
  = Success !(Seq (InfoNote v loc)) !a
  | TypeError !(NESeq (ErrorNote v loc)) !(Seq (InfoNote v loc))
  | CompilerBug
      !(CompilerBug v loc)
      !(Seq (ErrorNote v loc)) -- type errors before hitting the bug
      !(Seq (InfoNote v loc)) -- info notes before hitting the bug
  deriving ((forall a b. (a -> b) -> Result v loc a -> Result v loc b)
-> (forall a b. a -> Result v loc b -> Result v loc a)
-> Functor (Result v loc)
forall a b. a -> Result v loc b -> Result v loc a
forall a b. (a -> b) -> Result v loc a -> Result v loc b
forall v loc a b. a -> Result v loc b -> Result v loc a
forall v loc a b. (a -> b) -> Result v loc a -> Result v loc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v loc a b. (a -> b) -> Result v loc a -> Result v loc b
fmap :: forall a b. (a -> b) -> Result v loc a -> Result v loc b
$c<$ :: forall v loc a b. a -> Result v loc b -> Result v loc a
<$ :: forall a b. a -> Result v loc b -> Result v loc a
Functor)

instance Applicative (Result v loc) where
  pure :: forall a. a -> Result v loc a
pure = Seq (InfoNote v loc) -> a -> Result v loc a
forall v loc a. Seq (InfoNote v loc) -> a -> Result v loc a
Success Seq (InfoNote v loc)
forall a. Monoid a => a
mempty
  CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
is <*> :: forall a b.
Result v loc (a -> b) -> Result v loc a -> Result v loc b
<*> Result v loc a
_ = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
is
  Result v loc (a -> b)
r <*> CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es' Seq (InfoNote v loc)
is' = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug (Result v loc (a -> b) -> Seq (ErrorNote v loc)
forall v loc a. Result v loc a -> Seq (ErrorNote v loc)
typeErrors Result v loc (a -> b)
r Seq (ErrorNote v loc)
-> Seq (ErrorNote v loc) -> Seq (ErrorNote v loc)
forall a. Semigroup a => a -> a -> a
<> Seq (ErrorNote v loc)
es') (Result v loc (a -> b) -> Seq (InfoNote v loc)
forall v loc a. Result v loc a -> Seq (InfoNote v loc)
infoNotes Result v loc (a -> b)
r Seq (InfoNote v loc)
-> Seq (InfoNote v loc) -> Seq (InfoNote v loc)
forall a. Semigroup a => a -> a -> a
<> Seq (InfoNote v loc)
is')
  TypeError NESeq (ErrorNote v loc)
es Seq (InfoNote v loc)
is <*> Result v loc a
r' = NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError (NESeq (ErrorNote v loc)
es NESeq (ErrorNote v loc)
-> Seq (ErrorNote v loc) -> NESeq (ErrorNote v loc)
forall a. NESeq a -> Seq a -> NESeq a
NESeq.|>< (Result v loc a -> Seq (ErrorNote v loc)
forall v loc a. Result v loc a -> Seq (ErrorNote v loc)
typeErrors Result v loc a
r')) (Seq (InfoNote v loc)
is Seq (InfoNote v loc)
-> Seq (InfoNote v loc) -> Seq (InfoNote v loc)
forall a. Semigroup a => a -> a -> a
<> Result v loc a -> Seq (InfoNote v loc)
forall v loc a. Result v loc a -> Seq (InfoNote v loc)
infoNotes Result v loc a
r')
  Success Seq (InfoNote v loc)
is a -> b
_ <*> TypeError NESeq (ErrorNote v loc)
es' Seq (InfoNote v loc)
is' = NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError NESeq (ErrorNote v loc)
es' (Seq (InfoNote v loc)
is Seq (InfoNote v loc)
-> Seq (InfoNote v loc) -> Seq (InfoNote v loc)
forall a. Semigroup a => a -> a -> a
<> Seq (InfoNote v loc)
is')
  Success Seq (InfoNote v loc)
is a -> b
f <*> Success Seq (InfoNote v loc)
is' a
a = Seq (InfoNote v loc) -> b -> Result v loc b
forall v loc a. Seq (InfoNote v loc) -> a -> Result v loc a
Success (Seq (InfoNote v loc)
is Seq (InfoNote v loc)
-> Seq (InfoNote v loc) -> Seq (InfoNote v loc)
forall a. Semigroup a => a -> a -> a
<> Seq (InfoNote v loc)
is') (a -> b
f a
a)
  {-# INLINE (<*>) #-}

instance Monad (Result v loc) where
  s :: Result v loc a
s@(Success Seq (InfoNote v loc)
_ a
a) >>= :: forall a b.
Result v loc a -> (a -> Result v loc b) -> Result v loc b
>>= a -> Result v loc b
f = Result v loc a
s Result v loc a -> Result v loc b -> Result v loc b
forall a b. Result v loc a -> Result v loc b -> Result v loc b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> Result v loc b
f a
a
  TypeError NESeq (ErrorNote v loc)
es Seq (InfoNote v loc)
is >>= a -> Result v loc b
_ = NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError NESeq (ErrorNote v loc)
es Seq (InfoNote v loc)
is
  CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
is >>= a -> Result v loc b
_ = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc b
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
is
  {-# INLINE (>>=) #-}

instance MonadFix (Result v loc) where
  mfix :: forall a. (a -> Result v loc a) -> Result v loc a
mfix a -> Result v loc a
f =
    let res :: Result v loc a
res = a -> Result v loc a
f a
theA
        theA :: a
theA = case Result v loc a
res of
          Success Seq (InfoNote v loc)
_ a
a -> a
a
          Result v loc a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"mfix Result: forced an unsuccessful value"
     in Result v loc a
res

btw' :: InfoNote v loc -> Result v loc ()
btw' :: forall v loc. InfoNote v loc -> Result v loc ()
btw' InfoNote v loc
note = Seq (InfoNote v loc) -> () -> Result v loc ()
forall v loc a. Seq (InfoNote v loc) -> a -> Result v loc a
Success (InfoNote v loc -> Seq (InfoNote v loc)
forall a. a -> Seq a
Seq.singleton InfoNote v loc
note) ()

typeError :: Cause v loc -> Result v loc a
typeError :: forall v loc a. Cause v loc -> Result v loc a
typeError Cause v loc
cause = NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError (ErrorNote v loc -> NESeq (ErrorNote v loc)
forall a. a -> NESeq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorNote v loc -> NESeq (ErrorNote v loc))
-> ErrorNote v loc -> NESeq (ErrorNote v loc)
forall a b. (a -> b) -> a -> b
$ Cause v loc -> Seq (PathElement v loc) -> ErrorNote v loc
forall v loc.
Cause v loc -> Seq (PathElement v loc) -> ErrorNote v loc
ErrorNote Cause v loc
cause Seq (PathElement v loc)
forall a. Monoid a => a
mempty) Seq (InfoNote v loc)
forall a. Monoid a => a
mempty

compilerBug :: CompilerBug v loc -> Result v loc a
compilerBug :: forall v loc a. CompilerBug v loc -> Result v loc a
compilerBug CompilerBug v loc
bug = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
forall a. Monoid a => a
mempty Seq (InfoNote v loc)
forall a. Monoid a => a
mempty

typeErrors :: Result v loc a -> Seq (ErrorNote v loc)
typeErrors :: forall v loc a. Result v loc a -> Seq (ErrorNote v loc)
typeErrors = \case
  TypeError NESeq (ErrorNote v loc)
es Seq (InfoNote v loc)
_ -> NESeq (ErrorNote v loc) -> Seq (ErrorNote v loc)
forall a. NESeq a -> Seq a
NESeq.toSeq NESeq (ErrorNote v loc)
es
  CompilerBug CompilerBug v loc
_ Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
_ -> Seq (ErrorNote v loc)
es
  Success Seq (InfoNote v loc)
_ a
_ -> Seq (ErrorNote v loc)
forall a. Monoid a => a
mempty

infoNotes :: Result v loc a -> Seq (InfoNote v loc)
infoNotes :: forall v loc a. Result v loc a -> Seq (InfoNote v loc)
infoNotes = \case
  TypeError NESeq (ErrorNote v loc)
_ Seq (InfoNote v loc)
is -> Seq (InfoNote v loc)
is
  CompilerBug CompilerBug v loc
_ Seq (ErrorNote v loc)
_ Seq (InfoNote v loc)
is -> Seq (InfoNote v loc)
is
  Success Seq (InfoNote v loc)
is a
_ -> Seq (InfoNote v loc)
is

mapErrors :: (ErrorNote v loc -> ErrorNote v loc) -> Result v loc a -> Result v loc a
mapErrors :: forall v loc a.
(ErrorNote v loc -> ErrorNote v loc)
-> Result v loc a -> Result v loc a
mapErrors ErrorNote v loc -> ErrorNote v loc
f Result v loc a
r = case Result v loc a
r of
  TypeError NESeq (ErrorNote v loc)
es Seq (InfoNote v loc)
is -> NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError (ErrorNote v loc -> ErrorNote v loc
f (ErrorNote v loc -> ErrorNote v loc)
-> NESeq (ErrorNote v loc) -> NESeq (ErrorNote v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NESeq (ErrorNote v loc)
es) Seq (InfoNote v loc)
is
  CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
es Seq (InfoNote v loc)
is -> CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug (ErrorNote v loc -> ErrorNote v loc
f (ErrorNote v loc -> ErrorNote v loc)
-> Seq (ErrorNote v loc) -> Seq (ErrorNote v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (ErrorNote v loc)
es) Seq (InfoNote v loc)
is
  s :: Result v loc a
s@(Success Seq (InfoNote v loc)
_ a
_) -> Result v loc a
s

-- Allows modifying the stored notes in a scoped way.
-- This is based on the `pass` function in e.g. Control.Monad.Writer
adjustResultNotes ::
  Result v loc (a, InfoNote v loc -> InfoNote v loc) ->
  Result v loc a
adjustResultNotes :: forall v loc a.
Result v loc (a, InfoNote v loc -> InfoNote v loc)
-> Result v loc a
adjustResultNotes (Success Seq (InfoNote v loc)
notes (a
r, InfoNote v loc -> InfoNote v loc
f)) = Seq (InfoNote v loc) -> a -> Result v loc a
forall v loc a. Seq (InfoNote v loc) -> a -> Result v loc a
Success ((InfoNote v loc -> InfoNote v loc)
-> Seq (InfoNote v loc) -> Seq (InfoNote v loc)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InfoNote v loc -> InfoNote v loc
f Seq (InfoNote v loc)
notes) a
r
adjustResultNotes (TypeError NESeq (ErrorNote v loc)
e Seq (InfoNote v loc)
i) = NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
NESeq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
TypeError NESeq (ErrorNote v loc)
e Seq (InfoNote v loc)
i
adjustResultNotes (CompilerBug CompilerBug v loc
c Seq (ErrorNote v loc)
e Seq (InfoNote v loc)
i) = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
c Seq (ErrorNote v loc)
e Seq (InfoNote v loc)
i

data PatternMatchCoverageCheckAndKindInferenceSwitch
  = PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled
  | PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled

newtype MT v loc f a = MT
  { forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM ::
      -- for debug output
      PrettyPrintEnv ->
      PatternMatchCoverageCheckAndKindInferenceSwitch ->
      -- Data declarations in scope
      DataDeclarations v loc ->
      -- Effect declarations in scope
      EffectDeclarations v loc ->
      Env v loc ->
      f (a, Env v loc)
  }
  deriving stock ((forall a b. (a -> b) -> MT v loc f a -> MT v loc f b)
-> (forall a b. a -> MT v loc f b -> MT v loc f a)
-> Functor (MT v loc f)
forall a b. a -> MT v loc f b -> MT v loc f a
forall a b. (a -> b) -> MT v loc f a -> MT v loc f b
forall v loc (f :: * -> *) a b.
Functor f =>
a -> MT v loc f b -> MT v loc f a
forall v loc (f :: * -> *) a b.
Functor f =>
(a -> b) -> MT v loc f a -> MT v loc f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v loc (f :: * -> *) a b.
Functor f =>
(a -> b) -> MT v loc f a -> MT v loc f b
fmap :: forall a b. (a -> b) -> MT v loc f a -> MT v loc f b
$c<$ :: forall v loc (f :: * -> *) a b.
Functor f =>
a -> MT v loc f b -> MT v loc f a
<$ :: forall a b. a -> MT v loc f b -> MT v loc f a
Functor)

-- | Typechecking monad
type M v loc = MT v loc (Result v loc)

-- | Typechecking computation that, unless it crashes
-- with a compiler bug, always produces a value.
type TotalM v loc = MT v loc (Either (CompilerBug v loc))

liftResult :: Result v loc a -> M v loc a
liftResult :: forall v loc a. Result v loc a -> M v loc a
liftResult Result v loc a
r = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT (\PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (,Env v loc
env) (a -> (a, Env v loc))
-> Result v loc a -> Result v loc (a, Env v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result v loc a
r)

liftTotalM :: TotalM v loc a -> M v loc a
liftTotalM :: forall v loc a. TotalM v loc a -> M v loc a
liftTotalM (MT PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Either (CompilerBug v loc) (a, Env v loc)
m) = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT ((PrettyPrintEnv
  -> PatternMatchCoverageCheckAndKindInferenceSwitch
  -> DataDeclarations v loc
  -> EffectDeclarations v loc
  -> Env v loc
  -> Result v loc (a, Env v loc))
 -> MT v loc (Result v loc) a)
-> (PrettyPrintEnv
    -> PatternMatchCoverageCheckAndKindInferenceSwitch
    -> DataDeclarations v loc
    -> EffectDeclarations v loc
    -> Env v loc
    -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall a b. (a -> b) -> a -> b
$ \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env -> case PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Either (CompilerBug v loc) (a, Env v loc)
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env of
  Left CompilerBug v loc
bug -> CompilerBug v loc
-> Seq (ErrorNote v loc)
-> Seq (InfoNote v loc)
-> Result v loc (a, Env v loc)
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
forall a. Monoid a => a
mempty Seq (InfoNote v loc)
forall a. Monoid a => a
mempty
  Right (a, Env v loc)
a -> Seq (InfoNote v loc)
-> (a, Env v loc) -> Result v loc (a, Env v loc)
forall v loc a. Seq (InfoNote v loc) -> a -> Result v loc a
Success Seq (InfoNote v loc)
forall a. Monoid a => a
mempty (a, Env v loc)
a

-- Allows modifying the stored notes in a scoped way.
-- This is based on the `pass` function in e.g. Control.Monad.Writer
adjustNotes ::
  M v loc (a, InfoNote v loc -> InfoNote v loc) -> M v loc a
adjustNotes :: forall v loc a.
M v loc (a, InfoNote v loc -> InfoNote v loc) -> M v loc a
adjustNotes (MT PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc ((a, InfoNote v loc -> InfoNote v loc), Env v loc)
m) = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT ((PrettyPrintEnv
  -> PatternMatchCoverageCheckAndKindInferenceSwitch
  -> DataDeclarations v loc
  -> EffectDeclarations v loc
  -> Env v loc
  -> Result v loc (a, Env v loc))
 -> MT v loc (Result v loc) a)
-> (PrettyPrintEnv
    -> PatternMatchCoverageCheckAndKindInferenceSwitch
    -> DataDeclarations v loc
    -> EffectDeclarations v loc
    -> Env v loc
    -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall a b. (a -> b) -> a -> b
$ \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env ->
  Result v loc ((a, Env v loc), InfoNote v loc -> InfoNote v loc)
-> Result v loc (a, Env v loc)
forall v loc a.
Result v loc (a, InfoNote v loc -> InfoNote v loc)
-> Result v loc a
adjustResultNotes (((a, InfoNote v loc -> InfoNote v loc), Env v loc)
-> ((a, Env v loc), InfoNote v loc -> InfoNote v loc)
forall {a} {b} {b}. ((a, b), b) -> ((a, b), b)
twiddle (((a, InfoNote v loc -> InfoNote v loc), Env v loc)
 -> ((a, Env v loc), InfoNote v loc -> InfoNote v loc))
-> Result v loc ((a, InfoNote v loc -> InfoNote v loc), Env v loc)
-> Result v loc ((a, Env v loc), InfoNote v loc -> InfoNote v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc ((a, InfoNote v loc -> InfoNote v loc), Env v loc)
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env)
  where
    twiddle :: ((a, b), b) -> ((a, b), b)
twiddle ((a
a, b
c), b
b) = ((a
a, b
b), b
c)

-- errorNote :: Cause v loc -> M v loc ()
-- errorNote = liftResult . errorNote

btw :: InfoNote v loc -> M v loc ()
btw :: forall v loc. InfoNote v loc -> M v loc ()
btw = Result v loc () -> M v loc ()
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc () -> M v loc ())
-> (InfoNote v loc -> Result v loc ())
-> InfoNote v loc
-> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InfoNote v loc -> Result v loc ()
forall v loc. InfoNote v loc -> Result v loc ()
btw'

modEnv :: (Env v loc -> Env v loc) -> M v loc ()
modEnv :: forall v loc. (Env v loc -> Env v loc) -> M v loc ()
modEnv Env v loc -> Env v loc
f = (Env v loc -> ((), Env v loc)) -> M v loc ()
forall v loc a. (Env v loc -> (a, Env v loc)) -> M v loc a
modEnv' ((Env v loc -> ((), Env v loc)) -> M v loc ())
-> (Env v loc -> ((), Env v loc)) -> M v loc ()
forall a b. (a -> b) -> a -> b
$ ((),) (Env v loc -> ((), Env v loc))
-> (Env v loc -> Env v loc) -> Env v loc -> ((), Env v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env v loc -> Env v loc
f

modEnv' :: (Env v loc -> (a, Env v loc)) -> M v loc a
modEnv' :: forall v loc a. (Env v loc -> (a, Env v loc)) -> M v loc a
modEnv' Env v loc -> (a, Env v loc)
f = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT (\PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (a, Env v loc) -> Result v loc (a, Env v loc)
forall a. a -> Result v loc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Env v loc) -> Result v loc (a, Env v loc))
-> (Env v loc -> (a, Env v loc))
-> Env v loc
-> Result v loc (a, Env v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env v loc -> (a, Env v loc)
f (Env v loc -> Result v loc (a, Env v loc))
-> Env v loc -> Result v loc (a, Env v loc)
forall a b. (a -> b) -> a -> b
$ Env v loc
env)

data Unknown = Data | Effect deriving (Int -> Unknown -> ShowS
[Unknown] -> ShowS
Unknown -> [Char]
(Int -> Unknown -> ShowS)
-> (Unknown -> [Char]) -> ([Unknown] -> ShowS) -> Show Unknown
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Unknown -> ShowS
showsPrec :: Int -> Unknown -> ShowS
$cshow :: Unknown -> [Char]
show :: Unknown -> [Char]
$cshowList :: [Unknown] -> ShowS
showList :: [Unknown] -> ShowS
Show)

data CompilerBug v loc
  = UnknownDecl Unknown Reference (Map Reference (DataDeclaration v loc))
  | UnknownConstructor Unknown ConstructorReference (DataDeclaration v loc)
  | UndeclaredTermVariable v (Context v loc)
  | RetractFailure (Element v loc) (Context v loc)
  | EmptyLetRec (Term v loc) -- the body of the empty let rec
  | PatternMatchFailure
  | EffectConstructorHadMultipleEffects (Type v loc)
  | FreeVarsInTypeAnnotation (Set (TypeVar v loc))
  | UnannotatedReference Reference
  | MalformedPattern (Pattern loc)
  | UnknownTermReference Reference
  | UnknownExistentialVariable v (Context v loc)
  | -- `IllegalContextExtension ctx elem msg`
    --     extending `ctx` with `elem` would make `ctx` ill-formed, as explained by `msg`
    IllegalContextExtension (Context v loc) (Element v loc) String
  | OtherBug String
  deriving (Int -> CompilerBug v loc -> ShowS
[CompilerBug v loc] -> ShowS
CompilerBug v loc -> [Char]
(Int -> CompilerBug v loc -> ShowS)
-> (CompilerBug v loc -> [Char])
-> ([CompilerBug v loc] -> ShowS)
-> Show (CompilerBug v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> CompilerBug v loc -> ShowS
forall v loc.
(Var v, Show loc, Ord loc) =>
[CompilerBug v loc] -> ShowS
forall v loc.
(Var v, Show loc, Ord loc) =>
CompilerBug v loc -> [Char]
$cshowsPrec :: forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> CompilerBug v loc -> ShowS
showsPrec :: Int -> CompilerBug v loc -> ShowS
$cshow :: forall v loc.
(Var v, Show loc, Ord loc) =>
CompilerBug v loc -> [Char]
show :: CompilerBug v loc -> [Char]
$cshowList :: forall v loc.
(Var v, Show loc, Ord loc) =>
[CompilerBug v loc] -> ShowS
showList :: [CompilerBug v loc] -> ShowS
Show)

data PathElement v loc
  = InSynthesize (Term v loc)
  | InSubtype (Type v loc) (Type v loc)
  | InEquate (Type v loc) (Type v loc)
  | InCheck (Term v loc) (Type v loc)
  | InInstantiateL v (Type v loc)
  | InInstantiateR (Type v loc) v
  | InSynthesizeApp (Type v loc) (Term v loc) Int
  | InFunctionCall [v] (Term v loc) (Type v loc) [Term v loc]
  | InAndApp
  | InOrApp
  | InIfCond
  | InIfBody loc -- location of `then` expression
  | InVectorApp loc -- location of 1st vector element
  | InMatch loc -- location of 1st case body
  | InMatchGuard
  | InMatchBody
  deriving (Int -> PathElement v loc -> ShowS
[PathElement v loc] -> ShowS
PathElement v loc -> [Char]
(Int -> PathElement v loc -> ShowS)
-> (PathElement v loc -> [Char])
-> ([PathElement v loc] -> ShowS)
-> Show (PathElement v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc.
(Show v, Show loc) =>
Int -> PathElement v loc -> ShowS
forall v loc. (Show v, Show loc) => [PathElement v loc] -> ShowS
forall v loc. (Show v, Show loc) => PathElement v loc -> [Char]
$cshowsPrec :: forall v loc.
(Show v, Show loc) =>
Int -> PathElement v loc -> ShowS
showsPrec :: Int -> PathElement v loc -> ShowS
$cshow :: forall v loc. (Show v, Show loc) => PathElement v loc -> [Char]
show :: PathElement v loc -> [Char]
$cshowList :: forall v loc. (Show v, Show loc) => [PathElement v loc] -> ShowS
showList :: [PathElement v loc] -> ShowS
Show)

type ExpectedArgCount = Int

type ActualArgCount = Int

data SuggestionMatch = Exact | WrongType | WrongName
  deriving (Eq SuggestionMatch
Eq SuggestionMatch =>
(SuggestionMatch -> SuggestionMatch -> Ordering)
-> (SuggestionMatch -> SuggestionMatch -> Bool)
-> (SuggestionMatch -> SuggestionMatch -> Bool)
-> (SuggestionMatch -> SuggestionMatch -> Bool)
-> (SuggestionMatch -> SuggestionMatch -> Bool)
-> (SuggestionMatch -> SuggestionMatch -> SuggestionMatch)
-> (SuggestionMatch -> SuggestionMatch -> SuggestionMatch)
-> Ord SuggestionMatch
SuggestionMatch -> SuggestionMatch -> Bool
SuggestionMatch -> SuggestionMatch -> Ordering
SuggestionMatch -> SuggestionMatch -> SuggestionMatch
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
$ccompare :: SuggestionMatch -> SuggestionMatch -> Ordering
compare :: SuggestionMatch -> SuggestionMatch -> Ordering
$c< :: SuggestionMatch -> SuggestionMatch -> Bool
< :: SuggestionMatch -> SuggestionMatch -> Bool
$c<= :: SuggestionMatch -> SuggestionMatch -> Bool
<= :: SuggestionMatch -> SuggestionMatch -> Bool
$c> :: SuggestionMatch -> SuggestionMatch -> Bool
> :: SuggestionMatch -> SuggestionMatch -> Bool
$c>= :: SuggestionMatch -> SuggestionMatch -> Bool
>= :: SuggestionMatch -> SuggestionMatch -> Bool
$cmax :: SuggestionMatch -> SuggestionMatch -> SuggestionMatch
max :: SuggestionMatch -> SuggestionMatch -> SuggestionMatch
$cmin :: SuggestionMatch -> SuggestionMatch -> SuggestionMatch
min :: SuggestionMatch -> SuggestionMatch -> SuggestionMatch
Ord, SuggestionMatch -> SuggestionMatch -> Bool
(SuggestionMatch -> SuggestionMatch -> Bool)
-> (SuggestionMatch -> SuggestionMatch -> Bool)
-> Eq SuggestionMatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SuggestionMatch -> SuggestionMatch -> Bool
== :: SuggestionMatch -> SuggestionMatch -> Bool
$c/= :: SuggestionMatch -> SuggestionMatch -> Bool
/= :: SuggestionMatch -> SuggestionMatch -> Bool
Eq, Int -> SuggestionMatch -> ShowS
[SuggestionMatch] -> ShowS
SuggestionMatch -> [Char]
(Int -> SuggestionMatch -> ShowS)
-> (SuggestionMatch -> [Char])
-> ([SuggestionMatch] -> ShowS)
-> Show SuggestionMatch
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SuggestionMatch -> ShowS
showsPrec :: Int -> SuggestionMatch -> ShowS
$cshow :: SuggestionMatch -> [Char]
show :: SuggestionMatch -> [Char]
$cshowList :: [SuggestionMatch] -> ShowS
showList :: [SuggestionMatch] -> ShowS
Show)

data Suggestion v loc = Suggestion
  { forall v loc. Suggestion v loc -> Name
suggestionName :: Name,
    forall v loc. Suggestion v loc -> Type v loc
suggestionType :: Type v loc,
    forall v loc. Suggestion v loc -> Replacement v
suggestionReplacement :: Replacement v,
    forall v loc. Suggestion v loc -> SuggestionMatch
suggestionMatch :: SuggestionMatch
  }
  deriving stock (Suggestion v loc -> Suggestion v loc -> Bool
(Suggestion v loc -> Suggestion v loc -> Bool)
-> (Suggestion v loc -> Suggestion v loc -> Bool)
-> Eq (Suggestion v loc)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v loc. Var v => Suggestion v loc -> Suggestion v loc -> Bool
$c== :: forall v loc. Var v => Suggestion v loc -> Suggestion v loc -> Bool
== :: Suggestion v loc -> Suggestion v loc -> Bool
$c/= :: forall v loc. Var v => Suggestion v loc -> Suggestion v loc -> Bool
/= :: Suggestion v loc -> Suggestion v loc -> Bool
Eq, Int -> Suggestion v loc -> ShowS
[Suggestion v loc] -> ShowS
Suggestion v loc -> [Char]
(Int -> Suggestion v loc -> ShowS)
-> (Suggestion v loc -> [Char])
-> ([Suggestion v loc] -> ShowS)
-> Show (Suggestion v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc. Show v => Int -> Suggestion v loc -> ShowS
forall v loc. Show v => [Suggestion v loc] -> ShowS
forall v loc. Show v => Suggestion v loc -> [Char]
$cshowsPrec :: forall v loc. Show v => Int -> Suggestion v loc -> ShowS
showsPrec :: Int -> Suggestion v loc -> ShowS
$cshow :: forall v loc. Show v => Suggestion v loc -> [Char]
show :: Suggestion v loc -> [Char]
$cshowList :: forall v loc. Show v => [Suggestion v loc] -> ShowS
showList :: [Suggestion v loc] -> ShowS
Show)

isExact :: Suggestion v loc -> Bool
isExact :: forall v loc. Suggestion v loc -> Bool
isExact Suggestion {Type v loc
Name
Replacement v
SuggestionMatch
$sel:suggestionName:Suggestion :: forall v loc. Suggestion v loc -> Name
$sel:suggestionType:Suggestion :: forall v loc. Suggestion v loc -> Type v loc
$sel:suggestionReplacement:Suggestion :: forall v loc. Suggestion v loc -> Replacement v
$sel:suggestionMatch:Suggestion :: forall v loc. Suggestion v loc -> SuggestionMatch
suggestionName :: Name
suggestionType :: Type v loc
suggestionReplacement :: Replacement v
suggestionMatch :: SuggestionMatch
..} = SuggestionMatch
suggestionMatch SuggestionMatch -> SuggestionMatch -> Bool
forall a. Eq a => a -> a -> Bool
== SuggestionMatch
Exact

data Replacement v
  = ReplacementRef Referent
  | ReplacementVar v
  deriving stock (Replacement v -> Replacement v -> Bool
(Replacement v -> Replacement v -> Bool)
-> (Replacement v -> Replacement v -> Bool) -> Eq (Replacement v)
forall v. Eq v => Replacement v -> Replacement v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Eq v => Replacement v -> Replacement v -> Bool
== :: Replacement v -> Replacement v -> Bool
$c/= :: forall v. Eq v => Replacement v -> Replacement v -> Bool
/= :: Replacement v -> Replacement v -> Bool
Eq, Eq (Replacement v)
Eq (Replacement v) =>
(Replacement v -> Replacement v -> Ordering)
-> (Replacement v -> Replacement v -> Bool)
-> (Replacement v -> Replacement v -> Bool)
-> (Replacement v -> Replacement v -> Bool)
-> (Replacement v -> Replacement v -> Bool)
-> (Replacement v -> Replacement v -> Replacement v)
-> (Replacement v -> Replacement v -> Replacement v)
-> Ord (Replacement v)
Replacement v -> Replacement v -> Bool
Replacement v -> Replacement v -> Ordering
Replacement v -> Replacement v -> Replacement 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 (Replacement v)
forall v. Ord v => Replacement v -> Replacement v -> Bool
forall v. Ord v => Replacement v -> Replacement v -> Ordering
forall v. Ord v => Replacement v -> Replacement v -> Replacement v
$ccompare :: forall v. Ord v => Replacement v -> Replacement v -> Ordering
compare :: Replacement v -> Replacement v -> Ordering
$c< :: forall v. Ord v => Replacement v -> Replacement v -> Bool
< :: Replacement v -> Replacement v -> Bool
$c<= :: forall v. Ord v => Replacement v -> Replacement v -> Bool
<= :: Replacement v -> Replacement v -> Bool
$c> :: forall v. Ord v => Replacement v -> Replacement v -> Bool
> :: Replacement v -> Replacement v -> Bool
$c>= :: forall v. Ord v => Replacement v -> Replacement v -> Bool
>= :: Replacement v -> Replacement v -> Bool
$cmax :: forall v. Ord v => Replacement v -> Replacement v -> Replacement v
max :: Replacement v -> Replacement v -> Replacement v
$cmin :: forall v. Ord v => Replacement v -> Replacement v -> Replacement v
min :: Replacement v -> Replacement v -> Replacement v
Ord, Int -> Replacement v -> ShowS
[Replacement v] -> ShowS
Replacement v -> [Char]
(Int -> Replacement v -> ShowS)
-> (Replacement v -> [Char])
-> ([Replacement v] -> ShowS)
-> Show (Replacement v)
forall v. Show v => Int -> Replacement v -> ShowS
forall v. Show v => [Replacement v] -> ShowS
forall v. Show v => Replacement v -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Replacement v -> ShowS
showsPrec :: Int -> Replacement v -> ShowS
$cshow :: forall v. Show v => Replacement v -> [Char]
show :: Replacement v -> [Char]
$cshowList :: forall v. Show v => [Replacement v] -> ShowS
showList :: [Replacement v] -> ShowS
Show)

data ErrorNote v loc = ErrorNote
  { forall v loc. ErrorNote v loc -> Cause v loc
cause :: Cause v loc,
    forall v loc. ErrorNote v loc -> Seq (PathElement v loc)
path :: Seq (PathElement v loc)
  }
  deriving (Int -> ErrorNote v loc -> ShowS
[ErrorNote v loc] -> ShowS
ErrorNote v loc -> [Char]
(Int -> ErrorNote v loc -> ShowS)
-> (ErrorNote v loc -> [Char])
-> ([ErrorNote v loc] -> ShowS)
-> Show (ErrorNote v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> ErrorNote v loc -> ShowS
forall v loc.
(Var v, Show loc, Ord loc) =>
[ErrorNote v loc] -> ShowS
forall v loc.
(Var v, Show loc, Ord loc) =>
ErrorNote v loc -> [Char]
$cshowsPrec :: forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> ErrorNote v loc -> ShowS
showsPrec :: Int -> ErrorNote v loc -> ShowS
$cshow :: forall v loc.
(Var v, Show loc, Ord loc) =>
ErrorNote v loc -> [Char]
show :: ErrorNote v loc -> [Char]
$cshowList :: forall v loc.
(Var v, Show loc, Ord loc) =>
[ErrorNote v loc] -> ShowS
showList :: [ErrorNote v loc] -> ShowS
Show)

-- `Decision v loc fqn` is a decision to replace the name v at location loc
-- with the fully qualified name fqn.
data InfoNote v loc
  = SolvedBlank (B.Recorded loc) v (Type v loc)
  | Decision v loc (Term.Term v loc)
  | TopLevelComponent [(v, Type.Type v loc, RedundantTypeAnnotation)]
  deriving (Int -> InfoNote v loc -> ShowS
[InfoNote v loc] -> ShowS
InfoNote v loc -> [Char]
(Int -> InfoNote v loc -> ShowS)
-> (InfoNote v loc -> [Char])
-> ([InfoNote v loc] -> ShowS)
-> Show (InfoNote v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc. (Show loc, Show v) => Int -> InfoNote v loc -> ShowS
forall v loc. (Show loc, Show v) => [InfoNote v loc] -> ShowS
forall v loc. (Show loc, Show v) => InfoNote v loc -> [Char]
$cshowsPrec :: forall v loc. (Show loc, Show v) => Int -> InfoNote v loc -> ShowS
showsPrec :: Int -> InfoNote v loc -> ShowS
$cshow :: forall v loc. (Show loc, Show v) => InfoNote v loc -> [Char]
show :: InfoNote v loc -> [Char]
$cshowList :: forall v loc. (Show loc, Show v) => [InfoNote v loc] -> ShowS
showList :: [InfoNote v loc] -> ShowS
Show)

topLevelComponent :: (Var v) => [(v, Type.Type v loc, RedundantTypeAnnotation)] -> InfoNote v loc
topLevelComponent :: forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent = [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. [(v, Type v loc, Bool)] -> InfoNote v loc
TopLevelComponent ([(v, Type v loc, Bool)] -> InfoNote v loc)
-> ([(v, Type v loc, Bool)] -> [(v, Type v loc, Bool)])
-> [(v, Type v loc, Bool)]
-> InfoNote v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Type v loc, Bool) -> (v, Type v loc, Bool))
-> [(v, Type v loc, Bool)] -> [(v, Type v loc, Bool)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASetter
  (v, Type v loc, Bool)
  (v, Type v loc, Bool)
  (Type v loc)
  (Type v loc)
-> (Type v loc -> Type v loc)
-> (v, Type v loc, Bool)
-> (v, Type v loc, Bool)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (v, Type v loc, Bool)
  (v, Type v loc, Bool)
  (Type v loc)
  (Type v loc)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (v, Type v loc, Bool)
  (v, Type v loc, Bool)
  (Type v loc)
  (Type v loc)
_2 Type v loc -> Type v loc
forall v loc. Var v => Type v loc -> Type v loc
removeSyntheticTypeVars)

-- Given a list of Elements that are going to be discarded from a
-- context, substitutes the informataion into the solved blank types
-- of an InfoNote. This should give better TDNR results, because it
-- allows the stored solutions to incorporate information from later
-- in the type checking process, instead of it being entirely reliant
-- on information in the local scope of the reference to be resolved.
--
-- Note: this does not take any care to abstract over the variables
-- stored in the notes, so it is _heavily_ reliant on the fact that we
-- never reuse variable names/numberings in the typechecker. If this
-- becomes untrue, then we need to revisit this and instead properly
-- generalize types stored in the notes.
substituteSolved ::
  (Var v, Ord loc) =>
  [Element v loc] ->
  InfoNote v loc ->
  InfoNote v loc
substituteSolved :: forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> InfoNote v loc -> InfoNote v loc
substituteSolved [Element v loc]
ctx (SolvedBlank Recorded loc
b v
v Type v loc
t) =
  Recorded loc -> v -> Type v loc -> InfoNote v loc
forall v loc. Recorded loc -> v -> Type v loc -> InfoNote v loc
SolvedBlank Recorded loc
b v
v ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx Type v loc
t)
substituteSolved [Element v loc]
_ InfoNote v loc
i = InfoNote v loc
i

-- The typechecker generates synthetic type variables as part of type inference.
-- This function converts these synthetic type variables to regular named type
-- variables guaranteed to not collide with any other type variables.
--
-- It also attempts to pick "nice" type variable names, based on what sort of
-- synthetic type variable it is and what type variable names are not already
-- being used.
removeSyntheticTypeVars :: (Var v) => Type.Type v loc -> Type.Type v loc
removeSyntheticTypeVars :: forall v loc. Var v => Type v loc -> Type v loc
removeSyntheticTypeVars Type v loc
typ =
  (State (Set v, Map v v) (Type v loc)
 -> (Set v, Map v v) -> Type v loc)
-> (Set v, Map v v)
-> State (Set v, Map v v) (Type v loc)
-> Type v loc
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set v, Map v v) (Type v loc)
-> (Set v, Map v v) -> Type v loc
forall s a. State s a -> s -> a
evalState ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList (Type v loc -> [v]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Type v loc
typ), Map v v
forall a. Monoid a => a
mempty) (State (Set v, Map v v) (Type v loc) -> Type v loc)
-> State (Set v, Map v v) (Type v loc) -> Type v loc
forall a b. (a -> b) -> a -> b
$ (v -> StateT (Set v, Map v v) Identity v)
-> Type v loc -> State (Set v, Map v v) (Type v loc)
forall (m :: * -> *) (f :: * -> *) v2 v a.
(Applicative m, Traversable f, Foldable f, Ord v2) =>
(v -> m v2) -> Term f v a -> m (Term f v2 a)
ABT.vmapM v -> StateT (Set v, Map v v) Identity v
go Type v loc
typ
  where
    go :: v -> StateT (Set v, Map v v) Identity v
go v
v
      | Var.User Text
_ <- v -> Type
forall v. Var v => v -> Type
Var.typeOf v
v = v -> StateT (Set v, Map v v) Identity v
forall a. a -> StateT (Set v, Map v v) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v -- user-provided type variables left alone
      | Bool
otherwise = do
          (Set v
used, Map v v
curMappings) <- StateT (Set v, Map v v) Identity (Set v, Map v v)
forall s (m :: * -> *). MonadState s m => m s
get
          case v -> Map v v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v v
curMappings of
            Maybe v
Nothing -> do
              let v' :: v
v' = Set v -> Type -> v
pickName Set v
used (v -> Type
forall v. Var v => v -> Type
Var.typeOf v
v)
              (Set v, Map v v) -> StateT (Set v, Map v v) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v' Set v
used, v -> v -> Map v v -> Map v v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert v
v v
v' Map v v
curMappings)
              pure v
v'
            Just v
v' -> v -> StateT (Set v, Map v v) Identity v
forall a. a -> StateT (Set v, Map v v) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v'
    pickName :: Set v -> Type -> v
pickName Set v
used Type
vt = Set v -> v -> v
forall v. Var v => Set v -> v -> v
ABT.freshIn Set v
used (v -> v) -> (Text -> v) -> Text -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> v
forall v. Var v => Text -> v
Var.named (Text -> v) -> Text -> v
forall a b. (a -> b) -> a -> b
$ case Type
vt of
      -- for each type of variable, we have some preferred variable
      -- names that we like, if they aren't already being used
      Var.Inference InferenceType
Var.Ability -> [Text] -> Text
pick [Text
"g", Text
"h", Text
"m", Text
"p"]
      Var.Inference InferenceType
Var.Input -> [Text] -> Text
pick [Text
"a", Text
"b", Text
"c", Text
"i", Text
"j"]
      Var.Inference InferenceType
Var.Output -> [Text] -> Text
pick [Text
"r", Text
"o"]
      Var.Inference InferenceType
Var.Other -> [Text] -> Text
pick [Text
"t", Text
"u", Text
"w"]
      Var.Inference InferenceType
Var.TypeConstructor -> [Text] -> Text
pick [Text
"f", Text
"k", Text
"d"]
      Var.Inference InferenceType
Var.TypeConstructorArg -> [Text] -> Text
pick [Text
"v", Text
"w", Text
"y"]
      Var.User Text
n -> Text
n
      Type
_ -> Text
defaultName
      where
        used1CharVars :: Set Text
used1CharVars =
          [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$
            Type v loc -> [v]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Type v loc
typ [v] -> (v -> [Text]) -> [Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \v
v ->
              case Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name (v -> Text) -> (v -> v) -> v -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> v
forall v. Var v => v -> v
Var.reset (v -> Text) -> v -> Text
forall a b. (a -> b) -> a -> b
$ v
v) of
                [Char
ch] -> [Char -> Text
Text.singleton Char
ch]
                [Char]
_ -> []
        pick :: [Text] -> Text
pick ns :: [Text]
ns@(Text
n : [Text]
_) = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
n (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
used1CharVars) [Text]
ns
        pick [] = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
        defaultName :: Text
defaultName = Text
"x"

data Cause v loc
  = TypeMismatch (Context v loc)
  | IllFormedType (Context v loc)
  | UnknownSymbol loc v
  | UnknownTerm loc v [Suggestion v loc] (Type v loc)
  | AbilityCheckFailure [Type v loc] [Type v loc] (Context v loc) -- ambient, requested
  | AbilityEqFailure [Type v loc] [Type v loc] (Context v loc)
  | EffectConstructorWrongArgCount ExpectedArgCount ActualArgCount ConstructorReference
  | MalformedEffectBind (Type v loc) (Type v loc) [Type v loc] -- type of ctor, type of ctor result
  -- Type of ctor, number of arguments we got
  | PatternArityMismatch loc (Type v loc) Int
  | -- A variable is defined twice in the same block
    DuplicateDefinitions (NonEmpty (v, [loc]))
  | -- A let rec where things that aren't guarded cyclicly depend on each other
    UnguardedLetRecCycle [v] [(v, Term v loc)]
  | ConcatPatternWithoutConstantLength loc (Type v loc)
  | HandlerOfUnexpectedType loc (Type v loc)
  | DataEffectMismatch Unknown Reference (DataDeclaration v loc)
  | UncoveredPatterns loc (NonEmpty (Pattern ()))
  | RedundantPattern loc
  | KindInferenceFailure (KindInference.KindError v loc)
  | InaccessiblePattern loc
  deriving (Int -> Cause v loc -> ShowS
[Cause v loc] -> ShowS
Cause v loc -> [Char]
(Int -> Cause v loc -> ShowS)
-> (Cause v loc -> [Char])
-> ([Cause v loc] -> ShowS)
-> Show (Cause v loc)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> Cause v loc -> ShowS
forall v loc. (Var v, Show loc, Ord loc) => [Cause v loc] -> ShowS
forall v loc. (Var v, Show loc, Ord loc) => Cause v loc -> [Char]
$cshowsPrec :: forall v loc.
(Var v, Show loc, Ord loc) =>
Int -> Cause v loc -> ShowS
showsPrec :: Int -> Cause v loc -> ShowS
$cshow :: forall v loc. (Var v, Show loc, Ord loc) => Cause v loc -> [Char]
show :: Cause v loc -> [Char]
$cshowList :: forall v loc. (Var v, Show loc, Ord loc) => [Cause v loc] -> ShowS
showList :: [Cause v loc] -> ShowS
Show)

errorTerms :: ErrorNote v loc -> [Term v loc]
errorTerms :: forall v loc. ErrorNote v loc -> [Term v loc]
errorTerms ErrorNote v loc
n =
  Seq (PathElement v loc) -> [PathElement v loc]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (ErrorNote v loc -> Seq (PathElement v loc)
forall v loc. ErrorNote v loc -> Seq (PathElement v loc)
path ErrorNote v loc
n) [PathElement v loc]
-> (PathElement v loc -> [Term v loc]) -> [Term v loc]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PathElement v loc
e -> case PathElement v loc
e of
    InCheck Term v loc
e Type v loc
_ -> [Term v loc
e]
    InSynthesizeApp Type v loc
_ Term v loc
e Int
_ -> [Term v loc
e]
    InSynthesize Term v loc
e -> [Term v loc
e]
    PathElement v loc
_ -> []

innermostErrorTerm :: ErrorNote v loc -> Maybe (Term v loc)
innermostErrorTerm :: forall v loc. ErrorNote v loc -> Maybe (Term v loc)
innermostErrorTerm ErrorNote v loc
n = [Term v loc] -> Maybe (Term v loc)
forall a. [a] -> Maybe a
listToMaybe ([Term v loc] -> Maybe (Term v loc))
-> [Term v loc] -> Maybe (Term v loc)
forall a b. (a -> b) -> a -> b
$ ErrorNote v loc -> [Term v loc]
forall v loc. ErrorNote v loc -> [Term v loc]
errorTerms ErrorNote v loc
n

solveBlank :: B.Recorded loc -> v -> Type v loc -> M v loc ()
solveBlank :: forall loc v. Recorded loc -> v -> Type v loc -> M v loc ()
solveBlank Recorded loc
blank v
v Type v loc
typ = InfoNote v loc -> M v loc ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> M v loc ()) -> InfoNote v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Recorded loc -> v -> Type v loc -> InfoNote v loc
forall v loc. Recorded loc -> v -> Type v loc -> InfoNote v loc
SolvedBlank Recorded loc
blank v
v Type v loc
typ

-- Add `p` onto the end of the `path` of this `ErrorNote`
scope' :: PathElement v loc -> ErrorNote v loc -> ErrorNote v loc
scope' :: forall v loc.
PathElement v loc -> ErrorNote v loc -> ErrorNote v loc
scope' PathElement v loc
p (ErrorNote Cause v loc
cause Seq (PathElement v loc)
path) = Cause v loc -> Seq (PathElement v loc) -> ErrorNote v loc
forall v loc.
Cause v loc -> Seq (PathElement v loc) -> ErrorNote v loc
ErrorNote Cause v loc
cause (Seq (PathElement v loc)
path Seq (PathElement v loc)
-> Seq (PathElement v loc) -> Seq (PathElement v loc)
forall a. Monoid a => a -> a -> a
`mappend` PathElement v loc -> Seq (PathElement v loc)
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PathElement v loc
p)

-- Add `p` onto the end of the `path` of any `ErrorNote`s emitted by the action
scope :: PathElement v loc -> M v loc a -> M v loc a
scope :: forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
p (MT PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
m) = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> MT v loc (Result v loc) a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env -> (ErrorNote v loc -> ErrorNote v loc)
-> Result v loc (a, Env v loc) -> Result v loc (a, Env v loc)
forall v loc a.
(ErrorNote v loc -> ErrorNote v loc)
-> Result v loc a -> Result v loc a
mapErrors (PathElement v loc -> ErrorNote v loc -> ErrorNote v loc
forall v loc.
PathElement v loc -> ErrorNote v loc -> ErrorNote v loc
scope' PathElement v loc
p) (PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env)

newtype Context v loc = Context [(Element v loc, Info v loc)]

data Info v loc = Info
  { forall v loc. Info v loc -> Set v
existentialVars :: Set v, -- set of existentials seen so far
    forall v loc. Info v loc -> Map v (Monotype v loc)
solvedExistentials :: Map v (Monotype v loc), -- `v` is solved to some monotype
    forall v loc. Info v loc -> Set v
universalVars :: Set v, -- set of universals seen so far
    forall v loc. Info v loc -> Map v (Type v loc)
termVarAnnotations :: Map v (Type v loc),
    forall v loc. Info v loc -> Set v
allVars :: Set v -- all variables seen so far
  }

-- | The empty context
context0 :: Context v loc
context0 :: forall v loc. Context v loc
context0 = [(Element v loc, Info v loc)] -> Context v loc
forall v loc. [(Element v loc, Info v loc)] -> Context v loc
Context []

occursAnn :: (Var v) => (Ord loc) => TypeVar v loc -> Context v loc -> Bool
occursAnn :: forall v loc.
(Var v, Ord loc) =>
TypeVar v loc -> Context v loc -> Bool
occursAnn TypeVar v loc
v (Context [(Element v loc, Info v loc)]
eis) = (Element v loc -> Bool) -> [Element v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element v loc -> Bool
p [Element v loc]
es
  where
    es :: [Element v loc]
es = (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst ((Element v loc, Info v loc) -> Element v loc)
-> [(Element v loc, Info v loc)] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Element v loc, Info v loc)]
eis
    p :: Element v loc -> Bool
p (Ann v
_ Type v loc
ty) = TypeVar v loc
v TypeVar v loc -> Set (TypeVar v loc) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
es Type v loc
ty)
    p Element v loc
_ = Bool
False

-- | Focuses on the first element in the list that satisfies the predicate.
-- Returns `(prefix, focusedElem, suffix)`, where `prefix` is in reverse order.
focusAt :: (a -> Bool) -> [a] -> Maybe ([a], a, [a])
focusAt :: forall a. (a -> Bool) -> [a] -> Maybe ([a], a, [a])
focusAt a -> Bool
p [a]
xs = [a] -> [a] -> Maybe ([a], a, [a])
go [] [a]
xs
  where
    go :: [a] -> [a] -> Maybe ([a], a, [a])
go [a]
_ [] = Maybe ([a], a, [a])
forall a. Maybe a
Nothing
    go [a]
l (a
h : [a]
t) = if a -> Bool
p a
h then ([a], a, [a]) -> Maybe ([a], a, [a])
forall a. a -> Maybe a
Just ([a]
l, a
h, [a]
t) else [a] -> [a] -> Maybe ([a], a, [a])
go (a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
l) [a]
t

-- | Delete from the end of this context up to and including
-- the given `Element`. Returns `Nothing` if the element is not found.
retract0 :: (Var v, Ord loc) => Element v loc -> Context v loc -> Maybe (Context v loc, [Element v loc])
retract0 :: forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc -> Maybe (Context v loc, [Element v loc])
retract0 Element v loc
e (Context [(Element v loc, Info v loc)]
ctx) = case ((Element v loc, Info v loc) -> Bool)
-> [(Element v loc, Info v loc)]
-> Maybe
     ([(Element v loc, Info v loc)], (Element v loc, Info v loc),
      [(Element v loc, Info v loc)])
forall a. (a -> Bool) -> [a] -> Maybe ([a], a, [a])
focusAt (\(Element v loc
e', Info v loc
_) -> Element v loc
e' Element v loc -> Element v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Element v loc
e) [(Element v loc, Info v loc)]
ctx of
  Just ([(Element v loc, Info v loc)]
discarded, (Element v loc, Info v loc)
_, [(Element v loc, Info v loc)]
remaining) ->
    -- note: no need to recompute used variables; any suffix of the
    -- context snoc list is also a valid context
    (Context v loc, [Element v loc])
-> Maybe (Context v loc, [Element v loc])
forall a. a -> Maybe a
Just ([(Element v loc, Info v loc)] -> Context v loc
forall v loc. [(Element v loc, Info v loc)] -> Context v loc
Context [(Element v loc, Info v loc)]
remaining, ((Element v loc, Info v loc) -> Element v loc)
-> [(Element v loc, Info v loc)] -> [Element v loc]
forall a b. (a -> b) -> [a] -> [b]
map (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst [(Element v loc, Info v loc)]
discarded)
  Maybe
  ([(Element v loc, Info v loc)], (Element v loc, Info v loc),
   [(Element v loc, Info v loc)])
Nothing -> Maybe (Context v loc, [Element v loc])
forall a. Maybe a
Nothing

-- | Adds a marker to the end of the context, runs the `body` and then discards
-- from the end of the context up to and including the marker. Returns the result
-- of `body` and the discarded context (not including the marker), respectively.
-- Freshened `markerHint` is used to create the marker.
markThenRetract :: (Var v, Ord loc) => v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract :: forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract v
hint M v loc a
body =
  v
-> (M v loc [Element v loc] -> M v loc (a, [Element v loc]))
-> M v loc (a, [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> (M v loc [Element v loc] -> M v loc a) -> M v loc a
markThenCallWithRetract v
hint \M v loc [Element v loc]
retract -> M v loc ((a, [Element v loc]), InfoNote v loc -> InfoNote v loc)
-> M v loc (a, [Element v loc])
forall v loc a.
M v loc (a, InfoNote v loc -> InfoNote v loc) -> M v loc a
adjustNotes do
    a
r <- M v loc a
body
    [Element v loc]
ctx <- M v loc [Element v loc]
retract
    pure ((a
r, [Element v loc]
ctx), [Element v loc] -> InfoNote v loc -> InfoNote v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> InfoNote v loc -> InfoNote v loc
substituteSolved [Element v loc]
ctx)

markThenRetract0 :: (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 :: forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
markerHint M v loc a
body = () ()
-> MT v loc (Result v loc) (a, [Element v loc])
-> MT v loc (Result v loc) ()
forall a b.
a -> MT v loc (Result v loc) b -> MT v loc (Result v loc) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ v -> M v loc a -> MT v loc (Result v loc) (a, [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract v
markerHint M v loc a
body

markThenCallWithRetract ::
  (Var v, Ord loc) =>
  v ->
  (M v loc [Element v loc] -> M v loc a) ->
  M v loc a
markThenCallWithRetract :: forall v loc a.
(Var v, Ord loc) =>
v -> (M v loc [Element v loc] -> M v loc a) -> M v loc a
markThenCallWithRetract v
hint M v loc [Element v loc] -> M v loc a
k = do
  v
v <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
hint
  Element v loc -> M v loc ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext (v -> Element v loc
forall v loc. v -> Element v loc
Marker v
v)
  M v loc [Element v loc] -> M v loc a
k (Element v loc -> M v loc [Element v loc]
forall v loc.
(Var v, Ord loc) =>
Element v loc -> M v loc [Element v loc]
doRetract (v -> Element v loc
forall v loc. v -> Element v loc
Marker v
v))
  where
    doRetract :: (Var v, Ord loc) => Element v loc -> M v loc [Element v loc]
    doRetract :: forall v loc.
(Var v, Ord loc) =>
Element v loc -> M v loc [Element v loc]
doRetract Element v loc
e = do
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      case Element v loc
-> Context v loc -> Maybe (Context v loc, [Element v loc])
forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc -> Maybe (Context v loc, [Element v loc])
retract0 Element v loc
e Context v loc
ctx of
        Maybe (Context v loc, [Element v loc])
Nothing -> CompilerBug v loc -> M v loc [Element v loc]
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (Element v loc -> Context v loc -> CompilerBug v loc
forall v loc. Element v loc -> Context v loc -> CompilerBug v loc
RetractFailure Element v loc
e Context v loc
ctx)
        Just (Context v loc
t, [Element v loc]
discarded) -> do
          let solved :: [(Recorded loc, v, Type v loc)]
solved =
                [ (Recorded loc
b, v
v, Type v loc -> Type v loc
inst (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ Monotype (TypeVar v loc) loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype (TypeVar v loc) loc
sa)
                  | Solved (B.Recorded Recorded loc
b) v
v Monotype (TypeVar v loc) loc
sa <- [Element v loc]
discarded
                ]
              unsolved :: [(Recorded loc, v, Type v loc)]
unsolved =
                [ (Recorded loc
b, v
v, Type v loc -> Type v loc
inst (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Recorded loc -> loc
forall loc. Recorded loc -> loc
B.loc Recorded loc
b) Blank loc
b' v
v)
                  | Existential b' :: Blank loc
b'@(B.Recorded Recorded loc
b) v
v <- [Element v loc]
discarded
                ]
              go :: (Recorded loc, v, Type v loc) -> M v loc ()
go (Recorded loc
b, v
v, Type v loc
sa) = Recorded loc -> v -> Type v loc -> M v loc ()
forall loc v. Recorded loc -> v -> Type v loc -> M v loc ()
solveBlank Recorded loc
b v
v Type v loc
sa
              inst :: Type v loc -> Type v loc
inst = Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx
          ((Recorded loc, v, Type v loc) -> MT v loc (Result v loc) ())
-> [(Recorded loc, v, Type v loc)] -> MT v loc (Result v loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
Foldable.traverse_ (Recorded loc, v, Type v loc) -> MT v loc (Result v loc) ()
forall {loc} {v}. (Recorded loc, v, Type v loc) -> M v loc ()
go ([(Recorded loc, v, Type v loc)]
solved [(Recorded loc, v, Type v loc)]
-> [(Recorded loc, v, Type v loc)]
-> [(Recorded loc, v, Type v loc)]
forall a. [a] -> [a] -> [a]
++ [(Recorded loc, v, Type v loc)]
unsolved)
          Context v loc -> MT v loc (Result v loc) ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
t
          pure [Element v loc]
discarded

-- unsolved' :: Context v loc -> [(B.Blank loc, v)]
-- unsolved' (Context ctx) = [(b,v) | (Existential b v, _) <- ctx]

replace :: (Var v, Ord loc) => Element v loc -> [Element v loc] -> Context v loc -> M v loc (Context v loc)
replace :: forall v loc.
(Var v, Ord loc) =>
Element v loc
-> [Element v loc] -> Context v loc -> M v loc (Context v loc)
replace Element v loc
e [Element v loc]
focus Context v loc
ctx =
  case Element v loc
-> Context v loc
-> Maybe (Context v loc, Element v loc, [Element v loc])
forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc
-> Maybe (Context v loc, Element v loc, [Element v loc])
breakAt Element v loc
e Context v loc
ctx of
    Just (Context v loc
l, Element v loc
_, [Element v loc]
r) -> Context v loc
l Context v loc -> [Element v loc] -> M v loc (Context v loc)
forall v loc.
Var v =>
Context v loc -> [Element v loc] -> M v loc (Context v loc)
`extendN` ([Element v loc]
focus [Element v loc] -> [Element v loc] -> [Element v loc]
forall a. Semigroup a => a -> a -> a
<> [Element v loc]
r)
    Maybe (Context v loc, Element v loc, [Element v loc])
Nothing -> Context v loc -> M v loc (Context v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context v loc
ctx

breakAt ::
  (Var v, Ord loc) =>
  Element v loc ->
  Context v loc ->
  Maybe (Context v loc, Element v loc, [Element v loc])
breakAt :: forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc
-> Maybe (Context v loc, Element v loc, [Element v loc])
breakAt Element v loc
m (Context [(Element v loc, Info v loc)]
xs) =
  case ((Element v loc, Info v loc) -> Bool)
-> [(Element v loc, Info v loc)]
-> Maybe
     ([(Element v loc, Info v loc)], (Element v loc, Info v loc),
      [(Element v loc, Info v loc)])
forall a. (a -> Bool) -> [a] -> Maybe ([a], a, [a])
focusAt (\(Element v loc
e, Info v loc
_) -> Element v loc
e Element v loc -> Element v loc -> Bool
forall {a} {loc} {loc}.
Eq a =>
Element a loc -> Element a loc -> Bool
=== Element v loc
m) [(Element v loc, Info v loc)]
xs of
    Just ([(Element v loc, Info v loc)]
r, (Element v loc, Info v loc)
m, [(Element v loc, Info v loc)]
l) ->
      -- l is a suffix of xs and is already a valid context
      (Context v loc, Element v loc, [Element v loc])
-> Maybe (Context v loc, Element v loc, [Element v loc])
forall a. a -> Maybe a
Just ([(Element v loc, Info v loc)] -> Context v loc
forall v loc. [(Element v loc, Info v loc)] -> Context v loc
Context [(Element v loc, Info v loc)]
l, (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst (Element v loc, Info v loc)
m, ((Element v loc, Info v loc) -> Element v loc)
-> [(Element v loc, Info v loc)] -> [Element v loc]
forall a b. (a -> b) -> [a] -> [b]
map (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst [(Element v loc, Info v loc)]
r)
    Maybe
  ([(Element v loc, Info v loc)], (Element v loc, Info v loc),
   [(Element v loc, Info v loc)])
Nothing -> Maybe (Context v loc, Element v loc, [Element v loc])
forall a. Maybe a
Nothing
  where
    Existential Blank loc
_ a
v === :: Element a loc -> Element a loc -> Bool
=== Existential Blank loc
_ a
v2 | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v2 = Bool
True
    Universal a
v === Universal a
v2 | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v2 = Bool
True
    Marker a
v === Marker a
v2 | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v2 = Bool
True
    Element a loc
_ === Element a loc
_ = Bool
False

-- | ordered Γ α β = True <=> Γ[α^][β^]
ordered :: (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered :: forall v loc. (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered Context v loc
ctx v
v v
v2 = v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v (Context v loc -> Set v
forall v loc. Ord v => Context v loc -> Set v
existentials (Element v loc -> Context v loc -> Context v loc
forall v loc.
(Var v, Ord loc) =>
Element v loc -> Context v loc -> Context v loc
retract' (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v2) Context v loc
ctx))
  where
    -- Like `retract`, but returns the empty context if retracting would remove
    -- all elements.
    retract' ::
      (Var v, Ord loc) => Element v loc -> Context v loc -> Context v loc
    retract' :: forall v loc.
(Var v, Ord loc) =>
Element v loc -> Context v loc -> Context v loc
retract' Element v loc
e Context v loc
ctx = Context v loc
-> ((Context v loc, [Element v loc]) -> Context v loc)
-> Maybe (Context v loc, [Element v loc])
-> Context v loc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Context v loc
forall v loc. Context v loc
context0 (Context v loc, [Element v loc]) -> Context v loc
forall a b. (a, b) -> a
fst (Maybe (Context v loc, [Element v loc]) -> Context v loc)
-> Maybe (Context v loc, [Element v loc]) -> Context v loc
forall a b. (a -> b) -> a -> b
$ Element v loc
-> Context v loc -> Maybe (Context v loc, [Element v loc])
forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc -> Maybe (Context v loc, [Element v loc])
retract0 Element v loc
e Context v loc
ctx

-- env0 :: Env v loc
-- env0 = Env 0 context0

debugEnabled :: Bool
debugEnabled :: Bool
debugEnabled = Bool
False

debugShow :: (Show a) => a -> Bool
debugShow :: forall a. Show a => a -> Bool
debugShow a
e | Bool
debugEnabled = a -> Bool -> Bool
forall a b. Show a => a -> b -> b
traceShow a
e Bool
False
debugShow a
_ = Bool
False

debugTrace :: String -> Bool
debugTrace :: [Char] -> Bool
debugTrace [Char]
e | Bool
debugEnabled = [Char] -> Bool -> Bool
forall a. [Char] -> a -> a
trace [Char]
e Bool
False
debugTrace [Char]
_ = Bool
False

showType :: (Var v) => Type.Type v a -> String
showType :: forall v a. Var v => Type v a -> [Char]
showType Type v a
ty = Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
TP.prettyStr (Width -> Maybe Width
forall a. a -> Maybe a
Just Width
120) PrettyPrintEnv
PPE.empty Type v a
ty

debugType :: (Var v) => String -> Type.Type v a -> Bool
debugType :: forall v a. Var v => [Char] -> Type v a -> Bool
debugType [Char]
tag Type v a
ty
  | Bool
debugEnabled = [Char] -> Bool
debugTrace ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"(" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> [Char]
show [Char]
tag [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"," [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type v a -> [Char]
forall v a. Var v => Type v a -> [Char]
showType Type v a
ty [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
  | Bool
otherwise = Bool
False

debugTypes :: (Var v) => String -> Type.Type v a -> Type.Type v a -> Bool
debugTypes :: forall v a. Var v => [Char] -> Type v a -> Type v a -> Bool
debugTypes [Char]
tag Type v a
t1 Type v a
t2
  | Bool
debugEnabled = [Char] -> Bool
debugTrace ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"(" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> [Char]
show [Char]
tag [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
",\n  " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type v a -> [Char]
forall v a. Var v => Type v a -> [Char]
showType Type v a
t1 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
",\n  " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type v a -> [Char]
forall v a. Var v => Type v a -> [Char]
showType Type v a
t2 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
  | Bool
otherwise = Bool
False

debugPatternsEnabled :: Bool
debugPatternsEnabled :: Bool
debugPatternsEnabled = Bool
False

_logContext :: (Ord loc, Var v) => String -> M v loc ()
_logContext :: forall loc v. (Ord loc, Var v) => [Char] -> M v loc ()
_logContext [Char]
msg = Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugEnabled (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ do
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  let !()
_ = [Char] -> () -> ()
forall a. [Char] -> a -> a
trace ([Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Context v loc -> [Char]
forall a. Show a => a -> [Char]
show Context v loc
ctx) ()
  Context v loc -> MT v loc (Result v loc) ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx

usedVars :: (Ord v) => Context v loc -> Set v
usedVars :: forall v loc. Ord v => Context v loc -> Set v
usedVars = Info v loc -> Set v
forall v loc. Info v loc -> Set v
allVars (Info v loc -> Set v)
-> (Context v loc -> Info v loc) -> Context v loc -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info

getContext :: M v loc (Context v loc)
getContext :: forall v loc. M v loc (Context v loc)
getContext = (Env v loc -> Context v loc)
-> MT v loc (Result v loc) (Context v loc)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env v loc -> Context v loc
forall v loc. Env v loc -> Context v loc
ctx

setContext :: Context v loc -> M v loc ()
setContext :: forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx = (Env v loc -> Env v loc) -> M v loc ()
forall v loc. (Env v loc -> Env v loc) -> M v loc ()
modEnv (\Env v loc
e -> Env v loc
e {ctx = ctx})

modifyContext :: (Context v loc -> M v loc (Context v loc)) -> M v loc ()
modifyContext :: forall v loc.
(Context v loc -> M v loc (Context v loc)) -> M v loc ()
modifyContext Context v loc -> M v loc (Context v loc)
f = do
  Context v loc
c <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Context v loc
c <- Context v loc -> M v loc (Context v loc)
f Context v loc
c
  Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
c

appendContext :: (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext :: forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext = (Element v loc -> MT v loc (Result v loc) ())
-> [Element v loc] -> MT v loc (Result v loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Element v loc -> MT v loc (Result v loc) ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext

markRetained :: (Var v, Ord loc) => Set v -> M v loc ()
markRetained :: forall v loc. (Var v, Ord loc) => Set v -> M v loc ()
markRetained Set v
keep = Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext (Context v loc -> M v loc ())
-> (Context v loc -> Context v loc) -> Context v loc -> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Context v loc
marks (Context v loc -> M v loc ())
-> MT v loc (Result v loc) (Context v loc) -> M v loc ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MT v loc (Result v loc) (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  where
    marks :: Context v loc -> Context v loc
marks (Context [(Element v loc, Info v loc)]
eis) = [(Element v loc, Info v loc)] -> Context v loc
forall v loc. [(Element v loc, Info v loc)] -> Context v loc
Context (((Element v loc, Info v loc) -> (Element v loc, Info v loc))
-> [(Element v loc, Info v loc)] -> [(Element v loc, Info v loc)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Element v loc, Info v loc) -> (Element v loc, Info v loc)
mark [(Element v loc, Info v loc)]
eis)
    mark :: (Element v loc, Info v loc) -> (Element v loc, Info v loc)
mark (Existential Blank loc
B.Blank v
v, Info v loc
i)
      | v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
keep = (TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (Blank loc -> v -> TypeVar v loc
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Retain v
v), Info v loc
i)
    mark (Solved Blank loc
B.Blank v
v Monotype v loc
t, Info v loc
i)
      | v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
keep = (Blank loc -> v -> Monotype v loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
forall loc. Blank loc
B.Retain v
v Monotype v loc
t, Info v loc
i)
    mark (Element v loc, Info v loc)
p = (Element v loc, Info v loc)
p

extendContext :: (Var v) => Element v loc -> M v loc ()
extendContext :: forall v loc. Var v => Element v loc -> M v loc ()
extendContext Element v loc
e =
  v -> M v loc Bool
forall v loc. Var v => v -> M v loc Bool
isReserved (Element v loc -> v
forall v loc. Element v loc -> v
varOf Element v loc
e) M v loc Bool
-> (Bool -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> (Context v loc -> M v loc (Context v loc))
-> MT v loc (Result v loc) ()
forall v loc.
(Context v loc -> M v loc (Context v loc)) -> M v loc ()
modifyContext (Element v loc -> Context v loc -> M v loc (Context v loc)
forall v loc.
Var v =>
Element v loc -> Context v loc -> M v loc (Context v loc)
extend Element v loc
e)
    Bool
False ->
      M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx ->
        CompilerBug v loc -> MT v loc (Result v loc) ()
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> MT v loc (Result v loc) ())
-> CompilerBug v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$
          Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
forall v loc.
Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
IllegalContextExtension Context v loc
ctx Element v loc
e ([Char] -> CompilerBug v loc) -> [Char] -> CompilerBug v loc
forall a b. (a -> b) -> a -> b
$
            [Char]
"Extending context with a variable that is not reserved by the typechecking environment."
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" That means `freshenVar` is allowed to return it as a fresh variable, which would be wrong."

replaceContext :: (Var v, Ord loc) => Element v loc -> [Element v loc] -> M v loc ()
replaceContext :: forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext Element v loc
elem [Element v loc]
replacement = do
  Env v loc
env <- MT v loc (Result v loc) (Env v loc)
forall s (m :: * -> *). MonadState s m => m s
get
  case (Element v loc -> Bool) -> [Element v loc] -> Maybe (Element v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (Element v loc -> Bool) -> Element v loc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Env v loc -> Bool
forall v loc. Var v => v -> Env v loc -> Bool
`isReservedIn` Env v loc
env) (v -> Bool) -> (Element v loc -> v) -> Element v loc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element v loc -> v
forall v loc. Element v loc -> v
varOf) [Element v loc]
replacement of
    Maybe (Element v loc)
Nothing -> (Context v loc -> M v loc (Context v loc)) -> M v loc ()
forall v loc.
(Context v loc -> M v loc (Context v loc)) -> M v loc ()
modifyContext (Element v loc
-> [Element v loc] -> Context v loc -> M v loc (Context v loc)
forall v loc.
(Var v, Ord loc) =>
Element v loc
-> [Element v loc] -> Context v loc -> M v loc (Context v loc)
replace Element v loc
elem [Element v loc]
replacement)
    Just Element v loc
e ->
      M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx ->
        CompilerBug v loc -> M v loc ()
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> M v loc ())
-> CompilerBug v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
          Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
forall v loc.
Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
IllegalContextExtension Context v loc
ctx Element v loc
e ([Char] -> CompilerBug v loc) -> [Char] -> CompilerBug v loc
forall a b. (a -> b) -> a -> b
$
            [Char]
"Extending context with a variable that is not reserved by the typechecking environment."
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" That means `freshenVar` is allowed to return it as a fresh variable, which would be wrong."

varOf :: Element v loc -> v
varOf :: forall v loc. Element v loc -> v
varOf (Var TypeVar v loc
tv) = TypeVar v loc -> v
forall b v. TypeVar b v -> v
TypeVar.underlying TypeVar v loc
tv
varOf (Solved Blank loc
_ v
v Monotype v loc
_) = v
v
varOf (Ann v
v Type v loc
_) = v
v
varOf (Marker v
v) = v
v

isReserved :: (Var v) => v -> M v loc Bool
isReserved :: forall v loc. Var v => v -> M v loc Bool
isReserved v
v = (v
v v -> Env v loc -> Bool
forall v loc. Var v => v -> Env v loc -> Bool
`isReservedIn`) (Env v loc -> Bool)
-> MT v loc (Result v loc) (Env v loc)
-> MT v loc (Result v loc) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT v loc (Result v loc) (Env v loc)
forall s (m :: * -> *). MonadState s m => m s
get

isReservedIn :: (Var v) => v -> Env v loc -> Bool
isReservedIn :: forall v loc. Var v => v -> Env v loc -> Bool
isReservedIn v
v Env v loc
e = Env v loc -> Word64
forall v loc. Env v loc -> Word64
freshId Env v loc
e Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> v -> Word64
forall v. Var v => v -> Word64
Var.freshId v
v

universals :: (Ord v) => Context v loc -> Set v
universals :: forall v loc. Ord v => Context v loc -> Set v
universals = Info v loc -> Set v
forall v loc. Info v loc -> Set v
universalVars (Info v loc -> Set v)
-> (Context v loc -> Info v loc) -> Context v loc -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info

existentials :: (Ord v) => Context v loc -> Set v
existentials :: forall v loc. Ord v => Context v loc -> Set v
existentials = Info v loc -> Set v
forall v loc. Info v loc -> Set v
existentialVars (Info v loc -> Set v)
-> (Context v loc -> Info v loc) -> Context v loc -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info

-- | "Reserves" the given variables in this typechecking environment,
-- i.e. ensures that they won't be returned from `freshenVar` as fresh.
reserveAll :: (Var v, Foldable t) => t v -> M v loc ()
reserveAll :: forall v (t :: * -> *) loc.
(Var v, Foldable t) =>
t v -> M v loc ()
reserveAll t v
vs =
  let maxId :: Word64
maxId = (v -> Word64 -> Word64) -> Word64 -> t v -> Word64
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max (Word64 -> Word64 -> Word64)
-> (v -> Word64) -> v -> Word64 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Word64
forall v. Var v => v -> Word64
Var.freshId) Word64
0 t v
vs
   in (Env v loc -> Env v loc) -> M v loc ()
forall v loc. (Env v loc -> Env v loc) -> M v loc ()
modEnv (\Env v loc
e -> Env v loc
e {freshId = freshId e `max` maxId + 1})

freshenVar :: (Var v) => v -> M v0 loc v
freshenVar :: forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
v =
  (Env v0 loc -> (v, Env v0 loc)) -> M v0 loc v
forall v loc a. (Env v loc -> (a, Env v loc)) -> M v loc a
modEnv'
    ( \Env v0 loc
e ->
        let id :: Word64
id = Env v0 loc -> Word64
forall v loc. Env v loc -> Word64
freshId Env v0 loc
e in (Word64 -> v -> v
forall v. Var v => Word64 -> v -> v
Var.freshenId Word64
id v
v, Env v0 loc
e {freshId = freshId e + 1})
    )

freshenTypeVar :: (Var v) => TypeVar v loc -> M v loc v
freshenTypeVar :: forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
v =
  (Env v loc -> (v, Env v loc)) -> M v loc v
forall v loc a. (Env v loc -> (a, Env v loc)) -> M v loc a
modEnv'
    ( \Env v loc
e ->
        let id :: Word64
id = Env v loc -> Word64
forall v loc. Env v loc -> Word64
freshId Env v loc
e
         in (Word64 -> v -> v
forall v. Var v => Word64 -> v -> v
Var.freshenId Word64
id (TypeVar v loc -> v
forall b v. TypeVar b v -> v
TypeVar.underlying TypeVar v loc
v), Env v loc
e {freshId = id + 1})
    )

-- todo: do we want this to return a location for the aspect of the type that was not well formed
-- todo: or maybe a note / list of notes, or an M

-- | Check that the type is well formed wrt the given `Context`, see Figure 7 of paper
wellformedType :: (Var v) => Context v loc -> Type v loc -> Bool
wellformedType :: forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
t = case Type v loc
t of
  Type.Var' (TypeVar.Existential Blank loc
_ v
v) -> v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v (Context v loc -> Set v
forall v loc. Ord v => Context v loc -> Set v
existentials Context v loc
c)
  Type.Var' (TypeVar.Universal v
v) -> v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v (Context v loc -> Set v
forall v loc. Ord v => Context v loc -> Set v
universals Context v loc
c)
  Type.Ref' Reference
_ -> Bool
True
  Type.Arrow' Type v loc
i Type v loc
o -> Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
i Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
o
  Type.Ann' Type v loc
t' Kind
_ -> Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
t'
  Type.App' Type v loc
x Type v loc
y -> Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
x Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
y
  Type.Effect1' Type v loc
e Type v loc
a -> Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
e Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
a
  Type.Effects' [Type v loc]
es -> (Type v loc -> Bool) -> [Type v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c) [Type v loc]
es
  Type.IntroOuterNamed' TypeVar v loc
_ Type v loc
t -> Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type v loc
t
  Type.Forall' Subst F (TypeVar v loc) loc
t' ->
    let (v
v, Context v loc
ctx2) = Context v loc -> (v, Context v loc)
forall {a} {loc}. Var a => Context a loc -> (a, Context a loc)
extendUniversal Context v loc
c
     in Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx2 (Subst F (TypeVar v loc) loc -> Type v loc -> Type v loc
forall (f :: * -> *) v a. Subst f v a -> Term f v a -> Term f v a
ABT.bind Subst F (TypeVar v loc) loc
t' (loc -> v -> Type v loc
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Type v loc
t) v
v))
  Type v loc
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Match failure in wellformedType: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Type v loc -> [Char]
forall a. Show a => a -> [Char]
show Type v loc
t
  where
    -- Extend this `Context` with a single variable, guaranteed fresh
    extendUniversal :: Context a loc -> (a, Context a loc)
extendUniversal Context a loc
ctx =
      let v :: a
v = Set a -> a -> a
forall v. Var v => Set v -> v -> v
Var.freshIn (Context a loc -> Set a
forall v loc. Ord v => Context v loc -> Set v
usedVars Context a loc
ctx) (Text -> a
forall v. Var v => Text -> v
Var.named Text
"var")
          ctx' :: Context a loc
ctx' = Context a loc
-> Either (CompilerBug a loc) (Context a loc) -> Context a loc
forall b a. b -> Either a b -> b
fromRight ([Char] -> Context a loc
forall a. HasCallStack => [Char] -> a
error [Char]
"wellformedType: Expected Right") (Either (CompilerBug a loc) (Context a loc) -> Context a loc)
-> Either (CompilerBug a loc) (Context a loc) -> Context a loc
forall a b. (a -> b) -> a -> b
$ Element a loc
-> Context a loc -> Either (CompilerBug a loc) (Context a loc)
forall v loc.
Var v =>
Element v loc
-> Context v loc -> Either (CompilerBug v loc) (Context v loc)
extend' (a -> Element a loc
forall v loc. v -> Element v loc
Universal a
v) Context a loc
ctx
       in (a
v, Context a loc
ctx')

-- | Return the `Info` associated with the last element of the context, or the zero `Info`.
info :: (Ord v) => Context v loc -> Info v loc
info :: forall v loc. Ord v => Context v loc -> Info v loc
info (Context []) = Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info Set v
forall a. Monoid a => a
mempty Map v (Monotype v loc)
forall a. Monoid a => a
mempty Set v
forall a. Monoid a => a
mempty Map v (Type v loc)
forall a. Monoid a => a
mempty Set v
forall a. Monoid a => a
mempty
info (Context ((Element v loc
_, Info v loc
i) : [(Element v loc, Info v loc)]
_)) = Info v loc
i

-- | Add an element onto the end of this `Context`. Takes `O(log N)` time,
-- including updates to the accumulated `Info` value.
-- Fail if the new context is not well formed (see Figure 7 of paper).
extend' :: (Var v) => Element v loc -> Context v loc -> Either (CompilerBug v loc) (Context v loc)
extend' :: forall v loc.
Var v =>
Element v loc
-> Context v loc -> Either (CompilerBug v loc) (Context v loc)
extend' Element v loc
e c :: Context v loc
c@(Context [(Element v loc, Info v loc)]
ctx) = [(Element v loc, Info v loc)] -> Context v loc
forall v loc. [(Element v loc, Info v loc)] -> Context v loc
Context ([(Element v loc, Info v loc)] -> Context v loc)
-> (Info v loc -> [(Element v loc, Info v loc)])
-> Info v loc
-> Context v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Element v loc, Info v loc)
-> [(Element v loc, Info v loc)] -> [(Element v loc, Info v loc)]
forall a. a -> [a] -> [a]
: [(Element v loc, Info v loc)]
ctx) ((Element v loc, Info v loc) -> [(Element v loc, Info v loc)])
-> (Info v loc -> (Element v loc, Info v loc))
-> Info v loc
-> [(Element v loc, Info v loc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element v loc
e,) (Info v loc -> Context v loc)
-> Either (CompilerBug v loc) (Info v loc)
-> Either (CompilerBug v loc) (Context v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either (CompilerBug v loc) (Info v loc)
i'
  where
    Info Set v
es Map v (Monotype v loc)
ses Set v
us Map v (Type (TypeVar v loc) loc)
uas Set v
vs = Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info Context v loc
c
    -- see figure 7
    i' :: Either (CompilerBug v loc) (Info v loc)
i' = case Element v loc
e of
      Var TypeVar v loc
v -> case TypeVar v loc
v of
        -- UvarCtx - ensure no duplicates
        TypeVar.Universal v
v ->
          if v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v Set v
vs
            then Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a. a -> Either (CompilerBug v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info v loc -> Either (CompilerBug v loc) (Info v loc))
-> Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type (TypeVar v loc) loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info Set v
es Map v (Monotype v loc)
ses (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
us) Map v (Type (TypeVar v loc) loc)
uas (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
vs)
            else [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"variable " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already defined in the context"
        -- EvarCtx - ensure no duplicates, and that this existential is not solved earlier in context
        TypeVar.Existential Blank loc
_ v
v ->
          if v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v Set v
vs
            then Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a. a -> Either (CompilerBug v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info v loc -> Either (CompilerBug v loc) (Info v loc))
-> Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type (TypeVar v loc) loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
es) Map v (Monotype v loc)
ses Set v
us Map v (Type (TypeVar v loc) loc)
uas (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
vs)
            else [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"variable " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already defined in the context"
      -- SolvedEvarCtx - ensure `v` is fresh, and the solution is well-formed wrt the context
      Solved Blank loc
_ v
v sa :: Monotype v loc
sa@(Monotype v loc -> Type (TypeVar v loc) loc
forall v a. Monotype v a -> Type v a
Type.getPolytype -> Type (TypeVar v loc) loc
t)
        | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
vs -> [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"variable " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already defined in the context"
        | Bool -> Bool
not (Context v loc -> Type (TypeVar v loc) loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type (TypeVar v loc) loc
t) -> [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type (TypeVar v loc) loc -> [Char]
forall a. Show a => a -> [Char]
show Type (TypeVar v loc) loc
t [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not well-formed wrt the context"
        | Bool
otherwise ->
            Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a. a -> Either (CompilerBug v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info v loc -> Either (CompilerBug v loc) (Info v loc))
-> Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$
              Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type (TypeVar v loc) loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
es) (v
-> Monotype v loc
-> Map v (Monotype v loc)
-> Map v (Monotype v loc)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert v
v Monotype v loc
sa Map v (Monotype v loc)
ses) Set v
us Map v (Type (TypeVar v loc) loc)
uas (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
vs)
      -- VarCtx - ensure `v` is fresh, and annotation is well-formed wrt the context
      Ann v
v Type (TypeVar v loc) loc
t
        | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
vs -> [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"variable " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already defined in the context"
        | Bool -> Bool
not (Context v loc -> Type (TypeVar v loc) loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
c Type (TypeVar v loc) loc
t) -> [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type (TypeVar v loc) loc -> [Char]
forall a. Show a => a -> [Char]
show Type (TypeVar v loc) loc
t [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not well-formed wrt the context"
        | Bool
otherwise ->
            Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a. a -> Either (CompilerBug v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info v loc -> Either (CompilerBug v loc) (Info v loc))
-> Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$
              Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type (TypeVar v loc) loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info
                Set v
es
                Map v (Monotype v loc)
ses
                Set v
us
                (v
-> Type (TypeVar v loc) loc
-> Map v (Type (TypeVar v loc) loc)
-> Map v (Type (TypeVar v loc) loc)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert v
v Type (TypeVar v loc) loc
t Map v (Type (TypeVar v loc) loc)
uas)
                (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
vs)
      -- MarkerCtx - note that since a Marker is always the first mention of a variable, suffices to
      -- just check that `v` is not previously mentioned
      Marker v
v ->
        if v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v Set v
vs
          then Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a. a -> Either (CompilerBug v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info v loc -> Either (CompilerBug v loc) (Info v loc))
-> Info v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type (TypeVar v loc) loc)
-> Set v
-> Info v loc
forall v loc.
Set v
-> Map v (Monotype v loc)
-> Set v
-> Map v (Type v loc)
-> Set v
-> Info v loc
Info Set v
es Map v (Monotype v loc)
ses Set v
us Map v (Type (TypeVar v loc) loc)
uas (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
vs)
          else [Char] -> Either (CompilerBug v loc) (Info v loc)
crash ([Char] -> Either (CompilerBug v loc) (Info v loc))
-> [Char] -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"marker variable " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" already defined in the context"
    crash :: [Char] -> Either (CompilerBug v loc) (Info v loc)
crash [Char]
reason = CompilerBug v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. a -> Either a b
Left (CompilerBug v loc -> Either (CompilerBug v loc) (Info v loc))
-> CompilerBug v loc -> Either (CompilerBug v loc) (Info v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
forall v loc.
Context v loc -> Element v loc -> [Char] -> CompilerBug v loc
IllegalContextExtension Context v loc
c Element v loc
e [Char]
reason

extend :: (Var v) => Element v loc -> Context v loc -> M v loc (Context v loc)
extend :: forall v loc.
Var v =>
Element v loc -> Context v loc -> M v loc (Context v loc)
extend Element v loc
e Context v loc
c = (CompilerBug v loc -> M v loc (Context v loc))
-> (Context v loc -> M v loc (Context v loc))
-> Either (CompilerBug v loc) (Context v loc)
-> M v loc (Context v loc)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerBug v loc -> M v loc (Context v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash Context v loc -> M v loc (Context v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (CompilerBug v loc) (Context v loc)
 -> M v loc (Context v loc))
-> Either (CompilerBug v loc) (Context v loc)
-> M v loc (Context v loc)
forall a b. (a -> b) -> a -> b
$ Element v loc
-> Context v loc -> Either (CompilerBug v loc) (Context v loc)
forall v loc.
Var v =>
Element v loc
-> Context v loc -> Either (CompilerBug v loc) (Context v loc)
extend' Element v loc
e Context v loc
c

-- | Add the given elements onto the end of the given `Context`.
-- Fail if the new context is not well-formed.
extendN :: (Var v) => Context v loc -> [Element v loc] -> M v loc (Context v loc)
extendN :: forall v loc.
Var v =>
Context v loc -> [Element v loc] -> M v loc (Context v loc)
extendN Context v loc
ctx [Element v loc]
es = (Context v loc
 -> Element v loc -> MT v loc (Result v loc) (Context v loc))
-> Context v loc
-> [Element v loc]
-> MT v loc (Result v loc) (Context v loc)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Element v loc
 -> Context v loc -> MT v loc (Result v loc) (Context v loc))
-> Context v loc
-> Element v loc
-> MT v loc (Result v loc) (Context v loc)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Element v loc
-> Context v loc -> MT v loc (Result v loc) (Context v loc)
forall v loc.
Var v =>
Element v loc -> Context v loc -> M v loc (Context v loc)
extend) Context v loc
ctx [Element v loc]
es

-- | doesn't combine notes
orElse :: M v loc a -> M v loc a -> M v loc a
orElse :: forall v loc a. M v loc a -> M v loc a -> M v loc a
orElse M v loc a
m1 M v loc a
m2 = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (a, Env v loc))
-> M v loc a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
go
  where
    go :: PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
go PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env = M v loc a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM M v loc a
m1 PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env Result v loc (a, Env v loc)
-> Result v loc (a, Env v loc) -> Result v loc (a, Env v loc)
forall {v} {loc} {a}.
Result v loc a -> Result v loc a -> Result v loc a
<|> M v loc a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM M v loc a
m2 PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env
    s :: Result v loc a
s@(Success Seq (InfoNote v loc)
_ a
_) <|> :: Result v loc a -> Result v loc a -> Result v loc a
<|> Result v loc a
_ = Result v loc a
s
    TypeError NESeq (ErrorNote v loc)
_ Seq (InfoNote v loc)
_ <|> Result v loc a
r = Result v loc a
r
    CompilerBug CompilerBug v loc
_ Seq (ErrorNote v loc)
_ Seq (InfoNote v loc)
_ <|> Result v loc a
r = Result v loc a
r -- swallowing bugs for now: when checking whether a type annotation
    -- is redundant, typechecking without that annotation might result in
    -- a CompilerBug that we want `orElse` to recover from

-- getMaybe :: Result v loc a -> Result v loc (Maybe a)
-- getMaybe = hoistMaybe Just

-- hoistMaybe :: (Maybe a -> Maybe b) -> Result v loc a -> Result v loc b
-- hoistMaybe f (Result es is a) = Result es is (f a)

getPrettyPrintEnv :: M v loc PrettyPrintEnv
getPrettyPrintEnv :: forall v loc. M v loc PrettyPrintEnv
getPrettyPrintEnv = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (PrettyPrintEnv, Env v loc))
-> MT v loc (Result v loc) PrettyPrintEnv
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (PrettyPrintEnv, Env v loc)
-> Result v loc (PrettyPrintEnv, Env v loc)
forall a. a -> Result v loc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrettyPrintEnv
ppe, Env v loc
env)

getDataDeclarations :: M v loc (DataDeclarations v loc)
getDataDeclarations :: forall v loc. M v loc (DataDeclarations v loc)
getDataDeclarations = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (DataDeclarations v loc, Env v loc))
-> MT v loc (Result v loc) (DataDeclarations v loc)
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
datas EffectDeclarations v loc
_ Env v loc
env -> (DataDeclarations v loc, Env v loc)
-> Result v loc (DataDeclarations v loc, Env v loc)
forall a. a -> Result v loc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataDeclarations v loc
datas, Env v loc
env)

getEffectDeclarations :: M v loc (EffectDeclarations v loc)
getEffectDeclarations :: forall v loc. M v loc (EffectDeclarations v loc)
getEffectDeclarations = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result v loc (EffectDeclarations v loc, Env v loc))
-> MT v loc (Result v loc) (EffectDeclarations v loc)
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
effects Env v loc
env -> (EffectDeclarations v loc, Env v loc)
-> Result v loc (EffectDeclarations v loc, Env v loc)
forall a. a -> Result v loc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EffectDeclarations v loc
effects, Env v loc
env)

getPatternMatchCoverageCheckAndKindInferenceSwitch :: M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
getPatternMatchCoverageCheckAndKindInferenceSwitch :: forall v loc.
M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
getPatternMatchCoverageCheckAndKindInferenceSwitch = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Result
      v loc (PatternMatchCoverageCheckAndKindInferenceSwitch, Env v loc))
-> MT
     v
     loc
     (Result v loc)
     PatternMatchCoverageCheckAndKindInferenceSwitch
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (PatternMatchCoverageCheckAndKindInferenceSwitch, Env v loc)
-> Result
     v loc (PatternMatchCoverageCheckAndKindInferenceSwitch, Env v loc)
forall a. a -> Result v loc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch, Env v loc
env)

compilerCrash :: CompilerBug v loc -> M v loc a
compilerCrash :: forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash CompilerBug v loc
bug = Result v loc a -> M v loc a
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc a -> M v loc a) -> Result v loc a -> M v loc a
forall a b. (a -> b) -> a -> b
$ CompilerBug v loc -> Result v loc a
forall v loc a. CompilerBug v loc -> Result v loc a
compilerBug CompilerBug v loc
bug

failWith :: Cause v loc -> M v loc a
failWith :: forall v loc a. Cause v loc -> M v loc a
failWith Cause v loc
cause = Result v loc a -> M v loc a
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc a -> M v loc a) -> Result v loc a -> M v loc a
forall a b. (a -> b) -> a -> b
$ Cause v loc -> Result v loc a
forall v loc a. Cause v loc -> Result v loc a
typeError Cause v loc
cause

compilerCrashResult :: CompilerBug v loc -> Result v loc a
compilerCrashResult :: forall v loc a. CompilerBug v loc -> Result v loc a
compilerCrashResult CompilerBug v loc
bug = CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
forall v loc a.
CompilerBug v loc
-> Seq (ErrorNote v loc) -> Seq (InfoNote v loc) -> Result v loc a
CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
forall a. Monoid a => a
mempty Seq (InfoNote v loc)
forall a. Monoid a => a
mempty

getDataDeclaration :: Reference -> M v loc (DataDeclaration v loc)
getDataDeclaration :: forall v loc. Reference -> M v loc (DataDeclaration v loc)
getDataDeclaration Reference
r = do
  DataDeclarations v loc
ddecls <- M v loc (DataDeclarations v loc)
forall v loc. M v loc (DataDeclarations v loc)
getDataDeclarations
  case Reference
-> DataDeclarations v loc -> Maybe (DataDeclaration v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r DataDeclarations v loc
ddecls of
    Maybe (DataDeclaration v loc)
Nothing ->
      M v loc (EffectDeclarations v loc)
forall v loc. M v loc (EffectDeclarations v loc)
getEffectDeclarations M v loc (EffectDeclarations v loc)
-> (EffectDeclarations v loc -> M v loc (DataDeclaration v loc))
-> M v loc (DataDeclaration v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EffectDeclarations v loc
edecls ->
        case Reference
-> EffectDeclarations v loc -> Maybe (EffectDeclaration v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r EffectDeclarations v loc
edecls of
          Maybe (EffectDeclaration v loc)
Nothing -> CompilerBug v loc -> M v loc (DataDeclaration v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (Unknown -> Reference -> DataDeclarations v loc -> CompilerBug v loc
forall v loc.
Unknown
-> Reference
-> Map Reference (DataDeclaration v loc)
-> CompilerBug v loc
UnknownDecl Unknown
Data Reference
r DataDeclarations v loc
ddecls)
          Just EffectDeclaration v loc
decl ->
            Result v loc (DataDeclaration v loc)
-> M v loc (DataDeclaration v loc)
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc (DataDeclaration v loc)
 -> M v loc (DataDeclaration v loc))
-> (Cause v loc -> Result v loc (DataDeclaration v loc))
-> Cause v loc
-> M v loc (DataDeclaration v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> Result v loc (DataDeclaration v loc)
forall v loc a. Cause v loc -> Result v loc a
typeError (Cause v loc -> M v loc (DataDeclaration v loc))
-> Cause v loc -> M v loc (DataDeclaration v loc)
forall a b. (a -> b) -> a -> b
$
              Unknown -> Reference -> DataDeclaration v loc -> Cause v loc
forall v loc.
Unknown -> Reference -> DataDeclaration v loc -> Cause v loc
DataEffectMismatch Unknown
Effect Reference
r (EffectDeclaration v loc -> DataDeclaration v loc
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl EffectDeclaration v loc
decl)
    Just DataDeclaration v loc
decl -> DataDeclaration v loc -> M v loc (DataDeclaration v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataDeclaration v loc
decl

getEffectDeclaration :: Reference -> M v loc (EffectDeclaration v loc)
getEffectDeclaration :: forall v loc. Reference -> M v loc (EffectDeclaration v loc)
getEffectDeclaration Reference
r = do
  EffectDeclarations v loc
edecls <- M v loc (EffectDeclarations v loc)
forall v loc. M v loc (EffectDeclarations v loc)
getEffectDeclarations
  case Reference
-> EffectDeclarations v loc -> Maybe (EffectDeclaration v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r EffectDeclarations v loc
edecls of
    Maybe (EffectDeclaration v loc)
Nothing ->
      M v loc (DataDeclarations v loc)
forall v loc. M v loc (DataDeclarations v loc)
getDataDeclarations M v loc (DataDeclarations v loc)
-> (DataDeclarations v loc -> M v loc (EffectDeclaration v loc))
-> M v loc (EffectDeclaration v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DataDeclarations v loc
ddecls ->
        case Reference
-> DataDeclarations v loc -> Maybe (DataDeclaration v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r DataDeclarations v loc
ddecls of
          Maybe (DataDeclaration v loc)
Nothing ->
            CompilerBug v loc -> M v loc (EffectDeclaration v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> M v loc (EffectDeclaration v loc))
-> CompilerBug v loc -> M v loc (EffectDeclaration v loc)
forall a b. (a -> b) -> a -> b
$
              Unknown -> Reference -> DataDeclarations v loc -> CompilerBug v loc
forall v loc.
Unknown
-> Reference
-> Map Reference (DataDeclaration v loc)
-> CompilerBug v loc
UnknownDecl Unknown
Effect Reference
r (EffectDeclaration v loc -> DataDeclaration v loc
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl (EffectDeclaration v loc -> DataDeclaration v loc)
-> EffectDeclarations v loc -> DataDeclarations v loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectDeclarations v loc
edecls)
          Just DataDeclaration v loc
decl ->
            Result v loc (EffectDeclaration v loc)
-> M v loc (EffectDeclaration v loc)
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc (EffectDeclaration v loc)
 -> M v loc (EffectDeclaration v loc))
-> (Cause v loc -> Result v loc (EffectDeclaration v loc))
-> Cause v loc
-> M v loc (EffectDeclaration v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> Result v loc (EffectDeclaration v loc)
forall v loc a. Cause v loc -> Result v loc a
typeError (Cause v loc -> M v loc (EffectDeclaration v loc))
-> Cause v loc -> M v loc (EffectDeclaration v loc)
forall a b. (a -> b) -> a -> b
$ Unknown -> Reference -> DataDeclaration v loc -> Cause v loc
forall v loc.
Unknown -> Reference -> DataDeclaration v loc -> Cause v loc
DataEffectMismatch Unknown
Data Reference
r DataDeclaration v loc
decl
    Just EffectDeclaration v loc
decl -> EffectDeclaration v loc -> M v loc (EffectDeclaration v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EffectDeclaration v loc
decl

getDataConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
getDataConstructorType :: forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getDataConstructorType = Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> ConstructorReference
-> M v loc (Type v loc)
forall v loc.
Var v =>
Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> ConstructorReference
-> M v loc (Type v loc)
getConstructorType' Unknown
Data Reference -> M v loc (DataDeclaration v loc)
forall v loc. Reference -> M v loc (DataDeclaration v loc)
getDataDeclaration

getDataConstructors :: forall v loc. (Var v) => Type v loc -> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructors :: forall v loc.
Var v =>
Type v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructors Type v loc
typ
  | Type.Ref' Reference
r <- Type v loc
typ, Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.booleanRef = EnumeratedConstructors (TypeVar v loc) v loc
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumeratedConstructors (TypeVar v loc) v loc
forall vt v loc. EnumeratedConstructors vt v loc
BooleanType
  | Type.Request' [Type v loc]
effects Type v loc
resultType <- Type v loc
typ =
      let phi :: Type v loc
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
phi Type v loc
effect =
            case Type v loc -> Maybe Reference
forall {v} {a}. Type v a -> Maybe Reference
theRef Type v loc
effect of
              Just Reference
r -> [(ConstructorReference, (v, Type v loc))]
-> Map ConstructorReference (v, Type v loc)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ConstructorReference, (v, Type v loc))]
 -> Map ConstructorReference (v, Type v loc))
-> (EffectDeclaration v loc
    -> [(ConstructorReference, (v, Type v loc))])
-> EffectDeclaration v loc
-> Map ConstructorReference (v, Type v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, ConstructorReference, Type v loc)
 -> (ConstructorReference, (v, Type v loc)))
-> [(v, ConstructorReference, Type v loc)]
-> [(ConstructorReference, (v, Type v loc))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
v, ConstructorReference
cr, Type v loc
t) -> (ConstructorReference
cr, (v
v, Type v loc
t))) ([(v, ConstructorReference, Type v loc)]
 -> [(ConstructorReference, (v, Type v loc))])
-> (EffectDeclaration v loc
    -> [(v, ConstructorReference, Type v loc)])
-> EffectDeclaration v loc
-> [(ConstructorReference, (v, Type v loc))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> DataDeclaration v loc -> [(v, ConstructorReference, Type v loc)]
crFromDecl Reference
r (DataDeclaration v loc -> [(v, ConstructorReference, Type v loc)])
-> (EffectDeclaration v loc -> DataDeclaration v loc)
-> EffectDeclaration v loc
-> [(v, ConstructorReference, Type v loc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectDeclaration v loc -> DataDeclaration v loc
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl (EffectDeclaration v loc
 -> Map ConstructorReference (v, Type v loc))
-> MT v loc (Result v loc) (EffectDeclaration v loc)
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> MT v loc (Result v loc) (EffectDeclaration v loc)
forall v loc. Reference -> M v loc (EffectDeclaration v loc)
getEffectDeclaration Reference
r
              Maybe Reference
Nothing -> Map ConstructorReference (v, Type v loc)
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ConstructorReference (v, Type v loc)
forall k a. Map k a
Map.empty
          crefs :: MT v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
crefs = Ap
  (MT v loc (Result v loc))
  (Map ConstructorReference (v, Type v loc))
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp ((Type v loc
 -> Ap
      (MT v loc (Result v loc))
      (Map ConstructorReference (v, Type v loc)))
-> [Type v loc]
-> Ap
     (MT v loc (Result v loc))
     (Map ConstructorReference (v, Type v loc))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (MT v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
-> Ap
     (MT v loc (Result v loc))
     (Map ConstructorReference (v, Type v loc))
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (MT v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
 -> Ap
      (MT v loc (Result v loc))
      (Map ConstructorReference (v, Type v loc)))
-> (Type v loc
    -> MT
         v loc (Result v loc) (Map ConstructorReference (v, Type v loc)))
-> Type v loc
-> Ap
     (MT v loc (Result v loc))
     (Map ConstructorReference (v, Type v loc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type v loc
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
phi) [Type v loc]
effects)
       in Type v loc
-> Map ConstructorReference (v, Type v loc)
-> EnumeratedConstructors (TypeVar v loc) v loc
forall vt v loc.
Type vt loc
-> Map ConstructorReference (v, Type vt loc)
-> EnumeratedConstructors vt v loc
AbilityType Type v loc
resultType (Map ConstructorReference (v, Type v loc)
 -> EnumeratedConstructors (TypeVar v loc) v loc)
-> MT
     v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT v loc (Result v loc) (Map ConstructorReference (v, Type v loc))
crefs
  | Type.App' (Type.Ref' Reference
r) Type v loc
arg <- Type v loc
typ,
    Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.listRef =
      let xs :: [(ListPat, [Type v loc])]
xs =
            [ (ListPat
ListPat.Cons, [Type v loc
arg]),
              (ListPat
ListPat.Nil, [])
            ]
       in EnumeratedConstructors (TypeVar v loc) v loc
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ListPat, [Type v loc])]
-> EnumeratedConstructors (TypeVar v loc) v loc
forall vt v loc.
[(ListPat, [Type vt loc])] -> EnumeratedConstructors vt v loc
SequenceType [(ListPat, [Type v loc])]
xs)
  | Just Reference
r <- Type v loc -> Maybe Reference
forall {v} {a}. Type v a -> Maybe Reference
theRef Type v loc
typ = [(v, ConstructorReference, Type v loc)]
-> EnumeratedConstructors (TypeVar v loc) v loc
forall vt v loc.
[(v, ConstructorReference, Type vt loc)]
-> EnumeratedConstructors vt v loc
ConstructorType ([(v, ConstructorReference, Type v loc)]
 -> EnumeratedConstructors (TypeVar v loc) v loc)
-> (DataDeclaration v loc
    -> [(v, ConstructorReference, Type v loc)])
-> DataDeclaration v loc
-> EnumeratedConstructors (TypeVar v loc) v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> DataDeclaration v loc -> [(v, ConstructorReference, Type v loc)]
crFromDecl Reference
r (DataDeclaration v loc
 -> EnumeratedConstructors (TypeVar v loc) v loc)
-> MT v loc (Result v loc) (DataDeclaration v loc)
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> MT v loc (Result v loc) (DataDeclaration v loc)
forall v loc. Reference -> M v loc (DataDeclaration v loc)
getDataDeclaration Reference
r
  | Bool
otherwise = EnumeratedConstructors (TypeVar v loc) v loc
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumeratedConstructors (TypeVar v loc) v loc
forall vt v loc. EnumeratedConstructors vt v loc
OtherType
  where
    crFromDecl :: Reference -> DataDeclaration v loc -> [(v, ConstructorReference, Type v loc)]
    crFromDecl :: Reference
-> DataDeclaration v loc -> [(v, ConstructorReference, Type v loc)]
crFromDecl Reference
r DataDeclaration v loc
decl =
      [(v
v, Reference -> Word64 -> ConstructorReference
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference Reference
r Word64
i, (v -> TypeVar v loc) -> Term F v loc -> Type v loc
forall (f :: * -> *) v' v a.
(Functor f, Foldable f, Ord v') =>
(v -> v') -> Term f v a -> Term f v' a
ABT.vmap v -> TypeVar v loc
forall b v. v -> TypeVar b v
TypeVar.Universal Term F v loc
t) | (Word64
i, (v
v, Term F v loc
t)) <- [Word64] -> [(v, Term F v loc)] -> [(Word64, (v, Term F v loc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
0 ..] (DataDeclaration v loc -> [(v, Term F v loc)]
forall v a. DataDeclaration v a -> [(v, Type v a)]
DD.constructors DataDeclaration v loc
decl)]
    theRef :: Type v a -> Maybe Reference
theRef Type v a
t = case Type v a
t of
      Type.Apps' (Type.Ref' r :: Reference
r@Reference.DerivedId {}) [Type v a]
_targs -> Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
r
      Type.Ref' r :: Reference
r@Reference.DerivedId {} -> Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
r
      Type v a
_ -> Maybe Reference
forall a. Maybe a
Nothing

getEffectConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType :: forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType = Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> ConstructorReference
-> M v loc (Type v loc)
forall v loc.
Var v =>
Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> ConstructorReference
-> M v loc (Type v loc)
getConstructorType' Unknown
Effect Reference -> M v loc (DataDeclaration v loc)
forall v loc. Reference -> M v loc (DataDeclaration v loc)
go
  where
    go :: Reference -> MT v a (Result v a) (DataDeclaration v a)
go Reference
r = EffectDeclaration v a -> DataDeclaration v a
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl (EffectDeclaration v a -> DataDeclaration v a)
-> MT v a (Result v a) (EffectDeclaration v a)
-> MT v a (Result v a) (DataDeclaration v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> MT v a (Result v a) (EffectDeclaration v a)
forall v loc. Reference -> M v loc (EffectDeclaration v loc)
getEffectDeclaration Reference
r

-- Encountered an unknown constructor in the typechecker; unknown constructors
-- should have been detected earlier though.
getConstructorType' ::
  (Var v) =>
  Unknown ->
  (Reference -> M v loc (DataDeclaration v loc)) ->
  ConstructorReference ->
  M v loc (Type v loc)
getConstructorType' :: forall v loc.
Var v =>
Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> ConstructorReference
-> M v loc (Type v loc)
getConstructorType' Unknown
kind Reference -> M v loc (DataDeclaration v loc)
get (ConstructorReference Reference
r Word64
cid) = do
  DataDeclaration v loc
decl <- Reference -> M v loc (DataDeclaration v loc)
get Reference
r
  case Int -> [(v, Type v loc)] -> [(v, Type v loc)]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cid) (DataDeclaration v loc -> [(v, Type v loc)]
forall v a. DataDeclaration v a -> [(v, Type v a)]
DD.constructors DataDeclaration v loc
decl) of
    [] -> CompilerBug v loc -> M v loc (Type v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> M v loc (Type v loc))
-> CompilerBug v loc -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ Unknown
-> ConstructorReference
-> DataDeclaration v loc
-> CompilerBug v loc
forall v loc.
Unknown
-> ConstructorReference
-> DataDeclaration v loc
-> CompilerBug v loc
UnknownConstructor Unknown
kind (Reference -> Word64 -> ConstructorReference
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference Reference
r Word64
cid) DataDeclaration v loc
decl
    (v
_v, Type v loc
typ) : [(v, Type v loc)]
_ -> Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type v loc -> M v loc (Type v loc))
-> Type v loc -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ (v -> TypeVar v loc) -> Type v loc -> Type v loc
forall (f :: * -> *) v' v a.
(Functor f, Foldable f, Ord v') =>
(v -> v') -> Term f v a -> Term f v' a
ABT.vmap v -> TypeVar v loc
forall b v. v -> TypeVar b v
TypeVar.Universal Type v loc
typ

extendUniversal :: (Var v) => v -> M v loc v
extendUniversal :: forall v loc. Var v => v -> M v loc v
extendUniversal v
v = do
  v
v' <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
v
  Element v loc -> M v loc ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext (v -> Element v loc
forall v loc. v -> Element v loc
Universal v
v')
  pure v
v'

extendExistential :: (Var v) => v -> M v loc v
extendExistential :: forall v loc. Var v => v -> M v loc v
extendExistential v
v = do
  v
v' <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
v
  Element v loc -> M v loc ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext (TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (Blank loc -> v -> TypeVar v loc
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v'))
  pure v
v'

extendExistentialTV :: (Var v) => v -> M v loc (TypeVar v loc)
extendExistentialTV :: forall v loc. Var v => v -> M v loc (TypeVar v loc)
extendExistentialTV v
v =
  Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank (v -> TypeVar (Blank loc) v)
-> MT v loc (Result v loc) v
-> MT v loc (Result v loc) (TypeVar (Blank loc) v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendExistential v
v

notMember :: (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember :: forall v loc. (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember v
v Set (TypeVar (Blank loc) v)
s =
  TypeVar (Blank loc) v -> Set (TypeVar (Blank loc) v) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (v -> TypeVar (Blank loc) v
forall b v. v -> TypeVar b v
TypeVar.Universal v
v) Set (TypeVar (Blank loc) v)
s
    Bool -> Bool -> Bool
&& TypeVar (Blank loc) v -> Set (TypeVar (Blank loc) v) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v) Set (TypeVar (Blank loc) v)
s

-- | Replace any existentials with their solution in the context
apply :: (Var v, Ord loc) => Context v loc -> Type v loc -> Type v loc
apply :: forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx = Map v (Monotype v loc) -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Map v (Monotype v loc) -> Type v loc -> Type v loc
apply' (Info v loc -> Map v (Monotype v loc)
forall v loc. Info v loc -> Map v (Monotype v loc)
solvedExistentials (Info v loc -> Map v (Monotype v loc))
-> (Context v loc -> Info v loc)
-> Context v loc
-> Map v (Monotype v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info (Context v loc -> Map v (Monotype v loc))
-> Context v loc -> Map v (Monotype v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc
ctx)

-- | Replace any existentials with their solution in the context (given as a list of elements)
applyCtx :: (Var v, Ord loc) => [Element v loc] -> Type v loc -> Type v loc
applyCtx :: forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
elems = Map v (Monotype v loc) -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Map v (Monotype v loc) -> Type v loc -> Type v loc
apply' (Map v (Monotype v loc) -> Type v loc -> Type v loc)
-> Map v (Monotype v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ [(v, Monotype v loc)] -> Map v (Monotype v loc)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v
v, Monotype v loc
sa) | Solved Blank loc
_ v
v Monotype v loc
sa <- [Element v loc]
elems]

apply' :: (Var v, Ord loc) => Map v (Monotype v loc) -> Type v loc -> Type v loc
apply' :: forall v loc.
(Var v, Ord loc) =>
Map v (Monotype v loc) -> Type v loc -> Type v loc
apply' Map v (Monotype v loc)
_ Term F (TypeVar (Blank loc) v) loc
t | Set (TypeVar (Blank loc) v) -> Bool
forall a. Set a -> Bool
Set.null (Term F (TypeVar (Blank loc) v) loc -> Set (TypeVar (Blank loc) v)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar (Blank loc) v) loc
t) = Term F (TypeVar (Blank loc) v) loc
t
apply' Map v (Monotype v loc)
solvedExistentials Term F (TypeVar (Blank loc) v) loc
t = Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t
  where
    go :: Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t = case Term F (TypeVar (Blank loc) v) loc
t of
      Type.Var' (TypeVar.Universal v
_) -> Term F (TypeVar (Blank loc) v) loc
t
      Type.Ref' Reference
_ -> Term F (TypeVar (Blank loc) v) loc
t
      Type.Var' (TypeVar.Existential Blank loc
_ v
v) ->
        Term F (TypeVar (Blank loc) v) loc
-> (Monotype v loc -> Term F (TypeVar (Blank loc) v) loc)
-> Maybe (Monotype v loc)
-> Term F (TypeVar (Blank loc) v) loc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Term F (TypeVar (Blank loc) v) loc
t (\(Type.Monotype Term F (TypeVar (Blank loc) v) loc
t') -> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t') (v -> Map v (Monotype v loc) -> Maybe (Monotype v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v (Monotype v loc)
solvedExistentials)
      Type.Arrow' Term F (TypeVar (Blank loc) v) loc
i Term F (TypeVar (Blank loc) v) loc
o -> loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow loc
a (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
i) (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
o)
      Type.App' Term F (TypeVar (Blank loc) v) loc
x Term F (TypeVar (Blank loc) v) loc
y -> loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
a (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
x) (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
y)
      Type.Ann' Term F (TypeVar (Blank loc) v) loc
v Kind
k -> loc
-> Term F (TypeVar (Blank loc) v) loc
-> Kind
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> Type v a -> Kind -> Type v a
Type.ann loc
a (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
v) Kind
k
      Type.Effect1' Term F (TypeVar (Blank loc) v) loc
e Term F (TypeVar (Blank loc) v) loc
t -> loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.effect1 loc
a (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
e) (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t)
      Type.Effects' [Term F (TypeVar (Blank loc) v) loc]
es -> loc
-> [Term F (TypeVar (Blank loc) v) loc]
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects loc
a ((Term F (TypeVar (Blank loc) v) loc
 -> Term F (TypeVar (Blank loc) v) loc)
-> [Term F (TypeVar (Blank loc) v) loc]
-> [Term F (TypeVar (Blank loc) v) loc]
forall a b. (a -> b) -> [a] -> [b]
map Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go [Term F (TypeVar (Blank loc) v) loc]
es)
      Type.ForallNamed' TypeVar (Blank loc) v
v Term F (TypeVar (Blank loc) v) loc
t' -> loc
-> TypeVar (Blank loc) v
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.forAll loc
a TypeVar (Blank loc) v
v (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t')
      Type.IntroOuterNamed' TypeVar (Blank loc) v
v Term F (TypeVar (Blank loc) v) loc
t' -> loc
-> TypeVar (Blank loc) v
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.introOuter loc
a TypeVar (Blank loc) v
v (Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
go Term F (TypeVar (Blank loc) v) loc
t')
      Term F (TypeVar (Blank loc) v) loc
_ -> [Char] -> Term F (TypeVar (Blank loc) v) loc
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term F (TypeVar (Blank loc) v) loc)
-> [Char] -> Term F (TypeVar (Blank loc) v) loc
forall a b. (a -> b) -> a -> b
$ [Char]
"Match error in Context.apply': " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Term F (TypeVar (Blank loc) v) loc -> [Char]
forall a. Show a => a -> [Char]
show Term F (TypeVar (Blank loc) v) loc
t
      where
        a :: loc
a = Term F (TypeVar (Blank loc) v) loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term F (TypeVar (Blank loc) v) loc
t

loc :: ABT.Term f v loc -> loc
loc :: forall (f :: * -> *) v a. Term f v a -> a
loc = Term f v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation

-- | Post-processes an action that wants abilities by filtering out
-- some handled abilities.
withEffects ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  M v loc (Wanted v loc) ->
  M v loc (Wanted v loc)
withEffects :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
withEffects [Type v loc]
handled M v loc (Wanted v loc)
act = do
  Wanted v loc
want <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted (Wanted v loc -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< M v loc (Wanted v loc)
act
  [Type v loc]
handled <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
handled
  Wanted v loc
-> Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc
-> Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneWanted [] Wanted v loc
want [Type v loc]
handled

synthesizeApps ::
  (Foldable f, Var v, Ord loc) =>
  Term v loc ->
  Type v loc ->
  f (Term v loc) ->
  M v loc (Type v loc, Wanted v loc)
synthesizeApps :: forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term v loc
fun Type v loc
ft f (Term v loc)
args =
  ((Type v loc, Wanted v loc)
 -> (Term v loc, Int)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> (Type v loc, Wanted v loc)
-> [(Term v loc, Int)]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Type v loc, Wanted v loc)
-> (Term v loc, Int)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
go (Type v loc
ft, []) ([(Term v loc, Int)]
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> [(Term v loc, Int)]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ f (Term v loc) -> [Term v loc]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList f (Term v loc)
args [Term v loc] -> [Int] -> [(Term v loc, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
1 ..]
  where
    go :: (Type v loc, Wanted v loc)
-> (Term v loc, Int)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
go (Type v loc
ft, Wanted v loc
want) (Term v loc, Int)
arg = do
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      (Type v loc
t, Wanted v loc
rwant) <- Term v loc
-> Type v loc
-> (Term v loc, Int)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApp Term v loc
fun (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
ft) (Term v loc, Int)
arg
      (Type v loc
t,) (Wanted v loc -> (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
rwant Wanted v loc
want

-- | Synthesize the type of the given term, `arg` given that a function of
-- the given type `ft` is being applied to `arg`. Update the context in
-- the process.
-- e.g. in `(f:t) x` -- finds the type of (f x) given t and x.
synthesizeApp ::
  (Var v, Ord loc) =>
  Term v loc ->
  Type v loc ->
  (Term v loc, Int) ->
  M v loc (Type v loc, Wanted v loc)
synthesizeApp :: forall v loc.
(Var v, Ord loc) =>
Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApp Term v loc
_ Type v loc
ft (Term v loc, Int)
arg
  | Bool
debugEnabled Bool -> Bool -> Bool
&& ([Char], Type v loc, (Term v loc, Int)) -> Bool -> Bool
forall a b. Show a => a -> b -> b
traceShow ([Char]
"synthesizeApp" :: String, Type v loc
ft, (Term v loc, Int)
arg) Bool
False =
      M v loc (Type v loc, Wanted v loc)
forall a. HasCallStack => a
undefined
synthesizeApp Term v loc
fun (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters -> Type.Effect'' [Type v loc]
es Type v loc
ft) argp :: (Term v loc, Int)
argp@(Term v loc
arg, Int
argNum) =
  PathElement v loc
-> M v loc (Type v loc, Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Type v loc -> Term v loc -> Int -> PathElement v loc
forall v loc. Type v loc -> Term v loc -> Int -> PathElement v loc
InSynthesizeApp Type v loc
ft Term v loc
arg Int
argNum) (M v loc (Type v loc, Wanted v loc)
 -> M v loc (Type v loc, Wanted v loc))
-> M v loc (Type v loc, Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    (Type v loc
t, Wanted v loc
w) <- Type v loc -> M v loc (Type v loc, Wanted v loc)
go Type v loc
ft
    (Type v loc
t,) (Wanted v loc -> (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted ((Term v loc -> Maybe (Term v loc)
forall a. a -> Maybe a
Just Term v loc
fun,) (Type v loc -> (Maybe (Term v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es) Wanted v loc
w
  where
    go :: Type v loc -> M v loc (Type v loc, Wanted v loc)
go (Type.Forall' Subst F (TypeVar v loc) loc
body) = do
      -- Forall1App
      v
v <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
body TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
      [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
v]
      let ft2 :: Type v loc
ft2 = Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Type v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
body (() -> Blank loc -> v -> Term F (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank v
v)
      Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApp Term v loc
fun Type v loc
ft2 (Term v loc, Int)
argp
    go (Type.Arrow' Type v loc
i Type v loc
o0) = do
      -- ->App
      let ([Type v loc]
es, Type v loc
o) = Type v loc -> ([Type v loc], Type v loc)
forall v a. Ord v => Type v a -> ([Type v a], Type v a)
Type.stripEffect Type v loc
o0
      (Type v loc
o,) (Wanted v loc -> (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc
-> Term v loc
-> Type v loc
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWantedScoped ((Term v loc -> Maybe (Term v loc)
forall a. a -> Maybe a
Just Term v loc
fun,) (Type v loc -> (Maybe (Term v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es) Term v loc
arg Type v loc
i
    go (Type.Var' (TypeVar.Existential Blank loc
b v
a)) = do
      -- a^App
      [v
i, v
e, v
o] <- (v -> MT v loc (Result v loc) v)
-> [v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [Text -> v
forall v. Var v => Text -> v
Var.named Text
"i", v
forall v. Var v => v
Var.inferAbility, Text -> v
forall v. Var v => Text -> v
Var.named Text
"o"]
      let it :: Type v loc
it = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ft) Blank loc
forall loc. Blank loc
B.Blank v
i
          ot :: Type v loc
ot = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ft) Blank loc
forall loc. Blank loc
B.Blank v
o
          et :: Type v loc
et = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ft) Blank loc
forall loc. Blank loc
B.Blank v
e
          soln :: Monotype (TypeVar v loc) loc
soln =
            Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype
              ( loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow
                  (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ft)
                  Type v loc
it
                  (loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ft) [Type v loc
et] Type v loc
ot)
              )
          ctxMid :: [Element v loc]
ctxMid =
            [ v -> Element v loc
forall v loc. v -> Element v loc
existential v
o,
              v -> Element v loc
forall v loc. v -> Element v loc
existential v
e,
              v -> Element v loc
forall v loc. v -> Element v loc
existential v
i,
              Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
b v
a Monotype (TypeVar v loc) loc
soln
            ]
      Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext (v -> Element v loc
forall v loc. v -> Element v loc
existential v
a) [Element v loc]
ctxMid
      Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc
-> Type v loc
-> (Term v loc, Int)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApp Term v loc
fun (Monotype (TypeVar v loc) loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype (TypeVar v loc) loc
soln) (Term v loc, Int)
argp
    go Type v loc
_ = M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc (Type v loc, Wanted v loc))
-> M v loc (Type v loc, Wanted v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx -> Cause v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc (Type v loc, Wanted v loc))
-> Cause v loc -> M v loc (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx
synthesizeApp Term v loc
_ Type v loc
_ (Term v loc, Int)
_ =
  [Char] -> M v loc (Type v loc, Wanted v loc)
forall a. HasCallStack => [Char] -> a
error [Char]
"unpossible - Type.Effect'' pattern always succeeds"

-- For arity 3, creates the type `∀ a . a -> a -> a -> Sequence a`
-- For arity 2, creates the type `∀ a . a -> a -> Sequence a`
vectorConstructorOfArity :: (Var v, Ord loc) => loc -> Int -> M v loc (Type v loc)
vectorConstructorOfArity :: forall v loc.
(Var v, Ord loc) =>
loc -> Int -> M v loc (Type v loc)
vectorConstructorOfArity loc
loc Int
arity = do
  let elementVar :: TypeVar v loc
elementVar = Text -> TypeVar v loc
forall v. Var v => Text -> v
Var.named Text
"elem"
      args :: [(loc, Type v loc)]
args = Int -> (loc, Type v loc) -> [(loc, Type v loc)]
forall a. Int -> a -> [a]
replicate Int
arity (loc
loc, loc -> TypeVar v loc -> Type v loc
forall v a. Ord v => a -> v -> Type v a
Type.var loc
loc TypeVar v loc
elementVar)
      resultType :: Type v loc
resultType = loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
loc (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
loc) (loc -> TypeVar v loc -> Type v loc
forall v a. Ord v => a -> v -> Type v a
Type.var loc
loc TypeVar v loc
elementVar)
      vt :: Type v loc
vt = loc -> TypeVar v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.forAll loc
loc TypeVar v loc
elementVar ([(loc, Type v loc)] -> Type v loc -> Type v loc
forall v a. Ord v => [(a, Type v a)] -> Type v a -> Type v a
Type.arrows [(loc, Type v loc)]
args Type v loc
resultType)
  Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type v loc
vt

generalizeAndUnTypeVar :: (Var v) => Type v a -> Type.Type v a
generalizeAndUnTypeVar :: forall v a. Var v => Type v a -> Type v a
generalizeAndUnTypeVar Type v a
t | [Char] -> Type v a -> Bool
forall v a. Var v => [Char] -> Type v a -> Bool
debugType [Char]
"generalizeAndUnTypeVar" Type v a
t = Type v a
forall a. HasCallStack => a
undefined
generalizeAndUnTypeVar Type v a
t =
  Type v a -> Type v a
forall v loc. Var v => Type v loc -> Type v loc
Type.cleanup (Type v a -> Type v a)
-> (Type v a -> Type v a) -> Type v a -> Type v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeVar v a -> v) -> Type v a -> Type v a
forall (f :: * -> *) v' v a.
(Functor f, Foldable f, Ord v') =>
(v -> v') -> Term f v a -> Term f v' a
ABT.vmap TypeVar v a -> v
forall b v. TypeVar b v -> v
TypeVar.underlying (Type v a -> Type v a)
-> (Type v a -> Type v a) -> Type v a -> Type v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeVar v a] -> Type v a -> Type v a
forall v a. Ord v => [v] -> Type v a -> Type v a
Type.generalize (Set (TypeVar v a) -> [TypeVar v a]
forall a. Set a -> [a]
Set.toList (Set (TypeVar v a) -> [TypeVar v a])
-> Set (TypeVar v a) -> [TypeVar v a]
forall a b. (a -> b) -> a -> b
$ Type v a -> Set (TypeVar v a)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v a
t) (Type v a -> Type v a) -> Type v a -> Type v a
forall a b. (a -> b) -> a -> b
$ Type v a
t

generalizeExistentials' ::
  (Var v) => Type v a -> Type v a
generalizeExistentials' :: forall v a. Var v => Type v a -> Type v a
generalizeExistentials' Type v a
t =
  [TypeVar v a] -> Type v a -> Type v a
forall v a. Ord v => [v] -> Type v a -> Type v a
Type.generalize ((TypeVar v a -> Bool) -> [TypeVar v a] -> [TypeVar v a]
forall a. (a -> Bool) -> [a] -> [a]
filter TypeVar v a -> Bool
forall {b} {v}. TypeVar b v -> Bool
isExistential ([TypeVar v a] -> [TypeVar v a])
-> (Set (TypeVar v a) -> [TypeVar v a])
-> Set (TypeVar v a)
-> [TypeVar v a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TypeVar v a) -> [TypeVar v a]
forall a. Set a -> [a]
Set.toList (Set (TypeVar v a) -> [TypeVar v a])
-> Set (TypeVar v a) -> [TypeVar v a]
forall a b. (a -> b) -> a -> b
$ Type v a -> Set (TypeVar v a)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v a
t) Type v a
t
  where
    isExistential :: TypeVar b v -> Bool
isExistential TypeVar.Existential {} = Bool
True
    isExistential TypeVar b v
_ = Bool
False

noteTopLevelType ::
  (Ord loc, Var v) =>
  ABT.Subst f v a ->
  Term v loc ->
  Type v loc ->
  M v loc ()
noteTopLevelType :: forall loc v (f :: * -> *) a.
(Ord loc, Var v) =>
Subst f v a -> Term v loc -> Type v loc -> M v loc ()
noteTopLevelType Subst f v a
e Term v loc
binding Type v loc
typ = case Term v loc
binding of
  Term.Ann' Term v loc
strippedBinding Type v loc
_ -> do
    Maybe (Type v loc)
inferred <- (Type v loc -> Maybe (Type v loc)
forall a. a -> Maybe a
Just (Type v loc -> Maybe (Type v loc))
-> MT v loc (Result v loc) (Type v loc)
-> MT v loc (Result v loc) (Maybe (Type v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc)
synthesizeTop Term v loc
strippedBinding) MT v loc (Result v loc) (Maybe (Type v loc))
-> MT v loc (Result v loc) (Maybe (Type v loc))
-> MT v loc (Result v loc) (Maybe (Type v loc))
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` Maybe (Type v loc) -> MT v loc (Result v loc) (Maybe (Type v loc))
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type v loc)
forall a. Maybe a
Nothing
    case Maybe (Type v loc)
inferred of
      Maybe (Type v loc)
Nothing ->
        InfoNote v loc -> M v loc ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> M v loc ()) -> InfoNote v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
          [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent
            [(v -> v
forall v. Var v => v -> v
Var.reset (Subst f v a -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst f v a
e), Type v loc -> Type v loc
forall v a. Var v => Type v a -> Type v a
generalizeAndUnTypeVar Type v loc
typ, Bool
False)]
      Just Type v loc
inferred -> do
        Bool
redundant <- Type v loc -> Type v loc -> M v loc Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc Bool
isRedundant Type v loc
typ Type v loc
inferred
        InfoNote v loc -> M v loc ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> M v loc ()) -> InfoNote v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
          [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent
            [(v -> v
forall v. Var v => v -> v
Var.reset (Subst f v a -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst f v a
e), Type v loc -> Type v loc
forall v a. Var v => Type v a -> Type v a
generalizeAndUnTypeVar Type v loc
typ, Bool
redundant)]
  -- The signature didn't exist, so was definitely redundant
  Term v loc
_ ->
    InfoNote v loc -> M v loc ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> M v loc ()) -> InfoNote v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
      [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent
        [(v -> v
forall v. Var v => v -> v
Var.reset (Subst f v a -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst f v a
e), Type v loc -> Type v loc
forall v a. Var v => Type v a -> Type v a
generalizeAndUnTypeVar Type v loc
typ, Bool
True)]

synthesizeTop ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  M v loc (Type v loc)
synthesizeTop :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc)
synthesizeTop Term v loc
tm = do
  (Type v loc
ty, Wanted v loc
want) <- Term v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
tm
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Wanted v loc
want <- Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
substAndDefaultWanted Wanted v loc
want (Context v loc -> [Element v loc]
forall {v} {loc}. Context v loc -> [Element v loc]
out Context v loc
ctx)
  Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Wanted v loc -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Wanted v loc
want) (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> (Cause v loc -> MT v loc (Result v loc) ())
-> Cause v loc
-> MT v loc (Result v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> MT v loc (Result v loc) ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) ())
-> Cause v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ do
    [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityCheckFailure
      []
      (Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects (Type v loc -> [Type v loc])
-> ((Maybe (Term v loc), Type v loc) -> Type v loc)
-> (Maybe (Term v loc), Type v loc)
-> [Type v loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Term v loc), Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd ((Maybe (Term v loc), Type v loc) -> [Type v loc])
-> Wanted v loc -> [Type v loc]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wanted v loc
want)
      Context v loc
ctx
  Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
ty
  where
    out :: Context v loc -> [Element v loc]
out (Context [(Element v loc, Info v loc)]
es) = ((Element v loc, Info v loc) -> Element v loc)
-> [(Element v loc, Info v loc)] -> [Element v loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst [(Element v loc, Info v loc)]
es

-- | Synthesize the type of the given term, updating the context in
-- the process.  Also collect wanted abilities.
-- | Figure 11 from the paper
synthesize ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  M v loc (Type v loc, Wanted v loc)
synthesize :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
e | ([Char], Term v loc) -> Bool
forall a. Show a => a -> Bool
debugShow ([Char]
"synthesize" :: String, Term v loc
e) = M v loc (Type v loc, Wanted v loc)
forall a. HasCallStack => a
undefined
synthesize Term v loc
e = PathElement v loc
-> M v loc (Type v loc, Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Term v loc -> PathElement v loc
forall v loc. Term v loc -> PathElement v loc
InSynthesize Term v loc
e) (M v loc (Type v loc, Wanted v loc)
 -> M v loc (Type v loc, Wanted v loc))
-> M v loc (Type v loc, Wanted v loc)
-> M v loc (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$
  case Term v loc -> Either (NonEmpty (v, [loc])) (Term v loc)
forall v vt a.
Var v =>
Term' vt v a -> Either (NonEmpty (v, [a])) (Term' vt v a)
minimize' Term v loc
e of
    Left NonEmpty (v, [loc])
es -> Cause v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc a. Cause v loc -> M v loc a
failWith (NonEmpty (v, [loc]) -> Cause v loc
forall v loc. NonEmpty (v, [loc]) -> Cause v loc
DuplicateDefinitions NonEmpty (v, [loc])
es)
    Right Term v loc
e -> do
      (Type.Effect'' [Type v loc]
es Type v loc
t, Wanted v loc
want) <- Term v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeWanted Term v loc
e
      Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted ((Type v loc -> (Maybe (Term v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term v loc -> Maybe (Term v loc)
forall a. a -> Maybe a
Just Term v loc
e,) [Type v loc]
es) Wanted v loc
want
      pure (Type v loc
t, Wanted v loc
want)

-- | Helper function for turning an ability request's type into the
-- results used by type checking.
wantRequest ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  Type v loc ->
  (Type v loc, Wanted v loc)
wantRequest :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> (Type v loc, Wanted v loc)
wantRequest Term v loc
loc Type v loc
ty =
  let ~([Type v loc]
es, Type v loc
t) = Type v loc -> ([Type v loc], Type v loc)
forall v a. Ord v => Type v a -> ([Type v a], Type v a)
Type.unEffect0 Type v loc
ty
   in (Type v loc
t, (Type v loc -> (Maybe (Term v loc), Type v loc))
-> [Type v loc] -> [(Maybe (Term v loc), Type v loc)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term v loc -> Maybe (Term v loc)
forall a. a -> Maybe a
Just Term v loc
loc,) [Type v loc]
es)

-- | This is the main worker for type synthesis. It was factored out
-- of the `synthesize` function. It handles the various actual
-- synthesis cases for terms, while the `synthesize` function wraps
-- this in some common pre/postprocessing.
--
-- The return value is the synthesized type together with a list of
-- wanted abilities.
synthesizeWanted ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  M v loc (Type v loc, Wanted v loc)
synthesizeWanted :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeWanted (Term.Var' v
v) =
  M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc
    -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx ->
    case Context v loc -> v -> Maybe (Type v loc)
forall v loc. Ord v => Context v loc -> v -> Maybe (Type v loc)
lookupAnn Context v loc
ctx v
v of -- Var
      Maybe (Type v loc)
Nothing -> CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ v -> Context v loc -> CompilerBug v loc
forall v loc. v -> Context v loc -> CompilerBug v loc
UndeclaredTermVariable v
v Context v loc
ctx
      -- variables accesses are pure
      Just Type v loc
t -> do
        -- Note: we ungeneralize the type for ease of discarding. The
        -- current algorithm isn't sensitive to keeping things
        -- quantified, so it should be valid to not worry about
        -- re-generalizing.
        --
        -- Polymorphic ability variables in covariant positions in an
        -- occurrence's type only add useless degrees of freedom to the
        -- solver. They allow an occurrence to 'want' any row, but the
        -- occurrence might as well be chosen to 'want' the empty row,
        -- since that can be satisfied the most easily. The solver
        -- generally has no way of deciding that these arbitrary degrees
        -- of freedom are unnecessary later, and will get confused about
        -- which variable ot instantiate, so we ought to discard them
        -- early.
        ([v]
vs, Type v loc
t) <- Type v loc -> M v loc ([v], Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc ([v], Type v loc)
ungeneralize' Type v loc
t
        (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set v -> Type v loc -> Type v loc
forall v loc. Var v => Set v -> Type v loc -> Type v loc
discardCovariant ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs) Type v loc
t, [])
synthesizeWanted (Term.Ref' Reference
h) =
  CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Reference -> CompilerBug v loc
forall v loc. Reference -> CompilerBug v loc
UnannotatedReference Reference
h
synthesizeWanted (Term.Ann' (Term.Ref' Reference
_) Type v loc
t)
  -- innermost Ref annotation assumed to be correctly provided by
  -- `synthesizeClosed`
  --
  -- Top level references don't have their own effects.
  | Set (TypeVar v loc) -> Bool
forall a. Set a -> Bool
Set.null Set (TypeVar v loc)
s = do
      Type v loc
t <- Type v loc -> M v loc (Type v loc)
forall v loc. Var v => Type v loc -> M v loc (Type v loc)
existentializeArrows Type v loc
t
      -- See note about ungeneralizing above in the Var case.
      Type v loc
t <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
t
      pure (Type v loc -> Type v loc
forall v a. Var v => Type v a -> Type v a
discard Type v loc
t, [])
  | Bool
otherwise = CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Set (TypeVar v loc) -> CompilerBug v loc
forall v loc. Set (TypeVar v loc) -> CompilerBug v loc
FreeVarsInTypeAnnotation Set (TypeVar v loc)
s
  where
    s :: Set (TypeVar v loc)
s = Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v loc
t
    discard :: Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
discard Term F (TypeVar (Blank loc) v) loc
ty = Set v
-> Term F (TypeVar (Blank loc) v) loc
-> Term F (TypeVar (Blank loc) v) loc
forall v loc. Var v => Set v -> Type v loc -> Type v loc
discardCovariant Set v
fvs Term F (TypeVar (Blank loc) v) loc
ty
      where
        fvs :: Set v
fvs = (TypeVar (Blank loc) v -> Set v)
-> Set (TypeVar (Blank loc) v) -> Set v
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeVar (Blank loc) v -> Set v
forall {a} {b}. Ord a => TypeVar b a -> Set a
p (Set (TypeVar (Blank loc) v) -> Set v)
-> Set (TypeVar (Blank loc) v) -> Set v
forall a b. (a -> b) -> a -> b
$ Term F (TypeVar (Blank loc) v) loc -> Set (TypeVar (Blank loc) v)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term F (TypeVar (Blank loc) v) loc
ty
        p :: TypeVar b a -> Set a
p (TypeVar.Existential b
_ a
v) = a -> Set a
forall a. a -> Set a
Set.singleton a
v
        p TypeVar b a
_ = Set a
forall a. Monoid a => a
mempty
synthesizeWanted (Term.Constructor' ConstructorReference
r) =
  -- Constructors do not have effects
  (,[]) (Type v loc -> (Type v loc, Wanted v loc))
-> (Type v loc -> Type v loc)
-> Type v loc
-> (Type v loc, Wanted v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type v loc -> Type v loc
forall v a. Ord v => Type v a -> Type v a
Type.purifyArrows (Type v loc -> (Type v loc, Wanted v loc))
-> M v loc (Type v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorReference -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getDataConstructorType ConstructorReference
r
synthesizeWanted tm :: Term (F (TypeVar v loc) loc loc) v loc
tm@(Term.Request' ConstructorReference
r) =
  (Type v loc -> (Type v loc, Wanted v loc))
-> M v loc (Type v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b.
(a -> b) -> MT v loc (Result v loc) a -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc -> (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> (Type v loc, Wanted v loc)
wantRequest Term (F (TypeVar v loc) loc loc) v loc
tm) (M v loc (Type v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> (Type v loc -> M v loc (Type v loc))
-> Type v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize (Type v loc -> M v loc (Type v loc))
-> (Type v loc -> Type v loc) -> Type v loc -> M v loc (Type v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type v loc -> Type v loc
forall v a. Ord v => Type v a -> Type v a
Type.purifyArrows
    (Type v loc -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> M v loc (Type v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConstructorReference -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType ConstructorReference
r
synthesizeWanted (Term.Let1Top' Bool
top Term (F (TypeVar v loc) loc loc) v loc
binding Subst (F (TypeVar v loc) loc loc) v loc
e) = do
  (Type v loc
tbinding, Wanted v loc
wb) <- Bool
-> Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Bool -> Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeBinding Bool
top Term (F (TypeVar v loc) loc loc) v loc
binding
  v
v' <- Subst (F (TypeVar v loc) loc loc) v loc
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst (F (TypeVar v loc) loc loc) v loc
e v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar
  Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (v -> Bool
forall v. Var v => v -> Bool
Var.isAction (Subst (F (TypeVar v loc) loc loc) v loc -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst (F (TypeVar v loc) loc loc) v loc
e)) (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$
    -- enforce that actions in a block have type ()
    Type v loc -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
tbinding (loc -> Type v loc
forall v a. Ord v => a -> Type v a
DDB.unitType (Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term (F (TypeVar v loc) loc loc) v loc
binding))
  [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
v' Type v loc
tbinding]
  (Type v loc
t, Wanted v loc
w) <- Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize (Subst (F (TypeVar v loc) loc loc) v loc
-> forall b.
   Term (F (TypeVar v loc) loc loc) v b
   -> Term (F (TypeVar v loc) loc loc) v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst (F (TypeVar v loc) loc loc) v loc
e (() -> v -> Term (F (TypeVar v loc) loc loc) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var () v
v'))
  Type v loc
t <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t
  Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
top (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ Subst (F (TypeVar v loc) loc loc) v loc
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> MT v loc (Result v loc) ()
forall loc v (f :: * -> *) a.
(Ord loc, Var v) =>
Subst f v a -> Term v loc -> Type v loc -> M v loc ()
noteTopLevelType Subst (F (TypeVar v loc) loc loc) v loc
e Term (F (TypeVar v loc) loc loc) v loc
binding Type v loc
tbinding
  Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
w Wanted v loc
wb
  -- doRetract $ Ann v' tbinding
  pure (Type v loc
t, Wanted v loc
want)
synthesizeWanted (Term.LetRecNamed' [] Term (F (TypeVar v loc) loc loc) v loc
body) = Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeWanted Term (F (TypeVar v loc) loc loc) v loc
body
synthesizeWanted (Term.LetRecTop' Bool
isTop (v -> MT v loc (Result v loc) v)
-> MT
     v
     loc
     (Result v loc)
     ([(v, Term (F (TypeVar v loc) loc loc) v loc)],
      Term (F (TypeVar v loc) loc loc) v loc)
letrec) = do
  ((Type v loc
t, Wanted v loc
want), [Element v loc]
ctx2) <- v
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> M v loc ((Type v loc, Wanted v loc), [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract (Text -> v
forall v. Var v => Text -> v
Var.named Text
"let-rec-marker") (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> M v loc ((Type v loc, Wanted v loc), [Element v loc]))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> M v loc ((Type v loc, Wanted v loc), [Element v loc])
forall a b. (a -> b) -> a -> b
$ do
    Term (F (TypeVar v loc) loc loc) v loc
e <- Bool
-> ((v -> MT v loc (Result v loc) v)
    -> MT
         v
         loc
         (Result v loc)
         ([(v, Term (F (TypeVar v loc) loc loc) v loc)],
          Term (F (TypeVar v loc) loc loc) v loc))
-> M v loc (Term (F (TypeVar v loc) loc loc) v loc)
forall v loc.
(Var v, Ord loc) =>
Bool
-> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc))
-> M v loc (Term v loc)
annotateLetRecBindings Bool
isTop (v -> MT v loc (Result v loc) v)
-> MT
     v
     loc
     (Result v loc)
     ([(v, Term (F (TypeVar v loc) loc loc) v loc)],
      Term (F (TypeVar v loc) loc loc) v loc)
letrec
    Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term (F (TypeVar v loc) loc loc) v loc
e
  Wanted v loc
want <- Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
substAndDefaultWanted Wanted v loc
want [Element v loc]
ctx2
  pure ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
ctx2 Type v loc
t, Wanted v loc
want)
synthesizeWanted (Term.Handle' Term (F (TypeVar v loc) loc loc) v loc
h Term (F (TypeVar v loc) loc loc) v loc
body) = do
  -- To synthesize a handle block, we first synthesize the handler h,
  -- then push its allowed abilities onto the current ambient set when
  -- checking the body. Assuming that works, we also verify that the
  -- handler only uses abilities in the current ambient set.
  (Type v loc
ht, Wanted v loc
hwant) <- Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term (F (TypeVar v loc) loc loc) v loc
h
  Type v loc
ht <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize (Type v loc -> M v loc (Type v loc))
-> M v loc (Type v loc) -> M v loc (Type v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
ht
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  case Type v loc
ht of
    -- common case, like `h : Request {Remote} a -> b`, brings
    -- `Remote` into ambient when checking `body`
    Type.Arrow' (Type.Apps' (Type.Ref' Reference
ref) [Type v loc
et, Type v loc
i]) Type v loc
o | Reference
ref Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.effectRef -> do
      let es :: [Type v loc]
es = Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects Type v loc
et
      Wanted v loc
bwant <- [Type v loc] -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
withEffects [Type v loc]
es (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Wanted v loc
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted [] Term (F (TypeVar v loc) loc loc) v loc
body Type v loc
i
      Type v loc
o <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
o
      let ([Type v loc]
oes, Type v loc
o') = Type v loc -> ([Type v loc], Type v loc)
forall v a. Ord v => Type v a -> ([Type v a], Type v a)
Type.stripEffect Type v loc
o
      Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted ((Type v loc
 -> (Maybe (Term (F (TypeVar v loc) loc loc) v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term (F (TypeVar v loc) loc loc) v loc
-> Maybe (Term (F (TypeVar v loc) loc loc) v loc)
forall a. a -> Maybe a
Just Term (F (TypeVar v loc) loc loc) v loc
h,) [Type v loc]
oes Wanted v loc -> Wanted v loc -> Wanted v loc
forall a. [a] -> [a] -> [a]
++ Wanted v loc
bwant) Wanted v loc
hwant
      pure (Type v loc
o', Wanted v loc
want)
    -- degenerate case, like `handle x -> 10 in ...`
    -- todo: reviewme - I think just generate a type error in this case
    -- Currently assuming no effects are handled.
    Type.Arrow' (i :: Type v loc
i@(Type.Var' (TypeVar.Existential Blank loc
_ v :: v
v@(Context v loc -> v -> Maybe (Monotype v loc)
forall v loc. Ord v => Context v loc -> v -> Maybe (Monotype v loc)
lookupSolved Context v loc
ctx -> Maybe (Monotype v loc)
Nothing)))) Type v loc
o -> do
      v
r <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendExistential v
v
      let rt :: Type v loc
rt = loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i) v
r
          e0 :: Type v loc
e0 =
            Type v loc -> [(loc, Type v loc)] -> Type v loc
forall v a. Ord v => Type v a -> [(a, Type v a)] -> Type v a
Type.apps
              (loc -> Reference -> Type v loc
forall v a. Ord v => a -> Reference -> Type v a
Type.ref (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i) Reference
Type.effectRef)
              [(Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i, loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i) []), (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i, Type v loc
rt)]
      Type v loc -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
i Type v loc
e0
      Type v loc
o <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
o
      let ([Type v loc]
oes, Type v loc
o') = Type v loc -> ([Type v loc], Type v loc)
forall v a. Ord v => Type v a -> ([Type v a], Type v a)
Type.stripEffect Type v loc
o
      Wanted v loc
want <- Wanted v loc
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted ((Type v loc
 -> (Maybe (Term (F (TypeVar v loc) loc loc) v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term (F (TypeVar v loc) loc loc) v loc
-> Maybe (Term (F (TypeVar v loc) loc loc) v loc)
forall a. a -> Maybe a
Just Term (F (TypeVar v loc) loc loc) v loc
h,) [Type v loc]
oes) Term (F (TypeVar v loc) loc loc) v loc
body Type v loc
rt
      pure (Type v loc
o', Wanted v loc
want)
    Type v loc
_ -> Cause v loc -> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> Cause v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ loc -> Type v loc -> Cause v loc
forall v loc. loc -> Type v loc -> Cause v loc
HandlerOfUnexpectedType (Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term (F (TypeVar v loc) loc loc) v loc
h) Type v loc
ht
synthesizeWanted (Term.Ann' Term (F (TypeVar v loc) loc loc) v loc
e Type v loc
t) = Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc -> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc)
checkScoped Term (F (TypeVar v loc) loc loc) v loc
e Type v loc
t
synthesizeWanted tm :: Term (F (TypeVar v loc) loc loc) v loc
tm@(Term.Apps' Term (F (TypeVar v loc) loc loc) v loc
f [Term (F (TypeVar v loc) loc loc) v loc]
args) = do
  -- ->EEEEE
  (Type v loc
ft, Wanted v loc
fwant) <- Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term (F (TypeVar v loc) loc loc) v loc
f
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  ([v]
vs, Type v loc
ft) <- Type v loc -> M v loc ([v], Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc ([v], Type v loc)
ungeneralize' Type v loc
ft
  (Type v loc
at, Wanted v loc
awant) <-
    PathElement v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope ([v]
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [Term (F (TypeVar v loc) loc loc) v loc]
-> PathElement v loc
forall v loc.
[v]
-> Term v loc -> Type v loc -> [Term v loc] -> PathElement v loc
InFunctionCall [v]
vs Term (F (TypeVar v loc) loc loc) v loc
f Type v loc
ft [Term (F (TypeVar v loc) loc loc) v loc]
args) (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$
      Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [Term (F (TypeVar v loc) loc loc) v loc]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term (F (TypeVar v loc) loc loc) v loc
tm (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
ft) [Term (F (TypeVar v loc) loc loc) v loc]
args
  (Type v loc
at,) (Wanted v loc -> (Type v loc, Wanted v loc))
-> M v loc (Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
awant Wanted v loc
fwant

-- From here down, the term location is used in the result, so it is
-- more convenient to use pattern guards.
synthesizeWanted Term (F (TypeVar v loc) loc loc) v loc
e
  -- literals
  | Term.Float' Double
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.float loc
l, []) -- 1I=>
  | Term.Int' Int64
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.int loc
l, []) -- 1I=>
  | Term.Nat' Word64
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.nat loc
l, []) -- 1I=>
  | Term.Boolean' Bool
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.boolean loc
l, [])
  | Term.Text' Text
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.text loc
l, [])
  | Term.Char' Char
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.char loc
l, [])
  | Term.TermLink' Referent
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.termLink loc
l, [])
  | Term.TypeLink' Reference
_ <- Term (F (TypeVar v loc) loc loc) v loc
e = (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.typeLink loc
l, [])
  | Term.Blank' Blank loc
blank <- Term (F (TypeVar v loc) loc loc) v loc
e = do
      let freshType :: v
freshType = case Blank loc
blank of
            B.Recorded (B.MissingResultPlaceholder loc
_) -> v
forall v. Var v => v
Var.missingResult
            Blank loc
_ -> v
forall v. Var v => v
Var.blank
      v
v <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
freshType
      [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (Blank loc -> v -> TypeVar v loc
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
blank v
v)]
      pure (loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' loc
l Blank loc
blank v
v, [])
  | Term.List' Seq (Term (F (TypeVar v loc) loc loc) v loc)
v <- Term (F (TypeVar v loc) loc loc) v loc
e = do
      Type v loc
ft <- loc -> Int -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
loc -> Int -> M v loc (Type v loc)
vectorConstructorOfArity loc
l (Seq (Term (F (TypeVar v loc) loc loc) v loc) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Foldable.length Seq (Term (F (TypeVar v loc) loc loc) v loc)
v)
      case Seq (Term (F (TypeVar v loc) loc loc) v loc)
-> [Term (F (TypeVar v loc) loc loc) v loc]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Term (F (TypeVar v loc) loc loc) v loc)
v of
        [] -> (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type v loc
ft, [])
        Term (F (TypeVar v loc) loc loc) v loc
v1 : [Term (F (TypeVar v loc) loc loc) v loc]
_ ->
          PathElement v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (loc -> PathElement v loc
forall v loc. loc -> PathElement v loc
InVectorApp (Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term (F (TypeVar v loc) loc loc) v loc
v1)) (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$
            Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> Seq (Term (F (TypeVar v loc) loc loc) v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term (F (TypeVar v loc) loc loc) v loc
e Type v loc
ft Seq (Term (F (TypeVar v loc) loc loc) v loc)
v

  -- ->I=> (Full Damas Milner rule)
  | Term.Lam' Subst (F (TypeVar v loc) loc loc) v loc
body <- Term (F (TypeVar v loc) loc loc) v loc
e = do
      -- arya: are there more meaningful locations we could put into and
      -- pull out of the abschain?)
      [v
arg, v
i, v
e, v
o] <-
        [MT v loc (Result v loc) v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ Subst (F (TypeVar v loc) loc loc) v loc
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst (F (TypeVar v loc) loc loc) v loc
body v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar,
            v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (Subst (F (TypeVar v loc) loc loc) v loc -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst (F (TypeVar v loc) loc loc) v loc
body),
            v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferAbility,
            v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferOutput
          ]
      let it :: Type v loc
it = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' loc
l Blank loc
forall loc. Blank loc
B.Blank v
i
          ot :: Type v loc
ot = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' loc
l Blank loc
forall loc. Blank loc
B.Blank v
o
          et :: Type v loc
et = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' loc
l Blank loc
forall loc. Blank loc
B.Blank v
e
      [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext ([Element v loc] -> MT v loc (Result v loc) ())
-> [Element v loc] -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$
        [v -> Element v loc
forall v loc. v -> Element v loc
existential v
i, v -> Element v loc
forall v loc. v -> Element v loc
existential v
e, v -> Element v loc
forall v loc. v -> Element v loc
existential v
o, v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
arg Type v loc
it]
      Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (v -> Type
forall v. Var v => v -> Type
Var.typeOf v
i Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
Var.Delay) (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ do
        -- '(1 + 1) turns into a lambda with an arg variable of type Var.Delay
        -- here's where the typechecker assumes this must be of type 'thunkArgType'
        Type v loc -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
it (loc -> Type v loc
forall v a. Ord v => a -> Type v a
DDB.thunkArgType loc
l)
      Term (F (TypeVar v loc) loc loc) v loc
body' <- Term (F (TypeVar v loc) loc loc) v loc
-> M v loc (Term (F (TypeVar v loc) loc loc) v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (F (TypeVar v loc) loc loc) v loc
 -> M v loc (Term (F (TypeVar v loc) loc loc) v loc))
-> Term (F (TypeVar v loc) loc loc) v loc
-> M v loc (Term (F (TypeVar v loc) loc loc) v loc)
forall a b. (a -> b) -> a -> b
$ Subst (F (TypeVar v loc) loc loc) v loc
-> forall b.
   Term (F (TypeVar v loc) loc loc) v b
   -> Term (F (TypeVar v loc) loc loc) v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst (F (TypeVar v loc) loc loc) v loc
body (() -> v -> Term (F (TypeVar v loc) loc loc) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var () v
arg)
      if Term (F (TypeVar v loc) loc loc) v loc -> Bool
forall vt at ap v a. Term2 vt at ap v a -> Bool
Term.isLam Term (F (TypeVar v loc) loc loc) v loc
body'
        then [Type v loc]
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> Type v loc -> M v loc ()
checkWithAbilities [] Term (F (TypeVar v loc) loc loc) v loc
body' Type v loc
ot
        else [Type v loc]
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> Type v loc -> M v loc ()
checkWithAbilities [Type v loc
et] Term (F (TypeVar v loc) loc loc) v loc
body' Type v loc
ot
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      let t :: Type v loc
t = Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow loc
l Type v loc
it (loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect loc
l [Type v loc
et] Type v loc
ot)
      pure (Type v loc
t, [])
  | Term.If' Term (F (TypeVar v loc) loc loc) v loc
cond Term (F (TypeVar v loc) loc loc) v loc
t Term (F (TypeVar v loc) loc loc) v loc
f <- Term (F (TypeVar v loc) loc loc) v loc
e = do
      Wanted v loc
cwant <- PathElement v loc
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
forall v loc. PathElement v loc
InIfCond (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Wanted v loc)
check Term (F (TypeVar v loc) loc loc) v loc
cond (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.boolean loc
l)
      (Type v loc
ty, Wanted v loc
bwant) <-
        PathElement v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (loc -> PathElement v loc
forall v loc. loc -> PathElement v loc
InIfBody (loc -> PathElement v loc) -> loc -> PathElement v loc
forall a b. (a -> b) -> a -> b
$ Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term (F (TypeVar v loc) loc loc) v loc
t) (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$
          Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [Term (F (TypeVar v loc) loc loc) v loc]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term (F (TypeVar v loc) loc loc) v loc
e (loc -> Type v loc
forall v a. Var v => a -> Type v a
Type.iff2 loc
l) [Term (F (TypeVar v loc) loc loc) v loc
t, Term (F (TypeVar v loc) loc loc) v loc
f]
      (Type v loc
ty,) (Wanted v loc -> (Type v loc, Wanted v loc))
-> M v loc (Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
bwant Wanted v loc
cwant
  | Term.And' Term (F (TypeVar v loc) loc loc) v loc
a Term (F (TypeVar v loc) loc loc) v loc
b <- Term (F (TypeVar v loc) loc loc) v loc
e =
      PathElement v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
forall v loc. PathElement v loc
InAndApp (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [Term (F (TypeVar v loc) loc loc) v loc]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term (F (TypeVar v loc) loc loc) v loc
e (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.andor' loc
l) [Term (F (TypeVar v loc) loc loc) v loc
a, Term (F (TypeVar v loc) loc loc) v loc
b]
  | Term.Or' Term (F (TypeVar v loc) loc loc) v loc
a Term (F (TypeVar v loc) loc loc) v loc
b <- Term (F (TypeVar v loc) loc loc) v loc
e =
      PathElement v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
forall v loc. PathElement v loc
InOrApp (MT v loc (Result v loc) (Type v loc, Wanted v loc)
 -> MT v loc (Result v loc) (Type v loc, Wanted v loc))
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [Term (F (TypeVar v loc) loc loc) v loc]
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall (f :: * -> *) v loc.
(Foldable f, Var v, Ord loc) =>
Term v loc
-> Type v loc
-> f (Term v loc)
-> M v loc (Type v loc, Wanted v loc)
synthesizeApps Term (F (TypeVar v loc) loc loc) v loc
e (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.andor' loc
l) [Term (F (TypeVar v loc) loc loc) v loc
a, Term (F (TypeVar v loc) loc loc) v loc
b]
  | Term.Match' Term (F (TypeVar v loc) loc loc) v loc
scrutinee [MatchCase loc (Term (F (TypeVar v loc) loc loc) v loc)]
cases <- Term (F (TypeVar v loc) loc loc) v loc
e = do
      (Type v loc
scrutineeType, Wanted v loc
swant) <- Term (F (TypeVar v loc) loc loc) v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term (F (TypeVar v loc) loc loc) v loc
scrutinee
      v
outputTypev <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (Text -> v
forall v. Var v => Text -> v
Var.named Text
"match-output")
      let outputType :: Type v loc
outputType = loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' loc
l Blank loc
forall loc. Blank loc
B.Blank v
outputTypev
      [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
outputTypev]
      Wanted v loc
cwant <- Type v loc
-> Type v loc
-> [MatchCase loc (Term (F (TypeVar v loc) loc loc) v loc)]
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> M v loc (Wanted v loc)
checkCases Type v loc
scrutineeType Type v loc
outputType [MatchCase loc (Term (F (TypeVar v loc) loc loc) v loc)]
cases
      Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
cwant Wanted v loc
swant
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      let matchType :: Type v loc
matchType = Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
outputType
      M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
forall v loc.
M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
getPatternMatchCoverageCheckAndKindInferenceSwitch M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
-> (PatternMatchCoverageCheckAndKindInferenceSwitch
    -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled -> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type v loc
-> [MatchCase loc (Term (F (TypeVar v loc) loc loc) v loc)]
-> MT v loc (Result v loc) ()
forall v loc.
(Ord loc, Var v) =>
Term v loc
-> Type v loc
-> Term v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> MT v loc (Result v loc) ()
ensurePatternCoverage Term (F (TypeVar v loc) loc loc) v loc
e Type v loc
matchType Term (F (TypeVar v loc) loc loc) v loc
scrutinee Type v loc
scrutineeType [MatchCase loc (Term (F (TypeVar v loc) loc loc) v loc)]
cases
        PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled -> () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      pure $ (Type v loc
matchType, Wanted v loc
want)
  where
    l :: loc
l = Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term (F (TypeVar v loc) loc loc) v loc
e
synthesizeWanted Term (F (TypeVar v loc) loc loc) v loc
_e = CompilerBug v loc
-> MT v loc (Result v loc) (Type v loc, Wanted v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash CompilerBug v loc
forall v loc. CompilerBug v loc
PatternMatchFailure

-- | Synthesizes a type for a local binding, for use in synthesizing
-- or checking `Let1` expressions. There is a bit of wrapping around
-- the call to `synthesize` to attempt to generalize certain
-- definitions.
--
-- We want to generalize self-contained definitions when possible, so
-- that things like:
--
--   id x = x
--   id ()
--   id "hello"
--
-- will work. However, note that just checking that the definition is
-- self contained is insufficient, because:
--
--   r = IO.ref '(bug "whatever")
--
-- is self-contained (in the free variable sense), but would yield a
-- polymorphic reference. So, I think it is also necessary to check
-- that the binding has no wanted abilities. This automatically covers
-- the local function definitions we want.
--
-- ---
--
-- The current strategy for generalization is a bit sophisticated as
-- well. We want to generalize local definitions when possible.
-- However, when doing type directed name resolution, we _don't_ want
-- to generalize over variables that will help us figure out which
-- selection to make.
--
-- So, when we _do_ generalize, we first partition the discarded
-- context into the portion that is involved in TDNR solutions, and
-- the portion that isn't. We generalize the variables that aren't
-- involved in TDNR, and re-push the variables that are, so that they
-- can be refined later. This is a bit unusual for the algorithm we
-- use, but it seems like it should be safe.
synthesizeBinding ::
  (Var v) =>
  (Ord loc) =>
  Bool ->
  Term v loc ->
  M v loc (Type v loc, Wanted v loc)
synthesizeBinding :: forall v loc.
(Var v, Ord loc) =>
Bool -> Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeBinding Bool
top Term v loc
binding = do
  v
-> (M v loc [Element v loc] -> M v loc (Type v loc, Wanted v loc))
-> M v loc (Type v loc, Wanted v loc)
forall v loc a.
(Var v, Ord loc) =>
v -> (M v loc [Element v loc] -> M v loc a) -> M v loc a
markThenCallWithRetract v
forall v. Var v => v
Var.inferOther \M v loc [Element v loc]
retract -> M v
  loc
  ((Type v loc, Wanted v loc), InfoNote v loc -> InfoNote v loc)
-> M v loc (Type v loc, Wanted v loc)
forall v loc a.
M v loc (a, InfoNote v loc -> InfoNote v loc) -> M v loc a
adjustNotes do
    (Type v loc
tb, Wanted v loc
wb) <- Term v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
binding
    if Bool -> Bool
not (Wanted v loc -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Wanted v loc
wb)
      then (Type v loc
 -> ((Type v loc, Wanted v loc), InfoNote v loc -> InfoNote v loc))
-> MT v loc (Result v loc) (Type v loc)
-> M v
     loc
     ((Type v loc, Wanted v loc), InfoNote v loc -> InfoNote v loc)
forall a b.
(a -> b) -> MT v loc (Result v loc) a -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Type v loc
t -> ((Type v loc
t, Wanted v loc
wb), InfoNote v loc -> InfoNote v loc
forall a. a -> a
id)) (Type v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
tb)
      else
        if Bool
top
          then do
            [Element v loc]
ctx <- M v loc [Element v loc]
retract
            pure (([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
ctx Type v loc
tb, []), [Element v loc] -> InfoNote v loc -> InfoNote v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> InfoNote v loc -> InfoNote v loc
substituteSolved [Element v loc]
ctx)
          else do
            [Element v loc]
ctx <- M v loc [Element v loc]
retract
            -- Note: this is conservative about what we avoid
            -- generalizing. Right now only TDNR causes variables to be
            -- retained. It might be possible to make this happen for any
            -- `Recorded` to do more inference for unknown variable errors
            -- (or whatever the other cases are for), at the expense of
            -- less generalization in the process of reporting those.
            let retain :: Blank loc -> Bool
retain (B.Recorded B.Resolve {}) = Bool
True
                retain Blank loc
B.Retain = Bool
True
                retain Blank loc
_ = Bool
False

                erecs :: [v]
erecs = [v
v | Existential Blank loc
b v
v <- [Element v loc]
ctx, Blank loc -> Bool
forall {loc}. Blank loc -> Bool
retain Blank loc
b]
                srecs :: [v]
srecs =
                  [ v
v
                    | Solved Blank loc
b v
_ Monotype v loc
sa <- [Element v loc]
ctx,
                      Blank loc -> Bool
forall {loc}. Blank loc -> Bool
retain Blank loc
b,
                      TypeVar.Existential Blank loc
_ v
v <-
                        Set (TypeVar (Blank loc) v) -> [TypeVar (Blank loc) v]
forall a. Set a -> [a]
Set.toList (Set (TypeVar (Blank loc) v) -> [TypeVar (Blank loc) v])
-> (Type v loc -> Set (TypeVar (Blank loc) v))
-> Type v loc
-> [TypeVar (Blank loc) v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type v loc -> Set (TypeVar (Blank loc) v)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars (Type v loc -> Set (TypeVar (Blank loc) v))
-> (Type v loc -> Type v loc)
-> Type v loc
-> Set (TypeVar (Blank loc) v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx (Type v loc -> [TypeVar (Blank loc) v])
-> Type v loc -> [TypeVar (Blank loc) v]
forall a b. (a -> b) -> a -> b
$ Monotype v loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype v loc
sa
                  ]
                keep :: Set v
keep = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v]
erecs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
srecs)
                p :: Element v loc -> Either (Element v loc) (Element v loc)
p (Existential Blank loc
_ v
v)
                  | v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
keep =
                      Element v loc -> Either (Element v loc) (Element v loc)
forall a b. a -> Either a b
Left (Element v loc -> Either (Element v loc) (Element v loc))
-> (TypeVar (Blank loc) v -> Element v loc)
-> TypeVar (Blank loc) v
-> Either (Element v loc) (Element v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeVar (Blank loc) v -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (TypeVar (Blank loc) v -> Either (Element v loc) (Element v loc))
-> TypeVar (Blank loc) v -> Either (Element v loc) (Element v loc)
forall a b. (a -> b) -> a -> b
$ Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Retain v
v
                p Element v loc
e = Element v loc -> Either (Element v loc) (Element v loc)
forall a b. b -> Either a b
Right Element v loc
e
                ([Element v loc]
repush, [Element v loc]
discard) = [Either (Element v loc) (Element v loc)]
-> ([Element v loc], [Element v loc])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Element v loc) (Element v loc)]
 -> ([Element v loc], [Element v loc]))
-> [Either (Element v loc) (Element v loc)]
-> ([Element v loc], [Element v loc])
forall a b. (a -> b) -> a -> b
$ (Element v loc -> Either (Element v loc) (Element v loc))
-> [Element v loc] -> [Either (Element v loc) (Element v loc)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element v loc -> Either (Element v loc) (Element v loc)
p [Element v loc]
ctx
            [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [Element v loc]
repush
            Set v -> M v loc ()
forall v loc. (Var v, Ord loc) => Set v -> M v loc ()
markRetained Set v
keep
            let tf :: Type v loc
tf = [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
discard ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx Type v loc
tb)
            pure ((Type v loc
tf, []), [Element v loc] -> InfoNote v loc -> InfoNote v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> InfoNote v loc -> InfoNote v loc
substituteSolved [Element v loc]
ctx)

getDataConstructorsAtType :: forall v loc. (Ord loc, Var v) => Type v loc -> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructorsAtType :: forall v loc.
(Ord loc, Var v) =>
Type v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructorsAtType Type v loc
t0 = do
  EnumeratedConstructors (TypeVar v loc) v loc
dataConstructors <- Type v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
forall v loc.
Var v =>
Type v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructors Type v loc
t0
  case Type v loc
t0 of
    Type.Request' [Type v loc]
ets Type v loc
_res ->
      let effectMap :: Map Reference (Type v loc)
          effectMap :: Map Reference (Type v loc)
effectMap =
            [(Reference, Type v loc)] -> Map Reference (Type v loc)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              ([(Reference, Type v loc)] -> Map Reference (Type v loc))
-> ([Type v loc] -> [(Reference, Type v loc)])
-> [Type v loc]
-> Map Reference (Type v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type v loc -> Maybe (Reference, Type v loc))
-> [Type v loc] -> [(Reference, Type v loc)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
                ( \Type v loc
e -> case Type v loc
e of
                    Type.Apps' (Type.Ref' r :: Reference
r@Reference.DerivedId {}) [Type v loc]
_targs -> (Reference, Type v loc) -> Maybe (Reference, Type v loc)
forall a. a -> Maybe a
Just (Reference
r, Type v loc
e)
                    Type.Ref' r :: Reference
r@Reference.DerivedId {} -> (Reference, Type v loc) -> Maybe (Reference, Type v loc)
forall a. a -> Maybe a
Just (Reference
r, Type v loc
e)
                    Type v loc
_ -> Maybe (Reference, Type v loc)
forall a. Maybe a
Nothing
                )
              ([Type v loc] -> Map Reference (Type v loc))
-> [Type v loc] -> Map Reference (Type v loc)
forall a b. (a -> b) -> a -> b
$ [Type v loc]
ets
       in ((v
  -> ConstructorReference
  -> Type v loc
  -> MT v loc (Result v loc) (Type v loc))
 -> EnumeratedConstructors (TypeVar v loc) v loc
 -> M v loc (EnumeratedConstructors (TypeVar v loc) v loc))
-> EnumeratedConstructors (TypeVar v loc) v loc
-> (v
    -> ConstructorReference
    -> Type v loc
    -> MT v loc (Result v loc) (Type v loc))
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (v
 -> ConstructorReference
 -> Type v loc
 -> MT v loc (Result v loc) (Type v loc))
-> EnumeratedConstructors (TypeVar v loc) v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
forall (f :: * -> *) v vt loc.
Applicative f =>
(v -> ConstructorReference -> Type vt loc -> f (Type vt loc))
-> EnumeratedConstructors vt v loc
-> f (EnumeratedConstructors vt v loc)
traverseConstructorTypes EnumeratedConstructors (TypeVar v loc) v loc
dataConstructors \v
_ ConstructorReference
cr Type v loc
t -> do
            case Reference -> Map Reference (Type v loc) -> Maybe (Type v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Getting Reference ConstructorReference Reference
-> ConstructorReference -> Reference
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Reference ConstructorReference Reference
forall r s (f :: * -> *).
Functor f =>
(r -> f s)
-> GConstructorReference r -> f (GConstructorReference s)
reference_ ConstructorReference
cr) Map Reference (Type v loc)
effectMap of
              Maybe (Type v loc)
Nothing -> Type v loc -> MT v loc (Result v loc) (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type v loc
t
              Just Type v loc
t0 -> do
                Type v loc
t <- Type v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
t
                case Type v loc
t of
                  Type.EffectfulArrows' Type v loc
_ [(Maybe [Type v loc], Type v loc)]
xs
                    | (Just [Type v loc
e], Type v loc
_) <- [(Maybe [Type v loc], Type v loc)]
-> (Maybe [Type v loc], Type v loc)
forall a. HasCallStack => [a] -> a
last [(Maybe [Type v loc], Type v loc)]
xs -> do
                        Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
t0 Type v loc
e
                        Type v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t
                  Type v loc
_ -> Type v loc -> MT v loc (Result v loc) (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type v loc
t
    Type v loc
_ -> (v
 -> ConstructorReference
 -> Type v loc
 -> MT v loc (Result v loc) (Type v loc))
-> EnumeratedConstructors (TypeVar v loc) v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
forall (f :: * -> *) v vt loc.
Applicative f =>
(v -> ConstructorReference -> Type vt loc -> f (Type vt loc))
-> EnumeratedConstructors vt v loc
-> f (EnumeratedConstructors vt v loc)
traverseConstructorTypes (\v
_ ConstructorReference
_ Type v loc
t -> Type v loc -> MT v loc (Result v loc) (Type v loc)
fixType Type v loc
t) EnumeratedConstructors (TypeVar v loc) v loc
dataConstructors
  where
    fixType :: Type v loc -> MT v loc (Result v loc) (Type v loc)
fixType Type v loc
t = do
      Type v loc
t <- Type v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
t
      let lastT :: Type v loc
lastT = case Type v loc
t of
            Type.Arrows' [Type v loc]
xs -> [Type v loc] -> Type v loc
forall a. HasCallStack => [a] -> a
last [Type v loc]
xs
            Type v loc
_ -> Type v loc
t
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
t0 Type v loc
lastT
      Type v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t

data PmcState vt v loc = PmcState
  { forall vt v loc. PmcState vt v loc -> Set v
variables :: !(Set v),
    forall vt v loc.
PmcState vt v loc
-> Map (Type v loc) (EnumeratedConstructors vt v loc)
constructorCache :: !(Map (Type v loc) (EnumeratedConstructors vt v loc))
  }

instance (Ord loc, Var v) => Pmc (TypeVar v loc) v loc (StateT (PmcState (TypeVar v loc) v loc) (M v loc)) where
  getPrettyPrintEnv :: StateT (PmcState (TypeVar v loc) v loc) (M v loc) PrettyPrintEnv
getPrettyPrintEnv = M v loc PrettyPrintEnv
-> StateT (PmcState (TypeVar v loc) v loc) (M v loc) PrettyPrintEnv
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (PmcState (TypeVar v loc) v loc) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift M v loc PrettyPrintEnv
forall v loc. M v loc PrettyPrintEnv
getPrettyPrintEnv
  getConstructors :: Type (TypeVar v loc) loc
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc)
getConstructors Type (TypeVar v loc) loc
typ = do
    st :: PmcState (TypeVar v loc) v loc
st@PmcState {Map
  (Type (TypeVar v loc) loc)
  (EnumeratedConstructors (TypeVar v loc) v loc)
$sel:constructorCache:PmcState :: forall vt v loc.
PmcState vt v loc
-> Map (Type v loc) (EnumeratedConstructors vt v loc)
constructorCache :: Map
  (Type (TypeVar v loc) loc)
  (EnumeratedConstructors (TypeVar v loc) v loc)
constructorCache} <- StateT
  (PmcState (TypeVar v loc) v loc)
  (M v loc)
  (PmcState (TypeVar v loc) v loc)
forall s (m :: * -> *). MonadState s m => m s
get
    let f :: Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
f = \case
          Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
Nothing -> StateT
  (PmcState (TypeVar v loc) v loc)
  (M v loc)
  (EnumeratedConstructors (TypeVar v loc) v loc,
   Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (StateT
   (PmcState (TypeVar v loc) v loc)
   (M v loc)
   (EnumeratedConstructors (TypeVar v loc) v loc,
    Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
 -> Compose
      (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
      ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
      (Maybe (EnumeratedConstructors (TypeVar v loc) v loc)))
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc,
      Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall a b. (a -> b) -> a -> b
$ (\EnumeratedConstructors (TypeVar v loc) v loc
t -> (EnumeratedConstructors (TypeVar v loc) v loc
t, EnumeratedConstructors (TypeVar v loc) v loc
-> Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. a -> Maybe a
Just EnumeratedConstructors (TypeVar v loc) v loc
t)) (EnumeratedConstructors (TypeVar v loc) v loc
 -> (EnumeratedConstructors (TypeVar v loc) v loc,
     Maybe (EnumeratedConstructors (TypeVar v loc) v loc)))
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc)
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc,
      Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT
  v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (PmcState (TypeVar v loc) v loc) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Type (TypeVar v loc) loc
-> MT
     v loc (Result v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall v loc.
(Ord loc, Var v) =>
Type v loc
-> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
getDataConstructorsAtType Type (TypeVar v loc) loc
typ)
          Just EnumeratedConstructors (TypeVar v loc) v loc
t -> StateT
  (PmcState (TypeVar v loc) v loc)
  (M v loc)
  (EnumeratedConstructors (TypeVar v loc) v loc,
   Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (StateT
   (PmcState (TypeVar v loc) v loc)
   (M v loc)
   (EnumeratedConstructors (TypeVar v loc) v loc,
    Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
 -> Compose
      (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
      ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
      (Maybe (EnumeratedConstructors (TypeVar v loc) v loc)))
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc,
      Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall a b. (a -> b) -> a -> b
$ (EnumeratedConstructors (TypeVar v loc) v loc,
 Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc,
      Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumeratedConstructors (TypeVar v loc) v loc
t, EnumeratedConstructors (TypeVar v loc) v loc
-> Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. a -> Maybe a
Just EnumeratedConstructors (TypeVar v loc) v loc
t)
    (EnumeratedConstructors (TypeVar v loc) v loc
result, Map
  (Type (TypeVar v loc) loc)
  (EnumeratedConstructors (TypeVar v loc) v loc)
newCache) <- Compose
  (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
  ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
  (Map
     (Type (TypeVar v loc) loc)
     (EnumeratedConstructors (TypeVar v loc) v loc))
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc,
      Map
        (Type (TypeVar v loc) loc)
        (EnumeratedConstructors (TypeVar v loc) v loc))
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose ((Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
 -> Compose
      (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
      ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
      (Maybe (EnumeratedConstructors (TypeVar v loc) v loc)))
-> Type (TypeVar v loc) loc
-> Map
     (Type (TypeVar v loc) loc)
     (EnumeratedConstructors (TypeVar v loc) v loc)
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Map
        (Type (TypeVar v loc) loc)
        (EnumeratedConstructors (TypeVar v loc) v loc))
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe (EnumeratedConstructors (TypeVar v loc) v loc)
-> Compose
     (StateT (PmcState (TypeVar v loc) v loc) (M v loc))
     ((,) (EnumeratedConstructors (TypeVar v loc) v loc))
     (Maybe (EnumeratedConstructors (TypeVar v loc) v loc))
f Type (TypeVar v loc) loc
typ Map
  (Type (TypeVar v loc) loc)
  (EnumeratedConstructors (TypeVar v loc) v loc)
constructorCache)
    PmcState (TypeVar v loc) v loc
-> StateT (PmcState (TypeVar v loc) v loc) (M v loc) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PmcState (TypeVar v loc) v loc
st {constructorCache = newCache}
    pure EnumeratedConstructors (TypeVar v loc) v loc
result
  getConstructorVarTypes :: Type (TypeVar v loc) loc
-> ConstructorReference
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
getConstructorVarTypes Type (TypeVar v loc) loc
t cref :: ConstructorReference
cref@(ConstructorReference Reference
_r Word64
cid) = do
    Type (TypeVar v loc) loc
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     (EnumeratedConstructors (TypeVar v loc) v loc)
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc -> m (EnumeratedConstructors vt v loc)
Pmc.getConstructors Type (TypeVar v loc) loc
t StateT
  (PmcState (TypeVar v loc) v loc)
  (M v loc)
  (EnumeratedConstructors (TypeVar v loc) v loc)
-> (EnumeratedConstructors (TypeVar v loc) v loc
    -> StateT
         (PmcState (TypeVar v loc) v loc)
         (M v loc)
         [Type (TypeVar v loc) loc])
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a b.
StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
-> (a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) b)
-> StateT (PmcState (TypeVar v loc) v loc) (M v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      AbilityType Type (TypeVar v loc) loc
_ Map ConstructorReference (v, Type (TypeVar v loc) loc)
m -> case ConstructorReference
-> Map ConstructorReference (v, Type (TypeVar v loc) loc)
-> Maybe (v, Type (TypeVar v loc) loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConstructorReference
cref Map ConstructorReference (v, Type (TypeVar v loc) loc)
m of
        Maybe (v, Type (TypeVar v loc) loc)
Nothing -> [Char]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> StateT
      (PmcState (TypeVar v loc) v loc)
      (M v loc)
      [Type (TypeVar v loc) loc])
-> [Char]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a b. (a -> b) -> a -> b
$ ConstructorReference -> [Char]
forall a. Show a => a -> [Char]
show ConstructorReference
cref [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" not found in constructor map: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map ConstructorReference (v, Type (TypeVar v loc) loc) -> [Char]
forall a. Show a => a -> [Char]
show Map ConstructorReference (v, Type (TypeVar v loc) loc)
m
        Just (v
_, Type (TypeVar v loc) loc
conArgs) -> [Type (TypeVar v loc) loc]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type (TypeVar v loc) loc -> [Type (TypeVar v loc) loc]
forall v a. Type v a -> [Type v a]
extractArgs Type (TypeVar v loc) loc
conArgs)
      ConstructorType [(v, ConstructorReference, Type (TypeVar v loc) loc)]
cs -> case Int
-> [(v, ConstructorReference, Type (TypeVar v loc) loc)]
-> [(v, ConstructorReference, Type (TypeVar v loc) loc)]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cid) [(v, ConstructorReference, Type (TypeVar v loc) loc)]
cs of
        [] -> [Char]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> StateT
      (PmcState (TypeVar v loc) v loc)
      (M v loc)
      [Type (TypeVar v loc) loc])
-> [Char]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a b. (a -> b) -> a -> b
$ ConstructorReference -> [Char]
forall a. Show a => a -> [Char]
show ConstructorReference
cref [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" not found in constructor list: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(v, ConstructorReference, Type (TypeVar v loc) loc)] -> [Char]
forall a. Show a => a -> [Char]
show [(v, ConstructorReference, Type (TypeVar v loc) loc)]
cs
        (v
_, ConstructorReference
_, Type (TypeVar v loc) loc
conArgs) : [(v, ConstructorReference, Type (TypeVar v loc) loc)]
_ -> [Type (TypeVar v loc) loc]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type (TypeVar v loc) loc -> [Type (TypeVar v loc) loc]
forall v a. Type v a -> [Type v a]
extractArgs Type (TypeVar v loc) loc
conArgs)
      EnumeratedConstructors (TypeVar v loc) v loc
BooleanType -> [Type (TypeVar v loc) loc]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      EnumeratedConstructors (TypeVar v loc) v loc
OtherType -> [Type (TypeVar v loc) loc]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      SequenceType {} -> [Type (TypeVar v loc) loc]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (M v loc)
     [Type (TypeVar v loc) loc]
forall a. a -> StateT (PmcState (TypeVar v loc) v loc) (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    where
      extractArgs :: Type v a -> [Type v a]
extractArgs (Type.Arrows' [Type v a]
xs) = [Type v a] -> [Type v a]
forall a. HasCallStack => [a] -> [a]
init [Type v a]
xs
      extractArgs Type v a
_ = []
  fresh :: StateT (PmcState (TypeVar v loc) v loc) (M v loc) v
fresh = do
    st :: PmcState (TypeVar v loc) v loc
st@PmcState {Set v
$sel:variables:PmcState :: forall vt v loc. PmcState vt v loc -> Set v
variables :: Set v
variables} <- StateT
  (PmcState (TypeVar v loc) v loc)
  (M v loc)
  (PmcState (TypeVar v loc) v loc)
forall s (m :: * -> *). MonadState s m => m s
get
    let v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
variables (Type -> v
forall v. Var v => Type -> v
Var.typed Type
Var.Pattern)
    PmcState (TypeVar v loc) v loc
-> StateT (PmcState (TypeVar v loc) v loc) (M v loc) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PmcState (TypeVar v loc) v loc
st {variables = Set.insert v variables})
    pure v
v

ensurePatternCoverage ::
  forall v loc.
  (Ord loc, Var v) =>
  Term v loc ->
  Type v loc ->
  Term v loc ->
  Type v loc ->
  [Term.MatchCase loc (Term v loc)] ->
  MT v loc (Result v loc) ()
ensurePatternCoverage :: forall v loc.
(Ord loc, Var v) =>
Term v loc
-> Type v loc
-> Term v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> MT v loc (Result v loc) ()
ensurePatternCoverage Term v loc
theMatch Type v loc
_theMatchType Term v loc
_scrutinee Type v loc
scrutineeType [MatchCase loc (Term v loc)]
cases = do
  let matchLoc :: loc
matchLoc = Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v loc
theMatch
  Type v loc
scrutineeType <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
scrutineeType
  let PmcState (TypeVar v loc) v loc
pmcState :: PmcState (TypeVar v loc) v loc =
        PmcState
          { $sel:variables:PmcState :: Set v
variables = Term v loc -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v loc
theMatch,
            $sel:constructorCache:PmcState :: Map (Type v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
constructorCache = Map (Type v loc) (EnumeratedConstructors (TypeVar v loc) v loc)
forall a. Monoid a => a
mempty
          }
  ([loc]
redundant, [loc]
_inaccessible, [Pattern ()]
uncovered) <- (StateT
   (PmcState (TypeVar v loc) v loc)
   (MT v loc (Result v loc))
   ([loc], [loc], [Pattern ()])
 -> PmcState (TypeVar v loc) v loc
 -> MT v loc (Result v loc) ([loc], [loc], [Pattern ()]))
-> PmcState (TypeVar v loc) v loc
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (MT v loc (Result v loc))
     ([loc], [loc], [Pattern ()])
-> MT v loc (Result v loc) ([loc], [loc], [Pattern ()])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (PmcState (TypeVar v loc) v loc)
  (MT v loc (Result v loc))
  ([loc], [loc], [Pattern ()])
-> PmcState (TypeVar v loc) v loc
-> MT v loc (Result v loc) ([loc], [loc], [Pattern ()])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT PmcState (TypeVar v loc) v loc
pmcState do
    Type v loc
-> [MatchCase loc (Term v loc)]
-> StateT
     (PmcState (TypeVar v loc) v loc)
     (MT v loc (Result v loc))
     ([loc], [loc], [Pattern ()])
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> [MatchCase loc (Term' vt v loc)]
-> m ([loc], [loc], [Pattern ()])
checkMatch Type v loc
scrutineeType [MatchCase loc (Term v loc)]
cases
  let checkUncovered :: MT v loc (Result v loc) ()
checkUncovered = MT v loc (Result v loc) ()
-> (NonEmpty (Pattern ()) -> MT v loc (Result v loc) ())
-> Maybe (NonEmpty (Pattern ()))
-> MT v loc (Result v loc) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Cause v loc -> MT v loc (Result v loc) ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) ())
-> (NonEmpty (Pattern ()) -> Cause v loc)
-> NonEmpty (Pattern ())
-> MT v loc (Result v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. loc -> NonEmpty (Pattern ()) -> Cause v loc
forall v loc. loc -> NonEmpty (Pattern ()) -> Cause v loc
UncoveredPatterns loc
matchLoc) (Maybe (NonEmpty (Pattern ())) -> MT v loc (Result v loc) ())
-> Maybe (NonEmpty (Pattern ())) -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ [Pattern ()] -> Maybe (NonEmpty (Pattern ()))
forall a. [a] -> Maybe (NonEmpty a)
Nel.nonEmpty [Pattern ()]
uncovered
      checkRedundant :: MT v loc (Result v loc) ()
checkRedundant = (loc -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
-> [loc]
-> MT v loc (Result v loc) ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (MT v loc (Result v loc) Any
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> MT v loc (Result v loc) b -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) (MT v loc (Result v loc) Any
 -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> (loc -> MT v loc (Result v loc) Any)
-> loc
-> MT v loc (Result v loc) ()
-> MT v loc (Result v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> MT v loc (Result v loc) Any
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) Any)
-> (loc -> Cause v loc) -> loc -> MT v loc (Result v loc) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. loc -> Cause v loc
forall v loc. loc -> Cause v loc
RedundantPattern) (() -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) [loc]
redundant
  MT v loc (Result v loc) ()
checkUncovered MT v loc (Result v loc) ()
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> MT v loc (Result v loc) b -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> MT v loc (Result v loc) ()
checkRedundant

checkCases ::
  (Var v) =>
  (Ord loc) =>
  Type v loc ->
  Type v loc ->
  [Term.MatchCase loc (Term v loc)] ->
  M v loc (Wanted v loc)
checkCases :: forall v loc.
(Var v, Ord loc) =>
Type v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> M v loc (Wanted v loc)
checkCases Type v loc
_ Type v loc
_ [] = Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
checkCases Type v loc
scrutType Type v loc
outType cases :: [MatchCase loc (Term v loc)]
cases@(Term.MatchCase Pattern loc
_ Maybe (Term v loc)
_ Term v loc
t : [MatchCase loc (Term v loc)]
_) =
  PathElement v loc
-> MT v loc (Result v loc) (Wanted v loc)
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (loc -> PathElement v loc
forall v loc. loc -> PathElement v loc
InMatch (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v loc
t)) (MT v loc (Result v loc) (Wanted v loc)
 -> MT v loc (Result v loc) (Wanted v loc))
-> MT v loc (Result v loc) (Wanted v loc)
-> MT v loc (Result v loc) (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    Maybe [Type v loc]
mes <- [Pattern loc] -> M v loc (Maybe [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Pattern loc] -> M v loc (Maybe [Type v loc])
requestType ([MatchCase loc (Term v loc)]
cases [MatchCase loc (Term v loc)]
-> (MatchCase loc (Term v loc) -> Pattern loc) -> [Pattern loc]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Term.MatchCase Pattern loc
p Maybe (Term v loc)
_ Term v loc
_) -> Pattern loc
p)
    Maybe [Type v loc]
-> ([Type v loc] -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [Type v loc]
mes (([Type v loc] -> MT v loc (Result v loc) ())
 -> MT v loc (Result v loc) ())
-> ([Type v loc] -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ \[Type v loc]
es ->
      Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
scrutType M v loc (Type v loc)
-> (Type v loc -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v loc
sty -> Type v loc -> [Type v loc] -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> [Type v loc] -> M v loc ()
ensureReqEffects Type v loc
sty [Type v loc]
es
    Type v loc
scrutType' <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM (Type v loc -> M v loc (Type v loc))
-> M v loc (Type v loc) -> M v loc (Type v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
scrutType
    [Wanted v loc] -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
[Wanted v loc] -> M v loc (Wanted v loc)
coalesceWanteds ([Wanted v loc] -> MT v loc (Result v loc) (Wanted v loc))
-> MT v loc (Result v loc) [Wanted v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (MatchCase loc (Term v loc)
 -> MT v loc (Result v loc) (Wanted v loc))
-> [MatchCase loc (Term v loc)]
-> MT v loc (Result v loc) [Wanted v loc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Type v loc
-> Type v loc
-> MatchCase loc (Term v loc)
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc
-> Type v loc
-> MatchCase loc (Term v loc)
-> M v loc (Wanted v loc)
checkCase Type v loc
scrutType' Type v loc
outType) [MatchCase loc (Term v loc)]
cases

-- Checks a scrutinee type against a list of effects from e.g. a list of cases
-- from a handler.
--
-- This opportunistically destructures the scrutinee type if it is of the form
-- `Request es r` in an effort to avoid introducing ability unification
-- variables that will be more difficult to infer. In such cases, we just run an
-- ability check directly against `es`. This works better, for instance, where a
-- signature has been given for the handler, and es = {A,B,g}, for a universal
-- g. In such a situation, we have no good way of solving via the general check
-- for {A,B,e} < {A,B,g} with a fresh `e` existential, but the `e` is actually
-- useless in this scenario.
ensureReqEffects :: (Var v) => (Ord loc) => Type v loc -> [Type v loc] -> M v loc ()
ensureReqEffects :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> [Type v loc] -> M v loc ()
ensureReqEffects (Type.Apps' (Type.Ref' Reference
req) [Type (TypeVar v loc) loc
hes, Type (TypeVar v loc) loc
_]) [Type (TypeVar v loc) loc]
res
  | Reference
req Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.effectRef = [Type (TypeVar v loc) loc] -> M v loc [Type (TypeVar v loc) loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type (TypeVar v loc) loc
hes] M v loc [Type (TypeVar v loc) loc]
-> ([Type (TypeVar v loc) loc] -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Type (TypeVar v loc) loc]
hes -> [Type (TypeVar v loc) loc]
-> [Type (TypeVar v loc) loc] -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> [Type v loc] -> M v loc ()
abilityCheck' [Type (TypeVar v loc) loc]
hes [Type (TypeVar v loc) loc]
res
ensureReqEffects Type (TypeVar v loc) loc
sty [Type (TypeVar v loc) loc]
res = do
  v
v <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferPatternPureV
  v
g <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferAbility
  let lo :: loc
lo = Type (TypeVar v loc) loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type (TypeVar v loc) loc
sty
      vt :: Type (TypeVar v loc) loc
vt = loc -> v -> Type (TypeVar v loc) loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
lo v
v
      gt :: Type (TypeVar v loc) loc
gt = loc -> v -> Type (TypeVar v loc) loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
lo v
g
      es' :: [Type (TypeVar v loc) loc]
es' = Type (TypeVar v loc) loc
gt Type (TypeVar v loc) loc
-> [Type (TypeVar v loc) loc] -> [Type (TypeVar v loc) loc]
forall a. a -> [a] -> [a]
: [Type (TypeVar v loc) loc]
res
  [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
g, v -> Element v loc
forall v loc. v -> Element v loc
existential v
v]
  Type (TypeVar v loc) loc
-> Type (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc
-> (loc, Type (TypeVar v loc) loc)
-> (loc, Type (TypeVar v loc) loc)
-> Type (TypeVar v loc) loc
forall v a.
Ord v =>
a -> (a, Type v a) -> (a, Type v a) -> Type v a
Type.effectV loc
lo (loc
lo, loc -> [Type (TypeVar v loc) loc] -> Type (TypeVar v loc) loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects loc
lo [Type (TypeVar v loc) loc]
es') (loc
lo, Type (TypeVar v loc) loc
vt)) Type (TypeVar v loc) loc
sty

getEffect ::
  (Var v) => (Ord loc) => ConstructorReference -> M v loc (Type v loc)
getEffect :: forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffect ConstructorReference
ref = do
  Type v loc
ect <- ConstructorReference -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType ConstructorReference
ref
  Type v loc
uect <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
ect
  let final :: Term F v a -> Term F v a
final (Type.Arrow' Term F v a
_ Term F v a
o) = Term F v a -> Term F v a
final Term F v a
o
      final Term F v a
t = Term F v a
t
  case Type v loc -> Type v loc
final Type v loc
uect of
    Type.Effect'' [Type v loc
et] Type v loc
_ -> Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type v loc
et
    t :: Type v loc
t@(Type.Effect'' [Type v loc]
_ Type v loc
_) ->
      CompilerBug v loc -> M v loc (Type v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> M v loc (Type v loc))
-> CompilerBug v loc -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ Type v loc -> CompilerBug v loc
forall v loc. Type v loc -> CompilerBug v loc
EffectConstructorHadMultipleEffects Type v loc
t
    Type v loc
_ -> CompilerBug v loc -> M v loc (Type v loc)
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash CompilerBug v loc
forall v loc. CompilerBug v loc
PatternMatchFailure

requestType ::
  (Var v) => (Ord loc) => [Pattern loc] -> M v loc (Maybe [Type v loc])
requestType :: forall v loc.
(Var v, Ord loc) =>
[Pattern loc] -> M v loc (Maybe [Type v loc])
requestType [Pattern loc]
ps =
  ([ConstructorReference] -> MT v loc (Result v loc) [Type v loc])
-> Maybe [ConstructorReference]
-> MT v loc (Result v loc) (Maybe [Type v loc])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((ConstructorReference -> MT v loc (Result v loc) (Type v loc))
-> [ConstructorReference] -> MT v loc (Result v loc) [Type v loc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConstructorReference -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffect ([ConstructorReference] -> MT v loc (Result v loc) [Type v loc])
-> ([ConstructorReference] -> [ConstructorReference])
-> [ConstructorReference]
-> MT v loc (Result v loc) [Type v loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorReference -> ConstructorReference -> Bool)
-> [ConstructorReference] -> [ConstructorReference]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Reference -> Reference -> Bool)
-> (ConstructorReference -> Reference)
-> ConstructorReference
-> ConstructorReference
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting Reference ConstructorReference Reference
-> ConstructorReference -> Reference
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Reference ConstructorReference Reference
forall r s (f :: * -> *).
Functor f =>
(r -> f s)
-> GConstructorReference r -> f (GConstructorReference s)
reference_)) (Maybe [ConstructorReference]
 -> MT v loc (Result v loc) (Maybe [Type v loc]))
-> Maybe [ConstructorReference]
-> MT v loc (Result v loc) (Maybe [Type v loc])
forall a b. (a -> b) -> a -> b
$
    ([ConstructorReference]
 -> Pattern loc -> Maybe [ConstructorReference])
-> [ConstructorReference]
-> [Pattern loc]
-> Maybe [ConstructorReference]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Foldable.foldlM (\[ConstructorReference]
acc Pattern loc
p -> ([ConstructorReference]
-> [ConstructorReference] -> [ConstructorReference]
forall a. [a] -> [a] -> [a]
++ [ConstructorReference]
acc) ([ConstructorReference] -> [ConstructorReference])
-> Maybe [ConstructorReference] -> Maybe [ConstructorReference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern loc -> Maybe [ConstructorReference]
forall {loc}. Pattern loc -> Maybe [ConstructorReference]
single Pattern loc
p) [] [Pattern loc]
ps
  where
    single :: Pattern loc -> Maybe [ConstructorReference]
single (Pattern.As loc
_ Pattern loc
p) = Pattern loc -> Maybe [ConstructorReference]
single Pattern loc
p
    single Pattern.EffectPure {} = [ConstructorReference] -> Maybe [ConstructorReference]
forall a. a -> Maybe a
Just []
    single (Pattern.EffectBind loc
_ ConstructorReference
ref [Pattern loc]
_ Pattern loc
_) = [ConstructorReference] -> Maybe [ConstructorReference]
forall a. a -> Maybe a
Just [ConstructorReference
ref]
    single Pattern loc
_ = Maybe [ConstructorReference]
forall a. Maybe a
Nothing

checkCase ::
  forall v loc.
  (Var v, Ord loc) =>
  Type v loc ->
  Type v loc ->
  Term.MatchCase loc (Term v loc) ->
  M v loc (Wanted v loc)
checkCase :: forall v loc.
(Var v, Ord loc) =>
Type v loc
-> Type v loc
-> MatchCase loc (Term v loc)
-> M v loc (Wanted v loc)
checkCase Type v loc
scrutineeType Type v loc
outputType (Term.MatchCase Pattern loc
pat Maybe (Term v loc)
guard Term v loc
rhs) = do
  Type v loc
scrutineeType <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
scrutineeType
  Type v loc
outputType <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
outputType
  v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
markThenRetractWanted v
forall v. Var v => v
Var.inferOther (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    let peel :: Term f v a -> ([v], Term f v a)
peel Term f v a
t = case Term f v a
t of
          ABT.AbsN' [v]
vars Term f v a
bod -> ([v]
vars, Term f v a
bod)
        ([v]
rhsvs, Term v loc
rhsbod) = Term v loc -> ([v], Term v loc)
forall {f :: * -> *} {v} {a}. Term f v a -> ([v], Term f v a)
peel Term v loc
rhs
        mayGuard :: Maybe (Term v loc)
mayGuard = ([v], Term v loc) -> Term v loc
forall a b. (a, b) -> b
snd (([v], Term v loc) -> Term v loc)
-> (Term v loc -> ([v], Term v loc)) -> Term v loc -> Term v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v loc -> ([v], Term v loc)
forall {f :: * -> *} {v} {a}. Term f v a -> ([v], Term f v a)
peel (Term v loc -> Term v loc)
-> Maybe (Term v loc) -> Maybe (Term v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Term v loc)
guard
    ([(v, v)]
substs, [v]
remains) <- StateT [v] (MT v loc (Result v loc)) [(v, v)]
-> [v] -> MT v loc (Result v loc) ([(v, v)], [v])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Type v loc
-> Pattern loc -> StateT [v] (MT v loc (Result v loc)) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
scrutineeType Pattern loc
pat) [v]
rhsvs
    Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
remains) (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ CompilerBug v loc -> MT v loc (Result v loc) ()
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (Pattern loc -> CompilerBug v loc
forall v loc. Pattern loc -> CompilerBug v loc
MalformedPattern Pattern loc
pat)
    let subst :: Term v loc -> Term v loc
subst = [(v, Term (F (TypeVar v loc) loc loc) v ())]
-> Term v loc -> Term v loc
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v b)] -> Term f v a -> Term f v a
ABT.substsInheritAnnotation ((v -> Term (F (TypeVar v loc) loc loc) v ())
-> (v, v) -> (v, Term (F (TypeVar v loc) loc loc) v ())
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (() -> v -> Term (F (TypeVar v loc) loc loc) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var ()) ((v, v) -> (v, Term (F (TypeVar v loc) loc loc) v ()))
-> [(v, v)] -> [(v, Term (F (TypeVar v loc) loc loc) v ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, v)]
substs)
        rhs' :: Term v loc
rhs' = Term v loc -> Term v loc
subst Term v loc
rhsbod
        guard' :: Maybe (Term v loc)
guard' = Term v loc -> Term v loc
subst (Term v loc -> Term v loc)
-> Maybe (Term v loc) -> Maybe (Term v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Term v loc)
mayGuard
    Maybe (Wanted v loc)
gwant <- Maybe (Term v loc)
-> (Term v loc -> M v loc (Wanted v loc))
-> MT v loc (Result v loc) (Maybe (Wanted v loc))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Term v loc)
guard' ((Term v loc -> M v loc (Wanted v loc))
 -> MT v loc (Result v loc) (Maybe (Wanted v loc)))
-> (Term v loc -> M v loc (Wanted v loc))
-> MT v loc (Result v loc) (Maybe (Wanted v loc))
forall a b. (a -> b) -> a -> b
$ \Term v loc
g ->
      PathElement v loc
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
forall v loc. PathElement v loc
InMatchGuard (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$
        Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWantedScoped [] Term v loc
g (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.boolean (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
g))
    Type v loc
outputType <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
outputType
    PathElement v loc
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope PathElement v loc
forall v loc. PathElement v loc
InMatchBody (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$
      Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWantedScoped (Wanted v loc -> Maybe (Wanted v loc) -> Wanted v loc
forall a. a -> Maybe a -> a
fromMaybe [] Maybe (Wanted v loc)
gwant) Term v loc
rhs' Type v loc
outputType

-- For example:
--   match scrute with
--     (x, [42,y,Foo z]) -> blah x y z
--
-- scrutineeType will just be the type of `scrute`
-- The starting state will be the variables [x,y,z] (extracted from the Abs-chain on the RHS of the ->)
-- The output (assuming no type errors) is [(x,x'), (y,y'), (z,z')]
-- where x', y', z' are freshened versions of x, y, z. These will be substituted
-- into `blah x y z` to produce `blah x' y' z'` before typechecking it.
checkPattern ::
  (Var v, Ord loc) =>
  Type v loc ->
  Pattern loc ->
  StateT [v] (M v loc) [(v, v)]
checkPattern :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
tx Pattern loc
ty | (Bool
debugEnabled Bool -> Bool -> Bool
|| Bool
debugPatternsEnabled) Bool -> Bool -> Bool
&& ([Char], Type v loc, Pattern loc) -> Bool -> Bool
forall a b. Show a => a -> b -> b
traceShow ([Char]
"checkPattern" :: String, Type v loc
tx, Pattern loc
ty) Bool
False = StateT [v] (M v loc) [(v, v)]
forall a. HasCallStack => a
undefined
checkPattern Type v loc
scrutineeType Pattern loc
p =
  case Pattern loc
p of
    Pattern.Unbound loc
_ -> [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a. a -> StateT [v] (M v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Pattern.Var loc
_loc -> do
      v
v <- Pattern loc -> StateT [v] (M v loc) v
forall loc v. Pattern loc -> StateT [v] (M v loc) v
getAdvance Pattern loc
p
      v
v' <- M v loc v -> StateT [v] (M v loc) v
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc v -> StateT [v] (M v loc) v)
-> M v loc v -> StateT [v] (M v loc) v
forall a b. (a -> b) -> a -> b
$ v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
v
      M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc () -> StateT [v] (M v loc) ())
-> ([Element v loc] -> M v loc ())
-> [Element v loc]
-> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext ([Element v loc] -> StateT [v] (M v loc) ())
-> [Element v loc] -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ [v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
v' Type v loc
scrutineeType]
      pure [(v
v, v
v')]
    -- Ex: [42, y, Foo z]
    Pattern.SequenceLiteral loc
loc [Pattern loc]
ps -> do
      Type v loc
vt <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ do
        v
v <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferOther
        let vt :: Type v loc
vt = loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
loc v
v
        [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
v]
        -- ['a] <: scrutineeType, where 'a is fresh existential
        Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
loc (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
loc) Type v loc
vt) Type v loc
scrutineeType
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
vt
      [[(v, v)]] -> [(v, v)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(v, v)]] -> [(v, v)])
-> StateT [v] (M v loc) [[(v, v)]] -> StateT [v] (M v loc) [(v, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern loc -> StateT [v] (M v loc) [(v, v)])
-> [Pattern loc] -> StateT [v] (M v loc) [[(v, v)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
vt) [Pattern loc]
ps
    Pattern.SequenceOp loc
loc Pattern loc
l SeqOp
op Pattern loc
r -> do
      let (loc
locL, loc
locR) = (Pattern loc -> loc
forall loc. Pattern loc -> loc
Pattern.loc Pattern loc
l, Pattern loc -> loc
forall loc. Pattern loc -> loc
Pattern.loc Pattern loc
r)
      Type v loc
vt <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ do
        v
v <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferOther
        let vt :: Type v loc
vt = loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
loc v
v
        [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
v]
        -- todo: `Type.list loc` is super-probably wrong;
        -- I'm thinking it should be Ann.Intrinsic, but we don't
        -- have access to that here.
        Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
loc (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
loc) Type v loc
vt) Type v loc
scrutineeType
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
vt
      case SeqOp
op of
        SeqOp
Pattern.Cons -> do
          [(v, v)]
lvs <- Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
vt Pattern loc
l
          -- todo: same `Type.list loc` thing
          [(v, v)]
rvs <- Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
locR (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
locR) Type v loc
vt) Pattern loc
r
          pure $ [(v, v)]
lvs [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++ [(v, v)]
rvs
        SeqOp
Pattern.Snoc -> do
          -- todo: same `Type.list loc` thing
          [(v, v)]
lvs <- Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
locL (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
locL) Type v loc
vt) Pattern loc
l
          [(v, v)]
rvs <- Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
vt Pattern loc
r
          pure $ [(v, v)]
lvs [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++ [(v, v)]
rvs
        SeqOp
Pattern.Concat ->
          case (Pattern loc
l, Pattern loc
r) of
            (Pattern loc
p, Pattern loc
_) | Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
p -> StateT [v] (M v loc) [(v, v)]
f
            (Pattern loc
_, Pattern loc
p) | Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
p -> StateT [v] (M v loc) [(v, v)]
f
            (Pattern loc
_, Pattern loc
_) ->
              M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> (Cause v loc -> M v loc [(v, v)])
-> Cause v loc
-> StateT [v] (M v loc) [(v, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> M v loc [(v, v)]
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> StateT [v] (M v loc) [(v, v)])
-> Cause v loc -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$
                loc -> Type v loc -> Cause v loc
forall v loc. loc -> Type v loc -> Cause v loc
ConcatPatternWithoutConstantLength loc
loc (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
loc (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
loc) Type v loc
vt)
          where
            f :: StateT [v] (M v loc) [(v, v)]
f = ([(v, v)] -> [(v, v)] -> [(v, v)])
-> StateT [v] (M v loc) [(v, v)]
-> StateT [v] (M v loc) [(v, v)]
-> StateT [v] (M v loc) [(v, v)]
forall a b c.
(a -> b -> c)
-> StateT [v] (M v loc) a
-> StateT [v] (M v loc) b
-> StateT [v] (M v loc) c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
(++) (loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
g loc
locL Pattern loc
l) (loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
g loc
locR Pattern loc
r)
            -- todo: same `Type.list loc` thing
            g :: loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
g loc
l Pattern loc
p = Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app loc
l (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.list loc
l) Type v loc
vt) Pattern loc
p

            -- Only pertains to sequences, returns False if not a sequence
            isConstLen :: Pattern loc -> Bool
            isConstLen :: forall loc. Pattern loc -> Bool
isConstLen Pattern loc
p = case Pattern loc
p of
              Pattern.SequenceLiteral loc
_ [Pattern loc]
_ -> Bool
True
              Pattern.SequenceOp loc
_ Pattern loc
l SeqOp
op Pattern loc
r -> case SeqOp
op of
                SeqOp
Pattern.Snoc -> Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
l
                SeqOp
Pattern.Cons -> Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
r
                SeqOp
Pattern.Concat -> Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
l Bool -> Bool -> Bool
&& Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
r
              Pattern.As loc
_ Pattern loc
p -> Pattern loc -> Bool
forall loc. Pattern loc -> Bool
isConstLen Pattern loc
p
              Pattern loc
_ -> Bool
False
    -- TODO: provide a scope here for giving a good error message
    Pattern.Boolean loc
loc Bool
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.boolean loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Int loc
loc Int64
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.int loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Nat loc
loc Word64
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.nat loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Float loc
loc Double
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.float loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Text loc
loc Text
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.text loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Char loc
loc Char
_ ->
      M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> Type v loc
forall v a. Ord v => a -> Type v a
Type.char loc
loc) Type v loc
scrutineeType M v loc () -> [(v, v)] -> M v loc [(v, v)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [(v, v)]
forall a. Monoid a => a
mempty
    Pattern.Constructor loc
loc ConstructorReference
ref [Pattern loc]
args -> do
      Type v loc
dct <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ ConstructorReference -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getDataConstructorType ConstructorReference
ref
      Type v loc
udct <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ (Type v loc -> Set (TypeVar v loc))
-> Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
(Type v loc -> Set (TypeVar v loc))
-> Type v loc -> M v loc (Type v loc)
skolemize Type v loc -> Set (TypeVar v loc)
forall v loc. Type v loc -> Set (TypeVar v loc)
forcedData Type v loc
dct
      Bool -> StateT [v] (M v loc) () -> StateT [v] (M v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type v loc -> Int
forall v a. Type v a -> Int
Type.arity Type v loc
udct Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args)
        (StateT [v] (M v loc) () -> StateT [v] (M v loc) ())
-> (Cause v loc -> StateT [v] (M v loc) ())
-> Cause v loc
-> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (M v loc () -> StateT [v] (M v loc) ())
-> (Cause v loc -> M v loc ())
-> Cause v loc
-> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith
        (Cause v loc -> StateT [v] (M v loc) ())
-> Cause v loc -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ loc -> Type v loc -> Int -> Cause v loc
forall v loc. loc -> Type v loc -> Int -> Cause v loc
PatternArityMismatch loc
loc Type v loc
dct ([Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args)
      let step :: (Type v loc, [(v, v)])
-> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
step (Type.Arrow' Type v loc
i Type v loc
o, [(v, v)]
vso) Pattern loc
pat =
            (\[(v, v)]
vso' -> (Type v loc
o, [(v, v)]
vso [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++ [(v, v)]
vso')) ([(v, v)] -> (Type v loc, [(v, v)]))
-> StateT [v] (M v loc) [(v, v)]
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
i Pattern loc
pat
          step (Type v loc, [(v, v)])
_ Pattern loc
_ =
            M v loc (Type v loc, [(v, v)])
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc, [(v, v)])
 -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> (Cause v loc -> M v loc (Type v loc, [(v, v)]))
-> Cause v loc
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> M v loc (Type v loc, [(v, v)])
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> Cause v loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall a b. (a -> b) -> a -> b
$ loc -> Type v loc -> Int -> Cause v loc
forall v loc. loc -> Type v loc -> Int -> Cause v loc
PatternArityMismatch loc
loc Type v loc
dct ([Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args)
      (Type v loc
overall, [(v, v)]
vs) <- ((Type v loc, [(v, v)])
 -> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> (Type v loc, [(v, v)])
-> [Pattern loc]
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Type v loc, [(v, v)])
-> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
step (Type v loc
udct, []) [Pattern loc]
args
      Type v loc
st <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
scrutineeType
      M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc () -> StateT [v] (M v loc) ())
-> M v loc () -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
overall Type v loc
st
      pure [(v, v)]
vs
    Pattern.As loc
_loc Pattern loc
p' -> do
      v
v <- Pattern loc -> StateT [v] (M v loc) v
forall loc v. Pattern loc -> StateT [v] (M v loc) v
getAdvance Pattern loc
p
      v
v' <- M v loc v -> StateT [v] (M v loc) v
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc v -> StateT [v] (M v loc) v)
-> M v loc v -> StateT [v] (M v loc) v
forall a b. (a -> b) -> a -> b
$ v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
v
      M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc () -> StateT [v] (M v loc) ())
-> ([Element v loc] -> M v loc ())
-> [Element v loc]
-> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext ([Element v loc] -> StateT [v] (M v loc) ())
-> [Element v loc] -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ [v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
v' Type v loc
scrutineeType]
      ((v
v, v
v') (v, v) -> [(v, v)] -> [(v, v)]
forall a. a -> [a] -> [a]
:) ([(v, v)] -> [(v, v)])
-> StateT [v] (M v loc) [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
scrutineeType Pattern loc
p'
    -- ex: { a } -> a
    -- ex: { (x, 42) } -> a
    Pattern.EffectPure loc
loc Pattern loc
p
      -- Avoid creating extra effect variables when the scrutinee is already
      -- known to be a Request.
      --
      -- TODO: this should actually _always_ be the case, because we do a pass
      -- across the entire case statement refining the scrutinee type. The
      -- 'otherwise' still needs to be covered for exhaustivity, however.
      | Type.Apps' (Type.Ref' Reference
req) [Type v loc
_, Type v loc
r] <- Type v loc
scrutineeType,
        Reference
req Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.effectRef ->
          Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
r Pattern loc
p
      | Bool
otherwise -> do
          Type v loc
vt <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ do
            v
v <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferPatternPureV
            v
e <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferPatternPureE
            let vt :: Type v loc
vt = loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
loc v
v
            let et :: Type v loc
et = loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
loc v
e
            [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
v, v -> Element v loc
forall v loc. v -> Element v loc
existential v
e]
            Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> (loc, Type v loc) -> (loc, Type v loc) -> Type v loc
forall v a.
Ord v =>
a -> (a, Type v a) -> (a, Type v a) -> Type v a
Type.effectV loc
loc (loc
loc, Type v loc
et) (loc
loc, Type v loc
vt)) Type v loc
scrutineeType
            Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
vt
          Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
vt Pattern loc
p
    -- ex: { Stream.emit x -> k } -> ...
    Pattern.EffectBind loc
loc ConstructorReference
ref [Pattern loc]
args Pattern loc
k -> do
      -- scrutineeType should be a supertype of `Effect e vt`
      -- for fresh existentials `e` and `vt`
      Type v loc
ect <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ ConstructorReference -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType ConstructorReference
ref
      Type v loc
uect <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ (Type v loc -> Set (TypeVar v loc))
-> Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
(Type v loc -> Set (TypeVar v loc))
-> Type v loc -> M v loc (Type v loc)
skolemize Type v loc -> Set (TypeVar v loc)
forall v loc. Type v loc -> Set (TypeVar v loc)
forcedEffect Type v loc
ect
      Bool -> StateT [v] (M v loc) () -> StateT [v] (M v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type v loc -> Int
forall v a. Type v a -> Int
Type.arity Type v loc
uect Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args)
        (StateT [v] (M v loc) () -> StateT [v] (M v loc) ())
-> (Int -> StateT [v] (M v loc) ())
-> Int
-> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (M v loc () -> StateT [v] (M v loc) ())
-> (Int -> M v loc ()) -> Int -> StateT [v] (M v loc) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith
        (Cause v loc -> M v loc ())
-> (Int -> Cause v loc) -> Int -> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. loc -> Type v loc -> Int -> Cause v loc
forall v loc. loc -> Type v loc -> Int -> Cause v loc
PatternArityMismatch loc
loc Type v loc
ect
        (Int -> StateT [v] (M v loc) ()) -> Int -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ [Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args
      let step :: (Type v loc, [(v, v)])
-> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
step (Type.Arrow' Type v loc
i Type v loc
o, [(v, v)]
vso) Pattern loc
pat =
            (\[(v, v)]
vso' -> (Type v loc
o, [(v, v)]
vso [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++ [(v, v)]
vso')) ([(v, v)] -> (Type v loc, [(v, v)]))
-> StateT [v] (M v loc) [(v, v)]
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
i Pattern loc
pat
          step (Type v loc, [(v, v)])
_ Pattern loc
_ =
            M v loc (Type v loc, [(v, v)])
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc, [(v, v)])
 -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> (Cause v loc -> M v loc (Type v loc, [(v, v)]))
-> Cause v loc
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cause v loc -> M v loc (Type v loc, [(v, v)])
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> Cause v loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall a b. (a -> b) -> a -> b
$ loc -> Type v loc -> Int -> Cause v loc
forall v loc. loc -> Type v loc -> Int -> Cause v loc
PatternArityMismatch loc
loc Type v loc
ect ([Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
args)
      (Type v loc
ctorOutputType, [(v, v)]
vs) <- ((Type v loc, [(v, v)])
 -> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)]))
-> (Type v loc, [(v, v)])
-> [Pattern loc]
-> StateT [v] (M v loc) (Type v loc, [(v, v)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Type v loc, [(v, v)])
-> Pattern loc -> StateT [v] (M v loc) (Type v loc, [(v, v)])
step (Type v loc
uect, []) [Pattern loc]
args
      Type v loc
st <- M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc))
-> M v loc (Type v loc) -> StateT [v] (M v loc) (Type v loc)
forall a b. (a -> b) -> a -> b
$ Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
scrutineeType
      case Type v loc
ctorOutputType of
        -- an effect ctor should have exactly 1 effect!
        Type.Effect'' [Type v loc
et] Type v loc
it
          -- expecting scrutineeType to be `Effect et vt`
          | Type.Apps' Type v loc
_ [Type v loc
eff, Type v loc
vt] <- Type v loc
st -> do
              -- ensure that the variables in `et` unify with those from
              -- the scrutinee.
              M v loc () -> StateT [v] (M v loc) ()
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc () -> StateT [v] (M v loc) ())
-> M v loc () -> StateT [v] (M v loc) ()
forall a b. (a -> b) -> a -> b
$ [Type v loc] -> [Type v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> [Type v loc] -> M v loc ()
abilityCheck' [Type v loc
eff] [Type v loc
et]
              let kt :: Type v loc
kt =
                    loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow
                      (Pattern loc -> loc
forall loc. Pattern loc -> loc
Pattern.loc Pattern loc
k)
                      Type v loc
it
                      (loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect (Pattern loc -> loc
forall loc. Pattern loc -> loc
Pattern.loc Pattern loc
k) [Type v loc
eff] Type v loc
vt)
              ([(v, v)]
vs [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++) ([(v, v)] -> [(v, v)])
-> StateT [v] (M v loc) [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)]
checkPattern Type v loc
kt Pattern loc
k
          | Bool
otherwise -> M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> (CompilerBug v loc -> M v loc [(v, v)])
-> CompilerBug v loc
-> StateT [v] (M v loc) [(v, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBug v loc -> M v loc [(v, v)]
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> StateT [v] (M v loc) [(v, v)])
-> CompilerBug v loc -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$ CompilerBug v loc
forall v loc. CompilerBug v loc
PatternMatchFailure
        Type v loc
_ ->
          M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)]
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc [(v, v)] -> StateT [v] (M v loc) [(v, v)])
-> (CompilerBug v loc -> M v loc [(v, v)])
-> CompilerBug v loc
-> StateT [v] (M v loc) [(v, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBug v loc -> M v loc [(v, v)]
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> StateT [v] (M v loc) [(v, v)])
-> CompilerBug v loc -> StateT [v] (M v loc) [(v, v)]
forall a b. (a -> b) -> a -> b
$
            Type v loc -> CompilerBug v loc
forall v loc. Type v loc -> CompilerBug v loc
EffectConstructorHadMultipleEffects
              Type v loc
ctorOutputType
  where
    getAdvance :: Pattern loc -> StateT [v] (M v loc) v
    getAdvance :: forall loc v. Pattern loc -> StateT [v] (M v loc) v
getAdvance Pattern loc
p = do
      [v]
vs <- StateT [v] (M v loc) [v]
forall s (m :: * -> *). MonadState s m => m s
get
      case [v]
vs of
        [] -> M v loc v -> StateT [v] (M v loc) v
forall (m :: * -> *) a. Monad m => m a -> StateT [v] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M v loc v -> StateT [v] (M v loc) v)
-> M v loc v -> StateT [v] (M v loc) v
forall a b. (a -> b) -> a -> b
$ CompilerBug v loc -> M v loc v
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (Pattern loc -> CompilerBug v loc
forall v loc. Pattern loc -> CompilerBug v loc
MalformedPattern Pattern loc
p)
        (v
v : [v]
vs) -> do
          [v] -> StateT [v] (M v loc) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [v]
vs
          pure v
v

applyM :: (Var v, Ord loc) => Type v loc -> M v loc (Type v loc)
applyM :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t = (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
`apply` Type v loc
t) (Context v loc -> Type v loc)
-> MT v loc (Result v loc) (Context v loc)
-> MT v loc (Result v loc) (Type v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT v loc (Result v loc) (Context v loc)
forall v loc. M v loc (Context v loc)
getContext

lookupAnn :: (Ord v) => Context v loc -> v -> Maybe (Type v loc)
lookupAnn :: forall v loc. Ord v => Context v loc -> v -> Maybe (Type v loc)
lookupAnn Context v loc
ctx v
v = v -> Map v (Type v loc) -> Maybe (Type v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v (Info v loc -> Map v (Type v loc)
forall v loc. Info v loc -> Map v (Type v loc)
termVarAnnotations (Info v loc -> Map v (Type v loc))
-> (Context v loc -> Info v loc)
-> Context v loc
-> Map v (Type v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info (Context v loc -> Map v (Type v loc))
-> Context v loc -> Map v (Type v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc
ctx)

lookupSolved :: (Ord v) => Context v loc -> v -> Maybe (Monotype v loc)
lookupSolved :: forall v loc. Ord v => Context v loc -> v -> Maybe (Monotype v loc)
lookupSolved Context v loc
ctx v
v = v -> Map v (Monotype v loc) -> Maybe (Monotype v loc)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v (Info v loc -> Map v (Monotype v loc)
forall v loc. Info v loc -> Map v (Monotype v loc)
solvedExistentials (Info v loc -> Map v (Monotype v loc))
-> (Context v loc -> Info v loc)
-> Context v loc
-> Map v (Monotype v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Info v loc
forall v loc. Ord v => Context v loc -> Info v loc
info (Context v loc -> Map v (Monotype v loc))
-> Context v loc -> Map v (Monotype v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc
ctx)

resetContextAfter :: a -> M v loc a -> M v loc a
resetContextAfter :: forall a v loc. a -> M v loc a -> M v loc a
resetContextAfter a
x M v loc a
a = do
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  a
a <- M v loc a
a M v loc a -> M v loc a -> M v loc a
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` a -> M v loc a
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx
  pure a
a

-- | Synthesize and generalize the type of each binding in a let rec.
-- Updates the context so that all bindings are annotated with
-- their type. Also returns the freshened version of `body`.
-- See usage in `synthesize` and `check` for `LetRec'` case.
annotateLetRecBindings ::
  (Var v, Ord loc) =>
  Term.IsTop ->
  ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)) ->
  M v loc (Term v loc)
annotateLetRecBindings :: forall v loc.
(Var v, Ord loc) =>
Bool
-> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc))
-> M v loc (Term v loc)
annotateLetRecBindings Bool
isTop (v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)
letrec =
  -- If this is a top-level letrec, then emit a TopLevelComponent note,
  -- which asks if the user-provided type annotations were needed.
  if Bool
isTop
    then do
      -- First, typecheck (using annotateLetRecBindings') the bindings with any
      -- user-provided annotations.
      (Term v loc
body, [(v, Type v loc)]
vts) <- Bool -> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
annotateLetRecBindings' Bool
True
      -- Then, try typechecking again, but ignoring any user-provided annotations.
      -- This will infer whatever type.  If it altogether fails to typecheck here
      -- then, ...(1)
      Maybe (Term v loc, [(v, Type v loc)])
withoutAnnotations <-
        Maybe (Term v loc, [(v, Type v loc)])
-> M v loc (Maybe (Term v loc, [(v, Type v loc)]))
-> M v loc (Maybe (Term v loc, [(v, Type v loc)]))
forall a v loc. a -> M v loc a -> M v loc a
resetContextAfter Maybe (Term v loc, [(v, Type v loc)])
forall a. Maybe a
Nothing (M v loc (Maybe (Term v loc, [(v, Type v loc)]))
 -> M v loc (Maybe (Term v loc, [(v, Type v loc)])))
-> M v loc (Maybe (Term v loc, [(v, Type v loc)]))
-> M v loc (Maybe (Term v loc, [(v, Type v loc)]))
forall a b. (a -> b) -> a -> b
$ (Term v loc, [(v, Type v loc)])
-> Maybe (Term v loc, [(v, Type v loc)])
forall a. a -> Maybe a
Just ((Term v loc, [(v, Type v loc)])
 -> Maybe (Term v loc, [(v, Type v loc)]))
-> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
-> M v loc (Maybe (Term v loc, [(v, Type v loc)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
annotateLetRecBindings' Bool
False
      -- convert from typechecker TypeVar back to regular `v` vars
      let unTypeVar :: (a, Type v a) -> (a, Type v a)
unTypeVar (a
v, Type v a
t) = (a
v, Type v a -> Type v a
forall v a. Var v => Type v a -> Type v a
generalizeAndUnTypeVar Type v a
t)
      case Maybe (Term v loc, [(v, Type v loc)])
withoutAnnotations of
        Just (Term v loc
_, [(v, Type v loc)]
vts') -> do
          Bool
r <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> MT v loc (Result v loc) [Bool] -> MT v loc (Result v loc) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type v loc -> Type v loc -> MT v loc (Result v loc) Bool)
-> [Type v loc] -> [Type v loc] -> MT v loc (Result v loc) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type v loc -> Type v loc -> MT v loc (Result v loc) Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc Bool
isRedundant (((v, Type v loc) -> Type v loc)
-> [(v, Type v loc)] -> [Type v loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd [(v, Type v loc)]
vts) (((v, Type v loc) -> Type v loc)
-> [(v, Type v loc)] -> [Type v loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd [(v, Type v loc)]
vts')
          InfoNote v loc -> MT v loc (Result v loc) ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> MT v loc (Result v loc) ())
-> InfoNote v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent ((\(v
v, Type v loc
b) -> (v -> v
forall v. Var v => v -> v
Var.reset v
v, Type v loc
b, Bool
r)) ((v, Type v loc) -> (v, Type v loc, Bool))
-> ((v, Type v loc) -> (v, Type v loc))
-> (v, Type v loc)
-> (v, Type v loc, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, Type v loc) -> (v, Type v loc)
forall {v} {a} {a}. Var v => (a, Type v a) -> (a, Type v a)
unTypeVar ((v, Type v loc) -> (v, Type v loc, Bool))
-> [(v, Type v loc)] -> [(v, Type v loc, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Type v loc)]
vts)
        -- ...(1) we'll assume all the user-provided annotations were needed
        Maybe (Term v loc, [(v, Type v loc)])
Nothing ->
          InfoNote v loc -> MT v loc (Result v loc) ()
forall v loc. InfoNote v loc -> M v loc ()
btw (InfoNote v loc -> MT v loc (Result v loc) ())
-> InfoNote v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$
            [(v, Type v loc, Bool)] -> InfoNote v loc
forall v loc. Var v => [(v, Type v loc, Bool)] -> InfoNote v loc
topLevelComponent ((\(v
v, Type v loc
b) -> (v -> v
forall v. Var v => v -> v
Var.reset v
v, Type v loc
b, Bool
False)) ((v, Type v loc) -> (v, Type v loc, Bool))
-> ((v, Type v loc) -> (v, Type v loc))
-> (v, Type v loc)
-> (v, Type v loc, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, Type v loc) -> (v, Type v loc)
forall {v} {a} {a}. Var v => (a, Type v a) -> (a, Type v a)
unTypeVar ((v, Type v loc) -> (v, Type v loc, Bool))
-> [(v, Type v loc)] -> [(v, Type v loc, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Type v loc)]
vts)
      pure Term v loc
body
    else -- If this isn't a top-level letrec, then we don't have to do anything special
      (Term v loc, [(v, Type v loc)]) -> Term v loc
forall a b. (a, b) -> a
fst ((Term v loc, [(v, Type v loc)]) -> Term v loc)
-> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
-> M v loc (Term v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
annotateLetRecBindings' Bool
True
  where
    annotateLetRecBindings' :: Bool -> MT v loc (Result v loc) (Term v loc, [(v, Type v loc)])
annotateLetRecBindings' Bool
useUserAnnotations = do
      ([(v, Term v loc)]
bindings, Term v loc
body) <- (v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc)
letrec v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar
      let vs :: [v]
vs = ((v, Term v loc) -> v) -> [(v, Term v loc)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term v loc) -> v
forall a b. (a, b) -> a
fst [(v, Term v loc)]
bindings
      (([Term v loc]
bindings, [Type v loc]
bindingTypes), [Element v loc]
ctx2) <- v
-> M v loc ([Term v loc], [Type v loc])
-> M v loc (([Term v loc], [Type v loc]), [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract v
forall v. Var v => v
Var.inferOther (M v loc ([Term v loc], [Type v loc])
 -> M v loc (([Term v loc], [Type v loc]), [Element v loc]))
-> M v loc ([Term v loc], [Type v loc])
-> M v loc (([Term v loc], [Type v loc]), [Element v loc])
forall a b. (a -> b) -> a -> b
$ do
        let f :: (v, Term v loc) -> MT v loc (Result v loc) (Term v loc, Type v loc)
f (v
v, Term v loc
binding) = case Term v loc
binding of
              -- If user has provided an annotation, we use that
              Term.Ann' Term v loc
e Type v loc
t | Bool
useUserAnnotations -> do
                -- Arrows in `t` with no ability lists get an attached fresh
                -- existential to allow inference of required abilities
                Type v loc
t2 <- Type v loc -> M v loc (Type v loc)
forall v loc. Var v => Type v loc -> M v loc (Type v loc)
existentializeArrows (Type v loc -> M v loc (Type v loc))
-> M v loc (Type v loc) -> M v loc (Type v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t
                pure (loc -> Term v loc -> Type v loc -> Term v loc
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
binding) Term v loc
e Type v loc
t2, Type v loc
t2)
              -- If we're not using an annotation, we make one up. There's 2 cases:

              lam :: Term v loc
lam@(Term.Lam' Subst (F (TypeVar v loc) loc loc) v loc
_) ->
                -- If `e` is a lambda of arity K, we immediately refine the
                -- existential to `a1 ->{e1} a2 ... ->{eK} r`. This gives better
                -- inference of the lambda's ability variables in conjunction with
                -- handling of lambdas in `check` judgement.
                (Term v loc
lam,) (Type v loc -> (Term v loc, Type v loc))
-> M v loc (Type v loc)
-> MT v loc (Result v loc) (Term v loc, Type v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v loc -> M v loc (Type v loc)
forall loc v.
(Ord loc, Var v) =>
Term v loc -> M v loc (Type v loc)
existentialFunctionTypeFor Term v loc
lam
              Term v loc
e -> do
                -- Anything else, just make up a fresh existential
                -- which will be refined during typechecking of the binding
                v
vt <- v -> M v loc v
forall v loc. Var v => v -> M v loc v
extendExistential v
v
                pure $ (Term v loc
e, loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
binding) Blank loc
forall loc. Blank loc
B.Blank v
vt)
        ([Term v loc]
bindings, [Type v loc]
bindingTypes) <- [(Term v loc, Type v loc)] -> ([Term v loc], [Type v loc])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Term v loc, Type v loc)] -> ([Term v loc], [Type v loc]))
-> MT v loc (Result v loc) [(Term v loc, Type v loc)]
-> M v loc ([Term v loc], [Type v loc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((v, Term v loc)
 -> MT v loc (Result v loc) (Term v loc, Type v loc))
-> [(v, Term v loc)]
-> MT v loc (Result v loc) [(Term v loc, Type v loc)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (v, Term v loc) -> MT v loc (Result v loc) (Term v loc, Type v loc)
f [(v, Term v loc)]
bindings
        [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext ((v -> Type v loc -> Element v loc)
-> [v] -> [Type v loc] -> [Element v loc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann [v]
vs [Type v loc]
bindingTypes)
        -- check each `bi` against its type
        [(v, Term v loc, Type v loc)]
-> ((v, Term v loc, Type v loc) -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ ([v]
-> [Term v loc] -> [Type v loc] -> [(v, Term v loc, Type v loc)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [v]
vs [Term v loc]
bindings [Type v loc]
bindingTypes) (((v, Term v loc, Type v loc) -> MT v loc (Result v loc) ())
 -> MT v loc (Result v loc) ())
-> ((v, Term v loc, Type v loc) -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ \(v
v, Term v loc
b, Type v loc
t) -> do
          -- note: elements of a cycle have to be pure, otherwise order of effects
          -- is unclear and chaos ensues
          -- ensure actions in blocks have type ()
          Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (v -> Bool
forall v. Var v => v -> Bool
Var.isAction v
v) (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
t (loc -> Type v loc
forall v a. Ord v => a -> Type v a
DDB.unitType (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v loc
b))
          Term v loc
-> Type v loc -> [Type v loc] -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> [Type v loc] -> M v loc ()
checkScopedWith Term v loc
b Type v loc
t []
        [(v, Term v loc)] -> MT v loc (Result v loc) ()
forall v loc. Var v => [(v, Term v loc)] -> M v loc ()
ensureGuardedCycle ([v]
vs [v] -> [Term v loc] -> [(v, Term v loc)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Term v loc]
bindings)
        pure ([Term v loc]
bindings, [Type v loc]
bindingTypes)
      -- compute generalized types `gt1, gt2 ...` for each binding `b1, b2...`;
      -- add annotations `v1 : gt1, v2 : gt2 ...` to the context
      let bindingArities :: [Int]
bindingArities = Term v loc -> Int
forall vt at ap v a. Term2 vt at ap v a -> Int
Term.arity (Term v loc -> Int) -> [Term v loc] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term v loc]
bindings
          gen :: Type v loc -> Int -> Type v loc
gen Type v loc
bindingType Int
_arity = [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
ctx2 Type v loc
bindingType
          bindingTypesGeneralized :: [Type v loc]
bindingTypesGeneralized = (Type v loc -> Int -> Type v loc)
-> [Type v loc] -> [Int] -> [Type v loc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type v loc -> Int -> Type v loc
gen [Type v loc]
bindingTypes [Int]
bindingArities
          annotations :: [Element v loc]
annotations = (v -> Type v loc -> Element v loc)
-> [v] -> [Type v loc] -> [Element v loc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith v -> Type v loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann [v]
vs [Type v loc]
bindingTypesGeneralized
      [Element v loc] -> MT v loc (Result v loc) ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [Element v loc]
annotations
      pure (Term v loc
body, [v]
vs [v] -> [Type v loc] -> [(v, Type v loc)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type v loc]
bindingTypesGeneralized)

ensureGuardedCycle :: (Var v) => [(v, Term v loc)] -> M v loc ()
ensureGuardedCycle :: forall v loc. Var v => [(v, Term v loc)] -> M v loc ()
ensureGuardedCycle [(v, Term v loc)]
bindings =
  let -- We make sure that nonLambdas can depend only on lambdas, not on each other
      nonLambdas :: Set v
nonLambdas = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v
v | (v
v, Term v loc
b) <- [(v, Term v loc)]
bindings, Term v loc -> Int
forall vt at ap v a. Term2 vt at ap v a -> Int
Term.arity Term v loc
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
      ([(v, Term v loc)]
notok, [(v, Term v loc)]
ok) = ((v, Term v loc) -> Bool)
-> [(v, Term v loc)] -> ([(v, Term v loc)], [(v, Term v loc)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (v, Term v loc) -> Bool
f [(v, Term v loc)]
bindings
      f :: (v, Term v loc) -> Bool
f (v
v, Term v loc
b) =
        if v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
nonLambdas
          then Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set v -> Bool
forall a. Set a -> Bool
Set.null (Term v loc -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v loc
b Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set v
nonLambdas)
          else Bool
False
   in if [(v, Term v loc)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(v, Term v loc)]
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(v, Term v loc)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(v, Term v loc)]
bindings
        then () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else Cause v loc -> MT v loc (Result v loc) ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) ())
-> Cause v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ [v] -> [(v, Term v loc)] -> Cause v loc
forall v loc. [v] -> [(v, Term v loc)] -> Cause v loc
UnguardedLetRecCycle ((v, Term v loc) -> v
forall a b. (a, b) -> a
fst ((v, Term v loc) -> v) -> [(v, Term v loc)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Term v loc)]
notok) [(v, Term v loc)]
bindings

existentialFunctionTypeFor :: (Ord loc, Var v) => Term v loc -> M v loc (Type v loc)
existentialFunctionTypeFor :: forall loc v.
(Ord loc, Var v) =>
Term v loc -> M v loc (Type v loc)
existentialFunctionTypeFor lam :: Term v loc
lam@(Term.LamNamed' v
v Term v loc
body) = do
  v
v <- v -> M v loc v
forall v loc. Var v => v -> M v loc v
extendExistential v
v
  v
e <- v -> M v loc v
forall v loc. Var v => v -> M v loc v
extendExistential v
forall v. Var v => v
Var.inferAbility
  Type v loc
o <- Term v loc -> M v loc (Type v loc)
forall loc v.
(Ord loc, Var v) =>
Term v loc -> M v loc (Type v loc)
existentialFunctionTypeFor Term v loc
body
  pure $
    loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow
      (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
lam)
      (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
lam) v
v)
      (loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
lam) [loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
lam) v
e] Type v loc
o)
existentialFunctionTypeFor Term v loc
e = do
  v
v <- v -> M v loc v
forall v loc. Var v => v -> M v loc v
extendExistential v
forall v. Var v => v
Var.inferOutput
  pure $ loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Term v loc
e) v
v

existentializeArrows :: (Var v) => Type v loc -> M v loc (Type v loc)
existentializeArrows :: forall v loc. Var v => Type v loc -> M v loc (Type v loc)
existentializeArrows Type v loc
t = do
  let newVar :: M v loc (TypeVar v loc)
newVar = v -> M v loc (TypeVar v loc)
forall v loc. Var v => v -> M v loc (TypeVar v loc)
extendExistentialTV v
forall v. Var v => v
Var.inferAbility
  Type v loc
t <- MT v loc (Result v loc) (TypeVar v loc)
-> Type v loc -> M v loc (Type v loc)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
m v -> Type v a -> m (Type v a)
Type.existentializeArrows MT v loc (Result v loc) (TypeVar v loc)
forall {loc}. M v loc (TypeVar v loc)
newVar Type v loc
t
  pure Type v loc
t

ungeneralize :: (Var v, Ord loc) => Type v loc -> M v loc (Type v loc)
ungeneralize :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
t = ([v], Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd (([v], Type v loc) -> Type v loc)
-> MT v loc (Result v loc) ([v], Type v loc)
-> MT v loc (Result v loc) (Type v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc ([v], Type v loc)
ungeneralize' Type v loc
t

ungeneralize' :: (Var v, Ord loc) => Type v loc -> M v loc ([v], Type v loc)
ungeneralize' :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc ([v], Type v loc)
ungeneralize' (Type.ForallNamed' TypeVar v loc
v Term F (TypeVar v loc) loc
t) = do
  ([v]
vs, Term F (TypeVar v loc) loc
t) <- TypeVar v loc
-> Term F (TypeVar v loc) loc
-> M v loc ([v], Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
TypeVar v loc -> Type v loc -> M v loc ([v], Type v loc)
tweakEffects TypeVar v loc
v Term F (TypeVar v loc) loc
t
  ([v] -> [v])
-> ([v], Term F (TypeVar v loc) loc)
-> ([v], Term F (TypeVar v loc) loc)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([v]
vs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++) (([v], Term F (TypeVar v loc) loc)
 -> ([v], Term F (TypeVar v loc) loc))
-> M v loc ([v], Term F (TypeVar v loc) loc)
-> M v loc ([v], Term F (TypeVar v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term F (TypeVar v loc) loc
-> M v loc ([v], Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc ([v], Type v loc)
ungeneralize' Term F (TypeVar v loc) loc
t
ungeneralize' Term F (TypeVar v loc) loc
t = ([v], Term F (TypeVar v loc) loc)
-> M v loc ([v], Term F (TypeVar v loc) loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Term F (TypeVar v loc) loc
t)

-- Tries to massage types like:
--
--     (a ->{e} b ->{e} c) ->{e} d
--
-- by rewriting them into:
--
--     (a ->{e1} b ->{e2} c) ->{e1,e2} d
--
-- The strategy is to find all negative occurrences of `e` and
-- introduce a new variable for each, and then replace any
-- non-negative occurrences with the row of all negative
-- variables. The reason this is valid is that `e` can be
-- instantiated with the entire row, and then all the negative
-- rows can be pared down to the single variable via subtyping.
--
-- This is meant to occur when a polymorphic type is
-- de-generalized, and replaces simple freshening of the
-- polymorphic variable.
tweakEffects ::
  (Var v) =>
  (Ord loc) =>
  TypeVar v loc ->
  Type v loc ->
  M v loc ([v], Type v loc)
tweakEffects :: forall v loc.
(Var v, Ord loc) =>
TypeVar v loc -> Type v loc -> M v loc ([v], Type v loc)
tweakEffects TypeVar v loc
v0 Type v loc
t0
  | TypeVar v loc -> Type v loc -> Bool
forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar TypeVar v loc
v0 Type v loc
t0 Bool -> Bool -> Bool
&& TypeVar v loc -> Type v loc -> Bool
forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isVariant TypeVar v loc
v0 Type v loc
t0 =
      Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) Type v loc
t0 MT v loc (Result v loc) ([v], Type v loc)
-> (([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc))
-> MT v loc (Result v loc) ([v], Type v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ([], Type v loc
ty) ->
          TypeVar v loc -> M v loc v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
v0 M v loc v
-> (v -> MT v loc (Result v loc) ([v], Type v loc))
-> MT v loc (Result v loc) ([v], Type v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \v
out -> [v] -> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
finish [v
out] Type v loc
ty
        ([v]
vs, Type v loc
ty) -> [v] -> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
finish [v]
vs Type v loc
ty
  | Bool
otherwise =
      TypeVar v loc -> M v loc v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
v0 M v loc v
-> (v -> MT v loc (Result v loc) ([v], Type v loc))
-> MT v loc (Result v loc) ([v], Type v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \v
out -> [v] -> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
finish [v
out] Type v loc
t0
  where
    negative :: Maybe Bool -> Bool
negative = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False

    typ :: [v] -> Type (TypeVar v loc) ()
typ [v
v] = () -> Blank loc -> v -> Type (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank v
v
    typ [v]
vs = () -> [Type (TypeVar v loc) ()] -> Type (TypeVar v loc) ()
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects () ([Type (TypeVar v loc) ()] -> Type (TypeVar v loc) ())
-> [Type (TypeVar v loc) ()] -> Type (TypeVar v loc) ()
forall a b. (a -> b) -> a -> b
$ () -> Blank loc -> v -> Type (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank (v -> Type (TypeVar v loc) ()) -> [v] -> [Type (TypeVar v loc) ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vs

    finish :: [v] -> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
finish [v]
vs Type v loc
ty = do
      [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext (v -> Element v loc
forall v loc. v -> Element v loc
existential (v -> Element v loc) -> [v] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vs)
      pure ([v]
vs, TypeVar v loc
-> Term F (TypeVar v loc) () -> Type v loc -> Type v loc
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
v -> Term f v b -> Term f v a -> Term f v a
ABT.substInheritAnnotation TypeVar v loc
v0 ([v] -> Term F (TypeVar v loc) ()
forall {v} {loc}. Ord v => [v] -> Type (TypeVar v loc) ()
typ [v]
vs) Type v loc
ty)

    rewrite :: Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
ty
      | Type.ForallNamed' TypeVar v loc
v Type v loc
t <- Type v loc
ty,
        TypeVar v loc
v0 TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeVar v loc
v =
          (Type v loc -> Type v loc)
-> ([v], Type v loc) -> ([v], Type v loc)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (loc -> TypeVar v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.forAll loc
a TypeVar v loc
v) (([v], Type v loc) -> ([v], Type v loc))
-> MT v loc (Result v loc) ([v], Type v loc)
-> MT v loc (Result v loc) ([v], Type v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
t
      | Type.Arrow' Type v loc
i Type v loc
o <- Type v loc
ty = do
          ([v]
vis, Type v loc
i) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite (Bool -> Bool
not (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
p) Type v loc
i
          ([v]
vos, Type v loc
o) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
o
          ([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v]
vis [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vos, loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow loc
a Type v loc
i Type v loc
o)
      | Type.Effect1' Type v loc
e Type v loc
t <- Type v loc
ty = do
          ([v]
ves, Type v loc
e) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
e
          ([v]
vts, Type v loc
t) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
t
          ([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v]
ves [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vts, loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.effect1 loc
a Type v loc
e Type v loc
t)
      | Type.Effects' [Type v loc]
es <- Type v loc
ty = do
          [([v], Type v loc)]
ess <- (Type v loc -> MT v loc (Result v loc) ([v], Type v loc))
-> [Type v loc] -> MT v loc (Result v loc) [([v], Type v loc)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p) [Type v loc]
es
          let es :: [Type v loc]
es = ([v], Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd (([v], Type v loc) -> Type v loc)
-> [([v], Type v loc)] -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([v], Type v loc)]
ess; ves :: [v]
ves = ([v], Type v loc) -> [v]
forall a b. (a, b) -> a
fst (([v], Type v loc) -> [v]) -> [([v], Type v loc)] -> [v]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [([v], Type v loc)]
ess
          ([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v]
ves, loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects loc
a [Type v loc]
es)
      | Type.Var' TypeVar v loc
v <- Type v loc
ty,
        TypeVar v loc
v0 TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVar v loc
v Bool -> Bool -> Bool
&& Maybe Bool -> Bool
negative Maybe Bool
p = do
          v
u <- TypeVar v loc -> M v loc v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
v0
          pure ([v
u], loc -> Blank loc -> v -> Type v loc
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ty) Blank loc
forall loc. Blank loc
B.Blank v
u)
      | Type.App' Type v loc
f Type v loc
x <- Type v loc
ty = do
          ([v]
vfs, Type v loc
f) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
p Type v loc
f
          ([v]
vxs, Type v loc
x) <- Maybe Bool
-> Type v loc -> MT v loc (Result v loc) ([v], Type v loc)
rewrite Maybe Bool
forall a. Maybe a
Nothing Type v loc
x
          ([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v]
vfs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vxs, loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ty) Type v loc
f Type v loc
x)
      | Bool
otherwise = ([v], Type v loc) -> MT v loc (Result v loc) ([v], Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Type v loc
ty)
      where
        a :: loc
a = Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
ty

isEffectVar :: (Var v) => TypeVar v loc -> Type v loc -> Bool
isEffectVar :: forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar TypeVar v loc
u (Type.ForallNamed' TypeVar v loc
v Term F (TypeVar v loc) loc
t)
  | TypeVar v loc
u TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVar v loc
v = Bool
False
  | Bool
otherwise = TypeVar v loc -> Term F (TypeVar v loc) loc -> Bool
forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar TypeVar v loc
u Term F (TypeVar v loc) loc
t
isEffectVar TypeVar v loc
u (Type.Arrow'' Term F (TypeVar v loc) loc
i [Term F (TypeVar v loc) loc]
es Term F (TypeVar v loc) loc
o) =
  (Term F (TypeVar v loc) loc -> Bool)
-> [Term F (TypeVar v loc) loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Term F (TypeVar v loc) loc -> Bool
p [Term F (TypeVar v loc) loc]
es Bool -> Bool -> Bool
|| TypeVar v loc -> Term F (TypeVar v loc) loc -> Bool
forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar TypeVar v loc
u Term F (TypeVar v loc) loc
i Bool -> Bool -> Bool
|| TypeVar v loc -> Term F (TypeVar v loc) loc -> Bool
forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar TypeVar v loc
u Term F (TypeVar v loc) loc
o
  where
    p :: Term F (TypeVar v loc) loc -> Bool
p (Type.Var' TypeVar v loc
v) = TypeVar v loc
v TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVar v loc
u
    p Term F (TypeVar v loc) loc
_ = Bool
False
isEffectVar TypeVar v loc
_ Term F (TypeVar v loc) loc
_ = Bool
False

-- Checks that a variable only occurs in variant positions. This may mean that
-- it occurs in both covariant and contravariant positions, so long as it
-- doesn't occur in a single position that is invariant, like the `x` in `F x`.
isVariant :: (Var v) => TypeVar v loc -> Type v loc -> Bool
isVariant :: forall v loc. Var v => TypeVar v loc -> Type v loc -> Bool
isVariant TypeVar v loc
u = Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
True
  where
    walk :: Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var (Type.ForallNamed' TypeVar v loc
v Term F (TypeVar v loc) loc
t)
      | TypeVar v loc
u TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVar v loc
v = Bool
True
      | Bool
otherwise = Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var Term F (TypeVar v loc) loc
t
    walk Bool
var (Type.Arrow'' Term F (TypeVar v loc) loc
i [Term F (TypeVar v loc) loc]
es Term F (TypeVar v loc) loc
o) =
      Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var Term F (TypeVar v loc) loc
i Bool -> Bool -> Bool
&& Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var Term F (TypeVar v loc) loc
o Bool -> Bool -> Bool
&& (Term F (TypeVar v loc) loc -> Bool)
-> [Term F (TypeVar v loc) loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var) [Term F (TypeVar v loc) loc]
es
    walk Bool
var (Type.App' Term F (TypeVar v loc) loc
f Term F (TypeVar v loc) loc
x) = Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
var Term F (TypeVar v loc) loc
f Bool -> Bool -> Bool
&& Bool -> Term F (TypeVar v loc) loc -> Bool
walk Bool
False Term F (TypeVar v loc) loc
x
    walk Bool
var (Type.Var' TypeVar v loc
v) = TypeVar v loc
u TypeVar v loc -> TypeVar v loc -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeVar v loc
v Bool -> Bool -> Bool
|| Bool
var
    walk Bool
_ Term F (TypeVar v loc) loc
_ = Bool
True

skolemize ::
  (Var v) =>
  (Ord loc) =>
  (Type v loc -> Set (TypeVar v loc)) ->
  Type v loc ->
  M v loc (Type v loc)
skolemize :: forall v loc.
(Var v, Ord loc) =>
(Type v loc -> Set (TypeVar v loc))
-> Type v loc -> M v loc (Type v loc)
skolemize Type v loc -> Set (TypeVar v loc)
forced (Type.ForallsNamed' [TypeVar v loc]
vs Type v loc
ty) = do
  [(TypeVar v loc, v)]
urn <- [TypeVar v loc]
-> (TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
-> MT v loc (Result v loc) [(TypeVar v loc, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [TypeVar v loc]
uvs ((TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
 -> MT v loc (Result v loc) [(TypeVar v loc, v)])
-> (TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
-> MT v loc (Result v loc) [(TypeVar v loc, v)]
forall a b. (a -> b) -> a -> b
$ \TypeVar v loc
u -> (,) TypeVar v loc
u (v -> (TypeVar v loc, v))
-> MT v loc (Result v loc) v
-> MT v loc (Result v loc) (TypeVar v loc, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
u
  [(TypeVar v loc, v)]
srn <- [TypeVar v loc]
-> (TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
-> MT v loc (Result v loc) [(TypeVar v loc, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [TypeVar v loc]
svs ((TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
 -> MT v loc (Result v loc) [(TypeVar v loc, v)])
-> (TypeVar v loc -> MT v loc (Result v loc) (TypeVar v loc, v))
-> MT v loc (Result v loc) [(TypeVar v loc, v)]
forall a b. (a -> b) -> a -> b
$ \TypeVar v loc
u -> (,) TypeVar v loc
u (v -> (TypeVar v loc, v))
-> MT v loc (Result v loc) v
-> MT v loc (Result v loc) (TypeVar v loc, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar TypeVar v loc
u
  let uctx :: [Element v loc]
uctx = v -> Element v loc
forall v loc. v -> Element v loc
existential (v -> Element v loc)
-> ((TypeVar v loc, v) -> v) -> (TypeVar v loc, v) -> Element v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeVar v loc, v) -> v
forall a b. (a, b) -> b
snd ((TypeVar v loc, v) -> Element v loc)
-> [(TypeVar v loc, v)] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeVar v loc, v)]
urn
      sctx :: [Element v loc]
sctx = v -> Element v loc
forall v loc. v -> Element v loc
Universal (v -> Element v loc)
-> ((TypeVar v loc, v) -> v) -> (TypeVar v loc, v) -> Element v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeVar v loc, v) -> v
forall a b. (a, b) -> b
snd ((TypeVar v loc, v) -> Element v loc)
-> [(TypeVar v loc, v)] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeVar v loc, v)]
srn
      rn :: [(TypeVar v loc, Type (TypeVar v loc) ())]
rn =
        ((v -> Type (TypeVar v loc) ())
-> (TypeVar v loc, v) -> (TypeVar v loc, Type (TypeVar v loc) ())
forall a b. (a -> b) -> (TypeVar v loc, a) -> (TypeVar v loc, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Blank loc -> v -> Type (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank) ((TypeVar v loc, v) -> (TypeVar v loc, Type (TypeVar v loc) ()))
-> [(TypeVar v loc, v)]
-> [(TypeVar v loc, Type (TypeVar v loc) ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeVar v loc, v)]
urn)
          [(TypeVar v loc, Type (TypeVar v loc) ())]
-> [(TypeVar v loc, Type (TypeVar v loc) ())]
-> [(TypeVar v loc, Type (TypeVar v loc) ())]
forall a. [a] -> [a] -> [a]
++ ((v -> Type (TypeVar v loc) ())
-> (TypeVar v loc, v) -> (TypeVar v loc, Type (TypeVar v loc) ())
forall a b. (a -> b) -> (TypeVar v loc, a) -> (TypeVar v loc, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> v -> Type (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' ()) ((TypeVar v loc, v) -> (TypeVar v loc, Type (TypeVar v loc) ()))
-> [(TypeVar v loc, v)]
-> [(TypeVar v loc, Type (TypeVar v loc) ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeVar v loc, v)]
srn)
  [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext ([Element v loc] -> M v loc ()) -> [Element v loc] -> M v loc ()
forall a b. (a -> b) -> a -> b
$ [Element v loc]
uctx [Element v loc] -> [Element v loc] -> [Element v loc]
forall a. [a] -> [a] -> [a]
++ [Element v loc]
sctx
  pure $ (Type v loc
 -> (TypeVar v loc, Type (TypeVar v loc) ()) -> Type v loc)
-> Type v loc
-> [(TypeVar v loc, Type (TypeVar v loc) ())]
-> Type v loc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((TypeVar v loc, Type (TypeVar v loc) ())
 -> Type v loc -> Type v loc)
-> Type v loc
-> (TypeVar v loc, Type (TypeVar v loc) ())
-> Type v loc
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((TypeVar v loc, Type (TypeVar v loc) ())
  -> Type v loc -> Type v loc)
 -> Type v loc
 -> (TypeVar v loc, Type (TypeVar v loc) ())
 -> Type v loc)
-> ((TypeVar v loc, Type (TypeVar v loc) ())
    -> Type v loc -> Type v loc)
-> Type v loc
-> (TypeVar v loc, Type (TypeVar v loc) ())
-> Type v loc
forall a b. (a -> b) -> a -> b
$ (TypeVar v loc
 -> Type (TypeVar v loc) () -> Type v loc -> Type v loc)
-> (TypeVar v loc, Type (TypeVar v loc) ())
-> Type v loc
-> Type v loc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TypeVar v loc
-> Type (TypeVar v loc) () -> Type v loc -> Type v loc
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
v -> Term f v b -> Term f v a -> Term f v a
ABT.substInheritAnnotation) Type v loc
ty [(TypeVar v loc, Type (TypeVar v loc) ())]
rn
  where
    fovs :: Set (TypeVar v loc)
fovs = Type v loc -> Set (TypeVar v loc)
forced Type v loc
ty
    ([TypeVar v loc]
uvs, [TypeVar v loc]
svs) = (TypeVar v loc -> Bool)
-> [TypeVar v loc] -> ([TypeVar v loc], [TypeVar v loc])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TypeVar v loc -> Set (TypeVar v loc) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (TypeVar v loc)
fovs) [TypeVar v loc]
vs
skolemize Type v loc -> Set (TypeVar v loc)
_ Type v loc
ty = Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type v loc
ty

forcedEffect :: Type v loc -> Set (TypeVar v loc)
forcedEffect :: forall v loc. Type v loc -> Set (TypeVar v loc)
forcedEffect (Type.Arrow' Term F (TypeVar v loc) loc
_ Term F (TypeVar v loc) loc
o) = Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v loc. Type v loc -> Set (TypeVar v loc)
forcedEffect Term F (TypeVar v loc) loc
o
forcedEffect (Type.Effect1' Term F (TypeVar v loc) loc
es Term F (TypeVar v loc) loc
_) = Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar v loc) loc
es
forcedEffect Term F (TypeVar v loc) loc
_ = Set (TypeVar v loc)
forall a. Set a
Set.empty

forcedData :: Type v loc -> Set (TypeVar v loc)
forcedData :: forall v loc. Type v loc -> Set (TypeVar v loc)
forcedData (Type.Arrow' Term F (TypeVar v loc) loc
_ Term F (TypeVar v loc) loc
o) = Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v loc. Type v loc -> Set (TypeVar v loc)
forcedData Term F (TypeVar v loc) loc
o
forcedData Term F (TypeVar v loc) loc
ty = Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar v loc) loc
ty

-- | Apply the context to the input type, then convert any unsolved existentials
-- to universals.
generalizeExistentials :: (Var v, Ord loc) => [Element v loc] -> Type v loc -> Type v loc
generalizeExistentials :: forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
ctx Type v loc
ty0 = (Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
(Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc] -> Type v loc -> Type v loc
generalizeP Element v loc -> Maybe (TypeVar v loc, v)
pred [Element v loc]
ctx Type v loc
ty
  where
    gens :: Set v
gens = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ (Element v loc -> Maybe v) -> [Element v loc] -> [v]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (((TypeVar v loc, v) -> v) -> Maybe (TypeVar v loc, v) -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeVar v loc, v) -> v
forall a b. (a, b) -> b
snd (Maybe (TypeVar v loc, v) -> Maybe v)
-> (Element v loc -> Maybe (TypeVar v loc, v))
-> Element v loc
-> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element v loc -> Maybe (TypeVar v loc, v)
forall v loc. Element v loc -> Maybe (TypeVar v loc, v)
existentialP) [Element v loc]
ctx

    ty :: Type v loc
ty = Set v -> Type v loc -> Type v loc
forall v loc. Var v => Set v -> Type v loc -> Type v loc
discardCovariant Set v
gens (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx Type v loc
ty0
    fvs :: Set (TypeVar v loc)
fvs = Type v loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
ty

    pred :: Element v loc -> Maybe (TypeVar v loc, v)
pred Element v loc
e
      | pe :: Maybe (TypeVar v loc, v)
pe@(Just (TypeVar v loc
tv, v
_)) <- Element v loc -> Maybe (TypeVar v loc, v)
forall v loc. Element v loc -> Maybe (TypeVar v loc, v)
existentialP Element v loc
e,
        TypeVar v loc
tv TypeVar v loc -> Set (TypeVar v loc) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (TypeVar v loc)
fvs =
          Maybe (TypeVar v loc, v)
pe
      | Bool
otherwise = Maybe (TypeVar v loc, v)
forall a. Maybe a
Nothing

generalizeP ::
  (Var v) =>
  (Ord loc) =>
  (Element v loc -> Maybe (TypeVar v loc, v)) ->
  [Element v loc] ->
  Type v loc ->
  Type v loc
generalizeP :: forall v loc.
(Var v, Ord loc) =>
(Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc] -> Type v loc -> Type v loc
generalizeP Element v loc -> Maybe (TypeVar v loc, v)
p [Element v loc]
ctx0 Type v loc
ty = ((TypeVar v loc, v) -> Type v loc -> Type v loc)
-> Type v loc -> [(TypeVar v loc, v)] -> Type v loc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeVar v loc, v) -> Type v loc -> Type v loc
forall {v} {loc} {a}.
Var v =>
(TypeVar (Blank loc) v, v)
-> Term F (TypeVar (Blank loc) v) a
-> Term F (TypeVar (Blank loc) v) a
gen ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx0 Type v loc
ty) [(TypeVar v loc, v)]
ctx
  where
    ctx :: [(TypeVar v loc, v)]
ctx = (Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc] -> [(TypeVar v loc, v)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Element v loc -> Maybe (TypeVar v loc, v)
p [Element v loc]
ctx0

    gen :: (TypeVar (Blank loc) v, v)
-> Term F (TypeVar (Blank loc) v) a
-> Term F (TypeVar (Blank loc) v) a
gen (TypeVar (Blank loc) v
tv, v
v) Term F (TypeVar (Blank loc) v) a
t
      | TypeVar (Blank loc) v
tv TypeVar (Blank loc) v -> Term F (TypeVar (Blank loc) v) a -> Bool
forall v (f :: * -> *) a. Ord v => v -> Term f v a -> Bool
`ABT.isFreeIn` Term F (TypeVar (Blank loc) v) a
t =
          -- location of the forall is just the location of the input type
          -- and the location of each quantified variable is just inherited
          -- from its source location
          a
-> TypeVar (Blank loc) v
-> Term F (TypeVar (Blank loc) v) a
-> Term F (TypeVar (Blank loc) v) a
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.forAll
            (Term F (TypeVar (Blank loc) v) a -> a
forall (f :: * -> *) v a. Term f v a -> a
loc Term F (TypeVar (Blank loc) v) a
t)
            (v -> TypeVar (Blank loc) v
forall b v. v -> TypeVar b v
TypeVar.Universal v
v)
            (TypeVar (Blank loc) v
-> Term F (TypeVar (Blank loc) v) ()
-> Term F (TypeVar (Blank loc) v) a
-> Term F (TypeVar (Blank loc) v) a
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
v -> Term f v b -> Term f v a -> Term f v a
ABT.substInheritAnnotation TypeVar (Blank loc) v
tv (() -> v -> Term F (TypeVar (Blank loc) v) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
v) Term F (TypeVar (Blank loc) v) a
t)
      -- don't bother introducing a forall if type variable is unused
      | Bool
otherwise = Term F (TypeVar (Blank loc) v) a
t

existentialP :: Element v loc -> Maybe (TypeVar v loc, v)
existentialP :: forall v loc. Element v loc -> Maybe (TypeVar v loc, v)
existentialP (Var (TypeVar.Existential Blank loc
_ v
v)) =
  (TypeVar (Blank loc) v, v) -> Maybe (TypeVar (Blank loc) v, v)
forall a. a -> Maybe a
Just (Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v, v
v)
existentialP Element v loc
_ = Maybe (TypeVar (Blank loc) v, v)
forall a. Maybe a
Nothing

variableP :: Element v loc -> Maybe (TypeVar v loc, v)
variableP :: forall v loc. Element v loc -> Maybe (TypeVar v loc, v)
variableP (Var (TypeVar.Existential Blank loc
_ v
v)) =
  (TypeVar (Blank loc) v, v) -> Maybe (TypeVar (Blank loc) v, v)
forall a. a -> Maybe a
Just (Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v, v
v)
variableP (Var tv :: TypeVar (Blank loc) v
tv@(TypeVar.Universal v
v)) = (TypeVar (Blank loc) v, v) -> Maybe (TypeVar (Blank loc) v, v)
forall a. a -> Maybe a
Just (TypeVar (Blank loc) v
tv, v
v)
variableP Element v loc
_ = Maybe (TypeVar (Blank loc) v, v)
forall a. Maybe a
Nothing

-- This checks `e` against the type `t`, but if `t` is a `∀`, any ∀-quantified
-- variables are freshened and substituted into `e`. This should be called whenever
-- a term is being checked against a type due to a user-provided signature on `e`.
-- See its usage in `synthesize` and `annotateLetRecBindings`.
checkScoped ::
  forall v loc.
  (Var v, Ord loc) =>
  Term v loc ->
  Type v loc ->
  M v loc (Type v loc, Wanted v loc)
checkScoped :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc)
checkScoped Term v loc
e (Type.Forall' Subst F (TypeVar v loc) loc
body) = do
  v
v <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
body TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
  ((Term F (TypeVar v loc) loc
ty, Wanted v loc
want), [Element v loc]
pop) <- v
-> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
-> M v
     loc
     ((Term F (TypeVar v loc) loc, Wanted v loc), [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract v
v (M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
 -> M v
      loc
      ((Term F (TypeVar v loc) loc, Wanted v loc), [Element v loc]))
-> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
-> M v
     loc
     ((Term F (TypeVar v loc) loc, Wanted v loc), [Element v loc])
forall a b. (a -> b) -> a -> b
$ do
    v
x <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendUniversal v
v
    let e' :: Term v loc
e' = TypeVar v loc
-> Type (TypeVar v loc) () -> Term v loc -> Term v loc
forall v vt b a.
(Ord v, Var vt) =>
vt -> Type vt b -> Term' vt v a -> Term' vt v a
Term.substTypeVar (Subst F (TypeVar v loc) loc -> TypeVar v loc
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst F (TypeVar v loc) loc
body) (() -> v -> Type (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
x) Term v loc
e
    Term v loc
-> Term F (TypeVar v loc) loc
-> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc)
checkScoped Term v loc
e' (Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Term F (TypeVar v loc) loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
body (() -> v -> Type (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
x))
  Wanted v loc
want <- Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
substAndDefaultWanted Wanted v loc
want [Element v loc]
pop
  pure ((Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc]
-> Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc
forall v loc.
(Var v, Ord loc) =>
(Element v loc -> Maybe (TypeVar v loc, v))
-> [Element v loc] -> Type v loc -> Type v loc
generalizeP Element v loc -> Maybe (TypeVar v loc, v)
forall v loc. Element v loc -> Maybe (TypeVar v loc, v)
variableP [Element v loc]
pop Term F (TypeVar v loc) loc
ty, Wanted v loc
want)
checkScoped Term v loc
e Term F (TypeVar v loc) loc
t = do
  Term F (TypeVar v loc) loc
t <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc. Var v => Type v loc -> M v loc (Type v loc)
existentializeArrows Term F (TypeVar v loc) loc
t
  (Term F (TypeVar v loc) loc
t,) (Wanted v loc -> (Term F (TypeVar v loc) loc, Wanted v loc))
-> M v loc (Wanted v loc)
-> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v loc -> Term F (TypeVar v loc) loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Wanted v loc)
check Term v loc
e Term F (TypeVar v loc) loc
t

checkScopedWith ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  Type v loc ->
  [Type v loc] ->
  M v loc ()
checkScopedWith :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> [Type v loc] -> M v loc ()
checkScopedWith Term v loc
tm Type v loc
ty [Type v loc]
ab = do
  (Type v loc
_, Wanted v loc
want) <- Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Type v loc, Wanted v loc)
checkScoped Term v loc
tm Type v loc
ty
  Wanted v loc -> [Type v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc ()
subAbilities Wanted v loc
want [Type v loc]
ab

markThenRetractWanted ::
  (Var v) =>
  (Ord loc) =>
  v ->
  M v loc (Wanted v loc) ->
  M v loc (Wanted v loc)
markThenRetractWanted :: forall v loc.
(Var v, Ord loc) =>
v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
markThenRetractWanted v
v M v loc (Wanted v loc)
m =
  v
-> M v loc (Wanted v loc)
-> M v loc (Wanted v loc, [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract v
v M v loc (Wanted v loc)
m M v loc (Wanted v loc, [Element v loc])
-> ((Wanted v loc, [Element v loc]) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc))
-> (Wanted v loc, [Element v loc]) -> M v loc (Wanted v loc)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
substAndDefaultWanted

-- This function handles merging two sets of wanted abilities, along
-- with some pruning of the set. This means that coalescing a list
-- with the empty list may result in a distinct list, but coalescing
-- again afterwards should not further change things.
--
-- With respect to the above, it is presumed that the second argument
-- (`old`) has already been coalesced in this manner. So only the
-- contents of `new` may be reduced, and coalescing with the empty
-- list as `new` will just yield the `old` list.
--
-- There are two main operations performed while merging. First, an
-- ability (currently) may only occur once in a row, so if it occurs
-- twice in a list, those two occurrences are unified. Second, some
-- references to ability polymorphic functions can lead to arbitrary
-- variables being 'wanted'. However, if these variables do not occur
-- in the context, and we are thus not trying to infer them, it is
-- pointless to add them to the wanted abilities, just making types
-- more complicated, and inference harder. So in that scenario, we
-- default the variable to {} and omit it.
coalesceWanted' ::
  (Var v) =>
  (Ord loc) =>
  (TypeVar v loc -> Bool) ->
  Wanted v loc ->
  Wanted v loc ->
  M v loc (Wanted v loc)
coalesceWanted' :: forall v loc.
(Var v, Ord loc) =>
(TypeVar v loc -> Bool)
-> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted' TypeVar v loc -> Bool
_ [] [(Maybe (Term v loc), Type v loc)]
old = [(Maybe (Term v loc), Type v loc)]
-> MT v loc (Result v loc) [(Maybe (Term v loc), Type v loc)]
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Maybe (Term v loc), Type v loc)]
old
coalesceWanted' TypeVar v loc -> Bool
keep ((Maybe (Term v loc)
loc, Type v loc
n) : [(Maybe (Term v loc), Type v loc)]
new) [(Maybe (Term v loc), Type v loc)]
old
  | Just (Maybe (Term v loc)
_, Type v loc
o) <- ((Maybe (Term v loc), Type v loc) -> Bool)
-> [(Maybe (Term v loc), Type v loc)]
-> Maybe (Maybe (Term v loc), Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
n (Type v loc -> Bool)
-> ((Maybe (Term v loc), Type v loc) -> Type v loc)
-> (Maybe (Term v loc), Type v loc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Term v loc), Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd) [(Maybe (Term v loc), Type v loc)]
old = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
n Type v loc
o
      [(Maybe (Term v loc), Type v loc)]
-> [(Maybe (Term v loc), Type v loc)]
-> MT v loc (Result v loc) [(Maybe (Term v loc), Type v loc)]
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted [(Maybe (Term v loc), Type v loc)]
new [(Maybe (Term v loc), Type v loc)]
old
  | Type.Var' TypeVar v loc
u <- Type v loc
n = do
      ([(Maybe (Term v loc), Type v loc)]
new, [(Maybe (Term v loc), Type v loc)]
old) <-
        -- Only add existential variables to the wanted list if they
        -- occur in a type we're trying to infer in the context. If
        -- they don't, they were added as instantiations of polymorphic
        -- types that might as well just be instantiated to {}.
        if TypeVar v loc -> Bool
keep TypeVar v loc
u
          then ([(Maybe (Term v loc), Type v loc)],
 [(Maybe (Term v loc), Type v loc)])
-> MT
     v
     loc
     (Result v loc)
     ([(Maybe (Term v loc), Type v loc)],
      [(Maybe (Term v loc), Type v loc)])
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Maybe (Term v loc), Type v loc)]
new, (Maybe (Term v loc)
loc, Type v loc
n) (Maybe (Term v loc), Type v loc)
-> [(Maybe (Term v loc), Type v loc)]
-> [(Maybe (Term v loc), Type v loc)]
forall a. a -> [a] -> [a]
: [(Maybe (Term v loc), Type v loc)]
old)
          else do
            Bool
_ <- Type v loc -> M v loc Bool
forall v loc. (Var v, Ord loc) => Type v loc -> M v loc Bool
defaultAbility Type v loc
n
            pure ([(Maybe (Term v loc), Type v loc)]
new, [(Maybe (Term v loc), Type v loc)]
old)
      [(Maybe (Term v loc), Type v loc)]
-> [(Maybe (Term v loc), Type v loc)]
-> MT v loc (Result v loc) [(Maybe (Term v loc), Type v loc)]
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted [(Maybe (Term v loc), Type v loc)]
new [(Maybe (Term v loc), Type v loc)]
old
  | Bool
otherwise = (TypeVar v loc -> Bool)
-> [(Maybe (Term v loc), Type v loc)]
-> [(Maybe (Term v loc), Type v loc)]
-> MT v loc (Result v loc) [(Maybe (Term v loc), Type v loc)]
forall v loc.
(Var v, Ord loc) =>
(TypeVar v loc -> Bool)
-> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted' TypeVar v loc -> Bool
keep [(Maybe (Term v loc), Type v loc)]
new ((Maybe (Term v loc)
loc, Type v loc
n) (Maybe (Term v loc), Type v loc)
-> [(Maybe (Term v loc), Type v loc)]
-> [(Maybe (Term v loc), Type v loc)]
forall a. a -> [a] -> [a]
: [(Maybe (Term v loc), Type v loc)]
old)

-- Wrapper for coalesceWanted' that ensures both lists are fully
-- expanded and calculates some necessary information for the main
-- procedure.
coalesceWanted ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  Wanted v loc ->
  M v loc (Wanted v loc)
coalesceWanted :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
new Wanted v loc
old = do
  Wanted v loc
new <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
new
  Wanted v loc
old <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
old
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  let invars :: Term F v a -> Set v
invars (Type.Var' v
_) = Set v
forall a. Monoid a => a
mempty
      invars Term F v a
t = Term F v a -> Set v
forall v a. Type v a -> Set v
Type.freeVars Term F v a
t
      ivs :: Set (TypeVar v loc)
ivs = (((Maybe (Term v loc), Term F (TypeVar v loc) loc)
 -> Set (TypeVar v loc))
-> Wanted v loc -> Set (TypeVar v loc)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Maybe (Term v loc), Term F (TypeVar v loc) loc)
  -> Set (TypeVar v loc))
 -> Wanted v loc -> Set (TypeVar v loc))
-> ((Term F (TypeVar v loc) loc -> Set (TypeVar v loc))
    -> (Maybe (Term v loc), Term F (TypeVar v loc) loc)
    -> Set (TypeVar v loc))
-> (Term F (TypeVar v loc) loc -> Set (TypeVar v loc))
-> Wanted v loc
-> Set (TypeVar v loc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term F (TypeVar v loc) loc -> Set (TypeVar v loc))
-> (Maybe (Term v loc), Term F (TypeVar v loc) loc)
-> Set (TypeVar v loc)
forall m a. Monoid m => (a -> m) -> (Maybe (Term v loc), a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall {v} {a}. Ord v => Term F v a -> Set v
invars (Wanted v loc
new Wanted v loc -> Wanted v loc -> Wanted v loc
forall a. [a] -> [a] -> [a]
++ Wanted v loc
old)
      keep :: TypeVar v loc -> Bool
keep v :: TypeVar v loc
v@TypeVar.Existential {} = TypeVar v loc -> Set (TypeVar v loc) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TypeVar v loc
v Set (TypeVar v loc)
ivs Bool -> Bool -> Bool
|| TypeVar v loc -> Context v loc -> Bool
forall v loc.
(Var v, Ord loc) =>
TypeVar v loc -> Context v loc -> Bool
occursAnn TypeVar v loc
v Context v loc
ctx
      keep TypeVar v loc
_ = Bool
True
  (TypeVar v loc -> Bool)
-> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
(TypeVar v loc -> Bool)
-> Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted' TypeVar v loc -> Bool
keep Wanted v loc
new Wanted v loc
old

coalesceWanteds ::
  (Var v) => (Ord loc) => [Wanted v loc] -> M v loc (Wanted v loc)
coalesceWanteds :: forall v loc.
(Var v, Ord loc) =>
[Wanted v loc] -> M v loc (Wanted v loc)
coalesceWanteds = (Wanted v loc
 -> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc))
-> Wanted v loc
-> [Wanted v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Wanted v loc
 -> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc))
-> Wanted v loc
-> Wanted v loc
-> MT v loc (Result v loc) (Wanted v loc)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted) []

-- | This implements the subtraction of handled effects from the
-- wanted effects of its body. Similar to merging, it presumes that
-- only one occurrence of each concrete ability is in play in the
-- scope, and will impose subtyping relations between the wanted and
-- handled abilities.
pruneWanted ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  Wanted v loc ->
  [Type v loc] ->
  M v loc (Wanted v loc)
pruneWanted :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc
-> Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneWanted Wanted v loc
acc [] [Type v loc]
_ = Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wanted v loc
acc
pruneWanted Wanted v loc
acc ((Maybe (Term v loc)
loc, Type v loc
w) : Wanted v loc
want) [Type v loc]
handled
  | Just Type v loc
h <- (Type v loc -> Bool) -> [Type v loc] -> Maybe (Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
w) [Type v loc]
handled = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
w Type v loc
h
      Wanted v loc
want <- Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
want
      [Type v loc]
handled <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
handled
      Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc
-> Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneWanted Wanted v loc
acc Wanted v loc
want [Type v loc]
handled
  | Bool
otherwise = Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc
-> Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneWanted ((Maybe (Term v loc)
loc, Type v loc
w) (Maybe (Term v loc), Type v loc) -> Wanted v loc -> Wanted v loc
forall a. a -> [a] -> [a]
: Wanted v loc
acc) Wanted v loc
want [Type v loc]
handled

-- | Processes wanted effects with respect to a portion of context
-- that is being discarded. This has the following consequences:
--   - All solved variables are substituted into the wanted abilities
--   - Effects that would involve escaping universal variables cause
--     an error, because they cannot possibly be satisfied.
--   - Unsolved existential abilities are defaulted to the empty row
--   - Abilities containing unsolved existentials that are going out
--     of scope cause an error, because it is unclear what they ought
--     to be solved to.
substAndDefaultWanted ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  [Element v loc] ->
  M v loc (Wanted v loc)
substAndDefaultWanted :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Element v loc] -> M v loc (Wanted v loc)
substAndDefaultWanted Wanted v loc
want [Element v loc]
ctx
  | Wanted v loc
want <- (((Maybe (Term v loc), Type v loc)
 -> (Maybe (Term v loc), Type v loc))
-> Wanted v loc -> Wanted v loc
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe (Term v loc), Type v loc)
  -> (Maybe (Term v loc), Type v loc))
 -> Wanted v loc -> Wanted v loc)
-> ((Type v loc -> Type v loc)
    -> (Maybe (Term v loc), Type v loc)
    -> (Maybe (Term v loc), Type v loc))
-> (Type v loc -> Type v loc)
-> Wanted v loc
-> Wanted v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type v loc -> Type v loc)
-> (Maybe (Term v loc), Type v loc)
-> (Maybe (Term v loc), Type v loc)
forall a b.
(a -> b) -> (Maybe (Term v loc), a) -> (Maybe (Term v loc), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
applyCtx [Element v loc]
ctx) Wanted v loc
want,
    Wanted v loc
want <- ((Maybe (Term v loc), Type v loc) -> Bool)
-> Wanted v loc -> Wanted v loc
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Term v loc), Type v loc) -> Bool
q Wanted v loc
want,
    [Element v loc]
repush <- (Element v loc -> Bool) -> [Element v loc] -> [Element v loc]
forall a. (a -> Bool) -> [a] -> [a]
filter Element v loc -> Bool
keep [Element v loc]
ctx =
      [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [Element v loc]
repush M v loc ()
-> MT v loc (Result v loc) (Wanted v loc)
-> MT v loc (Result v loc) (Wanted v loc)
forall a b.
MT v loc (Result v loc) a
-> MT v loc (Result v loc) b -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
want []
  where
    isExistential :: TypeVar b v -> Bool
isExistential TypeVar.Existential {} = Bool
True
    isExistential TypeVar b v
_ = Bool
False

    -- get the free variables of things that aren't just variables
    necessary :: Term F (TypeVar b v) a -> Set (TypeVar b v)
necessary (Type.Var' TypeVar b v
_) = Set (TypeVar b v)
forall a. Monoid a => a
mempty
    necessary Term F (TypeVar b v) a
t = (TypeVar b v -> Bool) -> Set (TypeVar b v) -> Set (TypeVar b v)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter TypeVar b v -> Bool
forall {b} {v}. TypeVar b v -> Bool
isExistential (Set (TypeVar b v) -> Set (TypeVar b v))
-> Set (TypeVar b v) -> Set (TypeVar b v)
forall a b. (a -> b) -> a -> b
$ Term F (TypeVar b v) a -> Set (TypeVar b v)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar b v) a
t

    keeps :: Set (TypeVar (Blank loc) v)
keeps = ((Maybe (Term v loc), Type v loc) -> Set (TypeVar (Blank loc) v))
-> Wanted v loc -> Set (TypeVar (Blank loc) v)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Type v loc -> Set (TypeVar (Blank loc) v)
forall {v} {b} {a}.
Ord v =>
Term F (TypeVar b v) a -> Set (TypeVar b v)
necessary (Type v loc -> Set (TypeVar (Blank loc) v))
-> ((Maybe (Term v loc), Type v loc) -> Type v loc)
-> (Maybe (Term v loc), Type v loc)
-> Set (TypeVar (Blank loc) v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Term v loc), Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd) Wanted v loc
want
    keep :: Element v loc -> Bool
keep (Var TypeVar (Blank loc) v
v) = TypeVar (Blank loc) v
v TypeVar (Blank loc) v -> Set (TypeVar (Blank loc) v) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (TypeVar (Blank loc) v)
keeps
    keep Element v loc
_ = Bool
False

    p :: Element v loc -> Maybe (TypeVar v loc)
p (Var TypeVar v loc
v) | TypeVar v loc -> Bool
forall {b} {v}. TypeVar b v -> Bool
isExistential TypeVar v loc
v = TypeVar v loc -> Maybe (TypeVar v loc)
forall a. a -> Maybe a
Just TypeVar v loc
v
    p Element v loc
_ = Maybe (TypeVar v loc)
forall a. Maybe a
Nothing

    outScope :: Set (TypeVar (Blank loc) v)
outScope = [TypeVar (Blank loc) v] -> Set (TypeVar (Blank loc) v)
forall a. Ord a => [a] -> Set a
Set.fromList ([TypeVar (Blank loc) v] -> Set (TypeVar (Blank loc) v))
-> [TypeVar (Blank loc) v] -> Set (TypeVar (Blank loc) v)
forall a b. (a -> b) -> a -> b
$ (Element v loc -> Maybe (TypeVar (Blank loc) v))
-> [Element v loc] -> [TypeVar (Blank loc) v]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Element v loc -> Maybe (TypeVar (Blank loc) v)
forall {v} {loc}. Element v loc -> Maybe (TypeVar v loc)
p [Element v loc]
ctx

    q :: (Maybe (Term v loc), Type v loc) -> Bool
q (Maybe (Term v loc)
_, Type.Var' TypeVar (Blank loc) v
u) = TypeVar (Blank loc) v
u TypeVar (Blank loc) v -> Set (TypeVar (Blank loc) v) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (TypeVar (Blank loc) v)
outScope
    q (Maybe (Term v loc), Type v loc)
_ = Bool
True

-- Defaults unsolved ability variables to the empty row
defaultAbility :: (Var v) => (Ord loc) => Type v loc -> M v loc Bool
defaultAbility :: forall v loc. (Var v, Ord loc) => Type v loc -> M v loc Bool
defaultAbility e :: Type v loc
e@(Type.Var' (TypeVar.Existential Blank loc
b v
v)) =
  (Bool
True Bool -> MT v loc (Result v loc) () -> MT v loc (Result v loc) Bool
forall a b.
a -> MT v loc (Result v loc) b -> MT v loc (Result v loc) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Blank loc -> v -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v Type v loc
eff0) MT v loc (Result v loc) Bool
-> MT v loc (Result v loc) Bool -> MT v loc (Result v loc) Bool
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` Bool -> MT v loc (Result v loc) Bool
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  where
    eff0 :: Type v loc
eff0 = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
e) []
defaultAbility Type v loc
_ = Bool -> MT v loc (Result v loc) Bool
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- Discards existential ability variables that only occur in covariant
-- position in the type. This is a useful step before generalization,
-- because it eliminates unnecessary variable parameterization.
--
-- Expects a fully substituted type, so that it is unnecessary to
-- check if an existential in the type has been solved.
discardCovariant :: (Var v) => Set v -> Type v loc -> Type v loc
discardCovariant :: forall v loc. Var v => Set v -> Type v loc -> Type v loc
discardCovariant Set v
_ Type v loc
ty | [Char] -> Type v loc -> Bool
forall v a. Var v => [Char] -> Type v a -> Bool
debugType [Char]
"discardCovariant" Type v loc
ty = Type v loc
forall a. HasCallStack => a
undefined
discardCovariant Set v
gens Type v loc
ty =
  (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Term f v a) -> Term f v a -> Term f v a
ABT.rewriteDown (Set v -> Type v loc -> Type v loc
forall {a} {b} {a}.
Ord a =>
Set a -> Term F (TypeVar b a) a -> Term F (TypeVar b a) a
strip (Set v -> Type v loc -> Type v loc)
-> Set v -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ Bool -> Type v loc -> Set v
keepVarsT Bool
True Type v loc
ty) Type v loc
ty
  where
    keepVarsT :: Bool -> Type v loc -> Set v
keepVarsT Bool
pos (Type.Arrow' Type v loc
i Type v loc
o) =
      Bool -> Type v loc -> Set v
keepVarsT (Bool -> Bool
not Bool
pos) Type v loc
i Set v -> Set v -> Set v
forall a. Semigroup a => a -> a -> a
<> Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
o
    keepVarsT Bool
pos (Type.Effect1' Type v loc
e Type v loc
o) =
      Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
e Set v -> Set v -> Set v
forall a. Semigroup a => a -> a -> a
<> Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
o
    keepVarsT Bool
pos (Type.Effects' [Type v loc]
es) = (Type v loc -> Set v) -> [Type v loc] -> Set v
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> Type v loc -> Set v
keepVarsE Bool
pos) [Type v loc]
es
    keepVarsT Bool
pos (Type.ForallNamed' TypeVar v loc
_ Type v loc
t) = Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
t
    keepVarsT Bool
pos (Type.IntroOuterNamed' TypeVar v loc
_ Type v loc
t) = Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
t
    keepVarsT Bool
_ Type v loc
t = (TypeVar v loc -> Set v) -> Set (TypeVar v loc) -> Set v
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeVar v loc -> Set v
forall {a} {b}. Ord a => TypeVar b a -> Set a
exi (Set (TypeVar v loc) -> Set v) -> Set (TypeVar v loc) -> Set v
forall a b. (a -> b) -> a -> b
$ Type v loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
t

    exi :: TypeVar b a -> Set a
exi (TypeVar.Existential b
_ a
v) = a -> Set a
forall a. a -> Set a
Set.singleton a
v
    exi TypeVar b a
_ = Set a
forall a. Monoid a => a
mempty

    keepVarsE :: Bool -> Type v loc -> Set v
keepVarsE Bool
pos (Type.Var' (TypeVar.Existential Blank loc
_ v
v))
      | Bool
pos, v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
gens = Set v
forall a. Monoid a => a
mempty
      | Bool
otherwise = v -> Set v
forall a. a -> Set a
Set.singleton v
v
    keepVarsE Bool
pos Type v loc
e = Bool -> Type v loc -> Set v
keepVarsT Bool
pos Type v loc
e

    strip :: Set a -> Term F (TypeVar b a) a -> Term F (TypeVar b a) a
strip Set a
keep t :: Term F (TypeVar b a) a
t@(Type.Effect1' Term F (TypeVar b a) a
es0 Term F (TypeVar b a) a
o) =
      a
-> [Term F (TypeVar b a) a]
-> Term F (TypeVar b a) a
-> Term F (TypeVar b a) a
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect (Term F (TypeVar b a) a -> a
forall (f :: * -> *) v a. Term f v a -> a
loc Term F (TypeVar b a) a
t) (Set a -> [Term F (TypeVar b a) a] -> [Term F (TypeVar b a) a]
forall {a} {f :: * -> *} {b} {a}.
Ord a =>
Set a -> [Term f (TypeVar b a) a] -> [Term f (TypeVar b a) a]
discard Set a
keep ([Term F (TypeVar b a) a] -> [Term F (TypeVar b a) a])
-> [Term F (TypeVar b a) a] -> [Term F (TypeVar b a) a]
forall a b. (a -> b) -> a -> b
$ Term F (TypeVar b a) a -> [Term F (TypeVar b a) a]
forall v a. Type v a -> [Type v a]
Type.flattenEffects Term F (TypeVar b a) a
es0) Term F (TypeVar b a) a
o
    strip Set a
_ Term F (TypeVar b a) a
t = Term F (TypeVar b a) a
t

    discard :: Set a -> [Term f (TypeVar b a) a] -> [Term f (TypeVar b a) a]
discard Set a
keep [Term f (TypeVar b a) a]
es = (Term f (TypeVar b a) a -> Bool)
-> [Term f (TypeVar b a) a] -> [Term f (TypeVar b a) a]
forall a. (a -> Bool) -> [a] -> [a]
filter Term f (TypeVar b a) a -> Bool
p [Term f (TypeVar b a) a]
es
      where
        p :: Term f (TypeVar b a) a -> Bool
p (Type.Var' (TypeVar.Existential b
_ a
v)) = a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
keep
        p Term f (TypeVar b a) a
_ = Bool
True

-- Ability inference prefers minimal sets of abilities when
-- possible. However, such inference may disqualify certain TDNR
-- candicates due to a subtyping check with an overly minimal type.
-- It may be that the candidate's type would work fine, because the
-- inference was overly conservative about guessing which abilities
-- are in play.
--
-- `relax` adds an existential variable to the final inferred
-- abilities for such a function type if there isn't already one,
-- changing:
--
--   T ->{..} U ->{..} V
--
-- into:
--
--   T ->{..} U ->{e, ..} V
--
-- (where the `..` are presumed to be concrete) so that it can
-- behave better in the check.
--
-- It's possible this would allow an ability set that doesn't work,
-- but this is only used for type directed name resolution. A
-- separate type check must pass if the candidate is allowed, which
-- will ensure that the location has the right abilities.
relax :: (Var v) => (Ord loc) => Type v loc -> Type v loc
relax :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc
relax Type v loc
t = Bool -> v -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
True v
v Type v loc
t
  where
    fvs :: Set v
fvs = (TypeVar (Blank loc) v -> Set v)
-> Set (TypeVar (Blank loc) v) -> Set v
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeVar (Blank loc) v -> Set v
forall {a} {b}. Ord a => TypeVar b a -> Set a
f (Set (TypeVar (Blank loc) v) -> Set v)
-> Set (TypeVar (Blank loc) v) -> Set v
forall a b. (a -> b) -> a -> b
$ Type v loc -> Set (TypeVar (Blank loc) v)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
t
    f :: TypeVar b a -> Set a
f (TypeVar.Existential b
_ a
v) = a -> Set a
forall a. a -> Set a
Set.singleton a
v
    f TypeVar b a
_ = Set a
forall a. Monoid a => a
mempty
    v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
ABT.freshIn Set v
fvs (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ v
forall v. Var v => v
Var.inferAbility

-- The worker for `relax`.
--
-- The boolean argument controls whether a non-arrow type is relaxed.
-- For example, the type:
--
--   Nat
--
-- is relaxed to:
--
--   {e} Nat
--
-- if True. This is desirable when doing TDNR, because a potential
-- effect reference may have type `{A} T` while the inferred necessary
-- type is just `T`. However, it is undesirable to add these variables
-- when relax' is used during variable instantiation, because it just
-- adds ability inference ambiguity.
relax' :: (Var v) => (Ord loc) => Bool -> v -> Type v loc -> Type v loc
relax' :: forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
nonArrow v
v Type v loc
t
  | Type.Arrow' Type v loc
i Type v loc
o <- Type v loc
t =
      loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Type v loc
t) Type v loc
i (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ Bool -> v -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
nonArrow v
v Type v loc
o
  | Type.ForallsNamed' [TypeVar (Blank loc) v]
vs Type v loc
b <- Type v loc
t =
      loc -> [TypeVar (Blank loc) v] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [v] -> Type v a -> Type v a
Type.foralls loc
loc [TypeVar (Blank loc) v]
vs (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ Bool -> v -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
nonArrow v
v Type v loc
b
  | Type.Effect' [Type v loc]
es Type v loc
r <- Type v loc
t,
    Type.Arrow' Type v loc
i Type v loc
o <- Type v loc
r =
      loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect loc
loc [Type v loc]
es (Type v loc -> Type v loc)
-> (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Type v loc
t) Type v loc
i (Type v loc -> Type v loc) -> Type v loc -> Type v loc
forall a b. (a -> b) -> a -> b
$ Bool -> v -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
nonArrow v
v Type v loc
o
  | Type.Effect' [Type v loc]
es Type v loc
r <- Type v loc
t =
      if (Type v loc -> Bool) -> [Type v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type v loc -> Bool
forall {f :: * -> *} {b} {v} {a}. Term f (TypeVar b v) a -> Bool
open [Type v loc]
es then Type v loc
t else loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect loc
loc (Type v loc
tv Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
es) Type v loc
r
  | Bool
nonArrow = loc -> [Type v loc] -> Type v loc -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect loc
loc [Type v loc
tv] Type v loc
t
  | Bool
otherwise = Type v loc
t
  where
    open :: Term f (TypeVar b v) a -> Bool
open (Type.Var' (TypeVar.Existential {})) = Bool
True
    open Term f (TypeVar b v) a
_ = Bool
False
    loc :: loc
loc = Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Type v loc
t
    tv :: Type v loc
tv = loc -> TypeVar (Blank loc) v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
Type.var loc
loc (Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
forall loc. Blank loc
B.Blank v
v)

checkWantedScoped ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  Term v loc ->
  Type v loc ->
  M v loc (Wanted v loc)
checkWantedScoped :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWantedScoped Wanted v loc
want Term v loc
m Type v loc
ty =
  PathElement v loc
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Term v loc -> Type v loc -> PathElement v loc
forall v loc. Term v loc -> Type v loc -> PathElement v loc
InCheck Term v loc
m Type v loc
ty) (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want Term v loc
m Type v loc
ty

checkWanted ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  Term v loc ->
  Type v loc ->
  M v loc (Wanted v loc)
-- ForallI
checkWanted :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want Term v loc
m (Type.Forall' Subst F (TypeVar v loc) loc
body) = do
  v
v <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
body TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
  v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
markThenRetractWanted v
v (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    v
x <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendUniversal v
v
    Wanted v loc
-> Term v loc
-> Term F (TypeVar v loc) loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want Term v loc
m (Term F (TypeVar v loc) loc -> M v loc (Wanted v loc))
-> Term F (TypeVar v loc) loc -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$
      Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Term F (TypeVar v loc) loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
body (() -> v -> Term F (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
x)
-- =>I
-- Lambdas are pure, so they add nothing to the wanted set
checkWanted Wanted v loc
want (Term.Lam' Subst (F (TypeVar v loc) loc loc) v loc
body) (Type.Arrow'' Term F (TypeVar v loc) loc
i [Term F (TypeVar v loc) loc]
es Term F (TypeVar v loc) loc
o) = do
  v
x <- Subst (F (TypeVar v loc) loc loc) v loc
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst (F (TypeVar v loc) loc loc) v loc
body v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar
  v -> M v loc () -> M v loc ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
x (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
    Element v loc -> M v loc ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext (v -> Term F (TypeVar v loc) loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
x Term F (TypeVar v loc) loc
i)
    Term v loc
body <- Term v loc -> MT v loc (Result v loc) (Term v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v loc -> MT v loc (Result v loc) (Term v loc))
-> Term v loc -> MT v loc (Result v loc) (Term v loc)
forall a b. (a -> b) -> a -> b
$ Subst (F (TypeVar v loc) loc loc) v loc
-> forall b. Term (F (TypeVar v loc) loc loc) v b -> Term v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst (F (TypeVar v loc) loc loc) v loc
body (() -> v -> Term (F (TypeVar v loc) loc loc) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var () v
x)
    [Term F (TypeVar v loc) loc]
-> Term v loc -> Term F (TypeVar v loc) loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> Type v loc -> M v loc ()
checkWithAbilities [Term F (TypeVar v loc) loc]
es Term v loc
body Term F (TypeVar v loc) loc
o
  pure Wanted v loc
want
checkWanted Wanted v loc
want (Term.Let1Top' Bool
top Term v loc
binding Subst (F (TypeVar v loc) loc loc) v loc
m) Term F (TypeVar v loc) loc
t = do
  (Term F (TypeVar v loc) loc
tbinding, Wanted v loc
wbinding) <- Bool
-> Term v loc -> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Bool -> Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesizeBinding Bool
top Term v loc
binding
  Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
wbinding Wanted v loc
want
  v
v <- Subst (F (TypeVar v loc) loc loc) v loc
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst (F (TypeVar v loc) loc loc) v loc
m v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar
  v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
markThenRetractWanted v
v (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> M v loc () -> M v loc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (v -> Bool
forall v. Var v => v -> Bool
Var.isAction (Subst (F (TypeVar v loc) loc loc) v loc -> v
forall (f :: * -> *) v a. Subst f v a -> v
ABT.variable Subst (F (TypeVar v loc) loc loc) v loc
m)) (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$
      -- enforce that actions in a block have type ()
      Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Term F (TypeVar v loc) loc
tbinding (loc -> Term F (TypeVar v loc) loc
forall v a. Ord v => a -> Type v a
DDB.unitType (Term v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v loc
binding))
    Element v loc -> M v loc ()
forall v loc. Var v => Element v loc -> M v loc ()
extendContext (v -> Term F (TypeVar v loc) loc -> Element v loc
forall v loc. v -> Type v loc -> Element v loc
Ann v
v Term F (TypeVar v loc) loc
tbinding)
    Wanted v loc
-> Term v loc
-> Term F (TypeVar v loc) loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want (Subst (F (TypeVar v loc) loc loc) v loc
-> forall b. Term (F (TypeVar v loc) loc loc) v b -> Term v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst (F (TypeVar v loc) loc loc) v loc
m (() -> v -> Term (F (TypeVar v loc) loc loc) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var () v
v)) Term F (TypeVar v loc) loc
t
checkWanted Wanted v loc
want (Term.LetRecNamed' [] Term v loc
m) Term F (TypeVar v loc) loc
t =
  Wanted v loc
-> Term v loc
-> Term F (TypeVar v loc) loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want Term v loc
m Term F (TypeVar v loc) loc
t
-- letrec can't have effects, so it doesn't extend the wanted set
checkWanted Wanted v loc
want (Term.LetRecTop' Bool
isTop (v -> MT v loc (Result v loc) v)
-> MT v loc (Result v loc) ([(v, Term v loc)], Term v loc)
lr) Term F (TypeVar v loc) loc
t =
  v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
v -> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
markThenRetractWanted (Text -> v
forall v. Var v => Text -> v
Var.named Text
"let-rec-marker") (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
    Term v loc
e <- Bool
-> ((v -> MT v loc (Result v loc) v)
    -> MT v loc (Result v loc) ([(v, Term v loc)], Term v loc))
-> MT v loc (Result v loc) (Term v loc)
forall v loc.
(Var v, Ord loc) =>
Bool
-> ((v -> M v loc v) -> M v loc ([(v, Term v loc)], Term v loc))
-> M v loc (Term v loc)
annotateLetRecBindings Bool
isTop (v -> MT v loc (Result v loc) v)
-> MT v loc (Result v loc) ([(v, Term v loc)], Term v loc)
lr
    Wanted v loc
-> Term v loc
-> Term F (TypeVar v loc) loc
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted Wanted v loc
want Term v loc
e Term F (TypeVar v loc) loc
t
checkWanted Wanted v loc
want e :: Term v loc
e@(Term.Match' Term v loc
scrut [MatchCase loc (Term v loc)]
cases) Term F (TypeVar v loc) loc
t = do
  (Term F (TypeVar v loc) loc
scrutType, Wanted v loc
swant) <- Term v loc -> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
scrut
  Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
swant Wanted v loc
want
  Wanted v loc
cwant <- Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc
-> [MatchCase loc (Term v loc)]
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> M v loc (Wanted v loc)
checkCases Term F (TypeVar v loc) loc
scrutType Term F (TypeVar v loc) loc
t [MatchCase loc (Term v loc)]
cases
  Wanted v loc
want <- Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
cwant Wanted v loc
want
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  let matchType :: Term F (TypeVar v loc) loc
matchType = Context v loc
-> Term F (TypeVar v loc) loc -> Term F (TypeVar v loc) loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Term F (TypeVar v loc) loc
t
  M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
forall v loc.
M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
getPatternMatchCoverageCheckAndKindInferenceSwitch M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
-> (PatternMatchCoverageCheckAndKindInferenceSwitch -> M v loc ())
-> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled ->
      Term v loc
-> Term F (TypeVar v loc) loc
-> Term v loc
-> Term F (TypeVar v loc) loc
-> [MatchCase loc (Term v loc)]
-> M v loc ()
forall v loc.
(Ord loc, Var v) =>
Term v loc
-> Type v loc
-> Term v loc
-> Type v loc
-> [MatchCase loc (Term v loc)]
-> MT v loc (Result v loc) ()
ensurePatternCoverage Term v loc
e Term F (TypeVar v loc) loc
matchType Term v loc
scrut Term F (TypeVar v loc) loc
scrutType [MatchCase loc (Term v loc)]
cases
    PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled ->
      () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  pure Wanted v loc
want
checkWanted Wanted v loc
want Term v loc
e Term F (TypeVar v loc) loc
t = do
  (Term F (TypeVar v loc) loc
u, Wanted v loc
wnew) <- Term v loc -> M v loc (Term F (TypeVar v loc) loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
e
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (Context v loc
-> Term F (TypeVar v loc) loc -> Term F (TypeVar v loc) loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Term F (TypeVar v loc) loc
u) (Context v loc
-> Term F (TypeVar v loc) loc -> Term F (TypeVar v loc) loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Term F (TypeVar v loc) loc
t)
  Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
coalesceWanted Wanted v loc
wnew Wanted v loc
want

-- | Check that under the current context:
--     `m` has type `t` with abilities `es`,
-- updating the context in the process.
checkWithAbilities ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  Term v loc ->
  Type v loc ->
  M v loc ()
checkWithAbilities :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> Type v loc -> M v loc ()
checkWithAbilities [Type v loc]
es Term v loc
m Type v loc
t = do
  Wanted v loc
want <- Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Wanted v loc)
check Term v loc
m Type v loc
t
  Wanted v loc -> [Type v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc ()
subAbilities Wanted v loc
want [Type v loc]
es

-- traverse_ defaultAbility es

-- | Check that under the given context:
--     `m` has type `t`
-- updating the context in the process.
check ::
  (Var v) =>
  (Ord loc) =>
  Term v loc ->
  Type v loc ->
  M v loc (Wanted v loc)
check :: forall v loc.
(Var v, Ord loc) =>
Term v loc -> Type v loc -> M v loc (Wanted v loc)
check Term v loc
m Type v loc
t | ([Char], Term v loc, Type v loc) -> Bool
forall a. Show a => a -> Bool
debugShow ([Char]
"check" :: String, Term v loc
m, Type v loc
t) = M v loc (Wanted v loc)
forall a. HasCallStack => a
undefined
check Term v loc
m0 Type v loc
t0 = PathElement v loc
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Term v loc -> Type v loc -> PathElement v loc
forall v loc. Term v loc -> Type v loc -> PathElement v loc
InCheck Term v loc
m0 Type v loc
t0) (M v loc (Wanted v loc) -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ do
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  case Term v loc -> Either (NonEmpty (v, [loc])) (Term v loc)
forall v vt a.
Var v =>
Term' vt v a -> Either (NonEmpty (v, [a])) (Term' vt v a)
minimize' Term v loc
m0 of
    Left NonEmpty (v, [loc])
m -> Cause v loc -> M v loc (Wanted v loc)
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc (Wanted v loc))
-> Cause v loc -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ NonEmpty (v, [loc]) -> Cause v loc
forall v loc. NonEmpty (v, [loc]) -> Cause v loc
DuplicateDefinitions NonEmpty (v, [loc])
m
    Right Term v loc
m
      | Bool -> Bool
not (Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Type v loc
t0) ->
          Cause v loc -> M v loc (Wanted v loc)
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc (Wanted v loc))
-> Cause v loc -> M v loc (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
IllFormedType Context v loc
ctx
      | Type.Var' TypeVar.Existential {} <- Type v loc
t0 ->
          Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t0 M v loc (Type v loc)
-> (Type v loc -> M v loc (Wanted v loc)) -> M v loc (Wanted v loc)
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted [] Term v loc
m
      | Bool
otherwise ->
          Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Term v loc -> Type v loc -> M v loc (Wanted v loc)
checkWanted [] Term v loc
m (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters Type v loc
t0)

-- | `subtype ctx t1 t2` returns successfully if `t1` is a subtype of `t2`.
-- This may have the effect of altering the context.
subtype :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> M v loc ()
subtype :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
tx Type v loc
ty | [Char] -> Type v loc -> Type v loc -> Bool
forall v a. Var v => [Char] -> Type v a -> Type v a -> Bool
debugTypes [Char]
"subtype" Type v loc
tx Type v loc
ty = M v loc ()
forall a. HasCallStack => a
undefined
subtype Type v loc
tx Type v loc
ty = PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Type v loc -> Type v loc -> PathElement v loc
forall v loc. Type v loc -> Type v loc -> PathElement v loc
InSubtype Type v loc
tx Type v loc
ty) (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Context v loc -> Type v loc -> Type v loc -> M v loc ()
go (Context v loc
ctx :: Context v loc) (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters Type v loc
tx) (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters Type v loc
ty)
  where
    -- Rules from figure 9
    go :: Context v loc -> Type v loc -> Type v loc -> M v loc ()
    go :: Context v loc -> Type v loc -> Type v loc -> M v loc ()
go Context v loc
_ (Type.Ref' Reference
r) (Type.Ref' Reference
r2) | Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
r2 = () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- `Unit`
    go Context v loc
ctx t1 :: Type v loc
t1@(Type.Var' (TypeVar.Universal v
v1)) t2 :: Type v loc
t2@(Type.Var' (TypeVar.Universal v
v2)) -- `Var`
      | v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2 Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Type v loc
t1 Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Type v loc
t2 =
          () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Context v loc
ctx t1 :: Type v loc
t1@(Type.Var' (TypeVar.Existential Blank loc
_ v
v1)) t2 :: Type v loc
t2@(Type.Var' (TypeVar.Existential Blank loc
_ v
v2)) -- `Exvar`
      | v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2 Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Type v loc
t1 Bool -> Bool -> Bool
&& Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Type v loc
t2 =
          () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Context v loc
_ (Type.Arrow' Type v loc
i1 Type v loc
o1) (Type.Arrow' Type v loc
i2 Type v loc
o2) = do
      -- `-->`
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
i2 Type v loc
i1
      Context v loc
ctx' <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx' Type v loc
o1) (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx' Type v loc
o2)
    go Context v loc
_ (Type.App' Type v loc
x1 Type v loc
y1) (Type.App' Type v loc
x2 Type v loc
y2) = do
      -- analogue of `-->`
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
x1 Type v loc
x2
      -- We don't know the variance of the type argument, so we assume
      -- (conservatively) that it's invariant, see
      -- discussion https://github.com/unisonweb/unison/issues/512
      Type v loc
y1 <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
y1
      Type v loc
y2 <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
y2
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
y1 Type v loc
y2
    go Context v loc
_ Type v loc
t (Type.Forall' Subst F (TypeVar v loc) loc
t2) = do
      v
v <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
t2 TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
      v -> M v loc () -> M v loc ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
v (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
        v
v' <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendUniversal v
v
        Type v loc
t2 <- Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type v loc -> M v loc (Type v loc))
-> Type v loc -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Type v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
t2 (() -> v -> Term F (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
v')
        Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
t Type v loc
t2
    go Context v loc
_ (Type.Forall' Subst F (TypeVar v loc) loc
t) Type v loc
t2 = do
      v
v0 <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
t TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
      v -> M v loc () -> M v loc ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
v0 (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
        v
v <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendExistential v
v0
        Type v loc
t <- Type v loc -> M v loc (Type v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type v loc -> M v loc (Type v loc))
-> Type v loc -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Type v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
t (() -> Blank loc -> v -> Term F (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank v
v)
        Type v loc
t1 <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
t
        Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
t1 Type v loc
t2
    go Context v loc
_ (Type.Effect1' Type v loc
e1 Type v loc
a1) (Type.Effect1' Type v loc
e2 Type v loc
a2) = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
e1 Type v loc
e2
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
a1) (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
a2)
    go Context v loc
_ Type v loc
a (Type.Effect1' Type v loc
_e2 Type v loc
a2) = Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
a Type v loc
a2
    go Context v loc
_ (Type.Effect1' Type v loc
es Type v loc
a) Type v loc
a2 = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
es (loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
es) [])
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
a Type v loc
a2
    go Context v loc
ctx (Type.Var' (TypeVar.Existential Blank loc
b v
v)) Type v loc
t -- `InstantiateL`
      | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v (Context v loc -> Set v
forall v loc. Ord v => Context v loc -> Set v
existentials Context v loc
ctx)
          Bool -> Bool -> Bool
&& v -> Set (TypeVar v loc) -> Bool
forall v loc. (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember v
v (Type v loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
t) = do
          Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v Type v loc
t
    go Context v loc
ctx Type v loc
t (Type.Var' (TypeVar.Existential Blank loc
b v
v)) -- `InstantiateR`
      | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v (Context v loc -> Set v
forall v loc. Ord v => Context v loc -> Set v
existentials Context v loc
ctx)
          Bool -> Bool -> Bool
&& v -> Set (TypeVar v loc) -> Bool
forall v loc. (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember v
v (Type v loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
t) = do
          v
e <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendExistential v
forall v. Var v => v
Var.inferAbility
          Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Bool -> v -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Bool -> v -> Type v loc -> Type v loc
relax' Bool
False v
e Type v loc
t) Blank loc
b v
v
    go Context v loc
_ (Type.Effects' [Type v loc]
es1) (Type.Effects' [Type v loc]
es2) =
      Wanted v loc -> [Type v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc ()
subAbilities ((,) Maybe (Term v loc)
forall a. Maybe a
Nothing (Type v loc -> (Maybe (Term v loc), Type v loc))
-> [Type v loc] -> Wanted v loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es1) [Type v loc]
es2
    go Context v loc
_ Type v loc
t t2 :: Type v loc
t2@(Type.Effects' [Type v loc]
_) | Type v loc -> Bool
expand Type v loc
t = Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype (loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) [Type v loc
t]) Type v loc
t2
    go Context v loc
_ t :: Type v loc
t@(Type.Effects' [Type v loc]
_) Type v loc
t2 | Type v loc -> Bool
expand Type v loc
t2 = Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
t (loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t2) [Type v loc
t2])
    go Context v loc
ctx Type v loc
_ Type v loc
_ = Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx

    expand :: Type v loc -> Bool
    expand :: Type v loc -> Bool
expand Type v loc
t = case Type v loc
t of
      Type.Var' TypeVar v loc
_ -> Bool
True
      Type.App' Type v loc
_ Type v loc
_ -> Bool
True
      Type.Ref' Reference
_ -> Bool
True
      Type v loc
_ -> Bool
False

equate :: (Var v) => (Ord loc) => Type v loc -> Type v loc -> M v loc ()
equate :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
t1 Type v loc
t2 = PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Type v loc -> Type v loc -> PathElement v loc
forall v loc. Type v loc -> Type v loc -> PathElement v loc
InEquate Type v loc
t1 Type v loc
t2) (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
  Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Context v loc -> Type v loc -> M v loc ()
forall {v} {loc}.
Var v =>
Context v loc -> Term F (TypeVar v loc) loc -> M v loc ()
guardWF Context v loc
ctx Type v loc
t1
  Context v loc -> Type v loc -> M v loc ()
forall {v} {loc}.
Var v =>
Context v loc -> Term F (TypeVar v loc) loc -> M v loc ()
guardWF Context v loc
ctx Type v loc
t2
  Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate0 Type v loc
t1 Type v loc
t2
  where
    guardWF :: Context v loc -> Term F (TypeVar v loc) loc -> M v loc ()
guardWF Context v loc
ctx t :: Term F (TypeVar v loc) loc
t@(Type.Var' TypeVar v loc
_)
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Context v loc -> Term F (TypeVar v loc) loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctx Term F (TypeVar v loc) loc
t =
          Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx)
    guardWF Context v loc
_ Term F (TypeVar v loc) loc
_ = () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

equate0 ::
  (Var v) =>
  (Ord loc) =>
  Type v loc ->
  Type v loc ->
  M v loc ()
equate0 :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate0 (Type.Ref' Reference
r1) (Type.Ref' Reference
r2) | Reference
r1 Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
r2 = () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
equate0 t1 :: Term F (TypeVar v loc) loc
t1@(Type.Var' TypeVar v loc
tv1) t2 :: Term F (TypeVar v loc) loc
t2@(Type.Var' TypeVar v loc
tv2)
  | TypeVar.Universal v
v1 <- TypeVar v loc
tv1,
    TypeVar.Universal v
v2 <- TypeVar v loc
tv2,
    v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2 =
      () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | TypeVar.Existential Blank loc
b1 v
v1 <- TypeVar v loc
tv1,
    TypeVar.Existential Blank loc
b2 v
v2 <- TypeVar v loc
tv2 =
      if v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2
        then () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else do
          Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
          if Context v loc -> v -> v -> Bool
forall v loc. (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered Context v loc
ctx v
v1 v
v2
            then Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b2 v
v2 Term F (TypeVar v loc) loc
t1
            else Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b1 v
v1 Term F (TypeVar v loc) loc
t2
  | TypeVar.Existential Blank loc
b v
v1 <- TypeVar v loc
tv1 =
      Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v1 Term F (TypeVar v loc) loc
t2
  | TypeVar.Existential Blank loc
b v
v2 <- TypeVar v loc
tv2 =
      Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v2 Term F (TypeVar v loc) loc
t1
equate0 (Type.Forall' Subst F (TypeVar v loc) loc
t01) (Type.Forall' Subst F (TypeVar v loc) loc
t02) = do
  v
v <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
t02 TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
  v -> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
v (MT v loc (Result v loc) () -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) () -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$ do
    Type (TypeVar v loc) ()
v <- () -> v -> Type (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () (v -> Type (TypeVar v loc) ())
-> MT v loc (Result v loc) v
-> MT v loc (Result v loc) (Type (TypeVar v loc) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendUniversal v
v
    let t1 :: Term F (TypeVar v loc) loc
t1 = Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Term F (TypeVar v loc) loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
t01 Type (TypeVar v loc) ()
v
        t2 :: Term F (TypeVar v loc) loc
t2 = Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Term F (TypeVar v loc) loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
t02 Type (TypeVar v loc) ()
v
    Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
t1 Term F (TypeVar v loc) loc
t2
equate0 (Type.App' Term F (TypeVar v loc) loc
x1 Term F (TypeVar v loc) loc
y1) (Type.App' Term F (TypeVar v loc) loc
x2 Term F (TypeVar v loc) loc
y2) = do
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
x1 Term F (TypeVar v loc) loc
x2
  Term F (TypeVar v loc) loc
y1 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
y1
  Term F (TypeVar v loc) loc
y2 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
y2
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
y1 Term F (TypeVar v loc) loc
y2
equate0 (Type.Arrow' Term F (TypeVar v loc) loc
i1 Term F (TypeVar v loc) loc
o1) (Type.Arrow' Term F (TypeVar v loc) loc
i2 Term F (TypeVar v loc) loc
o2) = do
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
i1 Term F (TypeVar v loc) loc
i2
  Term F (TypeVar v loc) loc
o1 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
o1
  Term F (TypeVar v loc) loc
o2 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
o2
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
o1 Term F (TypeVar v loc) loc
o2
equate0 (Type.Effect1' Term F (TypeVar v loc) loc
e1 Term F (TypeVar v loc) loc
a1) (Type.Effect1' Term F (TypeVar v loc) loc
e2 Term F (TypeVar v loc) loc
a2) = do
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
e1 Term F (TypeVar v loc) loc
e2
  Term F (TypeVar v loc) loc
a1 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
a1
  Term F (TypeVar v loc) loc
a2 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
a2
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Term F (TypeVar v loc) loc
a1 Term F (TypeVar v loc) loc
a2
equate0 (Type.Var' (TypeVar.Existential Blank loc
b v
v)) Term F (TypeVar v loc) loc
t
  | v -> Set (TypeVar v loc) -> Bool
forall v loc. (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember v
v (Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar v loc) loc
t) =
      -- subtyping relaxes here, should equality
      Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v Term F (TypeVar v loc) loc
t
equate0 Term F (TypeVar v loc) loc
t (Type.Var' (TypeVar.Existential Blank loc
b v
v))
  | v -> Set (TypeVar v loc) -> Bool
forall v loc. (Var v, Ord loc) => v -> Set (TypeVar v loc) -> Bool
notMember v
v (Term F (TypeVar v loc) loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Term F (TypeVar v loc) loc
t) =
      -- subtyping relaxes here, should equality
      Blank loc
-> v -> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
b v
v Term F (TypeVar v loc) loc
t
equate0 (Type.Effects' [Term F (TypeVar v loc) loc]
es1) (Type.Effects' [Term F (TypeVar v loc) loc]
es2) =
  [Term F (TypeVar v loc) loc]
-> [Term F (TypeVar v loc) loc] -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> [Type v loc] -> M v loc ()
equateAbilities [Term F (TypeVar v loc) loc]
es1 [Term F (TypeVar v loc) loc]
es2
equate0 Term F (TypeVar v loc) loc
y1 Term F (TypeVar v loc) loc
y2 = do
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Term F (TypeVar v loc) loc
y1 Term F (TypeVar v loc) loc
y2
  Term F (TypeVar v loc) loc
y1 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
y1
  Term F (TypeVar v loc) loc
y2 <- Term F (TypeVar v loc) loc -> M v loc (Term F (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Term F (TypeVar v loc) loc
y2
  -- performing the subtype check in both directions means
  -- the types must be equal
  Term F (TypeVar v loc) loc
-> Term F (TypeVar v loc) loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Term F (TypeVar v loc) loc
y2 Term F (TypeVar v loc) loc
y1

-- | Instantiate the given existential such that it is
-- a subtype of the given type, updating the context
-- in the process.
instantiateL :: (Var v, Ord loc) => B.Blank loc -> v -> Type v loc -> M v loc ()
instantiateL :: forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
_ v
v Type v loc
t | Bool
debugEnabled Bool -> Bool -> Bool
&& ([Char], v, Type v loc) -> Bool -> Bool
forall a b. Show a => a -> b -> b
traceShow ([Char]
"instantiateL" :: String, v
v, Type v loc
t) Bool
False = M v loc ()
forall a. HasCallStack => a
undefined
instantiateL Blank loc
blank v
v (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters -> Type v loc
t) =
  PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (v -> Type v loc -> PathElement v loc
forall v loc. v -> Type v loc -> PathElement v loc
InInstantiateL v
v Type v loc
t) (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$
    M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx -> case Type v loc -> Maybe (Monotype (TypeVar v loc) loc)
forall v a. Var v => Type v a -> Maybe (Monotype v a)
Type.monotype Type v loc
t of
      Just Monotype (TypeVar v loc) loc
t ->
        Context v loc
-> v
-> Monotype (TypeVar v loc) loc
-> M v loc (Maybe (Context v loc))
forall v loc.
(Var v, Ord loc) =>
Context v loc
-> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve Context v loc
ctx v
v Monotype (TypeVar v loc) loc
t M v loc (Maybe (Context v loc))
-> (Maybe (Context v loc) -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Context v loc
ctx -> Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx -- InstLSolve
          Maybe (Context v loc)
Nothing -> Context v loc -> M v loc ()
go Context v loc
ctx
      Maybe (Monotype (TypeVar v loc) loc)
Nothing -> Context v loc -> M v loc ()
go Context v loc
ctx
  where
    go :: Context v loc -> M v loc ()
go Context v loc
ctx = case Type v loc
t of
      Type.Var' (TypeVar.Existential Blank loc
_ v
v2)
        | Context v loc -> v -> v -> Bool
forall v loc. (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered Context v loc
ctx v
v v
v2 -> -- InstLReach (both are existential, set v2 = v)
            Context v loc
-> v
-> Monotype (TypeVar v loc) loc
-> M v loc (Maybe (Context v loc))
forall v loc.
(Var v, Ord loc) =>
Context v loc
-> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve Context v loc
ctx v
v2 (Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) v
v))
              M v loc (Maybe (Context v loc))
-> (Maybe (Context v loc) -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M v loc ()
-> (Context v loc -> M v loc ())
-> Maybe (Context v loc)
-> M v loc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx) Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext
      Type.Arrow' Type v loc
i Type v loc
o -> do
        -- InstLArr
        [v
i', v
o'] <- (v -> MT v loc (Result v loc) v)
-> [v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferInput Type v loc
i, v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferOutput Type v loc
o]
        let s :: Element v loc
s =
              Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved
                Blank loc
blank
                v
v
                ( Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype
                    ( loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow
                        (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t)
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i) v
i')
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
o) v
o')
                    )
                )
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          [v -> Element v loc
forall v loc. v -> Element v loc
existential v
o', v -> Element v loc
forall v loc. v -> Element v loc
existential v
i', Element v loc
s]
        Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
i Blank loc
forall loc. Blank loc
B.Blank v
i' -- todo: not sure about this, could also be `blank`
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
o M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
o'
      Type.App' Type v loc
x Type v loc
y -> do
        -- analogue of InstLArr
        [v
x', v
y'] <- (v -> MT v loc (Result v loc) v)
-> [v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferTypeConstructor Type v loc
x, v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferTypeConstructorArg Type v loc
y]
        let s :: Element v loc
s =
              Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved
                Blank loc
blank
                v
v
                ( Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype
                    ( loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app
                        (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t)
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
x) v
x')
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
y) v
y')
                    )
                )
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          [v -> Element v loc
forall v loc. v -> Element v loc
existential v
y', v -> Element v loc
forall v loc. v -> Element v loc
existential v
x', Element v loc
s]
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
x M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
x'
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
y M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
y'
      Type.Effect1' Type v loc
es Type v loc
vt -> do
        v
es' <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferAbility
        v
vt' <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferOther
        let t' :: Type v loc
t' =
              loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.effect1
                (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t)
                (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
es) v
es')
                (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
vt) v
vt')
            s :: Element v loc
s = Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type v loc
t')
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          [v -> Element v loc
forall v loc. v -> Element v loc
existential v
es', v -> Element v loc
forall v loc. v -> Element v loc
existential v
vt', Element v loc
s]
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
es M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
es'
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
vt M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
vt'
      Type.Effects' [Type v loc]
es -> do
        [v]
es' <- (Type v loc -> MT v loc (Result v loc) v)
-> [Type v loc] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Type v loc
e -> v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferAbility Type v loc
e)) [Type v loc]
es
        let locs :: [loc]
locs = Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc (Type v loc -> loc) -> [Type v loc] -> [loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es
            t' :: Type v loc
t' = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) ((loc -> v -> Type v loc) -> (loc, v) -> Type v loc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp ((loc, v) -> Type v loc) -> [(loc, v)] -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [loc]
locs [loc] -> [v] -> [(loc, v)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [v]
es')
            s :: Element v loc
s = Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Monotype (TypeVar v loc) loc -> Element v loc)
-> Monotype (TypeVar v loc) loc -> Element v loc
forall a b. (a -> b) -> a -> b
$ Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type v loc
t'
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          ((v -> Element v loc
forall v loc. v -> Element v loc
existential (v -> Element v loc) -> [v] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
es') [Element v loc] -> [Element v loc] -> [Element v loc]
forall a. [a] -> [a] -> [a]
++ [Element v loc
s])
        [(v, Type v loc)] -> ((v, Type v loc) -> M v loc ()) -> M v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ ([v]
es' [v] -> [Type v loc] -> [(v, Type v loc)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type v loc]
es) (((v, Type v loc) -> M v loc ()) -> M v loc ())
-> ((v, Type v loc) -> M v loc ()) -> M v loc ()
forall a b. (a -> b) -> a -> b
$ \(v
e', Type v loc
e) ->
          Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
e M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
e'
      Type.Forall' Subst F (TypeVar v loc) loc
body -> do
        -- InstLIIL
        v
v0 <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
body TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
        v -> M v loc () -> M v loc ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
v0 (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
          v
v1 <- v -> MT v loc (Result v loc) v
forall v loc. Var v => v -> M v loc v
extendUniversal v
v0
          Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
v (Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Type v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
body (() -> v -> Term F (TypeVar v loc) ()
forall v a loc. Ord v => a -> v -> Type (TypeVar v loc) a
universal' () v
v1))
      Type v loc
_ -> Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx

nameFrom :: (Var v) => v -> Type v loc -> v
nameFrom :: forall v loc. Var v => v -> Type v loc -> v
nameFrom v
_ (Type.Var' TypeVar (Blank loc) v
v) = TypeVar (Blank loc) v -> v
forall b v. TypeVar b v -> v
TypeVar.underlying (TypeVar (Blank loc) v -> TypeVar (Blank loc) v
forall v. Var v => v -> v
Var.reset TypeVar (Blank loc) v
v)
nameFrom v
ifNotVar Term F (TypeVar (Blank loc) v) loc
_ = v
ifNotVar

refineEffectVar ::
  (Var v) =>
  (Ord loc) =>
  loc ->
  [Type v loc] ->
  B.Blank loc ->
  v ->
  Type v loc ->
  M v loc ()
refineEffectVar :: forall v loc.
(Var v, Ord loc) =>
loc -> [Type v loc] -> Blank loc -> v -> Type v loc -> M v loc ()
refineEffectVar loc
_ [Type v loc]
es Blank loc
_ v
v Type v loc
_
  | (Text, [Type v loc], v) -> Bool
forall a. Show a => a -> Bool
debugShow (Text
"refineEffectVar" :: Text, [Type v loc]
es, v
v) = M v loc ()
forall a. HasCallStack => a
undefined
refineEffectVar loc
_ [] Blank loc
_ v
_ Type v loc
_ = () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
refineEffectVar loc
l [Type v loc]
es Blank loc
blank v
v Type v loc
tv
  | TypeVar (Blank loc) v
ev <- Blank loc -> v -> TypeVar (Blank loc) v
forall b v. b -> v -> TypeVar b v
TypeVar.Existential Blank loc
blank v
v,
    (Type v loc -> Bool) -> [Type v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Type v loc
e -> TypeVar (Blank loc) v
ev TypeVar (Blank loc) v -> Set (TypeVar (Blank loc) v) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Type v loc -> Set (TypeVar (Blank loc) v)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
e) [Type v loc]
es =
      M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ())
-> (Context v loc -> Cause v loc) -> Context v loc -> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityCheckFailure [Type v loc
tv] [Type v loc]
es
  | Bool
otherwise = do
      v
slack <- v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar v
forall v. Var v => v
Var.inferAbility
      [v]
evs <- (Type v loc -> M v loc v)
-> [Type v loc] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Type v loc
e -> v -> M v loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferAbility Type v loc
e)) [Type v loc]
es
      let locs :: [loc]
locs = Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc (Type v loc -> loc) -> [Type v loc] -> [loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es
          es' :: [Type v loc]
es' = (loc -> v -> Type v loc) -> [loc] -> [v] -> [Type v loc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp [loc]
locs [v]
evs
          t' :: Type v loc
t' = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects loc
l (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
l v
slack Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
es')
          s :: Element v loc
s = Blank loc -> v -> Monotype v loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Type v loc -> Monotype v loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type v loc
t')
          vs :: [Element v loc]
vs = v -> Element v loc
forall v loc. v -> Element v loc
existential v
slack Element v loc -> [Element v loc] -> [Element v loc]
forall a. a -> [a] -> [a]
: (v -> Element v loc) -> [v] -> [Element v loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Element v loc
forall v loc. v -> Element v loc
existential [v]
evs
      Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v) ([Element v loc]
vs [Element v loc] -> [Element v loc] -> [Element v loc]
forall a. [a] -> [a] -> [a]
++ [Element v loc
s])
      [(Type v loc, v)] -> ((Type v loc, v) -> M v loc ()) -> M v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ ([Type v loc]
es [Type v loc] -> [v] -> [(Type v loc, v)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [v]
evs) (((Type v loc, v) -> M v loc ()) -> M v loc ())
-> ((Type v loc, v) -> M v loc ()) -> M v loc ()
forall a b. (a -> b) -> a -> b
$ \(Type v loc
e, v
ev) ->
        M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx -> Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
e) Blank loc
forall loc. Blank loc
B.Blank v
ev

-- | Instantiate the given existential such that it is
-- a supertype of the given type, updating the context
-- in the process.
instantiateR :: (Var v, Ord loc) => Type v loc -> B.Blank loc -> v -> M v loc ()
instantiateR :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
t Blank loc
_ v
v | Bool
debugEnabled Bool -> Bool -> Bool
&& ([Char], Type v loc, v) -> Bool -> Bool
forall a b. Show a => a -> b -> b
traceShow ([Char]
"instantiateR" :: String, Type v loc
t, v
v) Bool
False = M v loc ()
forall a. HasCallStack => a
undefined
instantiateR (Type v loc -> Type v loc
forall v a. Type v a -> Type v a
Type.stripIntroOuters -> Type v loc
t) Blank loc
blank v
v =
  PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Type v loc -> v -> PathElement v loc
forall v loc. Type v loc -> v -> PathElement v loc
InInstantiateR Type v loc
t v
v) (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$
    M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context v loc
ctx -> case Type v loc -> Maybe (Monotype (TypeVar v loc) loc)
forall v a. Var v => Type v a -> Maybe (Monotype v a)
Type.monotype Type v loc
t of
      Just Monotype (TypeVar v loc) loc
t ->
        Context v loc
-> v
-> Monotype (TypeVar v loc) loc
-> M v loc (Maybe (Context v loc))
forall v loc.
(Var v, Ord loc) =>
Context v loc
-> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve Context v loc
ctx v
v Monotype (TypeVar v loc) loc
t M v loc (Maybe (Context v loc))
-> (Maybe (Context v loc) -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Context v loc
ctx -> Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx -- InstRSolve
          Maybe (Context v loc)
Nothing -> Context v loc -> M v loc ()
go Context v loc
ctx
      Maybe (Monotype (TypeVar v loc) loc)
Nothing -> Context v loc -> M v loc ()
go Context v loc
ctx
  where
    go :: Context v loc -> M v loc ()
go Context v loc
ctx = case Type v loc
t of
      Type.Var' (TypeVar.Existential Blank loc
_ v
v2)
        | Context v loc -> v -> v -> Bool
forall v loc. (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered Context v loc
ctx v
v v
v2 -> -- InstRReach (both are existential, set v2 = v)
            Context v loc
-> v
-> Monotype (TypeVar v loc) loc
-> M v loc (Maybe (Context v loc))
forall v loc.
(Var v, Ord loc) =>
Context v loc
-> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve Context v loc
ctx v
v2 (Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) v
v))
              M v loc (Maybe (Context v loc))
-> (Maybe (Context v loc) -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= M v loc ()
-> (Context v loc -> M v loc ())
-> Maybe (Context v loc)
-> M v loc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx) Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext
      Type.Arrow' Type v loc
i Type v loc
o -> do
        -- InstRArrow
        [v
i', v
o'] <- (v -> MT v loc (Result v loc) v)
-> [v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferInput Type v loc
i, v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferOutput Type v loc
o]
        let s :: Element v loc
s =
              Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved
                Blank loc
blank
                v
v
                ( Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype
                    ( loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow
                        (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t)
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
i) v
i')
                        (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
o) v
o')
                    )
                )
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          [v -> Element v loc
forall v loc. v -> Element v loc
existential v
o', v -> Element v loc
forall v loc. v -> Element v loc
existential v
i', Element v loc
s]
        Context v loc
ctx <- Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Blank loc -> v -> Type v loc -> M v loc ()
instantiateL Blank loc
forall loc. Blank loc
B.Blank v
i' Type v loc
i M v loc () -> M v loc (Context v loc) -> M v loc (Context v loc)
forall a b.
MT v loc (Result v loc) a
-> MT v loc (Result v loc) b -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
        Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
o) Blank loc
forall loc. Blank loc
B.Blank v
o'
      Type.App' Type v loc
x Type v loc
y -> do
        -- analogue of InstRArr
        -- example foo a <: v' will
        -- 1. create foo', a', add these to the context
        -- 2. add v' = foo' a' to the context
        -- 3. recurse to refine the types of foo' and a'
        [v
x', v
y'] <- (v -> MT v loc (Result v loc) v)
-> [v] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferTypeConstructor Type v loc
x, v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferTypeConstructorArg Type v loc
y]
        let s :: Element v loc
s = Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype (loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
x) v
x') (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
y) v
y')))
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v) [v -> Element v loc
forall v loc. v -> Element v loc
existential v
y', v -> Element v loc
forall v loc. v -> Element v loc
existential v
x', Element v loc
s]
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
x M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v loc
x -> Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
x Blank loc
forall loc. Blank loc
B.Blank v
x'
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
y M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v loc
y -> Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
y Blank loc
forall loc. Blank loc
B.Blank v
y'
      Type.Effect1' Type v loc
es Type v loc
vt -> do
        v
es' <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferAbility Type v loc
es)
        v
vt' <- v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferTypeConstructorArg Type v loc
vt)
        let t' :: Type v loc
t' =
              loc -> Type v loc -> Type v loc -> Type v loc
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.effect1
                (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t)
                (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
es) v
es')
                (loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
vt) v
vt')
            s :: Element v loc
s = Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type v loc
t')
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          [v -> Element v loc
forall v loc. v -> Element v loc
existential v
es', v -> Element v loc
forall v loc. v -> Element v loc
existential v
vt', Element v loc
s]
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
es M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v loc
es -> Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
es Blank loc
forall loc. Blank loc
B.Blank v
es'
        Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
vt M v loc (Type v loc) -> (Type v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v loc
vt -> Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
vt Blank loc
forall loc. Blank loc
B.Blank v
vt'
      Type.Effects' [Type v loc]
es -> do
        [v]
es' <- (Type v loc -> MT v loc (Result v loc) v)
-> [Type v loc] -> MT v loc (Result v loc) [v]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Type v loc
e -> v -> MT v loc (Result v loc) v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferAbility Type v loc
e)) [Type v loc]
es
        let locs :: [loc]
locs = Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc (Type v loc -> loc) -> [Type v loc] -> [loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
es
            t' :: Type v loc
t' = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t) ((loc -> v -> Type v loc) -> (loc, v) -> Type v loc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp ((loc, v) -> Type v loc) -> [(loc, v)] -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [loc]
locs [loc] -> [v] -> [(loc, v)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [v]
es')
            s :: Element v loc
s = Blank loc -> v -> Monotype (TypeVar v loc) loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v (Monotype (TypeVar v loc) loc -> Element v loc)
-> Monotype (TypeVar v loc) loc -> Element v loc
forall a b. (a -> b) -> a -> b
$ Type v loc -> Monotype (TypeVar v loc) loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type v loc
t'
        Element v loc -> [Element v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext
          (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v)
          ((v -> Element v loc
forall v loc. v -> Element v loc
existential (v -> Element v loc) -> [v] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
es') [Element v loc] -> [Element v loc] -> [Element v loc]
forall a. [a] -> [a] -> [a]
++ [Element v loc
s])
        [(Type v loc, v)] -> ((Type v loc, v) -> M v loc ()) -> M v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ ([Type v loc]
es [Type v loc] -> [v] -> [(Type v loc, v)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [v]
es') (((Type v loc, v) -> M v loc ()) -> M v loc ())
-> ((Type v loc, v) -> M v loc ()) -> M v loc ()
forall a b. (a -> b) -> a -> b
$ \(Type v loc
e, v
e') -> do
          Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
          Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx Type v loc
e) Blank loc
forall loc. Blank loc
B.Blank v
e'
      Type.Forall' Subst F (TypeVar v loc) loc
body -> do
        -- InstRAIIL
        v
x' <- Subst F (TypeVar v loc) loc
-> forall (m :: * -> *) v'.
   Monad m =>
   (TypeVar v loc -> m v') -> m v'
forall (f :: * -> *) v a.
Subst f v a
-> forall (m :: * -> *) v'. Monad m => (v -> m v') -> m v'
ABT.freshen Subst F (TypeVar v loc) loc
body TypeVar v loc -> MT v loc (Result v loc) v
forall v loc. Var v => TypeVar v loc -> M v loc v
freshenTypeVar
        v -> M v loc () -> M v loc ()
forall v loc a. (Var v, Ord loc) => v -> M v loc a -> M v loc ()
markThenRetract0 v
x' (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
          [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext [v -> Element v loc
forall v loc. v -> Element v loc
existential v
x']
          Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Subst F (TypeVar v loc) loc
-> forall b. Term F (TypeVar v loc) b -> Type v loc
forall (f :: * -> *) v a.
Subst f v a -> forall b. Term f v b -> Term f v a
ABT.bindInheritAnnotation Subst F (TypeVar v loc) loc
body (() -> Blank loc -> v -> Term F (TypeVar v loc) ()
forall v a loc.
Ord v =>
a -> Blank loc -> v -> Type (TypeVar v loc) a
existential' () Blank loc
forall loc. Blank loc
B.Blank v
x')) Blank loc
forall loc. Blank loc
B.Blank v
v
      Type v loc
_ -> Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx

-- | solve (ΓL,α^,ΓR) α τ = (ΓL,α^ = τ,ΓR)
-- Solve the given existential variable to the given monotype.
-- If the given monotype is not well-formed at the context location
-- where the existential variable is introduced, return `Nothing`.
-- Fail with type mismatch if the existential is already solved to something else.
-- Fail with a compiler bug if the existential does not appear in the context at all.
solve :: (Var v, Ord loc) => Context v loc -> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve :: forall v loc.
(Var v, Ord loc) =>
Context v loc
-> v -> Monotype v loc -> M v loc (Maybe (Context v loc))
solve Context v loc
ctx v
v Monotype v loc
t = case Context v loc -> v -> Maybe (Monotype v loc)
forall v loc. Ord v => Context v loc -> v -> Maybe (Monotype v loc)
lookupSolved Context v loc
ctx v
v of
  Just Monotype v loc
t2 ->
    -- okay to solve something again if it's to an identical type
    if Monotype v loc -> Monotype v loc -> Bool
same Monotype v loc
t Monotype v loc
t2
      then Maybe (Context v loc) -> M v loc (Maybe (Context v loc))
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context v loc -> Maybe (Context v loc)
forall a. a -> Maybe a
Just Context v loc
ctx)
      else Cause v loc -> M v loc (Maybe (Context v loc))
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc (Maybe (Context v loc)))
-> Cause v loc -> M v loc (Maybe (Context v loc))
forall a b. (a -> b) -> a -> b
$ Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch Context v loc
ctx
    where
      same :: Monotype v loc -> Monotype v loc -> Bool
same Monotype v loc
t1 Monotype v loc
t2 = Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Monotype v loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype v loc
t1) Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Monotype v loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype v loc
t2)
  Maybe (Monotype v loc)
Nothing -> case Element v loc
-> Context v loc
-> Maybe (Context v loc, Element v loc, [Element v loc])
forall v loc.
(Var v, Ord loc) =>
Element v loc
-> Context v loc
-> Maybe (Context v loc, Element v loc, [Element v loc])
breakAt (v -> Element v loc
forall v loc. v -> Element v loc
existential v
v) Context v loc
ctx of
    Just (Context v loc
ctxL, Existential Blank loc
blank v
v, [Element v loc]
ctxR) ->
      if Context v loc -> Type v loc -> Bool
forall v loc. Var v => Context v loc -> Type v loc -> Bool
wellformedType Context v loc
ctxL (Monotype v loc -> Type v loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype v loc
t)
        then Context v loc -> Maybe (Context v loc)
forall a. a -> Maybe a
Just (Context v loc -> Maybe (Context v loc))
-> MT v loc (Result v loc) (Context v loc)
-> M v loc (Maybe (Context v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context v loc
ctxL Context v loc
-> [Element v loc] -> MT v loc (Result v loc) (Context v loc)
forall v loc.
Var v =>
Context v loc -> [Element v loc] -> M v loc (Context v loc)
`extendN` ((Blank loc -> v -> Monotype v loc -> Element v loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
blank v
v Monotype v loc
t) Element v loc -> [Element v loc] -> [Element v loc]
forall a. a -> [a] -> [a]
: [Element v loc]
ctxR)
        else Maybe (Context v loc) -> M v loc (Maybe (Context v loc))
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Context v loc)
forall a. Maybe a
Nothing
    Maybe (Context v loc, Element v loc, [Element v loc])
_ -> CompilerBug v loc -> M v loc (Maybe (Context v loc))
forall v loc a. CompilerBug v loc -> M v loc a
compilerCrash (CompilerBug v loc -> M v loc (Maybe (Context v loc)))
-> CompilerBug v loc -> M v loc (Maybe (Context v loc))
forall a b. (a -> b) -> a -> b
$ v -> Context v loc -> CompilerBug v loc
forall v loc. v -> Context v loc -> CompilerBug v loc
UnknownExistentialVariable v
v Context v loc
ctx

expandAbilities ::
  (Var v) => (Ord loc) => [Type v loc] -> M v loc [Type v loc]
expandAbilities :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities =
  ([Type (TypeVar v loc) loc] -> [Type (TypeVar v loc) loc])
-> MT v loc (Result v loc) [Type (TypeVar v loc) loc]
-> MT v loc (Result v loc) [Type (TypeVar v loc) loc]
forall a b.
(a -> b) -> MT v loc (Result v loc) a -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type (TypeVar v loc) loc -> [Type (TypeVar v loc) loc])
-> [Type (TypeVar v loc) loc] -> [Type (TypeVar v loc) loc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type (TypeVar v loc) loc -> [Type (TypeVar v loc) loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects) (MT v loc (Result v loc) [Type (TypeVar v loc) loc]
 -> MT v loc (Result v loc) [Type (TypeVar v loc) loc])
-> ([Type (TypeVar v loc) loc]
    -> MT v loc (Result v loc) [Type (TypeVar v loc) loc])
-> [Type (TypeVar v loc) loc]
-> MT v loc (Result v loc) [Type (TypeVar v loc) loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type (TypeVar v loc) loc
 -> MT v loc (Result v loc) (Type (TypeVar v loc) loc))
-> [Type (TypeVar v loc) loc]
-> MT v loc (Result v loc) [Type (TypeVar v loc) loc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type (TypeVar v loc) loc
-> MT v loc (Result v loc) (Type (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM

expandWanted ::
  (Var v) => (Ord loc) => Wanted v loc -> M v loc (Wanted v loc)
expandWanted :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted =
  (([(Maybe (Term v loc), Type (TypeVar v loc) loc)]
 -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall a b.
(a -> b) -> MT v loc (Result v loc) a -> MT v loc (Result v loc) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(Maybe (Term v loc), Type (TypeVar v loc) loc)]
  -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
 -> MT
      v
      loc
      (Result v loc)
      [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
 -> MT
      v
      loc
      (Result v loc)
      [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> (((Maybe (Term v loc), Type (TypeVar v loc) loc)
     -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
    -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
    -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> ((Maybe (Term v loc), Type (TypeVar v loc) loc)
    -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe (Term v loc), Type (TypeVar v loc) loc)
 -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap) (\(Maybe (Term v loc)
l, Type (TypeVar v loc) loc
es) -> (,) Maybe (Term v loc)
l (Type (TypeVar v loc) loc
 -> (Maybe (Term v loc), Type (TypeVar v loc) loc))
-> [Type (TypeVar v loc) loc]
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type (TypeVar v loc) loc -> [Type (TypeVar v loc) loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects Type (TypeVar v loc) loc
es)
    (MT
   v
   loc
   (Result v loc)
   [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
 -> MT
      v
      loc
      (Result v loc)
      [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> ([(Maybe (Term v loc), Type (TypeVar v loc) loc)]
    -> MT
         v
         loc
         (Result v loc)
         [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Maybe (Term v loc), Type (TypeVar v loc) loc)
 -> MT
      v
      loc
      (Result v loc)
      (Maybe (Term v loc), Type (TypeVar v loc) loc))
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Maybe (Term v loc), Type (TypeVar v loc) loc)
  -> MT
       v
       loc
       (Result v loc)
       (Maybe (Term v loc), Type (TypeVar v loc) loc))
 -> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
 -> MT
      v
      loc
      (Result v loc)
      [(Maybe (Term v loc), Type (TypeVar v loc) loc)])
-> ((Type (TypeVar v loc) loc
     -> MT v loc (Result v loc) (Type (TypeVar v loc) loc))
    -> (Maybe (Term v loc), Type (TypeVar v loc) loc)
    -> MT
         v
         loc
         (Result v loc)
         (Maybe (Term v loc), Type (TypeVar v loc) loc))
-> (Type (TypeVar v loc) loc
    -> MT v loc (Result v loc) (Type (TypeVar v loc) loc))
-> [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
-> MT
     v
     loc
     (Result v loc)
     [(Maybe (Term v loc), Type (TypeVar v loc) loc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type (TypeVar v loc) loc
 -> MT v loc (Result v loc) (Type (TypeVar v loc) loc))
-> (Maybe (Term v loc), Type (TypeVar v loc) loc)
-> MT
     v loc (Result v loc) (Maybe (Term v loc), Type (TypeVar v loc) loc)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Maybe (Term v loc), a) -> f (Maybe (Term v loc), b)
traverse) Type (TypeVar v loc) loc
-> MT v loc (Result v loc) (Type (TypeVar v loc) loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM

matchConcrete ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  [Type v loc] ->
  [Type v loc] ->
  [Type v loc] ->
  M v loc ([Type v loc], [Type v loc])
matchConcrete :: forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete [Type v loc]
common [Type v loc]
acc [] [Type v loc]
_ = ([Type v loc], [Type v loc])
-> MT v loc (Result v loc) ([Type v loc], [Type v loc])
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type v loc] -> [Type v loc]
forall a. [a] -> [a]
reverse [Type v loc]
acc, [Type v loc]
common)
matchConcrete [Type v loc]
common [Type v loc]
acc (Type v loc
l : [Type v loc]
ls) [Type v loc]
rs
  | Just Type v loc
v <- (Type v loc -> Bool) -> [Type v loc] -> Maybe (Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
l) [Type v loc]
common = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
v Type v loc
l
      [Type v loc]
ls <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
ls
      [Type v loc]
rs <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
rs
      [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> MT v loc (Result v loc) ([Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete [Type v loc]
common [Type v loc]
acc [Type v loc]
ls [Type v loc]
rs
  | Just Type v loc
v <- (Type v loc -> Bool) -> [Type v loc] -> Maybe (Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
l) [Type v loc]
rs = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
equate Type v loc
v Type v loc
l
      [Type v loc]
ls <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
ls
      [Type v loc]
rs <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
rs
      [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> MT v loc (Result v loc) ([Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete (Type v loc
l Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
common) [Type v loc]
acc [Type v loc]
ls [Type v loc]
rs
  | Bool
otherwise = [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> MT v loc (Result v loc) ([Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete [Type v loc]
common (Type v loc
l Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
acc) [Type v loc]
ls [Type v loc]
rs

pruneConcrete ::
  (Var v) =>
  (Ord loc) =>
  (Maybe (Term v loc) -> Type v loc -> M v loc ()) ->
  Wanted v loc ->
  Wanted v loc ->
  [Type v loc] ->
  M v loc (Wanted v loc)
pruneConcrete :: forall v loc.
(Var v, Ord loc) =>
(Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> M v loc (Wanted v loc)
pruneConcrete Maybe (Term v loc) -> Type v loc -> M v loc ()
_ Wanted v loc
acc [] [Type v loc]
_ = Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wanted v loc -> Wanted v loc
forall a. [a] -> [a]
reverse Wanted v loc
acc)
pruneConcrete Maybe (Term v loc) -> Type v loc -> M v loc ()
missing Wanted v loc
acc ((Maybe (Term v loc)
loc, Type v loc
w) : Wanted v loc
ws) [Type v loc]
have
  | Just Type v loc
v <- (Type v loc -> Bool) -> [Type v loc] -> Maybe (Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
w) [Type v loc]
have = do
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
v Type v loc
w M v loc () -> M v loc () -> M v loc ()
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` Maybe (Term v loc) -> Type v loc -> M v loc ()
missing Maybe (Term v loc)
loc Type v loc
w
      Wanted v loc
ws <- Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
ws
      [Type v loc]
have <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
have
      (Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
(Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> M v loc (Wanted v loc)
pruneConcrete Maybe (Term v loc) -> Type v loc -> M v loc ()
missing Wanted v loc
acc Wanted v loc
ws [Type v loc]
have
  | Bool
otherwise = (Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
(Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> M v loc (Wanted v loc)
pruneConcrete Maybe (Term v loc) -> Type v loc -> M v loc ()
missing ((Maybe (Term v loc)
loc, Type v loc
w) (Maybe (Term v loc), Type v loc) -> Wanted v loc -> Wanted v loc
forall a. a -> [a] -> [a]
: Wanted v loc
acc) Wanted v loc
ws [Type v loc]
have

matchVariables ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  [Type v loc] ->
  [Type v loc] ->
  [Type v loc] ->
  ([Type v loc], [Type v loc], [Type v loc])
matchVariables :: forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
matchVariables [Type v loc]
com [Type v loc]
acc (Type v loc
l : [Type v loc]
ls) [Type v loc]
rs
  | Type v loc -> Bool
forall {f :: * -> *} {b} {v} {a}. Term f (TypeVar b v) a -> Bool
isExistential Type v loc
l Bool -> Bool -> Bool
&& (Type v loc -> Bool) -> [Type v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Type v loc
l) [Type v loc]
rs =
      [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
matchVariables (Type v loc
l Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
com) [Type v loc]
acc ((Type v loc -> Bool) -> [Type v loc] -> [Type v loc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Type v loc
l) [Type v loc]
ls) ((Type v loc -> Bool) -> [Type v loc] -> [Type v loc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Type v loc
l) [Type v loc]
rs)
  | Bool
otherwise = [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
matchVariables [Type v loc]
com (Type v loc
l Type v loc -> [Type v loc] -> [Type v loc]
forall a. a -> [a] -> [a]
: [Type v loc]
acc) [Type v loc]
ls [Type v loc]
rs
  where
    isExistential :: Term f (TypeVar b v) a -> Bool
isExistential (Type.Var' TypeVar.Existential {}) = Bool
True
    isExistential Term f (TypeVar b v) a
_ = Bool
False
matchVariables [Type v loc]
com [Type v loc]
acc [] [Type v loc]
rs = ([Type v loc]
com, [Type v loc] -> [Type v loc]
forall a. [a] -> [a]
reverse [Type v loc]
acc, [Type v loc]
rs)

pruneVariables ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  Wanted v loc ->
  M v loc (Wanted v loc)
pruneVariables :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
pruneVariables Wanted v loc
acc [] = Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wanted v loc -> MT v loc (Result v loc) (Wanted v loc))
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall a b. (a -> b) -> a -> b
$ Wanted v loc -> Wanted v loc
forall a. [a] -> [a]
reverse Wanted v loc
acc
pruneVariables Wanted v loc
acc ((Maybe (Term v loc)
loc, Type v loc
v) : Wanted v loc
vs) = do
  Bool
discard <- Type v loc -> M v loc Bool
forall v loc. (Var v, Ord loc) => Type v loc -> M v loc Bool
defaultAbility Type v loc
v
  Wanted v loc
vs <- Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
vs
  if Bool
discard
    then Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
pruneVariables Wanted v loc
acc Wanted v loc
vs
    else Wanted v loc
-> Wanted v loc -> MT v loc (Result v loc) (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
pruneVariables ((Maybe (Term v loc)
loc, Type v loc
v) (Maybe (Term v loc), Type v loc) -> Wanted v loc -> Wanted v loc
forall a. a -> [a] -> [a]
: Wanted v loc
acc) Wanted v loc
vs

pruneAbilities ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  [Type v loc] ->
  M v loc (Wanted v loc)
pruneAbilities :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneAbilities Wanted v loc
want0 [Type v loc]
have0
  | (Text, Wanted v loc, [Type v loc]) -> Bool
forall a. Show a => a -> Bool
debugShow (Text
"pruneAbilities" :: Text, Wanted v loc
want0, [Type v loc]
have0) = M v loc (Wanted v loc)
forall a. HasCallStack => a
undefined
pruneAbilities Wanted v loc
want0 [Type v loc]
have0 = do
  Wanted v loc
pwant <- (Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
(Maybe (Term v loc) -> Type v loc -> M v loc ())
-> Wanted v loc
-> Wanted v loc
-> [Type v loc]
-> M v loc (Wanted v loc)
pruneConcrete Maybe (Term v loc) -> Type v loc -> M v loc ()
missing [] Wanted v loc
want0 [Type v loc]
have0
  if Wanted v loc
pwant Wanted v loc -> Wanted v loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Wanted v loc
want0
    then do
      Wanted v loc
want <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
pwant
      [Type v loc]
have <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
have0
      Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneAbilities Wanted v loc
want [Type v loc]
have
    else -- fixed point

      if Bool
dflt
        then Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted (Wanted v loc -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> Wanted v loc -> M v loc (Wanted v loc)
pruneVariables [] Wanted v loc
pwant
        else Wanted v loc -> M v loc (Wanted v loc)
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wanted v loc
pwant
  where
    missing :: Maybe (Term v loc) -> Type v loc -> M v loc ()
missing Maybe (Term v loc)
loc Type v loc
w = (M v loc () -> M v loc ())
-> (Term v loc -> M v loc () -> M v loc ())
-> Maybe (Term v loc)
-> M v loc ()
-> M v loc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe M v loc () -> M v loc ()
forall a. a -> a
id (PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (PathElement v loc -> M v loc () -> M v loc ())
-> (Term v loc -> PathElement v loc)
-> Term v loc
-> M v loc ()
-> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v loc -> PathElement v loc
forall v loc. Term v loc -> PathElement v loc
InSynthesize) Maybe (Term v loc)
loc (M v loc () -> M v loc ()) -> M v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$ do
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
        [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityCheckFailure
          (Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects (Type v loc -> [Type v loc])
-> (Type v loc -> Type v loc) -> Type v loc -> [Type v loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Type v loc -> [Type v loc]) -> [Type v loc] -> [Type v loc]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Type v loc]
have0)
          [Type v loc
w]
          Context v loc
ctx

    dflt :: Bool
dflt = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Type v loc -> Bool) -> [Type v loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type v loc -> Bool
forall v loc. Type v loc -> Bool
isExistential [Type v loc]
have0

isExistential :: Type v loc -> Bool
isExistential :: forall v loc. Type v loc -> Bool
isExistential (Type.Var' TypeVar.Existential {}) = Bool
True
isExistential Term F (TypeVar v loc) loc
_ = Bool
False

matchAbilities ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  [Type v loc] ->
  M v loc ([Type v loc], [Type v loc], [Type v loc])
matchAbilities :: forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
matchAbilities [Type v loc]
ls0 [Type v loc]
rs0 = do
  ([Type v loc]
ls, [Type v loc]
com) <- [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete [] [] [Type v loc]
ls0 [Type v loc]
rs0
  [Type v loc]
rs <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
rs0
  ([Type v loc]
rs, [Type v loc]
_) <- [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc])
matchConcrete [Type v loc]
com [] [Type v loc]
rs [Type v loc]
ls
  [Type v loc]
ls <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
ls
  if [Type v loc]
ls [Type v loc] -> [Type v loc] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type v loc]
ls0 Bool -> Bool -> Bool
|| [Type v loc]
rs [Type v loc] -> [Type v loc] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type v loc]
rs0
    then [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
matchAbilities [Type v loc]
ls [Type v loc]
rs
    else ([Type v loc], [Type v loc], [Type v loc])
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Type v loc], [Type v loc], [Type v loc])
 -> M v loc ([Type v loc], [Type v loc], [Type v loc]))
-> ([Type v loc], [Type v loc], [Type v loc])
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
forall a b. (a -> b) -> a -> b
$ [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> [Type v loc]
-> [Type v loc]
-> ([Type v loc], [Type v loc], [Type v loc])
matchVariables [] [] [Type v loc]
ls [Type v loc]
rs

equateAbilities ::
  (Var v) =>
  (Ord loc) =>
  [Type v loc] ->
  [Type v loc] ->
  M v loc ()
equateAbilities :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> [Type v loc] -> M v loc ()
equateAbilities [Type v loc]
abs1 [Type v loc]
abs2
  | (Text, [Type v loc], [Type v loc]) -> Bool
forall a. Show a => a -> Bool
debugShow (Text
"equateAbilities" :: Text, [Type v loc]
abs1, [Type v loc]
abs2) = M v loc ()
forall a. HasCallStack => a
undefined
equateAbilities [Type v loc]
ls [Type v loc]
rs =
  [Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
forall v loc.
(Var v, Ord loc) =>
[Type v loc]
-> [Type v loc]
-> M v loc ([Type v loc], [Type v loc], [Type v loc])
matchAbilities [Type v loc]
ls [Type v loc]
rs M v loc ([Type v loc], [Type v loc], [Type v loc])
-> (([Type v loc], [Type v loc], [Type v loc]) -> M v loc ())
-> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([Type v loc]
com, [Type v loc]
ls, [Type v loc]
rs) ->
    let ([Type v loc]
vls, [Type v loc]
cls) = (Type v loc -> Bool)
-> [Type v loc] -> ([Type v loc], [Type v loc])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Type v loc -> Bool
forall v loc. Type v loc -> Bool
isExistential [Type v loc]
ls
        ([Type v loc]
vrs, [Type v loc]
crs) = (Type v loc -> Bool)
-> [Type v loc] -> ([Type v loc], [Type v loc])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Type v loc -> Bool
forall v loc. Type v loc -> Bool
isExistential [Type v loc]
rs
        mlSlack :: Maybe (loc, Blank loc, v)
mlSlack
          | [t :: Type v loc
t@(Type.Var' (TypeVar.Existential Blank loc
b v
v))] <- [Type v loc]
vls =
              (loc, Blank loc, v) -> Maybe (loc, Blank loc, v)
forall a. a -> Maybe a
Just (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t, Blank loc
b, v
v)
          | Bool
otherwise = Maybe (loc, Blank loc, v)
forall a. Maybe a
Nothing
        mrSlack :: Maybe (loc, Blank loc, v)
mrSlack
          | [t :: Type v loc
t@(Type.Var' (TypeVar.Existential Blank loc
b v
v))] <- [Type v loc]
vrs =
              (loc, Blank loc, v) -> Maybe (loc, Blank loc, v)
forall a. a -> Maybe a
Just (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t, Blank loc
b, v
v)
          | Bool
otherwise = Maybe (loc, Blank loc, v)
forall a. Maybe a
Nothing
     in case ((loc, Blank loc, v)
 -> (loc, Blank loc, v)
 -> ((loc, Blank loc, v), (loc, Blank loc, v)))
-> Maybe (loc, Blank loc, v)
-> Maybe (loc, Blank loc, v)
-> Maybe ((loc, Blank loc, v), (loc, Blank loc, v))
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Maybe (loc, Blank loc, v)
mlSlack Maybe (loc, Blank loc, v)
mrSlack of
          Just ((loc
ll, Blank loc
bl, v
lSlack), (loc
lr, Blank loc
br, v
rSlack)) ->
            Bool -> [(loc, Blank loc, v)] -> [[Type v loc]] -> M v loc ()
forall {a} {loc}.
(Var a, Ord loc) =>
Bool
-> [(loc, Blank loc, a)]
-> [[Type a loc]]
-> MT a loc (Result a loc) ()
refine Bool
True [(loc
ll, Blank loc
bl, v
lSlack), (loc
lr, Blank loc
br, v
rSlack)] [[Type v loc]
crs, [Type v loc]
cls]
          Maybe ((loc, Blank loc, v), (loc, Blank loc, v))
_
            | [t :: Type v loc
t@(Type.Var' (TypeVar.Existential Blank loc
bc v
cv))] <- [Type v loc]
com,
              [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
vls,
              [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
vrs ->
                Bool -> [(loc, Blank loc, v)] -> [[Type v loc]] -> M v loc ()
forall {a} {loc}.
(Var a, Ord loc) =>
Bool
-> [(loc, Blank loc, a)]
-> [[Type a loc]]
-> MT a loc (Result a loc) ()
refine Bool
True [(Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
t, Blank loc
bc, v
cv)] [[Type v loc]
cls [Type v loc] -> [Type v loc] -> [Type v loc]
forall a. [a] -> [a] -> [a]
++ [Type v loc]
crs]
            | [] <- [Type v loc]
com, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
rs, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
cls -> [Type v loc]
-> (Type v loc -> MT v loc (Result v loc) Bool) -> M v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Type v loc]
vls Type v loc -> MT v loc (Result v loc) Bool
forall v loc. (Var v, Ord loc) => Type v loc -> M v loc Bool
defaultAbility
            | [] <- [Type v loc]
com, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
ls, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
crs -> [Type v loc]
-> (Type v loc -> MT v loc (Result v loc) Bool) -> M v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Type v loc]
vrs Type v loc -> MT v loc (Result v loc) Bool
forall v loc. (Var v, Ord loc) => Type v loc -> M v loc Bool
defaultAbility
            | [] <- [Type v loc]
com, Just (loc, Blank loc, v)
pl <- Maybe (loc, Blank loc, v)
mlSlack, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
cls -> Bool -> [(loc, Blank loc, v)] -> [[Type v loc]] -> M v loc ()
forall {a} {loc}.
(Var a, Ord loc) =>
Bool
-> [(loc, Blank loc, a)]
-> [[Type a loc]]
-> MT a loc (Result a loc) ()
refine Bool
False [(loc, Blank loc, v)
pl] [[Type v loc]
rs]
            | [] <- [Type v loc]
com, Just (loc, Blank loc, v)
pr <- Maybe (loc, Blank loc, v)
mrSlack, [Type v loc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type v loc]
crs -> Bool -> [(loc, Blank loc, v)] -> [[Type v loc]] -> M v loc ()
forall {a} {loc}.
(Var a, Ord loc) =>
Bool
-> [(loc, Blank loc, a)]
-> [[Type a loc]]
-> MT a loc (Result a loc) ()
refine Bool
False [(loc, Blank loc, v)
pr] [[Type v loc]
ls]
            | Bool
otherwise -> M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ())
-> (Context v loc -> Cause v loc) -> Context v loc -> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityEqFailure [Type v loc]
ls [Type v loc]
rs
  where
    refine :: Bool
-> [(loc, Blank loc, a)]
-> [[Type a loc]]
-> MT a loc (Result a loc) ()
refine Bool
common [(loc, Blank loc, a)]
lbvs [[Type a loc]]
ess = do
      [a]
cv <- (a -> MT a loc (Result a loc) a)
-> [a] -> MT a loc (Result a loc) [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> MT a loc (Result a loc) a
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar [a]
cn
      Context a loc
ctx <- M a loc (Context a loc)
forall v loc. M v loc (Context v loc)
getContext
      let (loc
_, Blank loc
_, a
early) = ((loc, Blank loc, a) -> (loc, Blank loc, a) -> Ordering)
-> [(loc, Blank loc, a)] -> (loc, Blank loc, a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Context a loc
-> (loc, Blank loc, a) -> (loc, Blank loc, a) -> Ordering
forall {v} {loc} {a} {b} {a} {b}.
(Var v, Ord loc) =>
Context v loc -> (a, b, v) -> (a, b, v) -> Ordering
cmp Context a loc
ctx) [(loc, Blank loc, a)]
lbvs
          frsh :: Type v loc -> M v0 loc v
frsh Type v loc
e = v -> M v0 loc v
forall v v0 loc. Var v => v -> M v0 loc v
freshenVar (v -> Type v loc -> v
forall v loc. Var v => v -> Type v loc -> v
nameFrom v
forall v. Var v => v
Var.inferAbility Type v loc
e)
      [[a]]
vss <- (([Type a loc] -> MT a loc (Result a loc) [a])
-> [[Type a loc]] -> MT a loc (Result a loc) [[a]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (([Type a loc] -> MT a loc (Result a loc) [a])
 -> [[Type a loc]] -> MT a loc (Result a loc) [[a]])
-> ((Type a loc -> MT a loc (Result a loc) a)
    -> [Type a loc] -> MT a loc (Result a loc) [a])
-> (Type a loc -> MT a loc (Result a loc) a)
-> [[Type a loc]]
-> MT a loc (Result a loc) [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type a loc -> MT a loc (Result a loc) a)
-> [Type a loc] -> MT a loc (Result a loc) [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse) Type a loc -> MT a loc (Result a loc) a
forall {v} {loc} {v0} {loc}. Var v => Type v loc -> M v0 loc v
frsh [[Type a loc]]
ess
      let evss :: [[(Type a loc, a)]]
evss = ([Type a loc] -> [a] -> [(Type a loc, a)])
-> [[Type a loc]] -> [[a]] -> [[(Type a loc, a)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Type a loc] -> [a] -> [(Type a loc, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Type a loc]]
ess [[a]]
vss
          p :: ((loc, Blank loc, a), [a]) -> Bool
p ((loc
_, Blank loc
_, a
u), [a]
_) = a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
early
          bigList :: [((loc, Blank loc, a), [a])]
bigList = case (((loc, Blank loc, a), [a]) -> Bool)
-> [((loc, Blank loc, a), [a])]
-> ([((loc, Blank loc, a), [a])], [((loc, Blank loc, a), [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((loc, Blank loc, a), [a]) -> Bool
p ([((loc, Blank loc, a), [a])]
 -> ([((loc, Blank loc, a), [a])], [((loc, Blank loc, a), [a])]))
-> [((loc, Blank loc, a), [a])]
-> ([((loc, Blank loc, a), [a])], [((loc, Blank loc, a), [a])])
forall a b. (a -> b) -> a -> b
$ [(loc, Blank loc, a)] -> [[a]] -> [((loc, Blank loc, a), [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(loc, Blank loc, a)]
lbvs [[a]]
vss of
            ([((loc, Blank loc, a), [a])]
l, ((loc, Blank loc, a), [a])
x : [((loc, Blank loc, a), [a])]
r) -> ((loc, Blank loc, a), [a])
x ((loc, Blank loc, a), [a])
-> [((loc, Blank loc, a), [a])] -> [((loc, Blank loc, a), [a])]
forall a. a -> [a] -> [a]
: [((loc, Blank loc, a), [a])]
l [((loc, Blank loc, a), [a])]
-> [((loc, Blank loc, a), [a])] -> [((loc, Blank loc, a), [a])]
forall a. [a] -> [a] -> [a]
++ [((loc, Blank loc, a), [a])]
r
            ([((loc, Blank loc, a), [a])], [((loc, Blank loc, a), [a])])
_ -> [Char] -> [((loc, Blank loc, a), [a])]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
      [((loc, Blank loc, a), [a])]
-> (((loc, Blank loc, a), [a]) -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [((loc, Blank loc, a), [a])]
bigList ((((loc, Blank loc, a), [a]) -> MT a loc (Result a loc) ())
 -> MT a loc (Result a loc) ())
-> (((loc, Blank loc, a), [a]) -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall a b. (a -> b) -> a -> b
$ \((loc
l, Blank loc
b, a
v), [a]
us) ->
        let pre :: [Element a loc]
pre
              | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
early = (a -> Element a loc) -> [a] -> [Element a loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Element a loc
forall v loc. v -> Element v loc
existential ([a] -> [Element a loc]) -> [a] -> [Element a loc]
forall a b. (a -> b) -> a -> b
$ [a]
cv [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [[a]] -> [a]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[a]]
vss
              | Bool
otherwise = []
            t :: Type a loc
t = loc -> [Type a loc] -> Type a loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects loc
l ((a -> Type a loc) -> [a] -> [Type a loc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (loc -> a -> Type a loc
forall v a. Ord v => a -> v -> Type v a
existentialp loc
l) ([a] -> [Type a loc]) -> [a] -> [Type a loc]
forall a b. (a -> b) -> a -> b
$ [a]
cv [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
us)
            s :: Element a loc
s = Blank loc -> a -> Monotype a loc -> Element a loc
forall v loc. Blank loc -> v -> Monotype v loc -> Element v loc
Solved Blank loc
b a
v (Type a loc -> Monotype a loc
forall v a. Type v a -> Monotype v a
Type.Monotype Type a loc
t)
         in Element a loc -> [Element a loc] -> MT a loc (Result a loc) ()
forall v loc.
(Var v, Ord loc) =>
Element v loc -> [Element v loc] -> M v loc ()
replaceContext (a -> Element a loc
forall v loc. v -> Element v loc
existential a
v) ([Element a loc]
pre [Element a loc] -> [Element a loc] -> [Element a loc]
forall a. [a] -> [a] -> [a]
++ [Element a loc
s])
      [[(Type a loc, a)]]
-> ([(Type a loc, a)] -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ [[(Type a loc, a)]]
evss (([(Type a loc, a)] -> MT a loc (Result a loc) ())
 -> MT a loc (Result a loc) ())
-> ([(Type a loc, a)] -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall a b. (a -> b) -> a -> b
$ \[(Type a loc, a)]
evs -> [(Type a loc, a)]
-> ((Type a loc, a) -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Foldable.for_ [(Type a loc, a)]
evs (((Type a loc, a) -> MT a loc (Result a loc) ())
 -> MT a loc (Result a loc) ())
-> ((Type a loc, a) -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall a b. (a -> b) -> a -> b
$ \(Type a loc
e, a
v) ->
        M a loc (Context a loc)
forall v loc. M v loc (Context v loc)
getContext M a loc (Context a loc)
-> (Context a loc -> MT a loc (Result a loc) ())
-> MT a loc (Result a loc) ()
forall a b.
MT a loc (Result a loc) a
-> (a -> MT a loc (Result a loc) b) -> MT a loc (Result a loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context a loc
ctx -> Type a loc -> Blank loc -> a -> MT a loc (Result a loc) ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (Context a loc -> Type a loc -> Type a loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context a loc
ctx Type a loc
e) Blank loc
forall loc. Blank loc
B.Blank a
v
      where
        cmp :: Context v loc -> (a, b, v) -> (a, b, v) -> Ordering
cmp Context v loc
ctx (a
_, b
_, v
u) (a
_, b
_, v
v)
          | v
u v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = Ordering
EQ
          | Context v loc -> v -> v -> Bool
forall v loc. (Var v, Ord loc) => Context v loc -> v -> v -> Bool
ordered Context v loc
ctx v
u v
v = Ordering
LT
          | Bool
otherwise = Ordering
GT
        cn :: [a]
cn | Bool
common = [a
forall v. Var v => v
Var.inferAbility] | Bool
otherwise = []

subAbilities ::
  (Var v) =>
  (Ord loc) =>
  Wanted v loc ->
  [Type v loc] ->
  M v loc ()
subAbilities :: forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc ()
subAbilities Wanted v loc
want [Type v loc]
have
  | (Text, Wanted v loc, [Type v loc]) -> Bool
forall a. Show a => a -> Bool
debugShow (Text
"subAbilities" :: Text, Wanted v loc
want, [Type v loc]
have) = M v loc ()
forall a. HasCallStack => a
undefined
subAbilities Wanted v loc
want [Type v loc]
have = do
  Wanted v loc
want <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted Wanted v loc
want
  [Type v loc]
have <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
have
  Wanted v loc
want <- Wanted v loc -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> M v loc (Wanted v loc)
expandWanted (Wanted v loc -> M v loc (Wanted v loc))
-> M v loc (Wanted v loc) -> M v loc (Wanted v loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc (Wanted v loc)
pruneAbilities Wanted v loc
want [Type v loc]
have
  [Type v loc]
have <- [Type v loc] -> M v loc [Type v loc]
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> M v loc [Type v loc]
expandAbilities [Type v loc]
have
  case (Wanted v loc
want, (Type v loc -> Maybe (Blank loc, v, Type v loc))
-> [Type v loc] -> [(Blank loc, v, Type v loc)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Type v loc -> Maybe (Blank loc, v, Type v loc)
forall {f :: * -> *} {a} {b} {a}.
Term f (TypeVar a b) a -> Maybe (a, b, Term f (TypeVar a b) a)
ex [Type v loc]
have) of
    ([], [(Blank loc, v, Type v loc)]
_) -> () -> M v loc ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (want :: Wanted v loc
want@((Maybe (Term v loc)
_, Type v loc
w) : Wanted v loc
_), [(Blank loc
b, v
ve, Type v loc
tv)]) ->
      loc -> [Type v loc] -> Blank loc -> v -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
loc -> [Type v loc] -> Blank loc -> v -> Type v loc -> M v loc ()
refineEffectVar (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
w) ((Maybe (Term v loc), Type v loc) -> Type v loc
forall a b. (a, b) -> b
snd ((Maybe (Term v loc), Type v loc) -> Type v loc)
-> Wanted v loc -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wanted v loc
want) Blank loc
b v
ve Type v loc
tv -- `orElse` die src w
    ((Maybe (Term v loc)
src, Type v loc
w) : Wanted v loc
_, [(Blank loc, v, Type v loc)]
_) -> Maybe (Term v loc) -> Type v loc -> M v loc ()
die Maybe (Term v loc)
src Type v loc
w
  where
    ex :: Term f (TypeVar a b) a -> Maybe (a, b, Term f (TypeVar a b) a)
ex t :: Term f (TypeVar a b) a
t@(Type.Var' (TypeVar.Existential a
b b
v)) = (a, b, Term f (TypeVar a b) a)
-> Maybe (a, b, Term f (TypeVar a b) a)
forall a. a -> Maybe a
Just (a
b, b
v, Term f (TypeVar a b) a
t)
    ex Term f (TypeVar a b) a
_ = Maybe (a, b, Term f (TypeVar a b) a)
forall a. Maybe a
Nothing
    die :: Maybe (Term v loc) -> Type v loc -> M v loc ()
die Maybe (Term v loc)
src Type v loc
w = (M v loc () -> M v loc ())
-> (Term v loc -> M v loc () -> M v loc ())
-> Maybe (Term v loc)
-> M v loc ()
-> M v loc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe M v loc () -> M v loc ()
forall a. a -> a
id (PathElement v loc -> M v loc () -> M v loc ()
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (PathElement v loc -> M v loc () -> M v loc ())
-> (Term v loc -> PathElement v loc)
-> Term v loc
-> M v loc ()
-> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v loc -> PathElement v loc
forall v loc. Term v loc -> PathElement v loc
InSynthesize) Maybe (Term v loc)
src do
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ()) -> Cause v loc -> M v loc ()
forall a b. (a -> b) -> a -> b
$
        [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityCheckFailure
          (Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects (Type v loc -> [Type v loc])
-> (Type v loc -> Type v loc) -> Type v loc -> [Type v loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Type v loc -> [Type v loc]) -> [Type v loc] -> [Type v loc]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Type v loc]
have)
          [Type v loc
w]
          Context v loc
ctx

-- This function deals with collecting up a list of used abilities
-- during inference. Example: when inferring `x -> Stream.emit 42`, an
-- ambient existential `e` ability is created for the lambda.  In the
-- body of the lambda, requests are made for various abilities and
-- this branch finds the first unsolved ambient ability, `e`, and
-- solves that to `{r, e'}` where `e'` is another fresh existential.
-- In this way, a lambda whose body uses multiple effects can be
-- inferred properly.
subAmbient ::
  (Var v) =>
  (Ord loc) =>
  M v loc () ->
  [Type v loc] ->
  Type v loc ->
  M v loc ()
subAmbient :: forall v loc.
(Var v, Ord loc) =>
M v loc () -> [Type v loc] -> Type v loc -> M v loc ()
subAmbient M v loc ()
die [Type v loc]
ambient Type v loc
r
  -- find unsolved existential, 'e, that appears in ambient
  | (Blank loc
b, v
e') : [(Blank loc, v)]
_ <- [(Blank loc, v)]
unsolveds = do
      -- introduce fresh existential 'e2 to context
      v
e2' <- v -> M v loc v
forall v loc. Var v => v -> M v loc v
extendExistential v
e'
      let et2 :: Type v loc
et2 = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
r) [Type v loc
r, loc -> v -> Type v loc
forall v a. Ord v => a -> v -> Type v a
existentialp (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
r) v
e2']
      Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
et2 Blank loc
b v
e' M v loc () -> M v loc () -> M v loc ()
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` M v loc ()
die
  | Bool
otherwise = M v loc ()
die
  where
    unsolveds :: [(Blank loc, v)]
unsolveds = ([Type v loc]
ambient [Type v loc] -> (Type v loc -> [Type v loc]) -> [Type v loc]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects [Type v loc]
-> (Type v loc -> [(Blank loc, v)]) -> [(Blank loc, v)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type v loc -> [(Blank loc, v)]
forall {f :: * -> *} {a} {b} {a}.
Term f (TypeVar a b) a -> [(a, b)]
vars)
    vars :: Term f (TypeVar a b) a -> [(a, b)]
vars (Type.Var' (TypeVar.Existential a
b b
v)) = [(a
b, b
v)]
    vars Term f (TypeVar a b) a
_ = []

abilityCheckSingle ::
  (Var v) =>
  (Ord loc) =>
  M v loc () ->
  [Type v loc] ->
  Type v loc ->
  M v loc ()
abilityCheckSingle :: forall v loc.
(Var v, Ord loc) =>
M v loc () -> [Type v loc] -> Type v loc -> M v loc ()
abilityCheckSingle M v loc ()
die [Type v loc]
ambient Type v loc
r
  -- Look in ambient for exact match of head of `r`
  --   Ex: given `State Nat`, `State` is the head
  --   Ex: given `IO`,        `IO` is the head
  --   Ex: given `a`, where there's an exact variable
  -- If yes for `a` in ambient, do `subtype a r` and done.
  | Just Type v loc
a <- (Type v loc -> Bool) -> [Type v loc] -> Maybe (Type v loc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
r) [Type v loc]
ambient =
      Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
a Type v loc
r M v loc () -> M v loc () -> M v loc ()
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` M v loc ()
die
  -- It's an unsolved existential, instantiate it to all of ambient
  | Type.Var' tv :: TypeVar v loc
tv@(TypeVar.Existential Blank loc
b v
v) <- Type v loc
r =
      let et2 :: Type v loc
et2 = loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
r) [Type v loc]
ambient
          acyclic :: M v loc ()
acyclic
            | TypeVar v loc -> Set (TypeVar v loc) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TypeVar v loc
tv (Type v loc -> Set (TypeVar v loc)
forall v a. Type v a -> Set v
Type.freeVars Type v loc
et2) =
                -- just need to trigger `orElse` in this case
                M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext M v loc (Context v loc)
-> (Context v loc -> M v loc ()) -> M v loc ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cause v loc -> M v loc ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> M v loc ())
-> (Context v loc -> Cause v loc) -> Context v loc -> M v loc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context v loc -> Cause v loc
forall v loc. Context v loc -> Cause v loc
TypeMismatch
            | Bool
otherwise = Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR Type v loc
et2 Blank loc
b v
v
       in -- instantiate it to `{}` if can't cover all of ambient
          M v loc ()
acyclic
            M v loc () -> M v loc () -> M v loc ()
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` Type v loc -> Blank loc -> v -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Blank loc -> v -> M v loc ()
instantiateR (loc -> [Type v loc] -> Type v loc
forall v a. Ord v => a -> [Type v a] -> Type v a
Type.effects (Type v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
loc Type v loc
r) []) Blank loc
b v
v
            M v loc () -> M v loc () -> M v loc ()
forall v loc a. M v loc a -> M v loc a -> M v loc a
`orElse` M v loc ()
die
  | Bool
otherwise = M v loc () -> [Type v loc] -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
M v loc () -> [Type v loc] -> Type v loc -> M v loc ()
subAmbient M v loc ()
die [Type v loc]
ambient Type v loc
r

headMatch :: (Var v) => (Ord loc) => Type v loc -> Type v loc -> Bool
headMatch :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch (Type.App' Type v loc
f Type v loc
_) (Type.App' Type v loc
f2 Type v loc
_) = Type v loc -> Type v loc -> Bool
forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> Bool
headMatch Type v loc
f Type v loc
f2
headMatch Type v loc
r Type v loc
r2 = Type v loc
r Type v loc -> Type v loc -> Bool
forall a. Eq a => a -> a -> Bool
== Type v loc
r2

abilityCheck' ::
  (Var v) => (Ord loc) => [Type v loc] -> [Type v loc] -> M v loc ()
abilityCheck' :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> [Type v loc] -> M v loc ()
abilityCheck' [Type v loc]
ambient0 [Type v loc]
requested0 = [Type v loc] -> [Type v loc] -> MT v loc (Result v loc) ()
go [Type v loc]
ambient0 [Type v loc]
requested0
  where
    go :: [Type v loc] -> [Type v loc] -> MT v loc (Result v loc) ()
go [Type v loc]
_ [] = () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go [Type v loc]
ambient0 (Type v loc
r0 : [Type v loc]
rs) =
      Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
r0 M v loc (Type v loc)
-> (Type v loc -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Type.Effects' [Type v loc]
es -> [Type v loc] -> [Type v loc] -> MT v loc (Result v loc) ()
go [Type v loc]
ambient0 ([Type v loc]
es [Type v loc] -> [Type v loc] -> [Type v loc]
forall a. [a] -> [a] -> [a]
++ [Type v loc]
rs)
        Type v loc
r -> do
          [Type v loc]
ambient <-
            (Type v loc -> [Type v loc]) -> [Type v loc] -> [Type v loc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type v loc -> [Type v loc]
forall v a. Type v a -> [Type v a]
Type.flattenEffects
              ([Type v loc] -> [Type v loc])
-> MT v loc (Result v loc) [Type v loc]
-> MT v loc (Result v loc) [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type v loc -> M v loc (Type v loc))
-> [Type v loc] -> MT v loc (Result v loc) [Type v loc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM [Type v loc]
ambient0
          MT v loc (Result v loc) ()
-> [Type v loc] -> Type v loc -> MT v loc (Result v loc) ()
forall v loc.
(Var v, Ord loc) =>
M v loc () -> [Type v loc] -> Type v loc -> M v loc ()
abilityCheckSingle MT v loc (Result v loc) ()
die [Type v loc]
ambient Type v loc
r
          [Type v loc] -> [Type v loc] -> MT v loc (Result v loc) ()
go [Type v loc]
ambient [Type v loc]
rs

    die :: MT v loc (Result v loc) ()
die = do
      Context v loc
ctx <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
      Cause v loc -> MT v loc (Result v loc) ()
forall v loc a. Cause v loc -> M v loc a
failWith (Cause v loc -> MT v loc (Result v loc) ())
-> Cause v loc -> MT v loc (Result v loc) ()
forall a b. (a -> b) -> a -> b
$
        [Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
forall v loc.
[Type v loc] -> [Type v loc] -> Context v loc -> Cause v loc
AbilityCheckFailure
          (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Type v loc -> Type v loc) -> [Type v loc] -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
ambient0)
          (Context v loc -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v loc
ctx (Type v loc -> Type v loc) -> [Type v loc] -> [Type v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type v loc]
requested0)
          Context v loc
ctx

verifyDataDeclarations :: (Var v, Ord loc) => DataDeclarations v loc -> Result v loc ()
verifyDataDeclarations :: forall v loc.
(Var v, Ord loc) =>
DataDeclarations v loc -> Result v loc ()
verifyDataDeclarations DataDeclarations v loc
decls = [(Reference, DataDeclaration v loc)]
-> ((Reference, DataDeclaration v loc) -> Result v loc ())
-> Result v loc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DataDeclarations v loc -> [(Reference, DataDeclaration v loc)]
forall k a. Map k a -> [(k, a)]
Map.toList DataDeclarations v loc
decls) (((Reference, DataDeclaration v loc) -> Result v loc ())
 -> Result v loc ())
-> ((Reference, DataDeclaration v loc) -> Result v loc ())
-> Result v loc ()
forall a b. (a -> b) -> a -> b
$ \(Reference
_ref, DataDeclaration v loc
decl) -> do
  let ctors :: [(v, Type v loc)]
ctors = DataDeclaration v loc -> [(v, Type v loc)]
forall v a. DataDeclaration v a -> [(v, Type v a)]
DD.constructors DataDeclaration v loc
decl
  [(v, Type v loc)]
-> ((v, Type v loc) -> Result v loc Bool) -> Result v loc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(v, Type v loc)]
ctors (((v, Type v loc) -> Result v loc Bool) -> Result v loc ())
-> ((v, Type v loc) -> Result v loc Bool) -> Result v loc ()
forall a b. (a -> b) -> a -> b
$ \(v
_ctorName, Type v loc
typ) -> Type v loc -> (v -> v) -> Result v loc Bool
forall (f :: * -> *) v a v2.
(Traversable f, Ord v) =>
Term f v a -> (v -> v2) -> Result v2 a Bool
verifyClosed Type v loc
typ v -> v
forall a. a -> a
id

-- | public interface to the typechecker
synthesizeClosed ::
  (BuiltinAnnotation loc, Var v, Ord loc, Show loc) =>
  PrettyPrintEnv ->
  PatternMatchCoverageCheckAndKindInferenceSwitch ->
  [Type v loc] ->
  TL.TypeLookup v loc ->
  Term v loc ->
  Result v loc (Type v loc)
synthesizeClosed :: forall loc v.
(BuiltinAnnotation loc, Var v, Ord loc, Show loc) =>
PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> [Type v loc]
-> TypeLookup v loc
-> Term v loc
-> Result v loc (Type v loc)
synthesizeClosed PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch [Type v loc]
abilities TypeLookup v loc
lookupType Term v loc
term0 =
  let datas :: Map Reference (DataDeclaration v loc)
datas = TypeLookup v loc -> Map Reference (DataDeclaration v loc)
forall v a. TypeLookup v a -> Map Reference (DataDeclaration v a)
TL.dataDecls TypeLookup v loc
lookupType
      effects :: Map Reference (EffectDeclaration v loc)
effects = TypeLookup v loc -> Map Reference (EffectDeclaration v loc)
forall v a. TypeLookup v a -> Map Reference (EffectDeclaration v a)
TL.effectDecls TypeLookup v loc
lookupType
      term :: Either Reference (Term v loc)
term = (Reference -> Either Reference (Type v loc))
-> Term v loc -> Either Reference (Term v loc)
forall (f :: * -> *) v loc.
(Applicative f, Var v) =>
(Reference -> f (Type v loc)) -> Term v loc -> f (Term v loc)
annotateRefs (TypeLookup v loc -> Reference -> Either Reference (Type v loc)
forall v a.
TypeLookup v a -> Reference -> Either Reference (Type v a)
TL.typeOfTerm' TypeLookup v loc
lookupType) Term v loc
term0
   in case Either Reference (Term v loc)
term of
        Left Reference
missingRef ->
          CompilerBug v loc -> Result v loc (Type v loc)
forall v loc a. CompilerBug v loc -> Result v loc a
compilerCrashResult (Reference -> CompilerBug v loc
forall v loc. Reference -> CompilerBug v loc
UnknownTermReference Reference
missingRef)
        Right Term v loc
term -> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> Map Reference (DataDeclaration v loc)
-> Map Reference (EffectDeclaration v loc)
-> MT v loc (Result v loc) (Type v loc)
-> Result v loc (Type v loc)
forall v loc (f :: * -> *) a.
(Var v, Ord loc, Functor f) =>
PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc f a
-> f a
run PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch Map Reference (DataDeclaration v loc)
datas Map Reference (EffectDeclaration v loc)
effects (MT v loc (Result v loc) (Type v loc) -> Result v loc (Type v loc))
-> MT v loc (Result v loc) (Type v loc)
-> Result v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$ do
          Result v loc () -> M v loc ()
forall v loc a. Result v loc a -> M v loc a
liftResult (Result v loc () -> M v loc ()) -> Result v loc () -> M v loc ()
forall a b. (a -> b) -> a -> b
$
            Map Reference (DataDeclaration v loc) -> Result v loc ()
forall v loc.
(Var v, Ord loc) =>
DataDeclarations v loc -> Result v loc ()
verifyDataDeclarations Map Reference (DataDeclaration v loc)
datas
              Result v loc () -> Result v loc () -> Result v loc ()
forall a b. Result v loc a -> Result v loc b -> Result v loc b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Reference (DataDeclaration v loc) -> Result v loc ()
forall v loc.
(Var v, Ord loc) =>
DataDeclarations v loc -> Result v loc ()
verifyDataDeclarations (EffectDeclaration v loc -> DataDeclaration v loc
forall v a. EffectDeclaration v a -> DataDeclaration v a
DD.toDataDecl (EffectDeclaration v loc -> DataDeclaration v loc)
-> Map Reference (EffectDeclaration v loc)
-> Map Reference (DataDeclaration v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Reference (EffectDeclaration v loc)
effects)
              Result v loc () -> Result v loc () -> Result v loc ()
forall a b. Result v loc a -> Result v loc b -> Result v loc b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Term v loc -> Result v loc ()
forall v loc. Ord v => Term v loc -> Result v loc ()
verifyClosedTerm Term v loc
term
          PrettyPrintEnv
-> Map Reference (DataDeclaration v loc)
-> Map Reference (EffectDeclaration v loc)
-> Term v loc
-> M v loc ()
forall v loc.
(Var v, Ord loc, BuiltinAnnotation loc, Show loc) =>
PrettyPrintEnv
-> DataDeclarations v loc
-> Map Reference (EffectDeclaration v loc)
-> Term v loc
-> MT v loc (Result v loc) ()
doKindInference PrettyPrintEnv
ppe Map Reference (DataDeclaration v loc)
datas Map Reference (EffectDeclaration v loc)
effects Term v loc
term
          [Type v loc] -> Term v loc -> MT v loc (Result v loc) (Type v loc)
forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> M v loc (Type v loc)
synthesizeClosed' [Type v loc]
abilities Term v loc
term

doKindInference ::
  ( Var v,
    Ord loc,
    BuiltinAnnotation loc,
    Show loc
  ) =>
  PrettyPrintEnv ->
  DataDeclarations v loc ->
  Map Reference (EffectDeclaration v loc) ->
  Term v loc ->
  MT v loc (Result v loc) ()
doKindInference :: forall v loc.
(Var v, Ord loc, BuiltinAnnotation loc, Show loc) =>
PrettyPrintEnv
-> DataDeclarations v loc
-> Map Reference (EffectDeclaration v loc)
-> Term v loc
-> MT v loc (Result v loc) ()
doKindInference PrettyPrintEnv
ppe DataDeclarations v loc
datas Map Reference (EffectDeclaration v loc)
effects Term v loc
term = do
  M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
forall v loc.
M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
getPatternMatchCoverageCheckAndKindInferenceSwitch M v loc PatternMatchCoverageCheckAndKindInferenceSwitch
-> (PatternMatchCoverageCheckAndKindInferenceSwitch
    -> MT v loc (Result v loc) ())
-> MT v loc (Result v loc) ()
forall a b.
MT v loc (Result v loc) a
-> (a -> MT v loc (Result v loc) b) -> MT v loc (Result v loc) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Disabled -> () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled -> do
      let kindInferRes :: Either (NonEmpty (KindError v loc)) ()
kindInferRes = do
            let decls :: Map
  Reference
  (Either (EffectDeclaration v loc) (DataDeclaration v loc))
decls = (EffectDeclaration v loc
-> Either (EffectDeclaration v loc) (DataDeclaration v loc)
forall a b. a -> Either a b
Left (EffectDeclaration v loc
 -> Either (EffectDeclaration v loc) (DataDeclaration v loc))
-> Map Reference (EffectDeclaration v loc)
-> Map
     Reference
     (Either (EffectDeclaration v loc) (DataDeclaration v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Reference (EffectDeclaration v loc)
effects) Map
  Reference
  (Either (EffectDeclaration v loc) (DataDeclaration v loc))
-> Map
     Reference
     (Either (EffectDeclaration v loc) (DataDeclaration v loc))
-> Map
     Reference
     (Either (EffectDeclaration v loc) (DataDeclaration v loc))
forall a. Semigroup a => a -> a -> a
<> (DataDeclaration v loc
-> Either (EffectDeclaration v loc) (DataDeclaration v loc)
forall a b. b -> Either a b
Right (DataDeclaration v loc
 -> Either (EffectDeclaration v loc) (DataDeclaration v loc))
-> DataDeclarations v loc
-> Map
     Reference
     (Either (EffectDeclaration v loc) (DataDeclaration v loc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataDeclarations v loc
datas)
            SolveState v loc
st <- PrettyPrintEnv
-> Map
     Reference
     (Either (EffectDeclaration v loc) (DataDeclaration v loc))
-> Either (NonEmpty (KindError v loc)) (SolveState v loc)
forall v loc.
(Var v, BuiltinAnnotation loc, Ord loc, Show loc) =>
PrettyPrintEnv
-> Map Reference (Decl v loc)
-> Either (NonEmpty (KindError v loc)) (SolveState v loc)
KindInference.inferDecls PrettyPrintEnv
ppe Map
  Reference
  (Either (EffectDeclaration v loc) (DataDeclaration v loc))
decls
            PrettyPrintEnv
-> SolveState v loc
-> Term v loc
-> Either (NonEmpty (KindError v loc)) ()
forall v loc.
(Var v, Ord loc, Show loc, BuiltinAnnotation loc) =>
PrettyPrintEnv
-> SolveState v loc
-> Term v loc
-> Either (NonEmpty (KindError v loc)) ()
KindInference.kindCheckAnnotations PrettyPrintEnv
ppe SolveState v loc
st (Term v loc -> Term v loc
forall v b a. Ord v => Term' (TypeVar b v) v a -> Term v a
TypeVar.lowerTerm Term v loc
term)
      case Either (NonEmpty (KindError v loc)) ()
kindInferRes of
        Left (KindError v loc
ke Nel.:| [KindError v loc]
_kes) -> Cause v loc -> MT v loc (Result v loc) ()
forall v loc a. Cause v loc -> M v loc a
failWith (KindError v loc -> Cause v loc
forall v loc. KindError v loc -> Cause v loc
KindInferenceFailure KindError v loc
ke)
        Right () -> () -> MT v loc (Result v loc) ()
forall a. a -> MT v loc (Result v loc) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

verifyClosedTerm :: forall v loc. (Ord v) => Term v loc -> Result v loc ()
verifyClosedTerm :: forall v loc. Ord v => Term v loc -> Result v loc ()
verifyClosedTerm Term v loc
t = do
  Bool
ok1 <- Term v loc -> (v -> v) -> Result v loc Bool
forall (f :: * -> *) v a v2.
(Traversable f, Ord v) =>
Term f v a -> (v -> v2) -> Result v2 a Bool
verifyClosed Term v loc
t v -> v
forall a. a -> a
id
  let freeTypeVars :: [(TypeVar v loc, [loc])]
freeTypeVars = Map (TypeVar v loc) [loc] -> [(TypeVar v loc, [loc])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (TypeVar v loc) [loc] -> [(TypeVar v loc, [loc])])
-> Map (TypeVar v loc) [loc] -> [(TypeVar v loc, [loc])]
forall a b. (a -> b) -> a -> b
$ Term v loc -> Map (TypeVar v loc) [loc]
forall vt v a. Ord vt => Term' vt v a -> Map vt [a]
Term.freeTypeVarAnnotations Term v loc
t
      reportError :: (TypeVar b v, t loc) -> Result v loc ()
reportError (TypeVar b v
v, t loc
locs) = t loc -> (loc -> Result v loc Any) -> Result v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t loc
locs ((loc -> Result v loc Any) -> Result v loc ())
-> (loc -> Result v loc Any) -> Result v loc ()
forall a b. (a -> b) -> a -> b
$ \loc
loc ->
        Cause v loc -> Result v loc Any
forall v loc a. Cause v loc -> Result v loc a
typeError (loc -> v -> Cause v loc
forall v loc. loc -> v -> Cause v loc
UnknownSymbol loc
loc (TypeVar b v -> v
forall b v. TypeVar b v -> v
TypeVar.underlying TypeVar b v
v))
  [(TypeVar v loc, [loc])]
-> ((TypeVar v loc, [loc]) -> Result v loc ()) -> Result v loc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(TypeVar v loc, [loc])]
freeTypeVars (TypeVar v loc, [loc]) -> Result v loc ()
forall {t :: * -> *} {b} {v} {loc}.
Foldable t =>
(TypeVar b v, t loc) -> Result v loc ()
reportError
  Bool -> Result v loc () -> Result v loc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ok1 Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool)
-> ([(TypeVar v loc, [loc])] -> Bool)
-> [(TypeVar v loc, [loc])]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TypeVar v loc, [loc])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [(TypeVar v loc, [loc])]
freeTypeVars) (Result v loc () -> Result v loc ())
-> Result v loc () -> Result v loc ()
forall a b. (a -> b) -> a -> b
$ CompilerBug v loc -> Result v loc ()
forall v loc a. CompilerBug v loc -> Result v loc a
compilerBug ([Char] -> CompilerBug v loc
forall v loc. [Char] -> CompilerBug v loc
OtherBug [Char]
"impossible")

verifyClosed :: (Traversable f, Ord v) => ABT.Term f v a -> (v -> v2) -> Result v2 a Bool
verifyClosed :: forall (f :: * -> *) v a v2.
(Traversable f, Ord v) =>
Term f v a -> (v -> v2) -> Result v2 a Bool
verifyClosed Term f v a
t v -> v2
toV2 =
  let isBoundIn :: a -> Term f v (a, Set a) -> Bool
isBoundIn a
v Term f v (a, Set a)
t = a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
v ((a, Set a) -> Set a
forall a b. (a, b) -> b
snd (Term f v (a, Set a) -> (a, Set a)
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term f v (a, Set a)
t))
      loc :: Term f v (a, b) -> a
loc Term f v (a, b)
t = (a, b) -> a
forall a b. (a, b) -> a
fst (Term f v (a, b) -> (a, b)
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term f v (a, b)
t)
      go :: Term f v (a, Set v) -> Result v2 a Bool
go t :: Term f v (a, Set v)
t@(ABT.Var' v
v) | Bool -> Bool
not (v -> Term f v (a, Set v) -> Bool
forall {a} {f :: * -> *} {v} {a}.
Ord a =>
a -> Term f v (a, Set a) -> Bool
isBoundIn v
v Term f v (a, Set v)
t) = Cause v2 a -> Result v2 a Bool
forall v loc a. Cause v loc -> Result v loc a
typeError (a -> v2 -> Cause v2 a
forall v loc. loc -> v -> Cause v loc
UnknownSymbol (Term f v (a, Set v) -> a
forall {f :: * -> *} {v} {a} {b}. Term f v (a, b) -> a
loc Term f v (a, Set v)
t) (v2 -> Cause v2 a) -> v2 -> Cause v2 a
forall a b. (a -> b) -> a -> b
$ v -> v2
toV2 v
v)
      go Term f v (a, Set v)
_ = Bool -> Result v2 a Bool
forall a. a -> Result v2 a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
   in (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id ([Bool] -> Bool) -> Result v2 a [Bool] -> Result v2 a Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term f v (a, Set v) -> Result v2 a Bool)
-> Term f v (a, Set v) -> Result v2 a [Bool]
forall (f :: * -> *) (g :: * -> *) v a b.
(Traversable f, Applicative g) =>
(Term f v a -> g b) -> Term f v a -> g [b]
ABT.foreachSubterm Term f v (a, Set v) -> Result v2 a Bool
go (Term f v a -> Term f v (a, Set v)
forall v (f :: * -> *) a.
(Ord v, Foldable f, Functor f) =>
Term f v a -> Term f v (a, Set v)
ABT.annotateBound Term f v a
t)

annotateRefs ::
  (Applicative f, Var v) =>
  (Reference -> f (Type.Type v loc)) ->
  Term v loc ->
  f (Term v loc)
annotateRefs :: forall (f :: * -> *) v loc.
(Applicative f, Var v) =>
(Reference -> f (Type v loc)) -> Term v loc -> f (Term v loc)
annotateRefs Reference -> f (Type v loc)
synth = (Term (F (TypeVar v loc) loc loc) v loc
 -> Maybe (f (Term (F (TypeVar v loc) loc loc) v loc)))
-> Term (F (TypeVar v loc) loc loc) v loc
-> f (Term (F (TypeVar v loc) loc loc) v loc)
forall (f :: * -> *) (g :: * -> *) v a.
(Traversable f, Applicative g, Ord v) =>
(Term f v a -> Maybe (g (Term f v a)))
-> Term f v a -> g (Term f v a)
ABT.visit Term (F (TypeVar v loc) loc loc) v loc
-> Maybe (f (Term (F (TypeVar v loc) loc loc) v loc))
f
  where
    f :: Term (F (TypeVar v loc) loc loc) v loc
-> Maybe (f (Term (F (TypeVar v loc) loc loc) v loc))
f r :: Term (F (TypeVar v loc) loc loc) v loc
r@(Term.Ref' Reference
h) = f (Term (F (TypeVar v loc) loc loc) v loc)
-> Maybe (f (Term (F (TypeVar v loc) loc loc) v loc))
forall a. a -> Maybe a
Just (loc
-> Term (F (TypeVar v loc) loc loc) v loc
-> Type (TypeVar v loc) loc
-> Term (F (TypeVar v loc) loc loc) v loc
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann loc
ra (loc -> Reference -> Term (F (TypeVar v loc) loc loc) v loc
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
Term.ref loc
ra Reference
h) (Type (TypeVar v loc) loc
 -> Term (F (TypeVar v loc) loc loc) v loc)
-> f (Type (TypeVar v loc) loc)
-> f (Term (F (TypeVar v loc) loc loc) v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type v loc -> Type (TypeVar v loc) loc
forall {f :: * -> *} {v} {a} {b}.
(Functor f, Foldable f, Ord v) =>
Term f v a -> Term f (TypeVar b v) a
ge (Type v loc -> Type (TypeVar v loc) loc)
-> f (Type v loc) -> f (Type (TypeVar v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> f (Type v loc)
synth Reference
h))
      where
        ra :: loc
ra = Term (F (TypeVar v loc) loc loc) v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term (F (TypeVar v loc) loc loc) v loc
r
        ge :: Term f v a -> Term f (TypeVar b v) a
ge Term f v a
t = (v -> TypeVar b v) -> Term f v a -> Term f (TypeVar b v) a
forall (f :: * -> *) v' v a.
(Functor f, Foldable f, Ord v') =>
(v -> v') -> Term f v a -> Term f v' a
ABT.vmap v -> TypeVar b v
forall b v. v -> TypeVar b v
TypeVar.Universal (Term f v a -> Term f (TypeVar b v) a)
-> Term f v a -> Term f (TypeVar b v) a
forall a b. (a -> b) -> a -> b
$ Term f v a
t
    f Term (F (TypeVar v loc) loc loc) v loc
_ = Maybe (f (Term (F (TypeVar v loc) loc loc) v loc))
forall a. Maybe a
Nothing

run ::
  (Var v, Ord loc, Functor f) =>
  PrettyPrintEnv ->
  PatternMatchCoverageCheckAndKindInferenceSwitch ->
  DataDeclarations v loc ->
  EffectDeclarations v loc ->
  MT v loc f a ->
  f a
run :: forall v loc (f :: * -> *) a.
(Var v, Ord loc, Functor f) =>
PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc f a
-> f a
run PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects MT v loc f a
m =
  ((a, Env v loc) -> a) -> f (a, Env v loc) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Env v loc) -> a
forall a b. (a, b) -> a
fst
    (f (a, Env v loc) -> f a)
-> (Env v loc -> f (a, Env v loc)) -> Env v loc -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM MT v loc f a
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmcSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects
    (Env v loc -> f a) -> Env v loc -> f a
forall a b. (a -> b) -> a -> b
$ Word64 -> Context v loc -> Env v loc
forall v loc. Word64 -> Context v loc -> Env v loc
Env Word64
1 Context v loc
forall v loc. Context v loc
context0

synthesizeClosed' ::
  (Var v, Ord loc) =>
  [Type v loc] ->
  Term v loc ->
  M v loc (Type v loc)
synthesizeClosed' :: forall v loc.
(Var v, Ord loc) =>
[Type v loc] -> Term v loc -> M v loc (Type v loc)
synthesizeClosed' [Type v loc]
abilities Term v loc
term = do
  -- save current context, for restoration when done
  Context v loc
ctx0 <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
forall v loc. Context v loc
context0
  (Type v loc
t, [Element v loc]
ctx) <- v -> M v loc (Type v loc) -> M v loc (Type v loc, [Element v loc])
forall v loc a.
(Var v, Ord loc) =>
v -> M v loc a -> M v loc (a, [Element v loc])
markThenRetract (Text -> v
forall v. Var v => Text -> v
Var.named Text
"start") (M v loc (Type v loc) -> M v loc (Type v loc, [Element v loc]))
-> M v loc (Type v loc) -> M v loc (Type v loc, [Element v loc])
forall a b. (a -> b) -> a -> b
$ do
    -- retract will cause notes to be written out for
    -- any `Blank`-tagged existentials passing out of scope
    (Type v loc
t, Wanted v loc
want) <- Term v loc -> M v loc (Type v loc, Wanted v loc)
forall v loc.
(Var v, Ord loc) =>
Term v loc -> M v loc (Type v loc, Wanted v loc)
synthesize Term v loc
term
    PathElement v loc -> M v loc (Type v loc) -> M v loc (Type v loc)
forall v loc a. PathElement v loc -> M v loc a -> M v loc a
scope (Term v loc -> PathElement v loc
forall v loc. Term v loc -> PathElement v loc
InSynthesize Term v loc
term) (M v loc (Type v loc) -> M v loc (Type v loc))
-> M v loc (Type v loc) -> M v loc (Type v loc)
forall a b. (a -> b) -> a -> b
$
      Type v loc
t Type v loc -> M v loc () -> M v loc (Type v loc)
forall a b.
a -> MT v loc (Result v loc) b -> MT v loc (Result v loc) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Wanted v loc -> [Type v loc] -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Wanted v loc -> [Type v loc] -> M v loc ()
subAbilities Wanted v loc
want [Type v loc]
abilities
  Context v loc -> M v loc ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx0 -- restore the initial context
  pure $ [Element v loc] -> Type v loc -> Type v loc
forall v loc.
(Var v, Ord loc) =>
[Element v loc] -> Type v loc -> Type v loc
generalizeExistentials [Element v loc]
ctx Type v loc
t

-- Check if the given typechecking action succeeds.
succeeds :: M v loc a -> TotalM v loc Bool
succeeds :: forall v loc a. M v loc a -> TotalM v loc Bool
succeeds M v loc a
m =
  (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> Either (CompilerBug v loc) (Bool, Env v loc))
-> MT v loc (Either (CompilerBug v loc)) Bool
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env ->
    case M v loc a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> Result v loc (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM M v loc a
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env of
      Success Seq (InfoNote v loc)
_ (a, Env v loc)
_ -> (Bool, Env v loc) -> Either (CompilerBug v loc) (Bool, Env v loc)
forall a b. b -> Either a b
Right (Bool
True, Env v loc
env)
      TypeError NESeq (ErrorNote v loc)
_ Seq (InfoNote v loc)
_ -> (Bool, Env v loc) -> Either (CompilerBug v loc) (Bool, Env v loc)
forall a b. b -> Either a b
Right (Bool
False, Env v loc
env)
      CompilerBug CompilerBug v loc
bug Seq (ErrorNote v loc)
_ Seq (InfoNote v loc)
_ -> CompilerBug v loc -> Either (CompilerBug v loc) (Bool, Env v loc)
forall a b. a -> Either a b
Left CompilerBug v loc
bug

-- Check if `t1` is a subtype of `t2`. Doesn't update the typechecking context.
isSubtype' :: (Var v, Ord loc) => Type v loc -> Type v loc -> TotalM v loc Bool
isSubtype' :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> TotalM v loc Bool
isSubtype' Type v loc
type1 Type v loc
type2 = M v loc () -> TotalM v loc Bool
forall v loc a. M v loc a -> TotalM v loc Bool
succeeds (M v loc () -> TotalM v loc Bool)
-> M v loc () -> TotalM v loc Bool
forall a b. (a -> b) -> a -> b
$ do
  let vars :: [TypeVar v loc]
vars = Set (TypeVar v loc) -> [TypeVar v loc]
forall a. Set a -> [a]
Set.toList (Set (TypeVar v loc) -> [TypeVar v loc])
-> Set (TypeVar v loc) -> [TypeVar v loc]
forall a b. (a -> b) -> a -> b
$ Set (TypeVar v loc) -> Set (TypeVar v loc) -> Set (TypeVar v loc)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v loc
type1) (Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v loc
type2)
  [v] -> M v loc ()
forall v (t :: * -> *) loc.
(Var v, Foldable t) =>
t v -> M v loc ()
reserveAll (TypeVar v loc -> v
forall b v. TypeVar b v -> v
TypeVar.underlying (TypeVar v loc -> v) -> [TypeVar v loc] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeVar v loc]
vars)
  [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext (TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (TypeVar v loc -> Element v loc)
-> [TypeVar v loc] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeVar v loc]
vars)
  Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
type1 Type v loc
type2

-- See documentation at 'Unison.Typechecker.fitsScheme'
fitsScheme :: (Var v, Ord loc) => Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
fitsScheme :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
fitsScheme Type v loc
type1 Type v loc
type2 = PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc (Either (CompilerBug v loc)) Bool
-> Either (CompilerBug v loc) Bool
forall v loc (f :: * -> *) a.
(Var v, Ord loc, Functor f) =>
PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc f a
-> f a
run PrettyPrintEnv
PPE.empty PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled DataDeclarations v loc
forall k a. Map k a
Map.empty EffectDeclarations v loc
forall k a. Map k a
Map.empty (MT v loc (Either (CompilerBug v loc)) Bool
 -> Either (CompilerBug v loc) Bool)
-> MT v loc (Either (CompilerBug v loc)) Bool
-> Either (CompilerBug v loc) Bool
forall a b. (a -> b) -> a -> b
$
  M v loc () -> MT v loc (Either (CompilerBug v loc)) Bool
forall v loc a. M v loc a -> TotalM v loc Bool
succeeds (M v loc () -> MT v loc (Either (CompilerBug v loc)) Bool)
-> M v loc () -> MT v loc (Either (CompilerBug v loc)) Bool
forall a b. (a -> b) -> a -> b
$ do
    let vars :: [TypeVar v loc]
vars = Set (TypeVar v loc) -> [TypeVar v loc]
forall a. Set a -> [a]
Set.toList (Set (TypeVar v loc) -> [TypeVar v loc])
-> Set (TypeVar v loc) -> [TypeVar v loc]
forall a b. (a -> b) -> a -> b
$ Set (TypeVar v loc) -> Set (TypeVar v loc) -> Set (TypeVar v loc)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v loc
type1) (Type v loc -> Set (TypeVar v loc)
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Type v loc
type2)
    [v] -> M v loc ()
forall v (t :: * -> *) loc.
(Var v, Foldable t) =>
t v -> M v loc ()
reserveAll (TypeVar v loc -> v
forall b v. TypeVar b v -> v
TypeVar.underlying (TypeVar v loc -> v) -> [TypeVar v loc] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeVar v loc]
vars)
    [Element v loc] -> M v loc ()
forall v loc. (Var v, Ord loc) => [Element v loc] -> M v loc ()
appendContext (TypeVar v loc -> Element v loc
forall v loc. TypeVar v loc -> Element v loc
Var (TypeVar v loc -> Element v loc)
-> [TypeVar v loc] -> [Element v loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeVar v loc]
vars)
    Type v loc
type2 <- Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
ungeneralize Type v loc
type2
    Type v loc -> Type v loc -> M v loc ()
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc ()
subtype Type v loc
type1 Type v loc
type2

-- `isRedundant userType inferredType` returns `True` if the `userType`
-- is equal "up to inferred abilities" to `inferredType`.
--
-- Example: `userType` is `Nat -> Nat`, `inferredType` is `∀ a . a ->{IO} a`.
--           In this case, the signature isn't redundant, and we return
--           `False`.
-- Example: `userType` is (`∀ a . a -> a`) and inferred is `∀ z e . z ->{e} z`.
--           In this case, the signature IS redundant, and we return `True`.
isRedundant ::
  (Var v, Ord loc) =>
  Type v loc ->
  Type v loc ->
  M v loc Bool
isRedundant :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> M v loc Bool
isRedundant Type v loc
userType0 Type v loc
inferredType0 = do
  Context v loc
ctx0 <- M v loc (Context v loc)
forall v loc. M v loc (Context v loc)
getContext
  -- the inferred type may have some unsolved existentials, which we generalize over
  -- before doing the comparison, otherwise it will just test equal to any
  -- concrete instantiation of those existentials. For instance, the
  -- inferred type `a -> a` for a existential `a` should get generalized
  -- to `∀ a . a -> a` before comparison to `Nat -> Nat`, otherwise the
  -- typechecker will solve `a = Nat` and call the types equal!
  Type v loc
userType <- Type v loc -> M v loc (Type v loc)
forall v loc. Var v => Type v loc -> M v loc (Type v loc)
existentializeArrows Type v loc
userType0
  Type v loc
inferredType <- Type v loc -> Type v loc
forall v a. Var v => Type v a -> Type v a
generalizeExistentials' (Type v loc -> Type v loc)
-> M v loc (Type v loc) -> M v loc (Type v loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> M v loc (Type v loc)
forall v loc.
(Var v, Ord loc) =>
Type v loc -> M v loc (Type v loc)
applyM Type v loc
inferredType0
  -- We already know `inferred <: userType`, otherwise the user's given
  -- type would have caused the program not to typecheck! Ex: if user writes
  -- `: Nat -> Nat` when it has an inferred type of `a -> a`. So we only
  -- need to check the other direction to determine redundancy.
  (TotalM v loc Bool -> M v loc Bool
forall v loc a. TotalM v loc a -> M v loc a
liftTotalM (TotalM v loc Bool -> M v loc Bool)
-> TotalM v loc Bool -> M v loc Bool
forall a b. (a -> b) -> a -> b
$ Type v loc -> Type v loc -> TotalM v loc Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> TotalM v loc Bool
isSubtype' Type v loc
userType Type v loc
inferredType) M v loc Bool -> MT v loc (Result v loc) () -> M v loc Bool
forall a b.
MT v loc (Result v loc) a
-> MT v loc (Result v loc) b -> MT v loc (Result v loc) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Context v loc -> MT v loc (Result v loc) ()
forall v loc. Context v loc -> M v loc ()
setContext Context v loc
ctx0

-- Public interface to `isSubtype`
isSubtype ::
  (Var v, Ord loc) => Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isSubtype :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isSubtype Type v loc
t1 Type v loc
t2 =
  PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc (Either (CompilerBug v loc)) Bool
-> Either (CompilerBug v loc) Bool
forall v loc (f :: * -> *) a.
(Var v, Ord loc, Functor f) =>
PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> MT v loc f a
-> f a
run PrettyPrintEnv
PPE.empty PatternMatchCoverageCheckAndKindInferenceSwitch
PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled DataDeclarations v loc
forall k a. Map k a
Map.empty EffectDeclarations v loc
forall k a. Map k a
Map.empty (Type v loc
-> Type v loc -> MT v loc (Either (CompilerBug v loc)) Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> TotalM v loc Bool
isSubtype' Type v loc
t1 Type v loc
t2)

isEqual ::
  (Var v, Ord loc) => Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isEqual :: forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isEqual Type v loc
t1 Type v loc
t2 =
  Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> Either (CompilerBug v loc) Bool
-> Either (CompilerBug v loc) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isSubtype Type v loc
t1 Type v loc
t2 Either (CompilerBug v loc) (Bool -> Bool)
-> Either (CompilerBug v loc) Bool
-> Either (CompilerBug v loc) Bool
forall a b.
Either (CompilerBug v loc) (a -> b)
-> Either (CompilerBug v loc) a -> Either (CompilerBug v loc) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
forall v loc.
(Var v, Ord loc) =>
Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool
isSubtype Type v loc
t2 Type v loc
t1

instance (Var v) => Show (Element v loc) where
  show :: Element v loc -> [Char]
show (Var TypeVar v loc
v) = case TypeVar v loc
v of
    TypeVar.Universal v
x -> [Char]
"@" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
x
    TypeVar v loc
e -> TypeVar v loc -> [Char]
forall a. Show a => a -> [Char]
show TypeVar v loc
e
  show (Solved Blank loc
_ v
v Monotype v loc
t) = [Char]
"'" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Width -> PrettyPrintEnv -> Type (TypeVar v loc) loc -> [Char]
forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
TP.prettyStr Maybe Width
forall a. Maybe a
Nothing PrettyPrintEnv
PPE.empty (Monotype v loc -> Type (TypeVar v loc) loc
forall v a. Monotype v a -> Type v a
Type.getPolytype Monotype v loc
t)
  show (Ann v
v Type (TypeVar v loc) loc
t) =
    Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v)
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" : "
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Width -> PrettyPrintEnv -> Type (TypeVar v loc) loc -> [Char]
forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
TP.prettyStr Maybe Width
forall a. Maybe a
Nothing PrettyPrintEnv
PPE.empty Type (TypeVar v loc) loc
t
  show (Marker v
v) = [Char]
"|" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"|"

instance (Ord loc, Var v) => Show (Context v loc) where
  show :: Context v loc -> [Char]
show ctx :: Context v loc
ctx@(Context [(Element v loc, Info v loc)]
es) = [Char]
"Γ\n  " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n  " ([[Char]] -> [Char])
-> ([(Element v loc, Info v loc)] -> [[Char]])
-> [(Element v loc, Info v loc)]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Element v loc, Info v loc) -> [Char])
-> [(Element v loc, Info v loc)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Context v loc -> Element v loc -> [Char]
forall {v} {a}.
(Var v, Ord a) =>
Context v a -> Element v a -> [Char]
showElem Context v loc
ctx (Element v loc -> [Char])
-> ((Element v loc, Info v loc) -> Element v loc)
-> (Element v loc, Info v loc)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element v loc, Info v loc) -> Element v loc
forall a b. (a, b) -> a
fst)) ([(Element v loc, Info v loc)] -> [(Element v loc, Info v loc)]
forall a. [a] -> [a]
reverse [(Element v loc, Info v loc)]
es)
    where
      showElem :: Context v a -> Element v a -> [Char]
showElem Context v a
_ctx (Var TypeVar v a
v) = case TypeVar v a
v of
        TypeVar.Universal v
x -> [Char]
"@" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> [Char]
forall a. Show a => a -> [Char]
show v
x
        TypeVar v a
e -> TypeVar v a -> [Char]
forall a. Show a => a -> [Char]
show TypeVar v a
e
      showElem Context v a
ctx (Solved Blank a
_ v
v (Type.Monotype Type (TypeVar v a) a
t)) = [Char]
"'" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Width -> PrettyPrintEnv -> Type (TypeVar v a) a -> [Char]
forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
TP.prettyStr Maybe Width
forall a. Maybe a
Nothing PrettyPrintEnv
PPE.empty (Context v a -> Type (TypeVar v a) a -> Type (TypeVar v a) a
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v a
ctx Type (TypeVar v a) a
t)
      showElem Context v a
ctx (Ann v
v Type (TypeVar v a) a
t) = Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" : " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Width -> PrettyPrintEnv -> Type (TypeVar v a) a -> [Char]
forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Type v a -> [Char]
TP.prettyStr Maybe Width
forall a. Maybe a
Nothing PrettyPrintEnv
PPE.empty (Context v a -> Type (TypeVar v a) a -> Type (TypeVar v a) a
forall v loc.
(Var v, Ord loc) =>
Context v loc -> Type v loc -> Type v loc
apply Context v a
ctx Type (TypeVar v a) a
t)
      showElem Context v a
_ (Marker v
v) = [Char]
"|" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (v -> Text
forall v. Var v => v -> Text
Var.name v
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"|"

instance (Monad f) => Monad (MT v loc f) where
  return :: forall a. a -> MT v loc f a
return = a -> MT v loc f a
forall a. a -> MT v loc f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  MT v loc f a
m >>= :: forall a b. MT v loc f a -> (a -> MT v loc f b) -> MT v loc f b
>>= a -> MT v loc f b
f = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (b, Env v loc))
-> MT v loc f b
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env0 -> do
    (a
a, Env v loc
env1) <- MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM MT v loc f a
m PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects Env v loc
env0
    MT v loc f b
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (b, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM (a -> MT v loc f b
f a
a) PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
datas EffectDeclarations v loc
effects (Env v loc -> f (b, Env v loc)) -> Env v loc -> f (b, Env v loc)
forall a b. (a -> b) -> a -> b
$! Env v loc
env1

instance (Monad f) => MonadFail.MonadFail (MT v loc f) where
  fail :: forall a. [Char] -> MT v loc f a
fail = [Char] -> MT v loc f a
forall a. HasCallStack => [Char] -> a
error

instance (Monad f) => Applicative (MT v loc f) where
  pure :: forall a. a -> MT v loc f a
pure a
a = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT (\PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (a, Env v loc) -> f (a, Env v loc)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, Env v loc
env))
  <*> :: forall a b. MT v loc f (a -> b) -> MT v loc f a -> MT v loc f b
(<*>) = MT v loc f (a -> b) -> MT v loc f a -> MT v loc f b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Monad f) => MonadState (Env v loc) (MT v loc f) where
  get :: MT v loc f (Env v loc)
get = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (Env v loc, Env v loc))
-> MT v loc f (Env v loc)
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
env -> (Env v loc, Env v loc) -> f (Env v loc, Env v loc)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env v loc
env, Env v loc
env)
  put :: Env v loc -> MT v loc f ()
put Env v loc
env = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f ((), Env v loc))
-> MT v loc f ()
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
_ PatternMatchCoverageCheckAndKindInferenceSwitch
_ DataDeclarations v loc
_ EffectDeclarations v loc
_ Env v loc
_ -> ((), Env v loc) -> f ((), Env v loc)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), Env v loc
env)

instance (MonadFix f) => MonadFix (MT v loc f) where
  mfix :: forall a. (a -> MT v loc f a) -> MT v loc f a
mfix a -> MT v loc f a
f = (PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
forall v loc (f :: * -> *) a.
(PrettyPrintEnv
 -> PatternMatchCoverageCheckAndKindInferenceSwitch
 -> DataDeclarations v loc
 -> EffectDeclarations v loc
 -> Env v loc
 -> f (a, Env v loc))
-> MT v loc f a
MT \PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
a EffectDeclarations v loc
b Env v loc
c ->
    let res :: f (a, Env v loc)
res = ((a, Env v loc) -> f (a, Env v loc)) -> f (a, Env v loc)
forall a. (a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (\ ~(a
wubble, Env v loc
_finalenv) -> MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
forall v loc (f :: * -> *) a.
MT v loc f a
-> PrettyPrintEnv
-> PatternMatchCoverageCheckAndKindInferenceSwitch
-> DataDeclarations v loc
-> EffectDeclarations v loc
-> Env v loc
-> f (a, Env v loc)
runM (a -> MT v loc f a
f a
wubble) PrettyPrintEnv
ppe PatternMatchCoverageCheckAndKindInferenceSwitch
pmccSwitch DataDeclarations v loc
a EffectDeclarations v loc
b Env v loc
c)
     in f (a, Env v loc)
res