{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | Facilities for type-checking Futhark terms.  Checking a term
-- requires a little more context to track uniqueness and such.
--
-- Type inference is implemented through a variation of
-- Hindley-Milner.  The main complication is supporting the rich
-- number of built-in language constructs, as well as uniqueness
-- types.  This is mostly done in an ad hoc way, and many programs
-- will require the programmer to fall back on type annotations.
module Language.Futhark.TypeChecker.Terms
  ( checkOneExp,
    checkFunDef,
  )
where

import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Either
import Data.List (find, foldl', partition)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import Futhark.IR.Primitive (intByteSize)
import Futhark.Util.Pretty hiding (bool, group, space)
import Language.Futhark
import Language.Futhark.Traversals
import Language.Futhark.TypeChecker.Match
import Language.Futhark.TypeChecker.Monad hiding (BoundV)
import Language.Futhark.TypeChecker.Terms.DoLoop
import Language.Futhark.TypeChecker.Terms.Monad
import Language.Futhark.TypeChecker.Terms.Pat
import Language.Futhark.TypeChecker.Types
import Language.Futhark.TypeChecker.Unify hiding (Usage)
import Prelude hiding (mod)

overloadedTypeVars :: Constraints -> Names
overloadedTypeVars :: Constraints -> Names
overloadedTypeVars = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names)
-> (Constraints -> [Names]) -> Constraints -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level, Constraint) -> Names) -> [(Level, Constraint)] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map (Level, Constraint) -> Names
forall a. (a, Constraint) -> Names
f ([(Level, Constraint)] -> [Names])
-> (Constraints -> [(Level, Constraint)]) -> Constraints -> [Names]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraints -> [(Level, Constraint)]
forall k a. Map k a -> [a]
M.elems
  where
    f :: (a, Constraint) -> Names
f (a
_, HasFields Map Name StructType
fs Usage
_) = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> [Names] -> Names
forall a b. (a -> b) -> a -> b
$ (StructType -> Names) -> [StructType] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Names
forall as dim. Monoid as => TypeBase dim as -> Names
typeVars ([StructType] -> [Names]) -> [StructType] -> [Names]
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> [StructType]
forall k a. Map k a -> [a]
M.elems Map Name StructType
fs
    f (a, Constraint)
_ = Names
forall a. Monoid a => a
mempty

--- Basic checking

-- | Determine if the two types are identical, ignoring uniqueness.
-- Mismatched dimensions are turned into fresh rigid type variables.
-- Causes a 'TypeError' if they fail to match, and otherwise returns
-- one of them.
unifyBranchTypes :: SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])
unifyBranchTypes :: SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])
unifyBranchTypes SrcLoc
loc PatType
t1 PatType
t2 =
  Checking
-> TermTypeM (PatType, [VName]) -> TermTypeM (PatType, [VName])
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (StructType -> StructType -> Checking
CheckingBranches (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t1) (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t2)) (TermTypeM (PatType, [VName]) -> TermTypeM (PatType, [VName]))
-> TermTypeM (PatType, [VName]) -> TermTypeM (PatType, [VName])
forall a b. (a -> b) -> a -> b
$
    Usage -> PatType -> PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *).
MonadUnify m =>
Usage -> PatType -> PatType -> m (PatType, [VName])
unifyMostCommon (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"unification of branch results") PatType
t1 PatType
t2

unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName])
unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName])
unifyBranches SrcLoc
loc Exp
e1 Exp
e2 = do
  PatType
e1_t <- Exp -> TermTypeM PatType
expTypeFully Exp
e1
  PatType
e2_t <- Exp -> TermTypeM PatType
expTypeFully Exp
e2
  SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])
unifyBranchTypes SrcLoc
loc PatType
e1_t PatType
e2_t

sliceShape ::
  Maybe (SrcLoc, Rigidity) ->
  Slice ->
  TypeBase (DimDecl VName) as ->
  TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape :: Maybe (SrcLoc, Rigidity)
-> Slice
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape Maybe (SrcLoc, Rigidity)
r Slice
slice t :: TypeBase (DimDecl VName) as
t@(Array as
als Uniqueness
u ScalarTypeBase (DimDecl VName) ()
et (ShapeDecl [DimDecl VName]
orig_dims)) =
  StateT [VName] TermTypeM (TypeBase (DimDecl VName) as)
-> [VName] -> TermTypeM (TypeBase (DimDecl VName) as, [VName])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([DimDecl VName] -> TypeBase (DimDecl VName) as
setDims ([DimDecl VName] -> TypeBase (DimDecl VName) as)
-> StateT [VName] TermTypeM [DimDecl VName]
-> StateT [VName] TermTypeM (TypeBase (DimDecl VName) as)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slice
-> [DimDecl VName] -> StateT [VName] TermTypeM [DimDecl VName]
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadState [VName] (t TermTypeM)) =>
Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims Slice
slice [DimDecl VName]
orig_dims) []
  where
    setDims :: [DimDecl VName] -> TypeBase (DimDecl VName) as
setDims [] = Level -> TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as
forall dim as. Level -> TypeBase dim as -> TypeBase dim as
stripArray ([DimDecl VName] -> Level
forall (t :: * -> *) a. Foldable t => t a -> Level
length [DimDecl VName]
orig_dims) TypeBase (DimDecl VName) as
t
    setDims [DimDecl VName]
dims' = as
-> Uniqueness
-> ScalarTypeBase (DimDecl VName) ()
-> ShapeDecl (DimDecl VName)
-> TypeBase (DimDecl VName) as
forall dim as.
as
-> Uniqueness
-> ScalarTypeBase dim ()
-> ShapeDecl dim
-> TypeBase dim as
Array as
als Uniqueness
u ScalarTypeBase (DimDecl VName) ()
et (ShapeDecl (DimDecl VName) -> TypeBase (DimDecl VName) as)
-> ShapeDecl (DimDecl VName) -> TypeBase (DimDecl VName) as
forall a b. (a -> b) -> a -> b
$ [DimDecl VName] -> ShapeDecl (DimDecl VName)
forall dim. [dim] -> ShapeDecl dim
ShapeDecl [DimDecl VName]
dims'

    -- If the result is supposed to be a nonrigid size variable, then
    -- don't bother trying to create non-existential sizes.  This is
    -- necessary to make programs type-check without too much
    -- ceremony; see e.g. tests/inplace5.fut.
    isRigid :: Rigidity -> Bool
isRigid Rigid {} = Bool
True
    isRigid Rigidity
_ = Bool
False
    refine_sizes :: Bool
refine_sizes = Bool
-> ((SrcLoc, Rigidity) -> Bool) -> Maybe (SrcLoc, Rigidity) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Rigidity -> Bool
isRigid (Rigidity -> Bool)
-> ((SrcLoc, Rigidity) -> Rigidity) -> (SrcLoc, Rigidity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcLoc, Rigidity) -> Rigidity
forall a b. (a, b) -> b
snd) Maybe (SrcLoc, Rigidity)
r

    sliceSize :: DimDecl VName
-> Maybe Exp
-> Maybe Exp
-> Maybe Exp
-> t TermTypeM (DimDecl VName)
sliceSize DimDecl VName
orig_d Maybe Exp
i Maybe Exp
j Maybe Exp
stride =
      case Maybe (SrcLoc, Rigidity)
r of
        Just (SrcLoc
loc, Rigid RigidSource
_) -> do
          (DimDecl VName
d, Maybe VName
ext) <-
            TermTypeM (DimDecl VName, Maybe VName)
-> t TermTypeM (DimDecl VName, Maybe VName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TermTypeM (DimDecl VName, Maybe VName)
 -> t TermTypeM (DimDecl VName, Maybe VName))
-> (SizeSource -> TermTypeM (DimDecl VName, Maybe VName))
-> SizeSource
-> t TermTypeM (DimDecl VName, Maybe VName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> SizeSource -> TermTypeM (DimDecl VName, Maybe VName)
extSize SrcLoc
loc (SizeSource -> t TermTypeM (DimDecl VName, Maybe VName))
-> SizeSource -> t TermTypeM (DimDecl VName, Maybe VName)
forall a b. (a -> b) -> a -> b
$
              Maybe (DimDecl VName)
-> Maybe (ExpBase NoInfo VName)
-> Maybe (ExpBase NoInfo VName)
-> Maybe (ExpBase NoInfo VName)
-> SizeSource
SourceSlice Maybe (DimDecl VName)
orig_d' (Exp -> ExpBase NoInfo VName
bareExp (Exp -> ExpBase NoInfo VName)
-> Maybe Exp -> Maybe (ExpBase NoInfo VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Exp
i) (Exp -> ExpBase NoInfo VName
bareExp (Exp -> ExpBase NoInfo VName)
-> Maybe Exp -> Maybe (ExpBase NoInfo VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Exp
j) (Exp -> ExpBase NoInfo VName
bareExp (Exp -> ExpBase NoInfo VName)
-> Maybe Exp -> Maybe (ExpBase NoInfo VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Exp
stride)
          ([VName] -> [VName]) -> t TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Maybe VName -> [VName]
forall a. Maybe a -> [a]
maybeToList Maybe VName
ext [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++)
          DimDecl VName -> t TermTypeM (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DimDecl VName
d
        Just (SrcLoc
loc, Rigidity
Nonrigid) ->
          TermTypeM (DimDecl VName) -> t TermTypeM (DimDecl VName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TermTypeM (DimDecl VName) -> t TermTypeM (DimDecl VName))
-> TermTypeM (DimDecl VName) -> t TermTypeM (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> (VName -> QualName VName) -> VName -> DimDecl VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> QualName VName
forall v. v -> QualName v
qualName (VName -> DimDecl VName)
-> TermTypeM VName -> TermTypeM (DimDecl VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcLoc -> Rigidity -> Name -> TermTypeM VName
forall (m :: * -> *).
MonadUnify m =>
SrcLoc -> Rigidity -> Name -> m VName
newDimVar SrcLoc
loc Rigidity
Nonrigid Name
"slice_dim"
        Maybe (SrcLoc, Rigidity)
Nothing -> do
          VName
v <- TermTypeM VName -> t TermTypeM VName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TermTypeM VName -> t TermTypeM VName)
-> TermTypeM VName -> t TermTypeM VName
forall a b. (a -> b) -> a -> b
$ Name -> TermTypeM VName
forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newID Name
"slice_anydim"
          ([VName] -> [VName]) -> t TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (VName
v VName -> [VName] -> [VName]
forall a. a -> [a] -> [a]
:)
          DimDecl VName -> t TermTypeM (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DimDecl VName -> t TermTypeM (DimDecl VName))
-> DimDecl VName -> t TermTypeM (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
v
      where
        -- The original size does not matter if the slice is fully specified.
        orig_d' :: Maybe (DimDecl VName)
orig_d'
          | Maybe Exp -> Bool
forall a. Maybe a -> Bool
isJust Maybe Exp
i, Maybe Exp -> Bool
forall a. Maybe a -> Bool
isJust Maybe Exp
j = Maybe (DimDecl VName)
forall a. Maybe a
Nothing
          | Bool
otherwise = DimDecl VName -> Maybe (DimDecl VName)
forall a. a -> Maybe a
Just DimDecl VName
orig_d

    adjustDims :: Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims (DimFix {} : Slice
idxes') (DimDecl VName
_ : [DimDecl VName]
dims) =
      Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims Slice
idxes' [DimDecl VName]
dims
    -- Pat match some known slices to be non-existential.
    adjustDims (DimSlice Maybe Exp
i Maybe Exp
j Maybe Exp
stride : Slice
idxes') (DimDecl VName
_ : [DimDecl VName]
dims)
      | Bool
refine_sizes,
        Bool -> (Exp -> Bool) -> Maybe Exp -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe Int64 -> Maybe Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
0) (Maybe Int64 -> Bool) -> (Exp -> Maybe Int64) -> Exp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Maybe Int64
isInt64) Maybe Exp
i,
        Just DimDecl VName
j' <- Exp -> Maybe (DimDecl VName)
maybeDimFromExp (Exp -> Maybe (DimDecl VName))
-> Maybe Exp -> Maybe (DimDecl VName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Exp
j,
        Bool -> (Exp -> Bool) -> Maybe Exp -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe Int64 -> Maybe Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
1) (Maybe Int64 -> Bool) -> (Exp -> Maybe Int64) -> Exp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Maybe Int64
isInt64) Maybe Exp
stride =
        (DimDecl VName
j' DimDecl VName -> [DimDecl VName] -> [DimDecl VName]
forall a. a -> [a] -> [a]
:) ([DimDecl VName] -> [DimDecl VName])
-> t TermTypeM [DimDecl VName] -> t TermTypeM [DimDecl VName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims Slice
idxes' [DimDecl VName]
dims
    adjustDims (DimSlice Maybe Exp
Nothing Maybe Exp
Nothing Maybe Exp
stride : Slice
idxes') (DimDecl VName
d : [DimDecl VName]
dims)
      | Bool
refine_sizes,
        Bool -> (Exp -> Bool) -> Maybe Exp -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> (Int64 -> Bool) -> Maybe Int64 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
1) (Int64 -> Bool) -> (Int64 -> Int64) -> Int64 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
forall a. Num a => a -> a
abs) (Maybe Int64 -> Bool) -> (Exp -> Maybe Int64) -> Exp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Maybe Int64
isInt64) Maybe Exp
stride =
        (DimDecl VName
d DimDecl VName -> [DimDecl VName] -> [DimDecl VName]
forall a. a -> [a] -> [a]
:) ([DimDecl VName] -> [DimDecl VName])
-> t TermTypeM [DimDecl VName] -> t TermTypeM [DimDecl VName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims Slice
idxes' [DimDecl VName]
dims
    adjustDims (DimSlice Maybe Exp
i Maybe Exp
j Maybe Exp
stride : Slice
idxes') (DimDecl VName
d : [DimDecl VName]
dims) =
      (:) (DimDecl VName -> [DimDecl VName] -> [DimDecl VName])
-> t TermTypeM (DimDecl VName)
-> t TermTypeM ([DimDecl VName] -> [DimDecl VName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DimDecl VName
-> Maybe Exp
-> Maybe Exp
-> Maybe Exp
-> t TermTypeM (DimDecl VName)
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadState [VName] (t TermTypeM)) =>
DimDecl VName
-> Maybe Exp
-> Maybe Exp
-> Maybe Exp
-> t TermTypeM (DimDecl VName)
sliceSize DimDecl VName
d Maybe Exp
i Maybe Exp
j Maybe Exp
stride t TermTypeM ([DimDecl VName] -> [DimDecl VName])
-> t TermTypeM [DimDecl VName] -> t TermTypeM [DimDecl VName]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Slice -> [DimDecl VName] -> t TermTypeM [DimDecl VName]
adjustDims Slice
idxes' [DimDecl VName]
dims
    adjustDims Slice
_ [DimDecl VName]
dims =
      [DimDecl VName] -> t TermTypeM [DimDecl VName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DimDecl VName]
dims
sliceShape Maybe (SrcLoc, Rigidity)
_ Slice
_ TypeBase (DimDecl VName) as
t = (TypeBase (DimDecl VName) as, [VName])
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeBase (DimDecl VName) as
t, [])

--- Main checkers

-- The closure of a lambda or local function are those variables that
-- it references, and which local to the current top-level function.
lexicalClosure :: [Pat] -> Occurrences -> TermTypeM Aliasing
lexicalClosure :: [Pat] -> Occurrences -> TermTypeM Aliasing
lexicalClosure [Pat]
params Occurrences
closure = do
  Map VName ValBinding
vtable <- (TermEnv -> Map VName ValBinding)
-> TermTypeM (Map VName ValBinding)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((TermEnv -> Map VName ValBinding)
 -> TermTypeM (Map VName ValBinding))
-> (TermEnv -> Map VName ValBinding)
-> TermTypeM (Map VName ValBinding)
forall a b. (a -> b) -> a -> b
$ TermScope -> Map VName ValBinding
scopeVtable (TermScope -> Map VName ValBinding)
-> (TermEnv -> TermScope) -> TermEnv -> Map VName ValBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermEnv -> TermScope
termScope
  let isLocal :: VName -> Bool
isLocal VName
v = case VName
v VName -> Map VName ValBinding -> Maybe ValBinding
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map VName ValBinding
vtable of
        Just (BoundV Locality
Local [TypeParam]
_ PatType
_) -> Bool
True
        Maybe ValBinding
_ -> Bool
False
  Aliasing -> TermTypeM Aliasing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Aliasing -> TermTypeM Aliasing)
-> (Names -> Aliasing) -> Names -> TermTypeM Aliasing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Alias) -> Names -> Aliasing
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map VName -> Alias
AliasBound (Names -> Aliasing) -> (Names -> Names) -> Names -> Aliasing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Bool) -> Names -> Names
forall a. (a -> Bool) -> Set a -> Set a
S.filter VName -> Bool
isLocal (Names -> TermTypeM Aliasing) -> Names -> TermTypeM Aliasing
forall a b. (a -> b) -> a -> b
$
    Occurrences -> Names
allOccurring Occurrences
closure Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ((Pat -> Names) -> [Pat] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Names
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set vn
patNames [Pat]
params)

noAliasesIfOverloaded :: PatType -> TermTypeM PatType
noAliasesIfOverloaded :: PatType -> TermTypeM PatType
noAliasesIfOverloaded t :: PatType
t@(Scalar (TypeVar Aliasing
_ Uniqueness
u TypeName
tn [])) = do
  Maybe Constraint
subst <- ((Level, Constraint) -> Constraint)
-> Maybe (Level, Constraint) -> Maybe Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level, Constraint) -> Constraint
forall a b. (a, b) -> b
snd (Maybe (Level, Constraint) -> Maybe Constraint)
-> (Constraints -> Maybe (Level, Constraint))
-> Constraints
-> Maybe Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Constraints -> Maybe (Level, Constraint)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (TypeName -> VName
typeLeaf TypeName
tn) (Constraints -> Maybe Constraint)
-> TermTypeM Constraints -> TermTypeM (Maybe Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermTypeM Constraints
forall (m :: * -> *). MonadUnify m => m Constraints
getConstraints
  case Maybe Constraint
subst of
    Just Overloaded {} -> PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatType -> TermTypeM PatType) -> PatType -> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar Aliasing
forall a. Monoid a => a
mempty Uniqueness
u TypeName
tn []
    Maybe Constraint
_ -> PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PatType
t
noAliasesIfOverloaded PatType
t =
  PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PatType
t

checkAscript ::
  SrcLoc ->
  UncheckedTypeDecl ->
  UncheckedExp ->
  TermTypeM (TypeDecl, Exp)
checkAscript :: SrcLoc
-> UncheckedTypeDecl -> UncheckedExp -> TermTypeM (TypeDecl, Exp)
checkAscript SrcLoc
loc (TypeDecl TypeExp Name
te NoInfo StructType
NoInfo) UncheckedExp
e = do
  (TypeExp VName
te', StructType
decl_t, [VName]
_) <- TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName])
checkTypeExpNonrigid TypeExp Name
te
  Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  StructType
e_t <- PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType)
-> TermTypeM PatType -> TermTypeM StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> TermTypeM PatType
expTypeFully Exp
e'

  Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (StructType -> StructType -> Checking
CheckingAscription StructType
decl_t StructType
e_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"type ascription") StructType
decl_t StructType
e_t

  -- We also have to make sure that uniqueness matches.  This is done
  -- explicitly, because uniqueness is ignored by unification.
  StructType
e_t' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
e_t
  StructType
decl_t' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
decl_t
  Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StructType -> TypeBase () ()
forall vn as. TypeBase (DimDecl vn) as -> TypeBase () as
noSizes StructType
e_t' TypeBase () () -> TypeBase () () -> Bool
`subtypeOf` StructType -> TypeBase () ()
forall vn as. TypeBase (DimDecl vn) as -> TypeBase () as
noSizes StructType
decl_t') (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
      Doc
"Type" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
e_t') Doc -> Doc -> Doc
<+> Doc
"is not a subtype of"
        Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
decl_t') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

  (TypeDecl, Exp) -> TermTypeM (TypeDecl, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExp VName -> Info StructType -> TypeDecl
forall (f :: * -> *) vn.
TypeExp vn -> f StructType -> TypeDeclBase f vn
TypeDecl TypeExp VName
te' (Info StructType -> TypeDecl) -> Info StructType -> TypeDecl
forall a b. (a -> b) -> a -> b
$ StructType -> Info StructType
forall a. a -> Info a
Info StructType
decl_t', Exp
e')

checkCoerce ::
  SrcLoc ->
  UncheckedTypeDecl ->
  UncheckedExp ->
  TermTypeM (TypeDecl, Exp, [VName])
checkCoerce :: SrcLoc
-> UncheckedTypeDecl
-> UncheckedExp
-> TermTypeM (TypeDecl, Exp, [VName])
checkCoerce SrcLoc
loc (TypeDecl TypeExp Name
te NoInfo StructType
NoInfo) UncheckedExp
e = do
  (TypeExp VName
te', StructType
decl_t, [VName]
ext) <- TypeExp Name
-> RigidSource -> TermTypeM (TypeExp VName, StructType, [VName])
checkTypeExpRigid TypeExp Name
te RigidSource
RigidCoerce
  Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  StructType
e_t <- PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType)
-> TermTypeM PatType -> TermTypeM StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> TermTypeM PatType
expTypeFully Exp
e'

  (StructType
e_t_nonrigid, Map VName (DimDecl VName)
_) <-
    SrcLoc
-> Rigidity
-> Name
-> StructType
-> TermTypeM (StructType, Map VName (DimDecl VName))
forall als.
SrcLoc
-> Rigidity
-> Name
-> TypeBase (DimDecl VName) als
-> TermTypeM
     (TypeBase (DimDecl VName) als, Map VName (DimDecl VName))
allDimsFreshInType SrcLoc
loc Rigidity
Nonrigid Name
"coerce_d" StructType
e_t

  Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (StructType -> StructType -> Checking
CheckingAscription StructType
decl_t StructType
e_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"type ascription") StructType
decl_t StructType
e_t_nonrigid

  -- We also have to make sure that uniqueness matches.  This is done
  -- explicitly, because uniqueness is ignored by unification.
  StructType
e_t' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
e_t
  StructType
decl_t' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
decl_t
  Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StructType -> TypeBase () ()
forall vn as. TypeBase (DimDecl vn) as -> TypeBase () as
noSizes StructType
e_t' TypeBase () () -> TypeBase () () -> Bool
`subtypeOf` StructType -> TypeBase () ()
forall vn as. TypeBase (DimDecl vn) as -> TypeBase () as
noSizes StructType
decl_t') (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
      Doc
"Type" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
e_t') Doc -> Doc -> Doc
<+> Doc
"is not a subtype of"
        Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
decl_t') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

  (TypeDecl, Exp, [VName]) -> TermTypeM (TypeDecl, Exp, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExp VName -> Info StructType -> TypeDecl
forall (f :: * -> *) vn.
TypeExp vn -> f StructType -> TypeDeclBase f vn
TypeDecl TypeExp VName
te' (Info StructType -> TypeDecl) -> Info StructType -> TypeDecl
forall a b. (a -> b) -> a -> b
$ StructType -> Info StructType
forall a. a -> Info a
Info StructType
decl_t', Exp
e', [VName]
ext)

unscopeType ::
  SrcLoc ->
  M.Map VName Ident ->
  PatType ->
  TermTypeM (PatType, [VName])
unscopeType :: SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType SrcLoc
tloc Map VName Ident
unscoped PatType
t = do
  (PatType
t', Map VName VName
m) <- StateT (Map VName VName) TermTypeM PatType
-> Map VName VName -> TermTypeM (PatType, Map VName VName)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((Names
 -> DimPos
 -> DimDecl VName
 -> StateT (Map VName VName) TermTypeM (DimDecl VName))
-> PatType -> StateT (Map VName VName) TermTypeM PatType
forall (f :: * -> *) fdim tdim als.
Applicative f =>
(Names -> DimPos -> fdim -> f tdim)
-> TypeBase fdim als -> f (TypeBase tdim als)
traverseDims Names
-> DimPos
-> DimDecl VName
-> StateT (Map VName VName) TermTypeM (DimDecl VName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) p.
(MonadState (Map VName VName) (t m), MonadTrans t, MonadUnify m) =>
Names -> p -> DimDecl VName -> t m (DimDecl VName)
onDim PatType
t) Map VName VName
forall a. Monoid a => a
mempty
  (PatType, [VName]) -> TermTypeM (PatType, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatType
t' PatType -> (Aliasing -> Aliasing) -> PatType
forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
`addAliases` (Alias -> Alias) -> Aliasing -> Aliasing
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> Alias
unAlias, Map VName VName -> [VName]
forall k a. Map k a -> [a]
M.elems Map VName VName
m)
  where
    onDim :: Names -> p -> DimDecl VName -> t m (DimDecl VName)
onDim Names
bound p
_ (NamedDim QualName VName
d)
      | Just SrcLoc
loc <- Ident -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf (Ident -> SrcLoc) -> Maybe Ident -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> Map VName Ident -> Maybe Ident
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
d) Map VName Ident
unscoped,
        Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
d VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
bound =
        SrcLoc -> VName -> t m (DimDecl VName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadState (Map VName VName) (t m), MonadTrans t, MonadUnify m) =>
SrcLoc -> VName -> t m (DimDecl VName)
inst SrcLoc
loc (VName -> t m (DimDecl VName)) -> VName -> t m (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
d
    onDim Names
_ p
_ DimDecl VName
d = DimDecl VName -> t m (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DimDecl VName
d

    inst :: SrcLoc -> VName -> t m (DimDecl VName)
inst SrcLoc
loc VName
d = do
      Maybe VName
prev <- (Map VName VName -> Maybe VName) -> t m (Maybe VName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map VName VName -> Maybe VName) -> t m (Maybe VName))
-> (Map VName VName -> Maybe VName) -> t m (Maybe VName)
forall a b. (a -> b) -> a -> b
$ VName -> Map VName VName -> Maybe VName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
d
      case Maybe VName
prev of
        Just VName
d' -> DimDecl VName -> t m (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DimDecl VName -> t m (DimDecl VName))
-> DimDecl VName -> t m (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
d'
        Maybe VName
Nothing -> do
          VName
d' <- m VName -> t m VName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m VName -> t m VName) -> m VName -> t m VName
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Rigidity -> Name -> m VName
forall (m :: * -> *).
MonadUnify m =>
SrcLoc -> Rigidity -> Name -> m VName
newDimVar SrcLoc
tloc (RigidSource -> Rigidity
Rigid (RigidSource -> Rigidity) -> RigidSource -> Rigidity
forall a b. (a -> b) -> a -> b
$ SrcLoc -> VName -> RigidSource
RigidOutOfScope SrcLoc
loc VName
d) Name
"d"
          (Map VName VName -> Map VName VName) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map VName VName -> Map VName VName) -> t m ())
-> (Map VName VName -> Map VName VName) -> t m ()
forall a b. (a -> b) -> a -> b
$ VName -> VName -> Map VName VName -> Map VName VName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
d VName
d'
          DimDecl VName -> t m (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DimDecl VName -> t m (DimDecl VName))
-> DimDecl VName -> t m (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
d'

    unAlias :: Alias -> Alias
unAlias (AliasBound VName
v) | VName
v VName -> Map VName Ident -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map VName Ident
unscoped = VName -> Alias
AliasFree VName
v
    unAlias Alias
a = Alias
a

-- When a function result is not immediately bound to a name, we need
-- to invent a name for it so we can track it during aliasing
-- (uniqueness-error54.fut, uniqueness-error55.fut).
addResultAliases :: NameReason -> PatType -> TermTypeM PatType
addResultAliases :: NameReason -> PatType -> TermTypeM PatType
addResultAliases NameReason
r (Scalar (Record Map Name PatType
fs)) =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> (Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> Map Name PatType
-> PatType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name PatType -> PatType)
-> TermTypeM (Map Name PatType) -> TermTypeM PatType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PatType -> TermTypeM PatType)
-> Map Name PatType -> TermTypeM (Map Name PatType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NameReason -> PatType -> TermTypeM PatType
addResultAliases NameReason
r) Map Name PatType
fs
addResultAliases NameReason
r (Scalar (Sum Map Name [PatType]
fs)) =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> (Map Name [PatType] -> ScalarTypeBase (DimDecl VName) Aliasing)
-> Map Name [PatType]
-> PatType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name [PatType] -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum (Map Name [PatType] -> PatType)
-> TermTypeM (Map Name [PatType]) -> TermTypeM PatType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([PatType] -> TermTypeM [PatType])
-> Map Name [PatType] -> TermTypeM (Map Name [PatType])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((PatType -> TermTypeM PatType) -> [PatType] -> TermTypeM [PatType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NameReason -> PatType -> TermTypeM PatType
addResultAliases NameReason
r)) Map Name [PatType]
fs
addResultAliases NameReason
r (Scalar (TypeVar Aliasing
as Uniqueness
u TypeName
tn [TypeArg (DimDecl VName)]
targs)) = do
  VName
v <- Name -> TermTypeM VName
forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newID Name
"internal_app_result"
  (TermTypeState -> TermTypeState) -> TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TermTypeState -> TermTypeState) -> TermTypeM ())
-> (TermTypeState -> TermTypeState) -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ \TermTypeState
s -> TermTypeState
s {stateNames :: Map VName NameReason
stateNames = VName -> NameReason -> Map VName NameReason -> Map VName NameReason
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v NameReason
r (Map VName NameReason -> Map VName NameReason)
-> Map VName NameReason -> Map VName NameReason
forall a b. (a -> b) -> a -> b
$ TermTypeState -> Map VName NameReason
stateNames TermTypeState
s}
  PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatType -> TermTypeM PatType) -> PatType -> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar (Alias -> Aliasing -> Aliasing
forall a. Ord a => a -> Set a -> Set a
S.insert (VName -> Alias
AliasFree VName
v) Aliasing
as) Uniqueness
u TypeName
tn [TypeArg (DimDecl VName)]
targs
addResultAliases NameReason
_ (Scalar t :: ScalarTypeBase (DimDecl VName) Aliasing
t@Prim {}) = PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar ScalarTypeBase (DimDecl VName) Aliasing
t)
addResultAliases NameReason
_ (Scalar t :: ScalarTypeBase (DimDecl VName) Aliasing
t@Arrow {}) = PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar ScalarTypeBase (DimDecl VName) Aliasing
t)
addResultAliases NameReason
r (Array Aliasing
als Uniqueness
u ScalarTypeBase (DimDecl VName) ()
t ShapeDecl (DimDecl VName)
shape) = do
  VName
v <- Name -> TermTypeM VName
forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newID Name
"internal_app_result"
  (TermTypeState -> TermTypeState) -> TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TermTypeState -> TermTypeState) -> TermTypeM ())
-> (TermTypeState -> TermTypeState) -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ \TermTypeState
s -> TermTypeState
s {stateNames :: Map VName NameReason
stateNames = VName -> NameReason -> Map VName NameReason -> Map VName NameReason
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v NameReason
r (Map VName NameReason -> Map VName NameReason)
-> Map VName NameReason -> Map VName NameReason
forall a b. (a -> b) -> a -> b
$ TermTypeState -> Map VName NameReason
stateNames TermTypeState
s}
  PatType -> TermTypeM PatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatType -> TermTypeM PatType) -> PatType -> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> Uniqueness
-> ScalarTypeBase (DimDecl VName) ()
-> ShapeDecl (DimDecl VName)
-> PatType
forall dim as.
as
-> Uniqueness
-> ScalarTypeBase dim ()
-> ShapeDecl dim
-> TypeBase dim as
Array (Alias -> Aliasing -> Aliasing
forall a. Ord a => a -> Set a -> Set a
S.insert (VName -> Alias
AliasFree VName
v) Aliasing
als) Uniqueness
u ScalarTypeBase (DimDecl VName) ()
t ShapeDecl (DimDecl VName)
shape

-- 'checkApplyExp' is like 'checkExp', but tries to find the "root
-- function", for better error messages.
checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)
checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)
checkApplyExp (AppExp (Apply UncheckedExp
e1 UncheckedExp
e2 NoInfo (Diet, Maybe VName)
_ SrcLoc
loc) NoInfo AppRes
_) = do
  Arg
arg <- UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
e2
  (Exp
e1', (Maybe (QualName VName)
fname, Level
i)) <- UncheckedExp -> TermTypeM (Exp, ApplyOp)
checkApplyExp UncheckedExp
e1
  PatType
t <- Exp -> TermTypeM PatType
expType Exp
e1'
  (PatType
t1, PatType
rt, Maybe VName
argext, [VName]
exts) <- SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply SrcLoc
loc (Maybe (QualName VName)
fname, Level
i) PatType
t Arg
arg
  PatType
rt' <- NameReason -> PatType -> TermTypeM PatType
addResultAliases (Maybe (QualName VName) -> SrcLoc -> NameReason
NameAppRes Maybe (QualName VName)
fname SrcLoc
loc) PatType
rt
  (Exp, ApplyOp) -> TermTypeM (Exp, ApplyOp)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp
        (Exp
-> Exp
-> Info (Diet, Maybe VName)
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn
-> ExpBase f vn
-> f (Diet, Maybe VName)
-> SrcLoc
-> AppExpBase f vn
Apply Exp
e1' (Arg -> Exp
argExp Arg
arg) ((Diet, Maybe VName) -> Info (Diet, Maybe VName)
forall a. a -> Info a
Info (PatType -> Diet
forall shape as. TypeBase shape as -> Diet
diet PatType
t1, Maybe VName
argext)) SrcLoc
loc)
        (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
rt' [VName]
exts),
      (Maybe (QualName VName)
fname, Level
i Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
1)
    )
checkApplyExp UncheckedExp
e = do
  Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  (Exp, ApplyOp) -> TermTypeM (Exp, ApplyOp)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Exp
e',
      ( case Exp
e' of
          Var QualName VName
qn Info PatType
_ SrcLoc
_ -> QualName VName -> Maybe (QualName VName)
forall a. a -> Maybe a
Just QualName VName
qn
          Exp
_ -> Maybe (QualName VName)
forall a. Maybe a
Nothing,
        Level
0
      )
    )

checkExp :: UncheckedExp -> TermTypeM Exp
checkExp :: UncheckedExp -> TermTypeM Exp
checkExp (Literal PrimValue
val SrcLoc
loc) =
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ PrimValue -> SrcLoc -> Exp
forall (f :: * -> *) vn. PrimValue -> SrcLoc -> ExpBase f vn
Literal PrimValue
val SrcLoc
loc
checkExp (StringLit [Word8]
vs SrcLoc
loc) =
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [Word8] -> SrcLoc -> Exp
forall (f :: * -> *) vn. [Word8] -> SrcLoc -> ExpBase f vn
StringLit [Word8]
vs SrcLoc
loc
checkExp (IntLit Integer
val NoInfo PatType
NoInfo SrcLoc
loc) = do
  StructType
t <- SrcLoc -> Name -> TermTypeM StructType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"t"
  [PrimType] -> Usage -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
[PrimType] -> Usage -> StructType -> m ()
mustBeOneOf [PrimType]
anyNumberType (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"integer literal") StructType
t
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Integer -> f PatType -> SrcLoc -> ExpBase f vn
IntLit Integer
val (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct StructType
t) SrcLoc
loc
checkExp (FloatLit Double
val NoInfo PatType
NoInfo SrcLoc
loc) = do
  StructType
t <- SrcLoc -> Name -> TermTypeM StructType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"t"
  [PrimType] -> Usage -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
[PrimType] -> Usage -> StructType -> m ()
mustBeOneOf [PrimType]
anyFloatType (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"float literal") StructType
t
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Double -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Double -> f PatType -> SrcLoc -> ExpBase f vn
FloatLit Double
val (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct StructType
t) SrcLoc
loc
checkExp (TupLit [UncheckedExp]
es SrcLoc
loc) =
  [Exp] -> SrcLoc -> Exp
forall (f :: * -> *) vn. [ExpBase f vn] -> SrcLoc -> ExpBase f vn
TupLit ([Exp] -> SrcLoc -> Exp)
-> TermTypeM [Exp] -> TermTypeM (SrcLoc -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UncheckedExp -> TermTypeM Exp)
-> [UncheckedExp] -> TermTypeM [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UncheckedExp -> TermTypeM Exp
checkExp [UncheckedExp]
es TermTypeM (SrcLoc -> Exp) -> TermTypeM SrcLoc -> TermTypeM Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> TermTypeM SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
checkExp (RecordLit [FieldBase NoInfo Name]
fs SrcLoc
loc) = do
  [FieldBase Info VName]
fs' <- StateT (Map Name SrcLoc) TermTypeM [FieldBase Info VName]
-> Map Name SrcLoc -> TermTypeM [FieldBase Info VName]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((FieldBase NoInfo Name
 -> StateT (Map Name SrcLoc) TermTypeM (FieldBase Info VName))
-> [FieldBase NoInfo Name]
-> StateT (Map Name SrcLoc) TermTypeM [FieldBase Info VName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldBase NoInfo Name
-> StateT (Map Name SrcLoc) TermTypeM (FieldBase Info VName)
forall (t :: (* -> *) -> * -> *).
(MonadState (Map Name SrcLoc) (t TermTypeM), MonadTrans t) =>
FieldBase NoInfo Name -> t TermTypeM (FieldBase Info VName)
checkField [FieldBase NoInfo Name]
fs) Map Name SrcLoc
forall a. Monoid a => a
mempty

  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [FieldBase Info VName] -> SrcLoc -> Exp
forall (f :: * -> *) vn. [FieldBase f vn] -> SrcLoc -> ExpBase f vn
RecordLit [FieldBase Info VName]
fs' SrcLoc
loc
  where
    checkField :: FieldBase NoInfo Name -> t TermTypeM (FieldBase Info VName)
checkField (RecordFieldExplicit Name
f UncheckedExp
e SrcLoc
rloc) = do
      Name -> SrcLoc -> t TermTypeM ()
forall a b (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadState (Map a b) (t m), Ord a, MonadTrans t,
 MonadTypeChecker m, Pretty a, Located a, Located b) =>
a -> a -> t m ()
errIfAlreadySet Name
f SrcLoc
rloc
      (Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ())
-> (Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ()
forall a b. (a -> b) -> a -> b
$ Name -> SrcLoc -> Map Name SrcLoc -> Map Name SrcLoc
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
f SrcLoc
rloc
      Name -> Exp -> SrcLoc -> FieldBase Info VName
forall (f :: * -> *) vn.
Name -> ExpBase f vn -> SrcLoc -> FieldBase f vn
RecordFieldExplicit Name
f (Exp -> SrcLoc -> FieldBase Info VName)
-> t TermTypeM Exp -> t TermTypeM (SrcLoc -> FieldBase Info VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermTypeM Exp -> t TermTypeM Exp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e) t TermTypeM (SrcLoc -> FieldBase Info VName)
-> t TermTypeM SrcLoc -> t TermTypeM (FieldBase Info VName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> t TermTypeM SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
rloc
    checkField (RecordFieldImplicit Name
name NoInfo PatType
NoInfo SrcLoc
rloc) = do
      Name -> SrcLoc -> t TermTypeM ()
forall a b (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadState (Map a b) (t m), Ord a, MonadTrans t,
 MonadTypeChecker m, Pretty a, Located a, Located b) =>
a -> a -> t m ()
errIfAlreadySet Name
name SrcLoc
rloc
      (QualName [VName]
_ VName
name', PatType
t) <- TermTypeM (QualName VName, PatType)
-> t TermTypeM (QualName VName, PatType)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TermTypeM (QualName VName, PatType)
 -> t TermTypeM (QualName VName, PatType))
-> TermTypeM (QualName VName, PatType)
-> t TermTypeM (QualName VName, PatType)
forall a b. (a -> b) -> a -> b
$ SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
rloc (QualName Name -> TermTypeM (QualName VName, PatType))
-> QualName Name -> TermTypeM (QualName VName, PatType)
forall a b. (a -> b) -> a -> b
$ Name -> QualName Name
forall v. v -> QualName v
qualName Name
name
      (Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ())
-> (Map Name SrcLoc -> Map Name SrcLoc) -> t TermTypeM ()
forall a b. (a -> b) -> a -> b
$ Name -> SrcLoc -> Map Name SrcLoc -> Map Name SrcLoc
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name SrcLoc
rloc
      FieldBase Info VName -> t TermTypeM (FieldBase Info VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldBase Info VName -> t TermTypeM (FieldBase Info VName))
-> FieldBase Info VName -> t TermTypeM (FieldBase Info VName)
forall a b. (a -> b) -> a -> b
$ VName -> Info PatType -> SrcLoc -> FieldBase Info VName
forall (f :: * -> *) vn.
vn -> f PatType -> SrcLoc -> FieldBase f vn
RecordFieldImplicit VName
name' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
t) SrcLoc
rloc

    errIfAlreadySet :: a -> a -> t m ()
errIfAlreadySet a
f a
rloc = do
      Maybe b
maybe_sloc <- (Map a b -> Maybe b) -> t m (Maybe b)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map a b -> Maybe b) -> t m (Maybe b))
-> (Map a b -> Maybe b) -> t m (Maybe b)
forall a b. (a -> b) -> a -> b
$ a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
f
      case Maybe b
maybe_sloc of
        Just b
sloc ->
          m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> (Doc -> m ()) -> Doc -> t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError a
rloc Notes
forall a. Monoid a => a
mempty (Doc -> t m ()) -> Doc -> t m ()
forall a b. (a -> b) -> a -> b
$
            Doc
"Field" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
f)
              Doc -> Doc -> Doc
<+> Doc
"previously defined at"
              Doc -> Doc -> Doc
<+> String -> Doc
text (a -> b -> String
forall a b. (Located a, Located b) => a -> b -> String
locStrRel a
rloc b
sloc) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
        Maybe b
Nothing -> () -> t m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkExp (ArrayLit [UncheckedExp]
all_es NoInfo PatType
_ SrcLoc
loc) =
  -- Construct the result type and unify all elements with it.  We
  -- only create a type variable for empty arrays; otherwise we use
  -- the type of the first element.  This significantly cuts down on
  -- the number of type variables generated for pathologically large
  -- multidimensional array literals.
  case [UncheckedExp]
all_es of
    [] -> do
      PatType
et <- SrcLoc -> Name -> TermTypeM PatType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"t"
      PatType
t <- SrcLoc
-> PatType
-> ShapeDecl (DimDecl VName)
-> Uniqueness
-> TermTypeM PatType
forall dim as.
(Pretty (ShapeDecl dim), Monoid as) =>
SrcLoc
-> TypeBase dim as
-> ShapeDecl dim
-> Uniqueness
-> TermTypeM (TypeBase dim as)
arrayOfM SrcLoc
loc PatType
et ([DimDecl VName] -> ShapeDecl (DimDecl VName)
forall dim. [dim] -> ShapeDecl dim
ShapeDecl [Level -> DimDecl VName
forall vn. Level -> DimDecl vn
ConstDim Level
0]) Uniqueness
Unique
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
[ExpBase f vn] -> f PatType -> SrcLoc -> ExpBase f vn
ArrayLit [] (PatType -> Info PatType
forall a. a -> Info a
Info PatType
t) SrcLoc
loc
    UncheckedExp
e : [UncheckedExp]
es -> do
      Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
      PatType
et <- Exp -> TermTypeM PatType
expType Exp
e'
      [Exp]
es' <- (UncheckedExp -> TermTypeM Exp)
-> [UncheckedExp] -> TermTypeM [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> StructType -> Exp -> TermTypeM Exp
unifies String
"type of first array element" (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
et) (Exp -> TermTypeM Exp)
-> (UncheckedExp -> TermTypeM Exp) -> UncheckedExp -> TermTypeM Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< UncheckedExp -> TermTypeM Exp
checkExp) [UncheckedExp]
es
      PatType
et' <- PatType -> TermTypeM PatType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully PatType
et
      PatType
t <- SrcLoc
-> PatType
-> ShapeDecl (DimDecl VName)
-> Uniqueness
-> TermTypeM PatType
forall dim as.
(Pretty (ShapeDecl dim), Monoid as) =>
SrcLoc
-> TypeBase dim as
-> ShapeDecl dim
-> Uniqueness
-> TermTypeM (TypeBase dim as)
arrayOfM SrcLoc
loc PatType
et' ([DimDecl VName] -> ShapeDecl (DimDecl VName)
forall dim. [dim] -> ShapeDecl dim
ShapeDecl [Level -> DimDecl VName
forall vn. Level -> DimDecl vn
ConstDim (Level -> DimDecl VName) -> Level -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ [UncheckedExp] -> Level
forall (t :: * -> *) a. Foldable t => t a -> Level
length [UncheckedExp]
all_es]) Uniqueness
Unique
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
[ExpBase f vn] -> f PatType -> SrcLoc -> ExpBase f vn
ArrayLit (Exp
e' Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es') (PatType -> Info PatType
forall a. a -> Info a
Info PatType
t) SrcLoc
loc
checkExp (AppExp (Range UncheckedExp
start Maybe UncheckedExp
maybe_step Inclusiveness UncheckedExp
end SrcLoc
loc) NoInfo AppRes
_) = do
  Exp
start' <- String -> [PrimType] -> Exp -> TermTypeM Exp
require String
"use in range expression" [PrimType]
anySignedType (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
start
  StructType
start_t <- PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType)
-> TermTypeM PatType -> TermTypeM StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> TermTypeM PatType
expTypeFully Exp
start'
  Maybe Exp
maybe_step' <- case Maybe UncheckedExp
maybe_step of
    Maybe UncheckedExp
Nothing -> Maybe Exp -> TermTypeM (Maybe Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Exp
forall a. Maybe a
Nothing
    Just UncheckedExp
step -> do
      let warning :: TermTypeM ()
warning = SrcLoc -> Doc -> TermTypeM ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc -> m ()
warn SrcLoc
loc Doc
"First and second element of range are identical, this will produce an empty array."
      case (UncheckedExp
start, UncheckedExp
step) of
        (Literal PrimValue
x SrcLoc
_, Literal PrimValue
y SrcLoc
_) -> Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimValue
x PrimValue -> PrimValue -> Bool
forall a. Eq a => a -> a -> Bool
== PrimValue
y) TermTypeM ()
warning
        (Var QualName Name
x_name NoInfo PatType
_ SrcLoc
_, Var QualName Name
y_name NoInfo PatType
_ SrcLoc
_) -> Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QualName Name
x_name QualName Name -> QualName Name -> Bool
forall a. Eq a => a -> a -> Bool
== QualName Name
y_name) TermTypeM ()
warning
        (UncheckedExp, UncheckedExp)
_ -> () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> TermTypeM Exp -> TermTypeM (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> StructType -> Exp -> TermTypeM Exp
unifies String
"use in range expression" StructType
start_t (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
step)

  let unifyRange :: UncheckedExp -> TermTypeM Exp
unifyRange UncheckedExp
e = String -> StructType -> Exp -> TermTypeM Exp
unifies String
"use in range expression" StructType
start_t (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  Inclusiveness Exp
end' <- (UncheckedExp -> TermTypeM Exp)
-> Inclusiveness UncheckedExp -> TermTypeM (Inclusiveness Exp)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UncheckedExp -> TermTypeM Exp
unifyRange Inclusiveness UncheckedExp
end

  PatType
end_t <- case Inclusiveness Exp
end' of
    DownToExclusive Exp
e -> Exp -> TermTypeM PatType
expType Exp
e
    ToInclusive Exp
e -> Exp -> TermTypeM PatType
expType Exp
e
    UpToExclusive Exp
e -> Exp -> TermTypeM PatType
expType Exp
e

  -- Special case some ranges to give them a known size.
  let dimFromBound :: Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromBound = (Exp -> SizeSource)
-> Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromExp (ExpBase NoInfo VName -> SizeSource
SourceBound (ExpBase NoInfo VName -> SizeSource)
-> (Exp -> ExpBase NoInfo VName) -> Exp -> SizeSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ExpBase NoInfo VName
bareExp)
  (DimDecl VName
dim, Maybe VName
retext) <-
    case (Exp -> Maybe Int64
isInt64 Exp
start', Exp -> Maybe Int64
isInt64 (Exp -> Maybe Int64) -> Maybe Exp -> Maybe (Maybe Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Exp
maybe_step', Inclusiveness Exp
end') of
      (Just Int64
0, Just (Just Int64
1), UpToExclusive Exp
end'')
        | Scalar (Prim (Signed IntType
Int64)) <- PatType
end_t ->
          Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromBound Exp
end''
      (Just Int64
0, Maybe (Maybe Int64)
Nothing, UpToExclusive Exp
end'')
        | Scalar (Prim (Signed IntType
Int64)) <- PatType
end_t ->
          Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromBound Exp
end''
      (Just Int64
1, Just (Just Int64
2), ToInclusive Exp
end'')
        | Scalar (Prim (Signed IntType
Int64)) <- PatType
end_t ->
          Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromBound Exp
end''
      (Maybe Int64, Maybe (Maybe Int64), Inclusiveness Exp)
_ -> do
        VName
d <- SrcLoc -> Rigidity -> Name -> TermTypeM VName
forall (m :: * -> *).
MonadUnify m =>
SrcLoc -> Rigidity -> Name -> m VName
newDimVar SrcLoc
loc (RigidSource -> Rigidity
Rigid RigidSource
RigidRange) Name
"range_dim"
        (DimDecl VName, Maybe VName)
-> TermTypeM (DimDecl VName, Maybe VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
d, VName -> Maybe VName
forall a. a -> Maybe a
Just VName
d)

  StructType
t <- SrcLoc
-> StructType
-> ShapeDecl (DimDecl VName)
-> Uniqueness
-> TermTypeM StructType
forall dim as.
(Pretty (ShapeDecl dim), Monoid as) =>
SrcLoc
-> TypeBase dim as
-> ShapeDecl dim
-> Uniqueness
-> TermTypeM (TypeBase dim as)
arrayOfM SrcLoc
loc StructType
start_t ([DimDecl VName] -> ShapeDecl (DimDecl VName)
forall dim. [dim] -> ShapeDecl dim
ShapeDecl [DimDecl VName
dim]) Uniqueness
Unique
  let res :: AppRes
res = PatType -> [VName] -> AppRes
AppRes (StructType
t StructType -> Aliasing -> PatType
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Aliasing
forall a. Monoid a => a
mempty) (Maybe VName -> [VName]
forall a. Maybe a -> [a]
maybeToList Maybe VName
retext)

  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Exp
-> Maybe Exp
-> Inclusiveness Exp
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn
-> Maybe (ExpBase f vn)
-> Inclusiveness (ExpBase f vn)
-> SrcLoc
-> AppExpBase f vn
Range Exp
start' Maybe Exp
maybe_step' Inclusiveness Exp
end' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info AppRes
res)
checkExp (Ascript UncheckedExp
e UncheckedTypeDecl
decl SrcLoc
loc) = do
  (TypeDecl
decl', Exp
e') <- SrcLoc
-> UncheckedTypeDecl -> UncheckedExp -> TermTypeM (TypeDecl, Exp)
checkAscript SrcLoc
loc UncheckedTypeDecl
decl UncheckedExp
e
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> TypeDecl -> SrcLoc -> Exp
forall (f :: * -> *) vn.
ExpBase f vn -> TypeDeclBase f vn -> SrcLoc -> ExpBase f vn
Ascript Exp
e' TypeDecl
decl' SrcLoc
loc
checkExp (AppExp (Coerce UncheckedExp
e UncheckedTypeDecl
decl SrcLoc
loc) NoInfo AppRes
_) = do
  (TypeDecl
decl', Exp
e', [VName]
ext) <- SrcLoc
-> UncheckedTypeDecl
-> UncheckedExp
-> TermTypeM (TypeDecl, Exp, [VName])
checkCoerce SrcLoc
loc UncheckedTypeDecl
decl UncheckedExp
e
  PatType
t <- Exp -> TermTypeM PatType
expTypeFully Exp
e'
  PatType
t' <- ([VName]
 -> DimDecl VName -> DimDecl VName -> TermTypeM (DimDecl VName))
-> PatType -> PatType -> TermTypeM PatType
forall as (m :: * -> *) d1 d2.
(Monoid as, Monad m) =>
([VName] -> d1 -> d2 -> m d1)
-> TypeBase d1 as -> TypeBase d2 as -> m (TypeBase d1 as)
matchDims ((DimDecl VName -> TermTypeM (DimDecl VName))
-> DimDecl VName -> DimDecl VName -> TermTypeM (DimDecl VName)
forall a b. a -> b -> a
const ((DimDecl VName -> TermTypeM (DimDecl VName))
 -> DimDecl VName -> DimDecl VName -> TermTypeM (DimDecl VName))
-> ([VName] -> DimDecl VName -> TermTypeM (DimDecl VName))
-> [VName]
-> DimDecl VName
-> DimDecl VName
-> TermTypeM (DimDecl VName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DimDecl VName -> TermTypeM (DimDecl VName))
-> [VName] -> DimDecl VName -> TermTypeM (DimDecl VName)
forall a b. a -> b -> a
const DimDecl VName -> TermTypeM (DimDecl VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) PatType
t (PatType -> TermTypeM PatType) -> PatType -> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct (StructType -> PatType) -> StructType -> PatType
forall a b. (a -> b) -> a -> b
$ Info StructType -> StructType
forall a. Info a -> a
unInfo (Info StructType -> StructType) -> Info StructType -> StructType
forall a b. (a -> b) -> a -> b
$ TypeDecl -> Info StructType
forall (f :: * -> *) vn. TypeDeclBase f vn -> f StructType
expandedType TypeDecl
decl'
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Exp -> TypeDecl -> SrcLoc -> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn -> TypeDeclBase f vn -> SrcLoc -> AppExpBase f vn
Coerce Exp
e' TypeDecl
decl' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
t' [VName]
ext)
checkExp (AppExp (BinOp (QualName Name
op, SrcLoc
oploc) NoInfo PatType
NoInfo (UncheckedExp
e1, NoInfo (StructType, Maybe VName)
_) (UncheckedExp
e2, NoInfo (StructType, Maybe VName)
_) SrcLoc
loc) NoInfo AppRes
NoInfo) = do
  (QualName VName
op', PatType
ftype) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
oploc QualName Name
op
  Arg
e1_arg <- UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
e1
  Arg
e2_arg <- UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
e2

  -- Note that the application to the first operand cannot fix any
  -- existential sizes, because it must by necessity be a function.
  (PatType
p1_t, PatType
rt, Maybe VName
p1_ext, [VName]
_) <- SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply SrcLoc
loc (QualName VName -> Maybe (QualName VName)
forall a. a -> Maybe a
Just QualName VName
op', Level
0) PatType
ftype Arg
e1_arg
  (PatType
p2_t, PatType
rt', Maybe VName
p2_ext, [VName]
retext) <- SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply SrcLoc
loc (QualName VName -> Maybe (QualName VName)
forall a. a -> Maybe a
Just QualName VName
op', Level
1) PatType
rt Arg
e2_arg

  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
    AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp
      ( (QualName VName, SrcLoc)
-> Info PatType
-> (Exp, Info (StructType, Maybe VName))
-> (Exp, Info (StructType, Maybe VName))
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
(QualName vn, SrcLoc)
-> f PatType
-> (ExpBase f vn, f (StructType, Maybe VName))
-> (ExpBase f vn, f (StructType, Maybe VName))
-> SrcLoc
-> AppExpBase f vn
BinOp
          (QualName VName
op', SrcLoc
oploc)
          (PatType -> Info PatType
forall a. a -> Info a
Info PatType
ftype)
          (Arg -> Exp
argExp Arg
e1_arg, (StructType, Maybe VName) -> Info (StructType, Maybe VName)
forall a. a -> Info a
Info (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
p1_t, Maybe VName
p1_ext))
          (Arg -> Exp
argExp Arg
e2_arg, (StructType, Maybe VName) -> Info (StructType, Maybe VName)
forall a. a -> Info a
Info (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
p2_t, Maybe VName
p2_ext))
          SrcLoc
loc
      )
      (AppRes -> Info AppRes
forall a. a -> Info a
Info (PatType -> [VName] -> AppRes
AppRes PatType
rt' [VName]
retext))
checkExp (Project Name
k UncheckedExp
e NoInfo PatType
NoInfo SrcLoc
loc) = do
  Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  PatType
t <- Exp -> TermTypeM PatType
expType Exp
e'
  PatType
kt <- Usage -> Name -> PatType -> TermTypeM PatType
forall (m :: * -> *).
MonadUnify m =>
Usage -> Name -> PatType -> m PatType
mustHaveField (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc (String -> Usage) -> String -> Usage
forall a b. (a -> b) -> a -> b
$ String
"projection of field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote (Name -> String
forall a. Pretty a => a -> String
pretty Name
k)) Name
k PatType
t
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Name -> ExpBase f vn -> f PatType -> SrcLoc -> ExpBase f vn
Project Name
k Exp
e' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
kt) SrcLoc
loc
checkExp (AppExp (If UncheckedExp
e1 UncheckedExp
e2 UncheckedExp
e3 SrcLoc
loc) NoInfo AppRes
_) =
  TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially TermTypeM Exp
checkCond ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
e1' Occurrences
_ -> do
    ((Exp
e2', Exp
e3'), Occurrences
dflow) <- TermTypeM (Exp, Exp) -> TermTypeM ((Exp, Exp), Occurrences)
forall a. TermTypeM a -> TermTypeM (a, Occurrences)
tapOccurrences (TermTypeM (Exp, Exp) -> TermTypeM ((Exp, Exp), Occurrences))
-> TermTypeM (Exp, Exp) -> TermTypeM ((Exp, Exp), Occurrences)
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e2 TermTypeM Exp -> TermTypeM Exp -> TermTypeM (Exp, Exp)
forall a b. TermTypeM a -> TermTypeM b -> TermTypeM (a, b)
`alternative` UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e3

    (PatType
brancht, [VName]
retext) <- SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName])
unifyBranches SrcLoc
loc Exp
e2' Exp
e3'
    let t' :: PatType
t' = PatType -> (Aliasing -> Aliasing) -> PatType
forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
addAliases PatType
brancht ((Aliasing -> Aliasing) -> PatType)
-> (Aliasing -> Aliasing) -> PatType
forall a b. (a -> b) -> a -> b
$ (Alias -> Bool) -> Aliasing -> Aliasing
forall a. (a -> Bool) -> Set a -> Set a
S.filter ((Alias -> Bool) -> Aliasing -> Aliasing)
-> (Alias -> Bool) -> Aliasing -> Aliasing
forall a b. (a -> b) -> a -> b
$ (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Occurrences -> Names
allConsumed Occurrences
dflow) (VName -> Bool) -> (Alias -> VName) -> Alias -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar

    Usage -> String -> PatType -> TermTypeM ()
forall (m :: * -> *) dim as.
(MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>
Usage -> String -> TypeBase dim as -> m ()
zeroOrderType
      (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"returning value of this type from 'if' expression")
      String
"type returned from branch"
      PatType
t'

    Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Exp -> Exp -> Exp -> SrcLoc -> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn
-> ExpBase f vn -> ExpBase f vn -> SrcLoc -> AppExpBase f vn
If Exp
e1' Exp
e2' Exp
e3' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
t' [VName]
retext)
  where
    checkCond :: TermTypeM Exp
checkCond = do
      Exp
e1' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e1
      let bool :: TypeBase dim as
bool = ScalarTypeBase dim as -> TypeBase dim as
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase dim as -> TypeBase dim as)
-> ScalarTypeBase dim as -> TypeBase dim as
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase dim as
forall dim as. PrimType -> ScalarTypeBase dim as
Prim PrimType
Bool
      StructType
e1_t <- PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType)
-> TermTypeM PatType -> TermTypeM StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> TermTypeM PatType
expType Exp
e1'
      Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure ([StructType] -> StructType -> Checking
CheckingRequired [StructType
forall dim as. TypeBase dim as
bool] StructType
e1_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify (SrcLoc -> String -> Usage
mkUsage (Exp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Exp
e1') String
"use as 'if' condition") StructType
forall dim as. TypeBase dim as
bool StructType
e1_t
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e1'
checkExp (Parens UncheckedExp
e SrcLoc
loc) =
  Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> ExpBase f vn
Parens (Exp -> SrcLoc -> Exp)
-> TermTypeM Exp -> TermTypeM (SrcLoc -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e TermTypeM (SrcLoc -> Exp) -> TermTypeM SrcLoc -> TermTypeM Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> TermTypeM SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
checkExp (QualParens (QualName Name
modname, SrcLoc
modnameloc) UncheckedExp
e SrcLoc
loc) = do
  (QualName VName
modname', Mod
mod) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, Mod)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, Mod)
lookupMod SrcLoc
loc QualName Name
modname
  case Mod
mod of
    ModEnv Env
env -> (TermEnv -> TermEnv) -> TermTypeM Exp -> TermTypeM Exp
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (TermEnv -> Env -> TermEnv
`withEnv` QualName VName -> Env -> Env
qualifyEnv QualName VName
modname' Env
env) (TermTypeM Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ do
      Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ (QualName VName, SrcLoc) -> Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn.
(QualName vn, SrcLoc) -> ExpBase f vn -> SrcLoc -> ExpBase f vn
QualParens (QualName VName
modname', SrcLoc
modnameloc) Exp
e' SrcLoc
loc
    ModFun {} ->
      SrcLoc -> Notes -> Doc -> TermTypeM Exp
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Exp) -> (Doc -> Doc) -> Doc -> TermTypeM Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"module-is-parametric" (Doc -> TermTypeM Exp) -> Doc -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
        Doc
"Module" Doc -> Doc -> Doc
<+> QualName Name -> Doc
forall a. Pretty a => a -> Doc
ppr QualName Name
modname Doc -> Doc -> Doc
<+> Doc
" is a parametric module."
  where
    qualifyEnv :: QualName VName -> Env -> Env
qualifyEnv QualName VName
modname' Env
env =
      Env
env {envNameMap :: NameMap
envNameMap = (QualName VName -> QualName VName) -> NameMap -> NameMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (QualName VName -> QualName VName -> QualName VName
forall vn. QualName vn -> QualName vn -> QualName vn
qualify' QualName VName
modname') (NameMap -> NameMap) -> NameMap -> NameMap
forall a b. (a -> b) -> a -> b
$ Env -> NameMap
envNameMap Env
env}
    qualify' :: QualName vn -> QualName vn -> QualName vn
qualify' QualName vn
modname' (QualName [vn]
qs vn
name) =
      [vn] -> vn -> QualName vn
forall vn. [vn] -> vn -> QualName vn
QualName (QualName vn -> [vn]
forall vn. QualName vn -> [vn]
qualQuals QualName vn
modname' [vn] -> [vn] -> [vn]
forall a. [a] -> [a] -> [a]
++ [QualName vn -> vn
forall vn. QualName vn -> vn
qualLeaf QualName vn
modname'] [vn] -> [vn] -> [vn]
forall a. [a] -> [a] -> [a]
++ [vn]
qs) vn
name
checkExp (Var QualName Name
qn NoInfo PatType
NoInfo SrcLoc
loc) = do
  -- The qualifiers of a variable is divided into two parts: first a
  -- possibly-empty sequence of module qualifiers, followed by a
  -- possible-empty sequence of record field accesses.  We use scope
  -- information to perform the split, by taking qualifiers off the
  -- end until we find a module.

  (QualName VName
qn', PatType
t, [Name]
fields) <- [Name] -> Name -> TermTypeM (QualName VName, PatType, [Name])
forall b (m :: * -> *).
(MonadError b m, MonadTypeChecker m) =>
[Name] -> Name -> m (QualName VName, PatType, [Name])
findRootVar (QualName Name -> [Name]
forall vn. QualName vn -> [vn]
qualQuals QualName Name
qn) (QualName Name -> Name
forall vn. QualName vn -> vn
qualLeaf QualName Name
qn)

  (Exp -> Name -> TermTypeM Exp) -> Exp -> [Name] -> TermTypeM Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exp -> Name -> TermTypeM Exp
checkField (QualName VName -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
QualName vn -> f PatType -> SrcLoc -> ExpBase f vn
Var QualName VName
qn' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
t) SrcLoc
loc) [Name]
fields
  where
    findRootVar :: [Name] -> Name -> m (QualName VName, PatType, [Name])
findRootVar [Name]
qs Name
name =
      ((QualName VName, PatType) -> (QualName VName, PatType, [Name])
forall a b a. (a, b) -> (a, b, [a])
whenFound ((QualName VName, PatType) -> (QualName VName, PatType, [Name]))
-> m (QualName VName, PatType)
-> m (QualName VName, PatType, [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcLoc -> QualName Name -> m (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
loc ([Name] -> Name -> QualName Name
forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
name)) m (QualName VName, PatType, [Name])
-> (b -> m (QualName VName, PatType, [Name]))
-> m (QualName VName, PatType, [Name])
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` [Name] -> Name -> b -> m (QualName VName, PatType, [Name])
notFound [Name]
qs Name
name

    whenFound :: (a, b) -> (a, b, [a])
whenFound (a
qn', b
t) = (a
qn', b
t, [])

    notFound :: [Name] -> Name -> b -> m (QualName VName, PatType, [Name])
notFound [Name]
qs Name
name b
err
      | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
qs = b -> m (QualName VName, PatType, [Name])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError b
err
      | Bool
otherwise = do
        (QualName VName
qn', PatType
t, [Name]
fields) <-
          [Name] -> Name -> m (QualName VName, PatType, [Name])
findRootVar ([Name] -> [Name]
forall a. [a] -> [a]
init [Name]
qs) ([Name] -> Name
forall a. [a] -> a
last [Name]
qs)
            m (QualName VName, PatType, [Name])
-> (b -> m (QualName VName, PatType, [Name]))
-> m (QualName VName, PatType, [Name])
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` m (QualName VName, PatType, [Name])
-> b -> m (QualName VName, PatType, [Name])
forall a b. a -> b -> a
const (b -> m (QualName VName, PatType, [Name])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError b
err)
        (QualName VName, PatType, [Name])
-> m (QualName VName, PatType, [Name])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName VName
qn', PatType
t, [Name]
fields [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
name])

    checkField :: Exp -> Name -> TermTypeM Exp
checkField Exp
e Name
k = do
      PatType
t <- Exp -> TermTypeM PatType
expType Exp
e
      let usage :: Usage
usage = SrcLoc -> String -> Usage
mkUsage SrcLoc
loc (String -> Usage) -> String -> Usage
forall a b. (a -> b) -> a -> b
$ String
"projection of field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote (Name -> String
forall a. Pretty a => a -> String
pretty Name
k)
      PatType
kt <- Usage -> Name -> PatType -> TermTypeM PatType
forall (m :: * -> *).
MonadUnify m =>
Usage -> Name -> PatType -> m PatType
mustHaveField Usage
usage Name
k PatType
t
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Name -> ExpBase f vn -> f PatType -> SrcLoc -> ExpBase f vn
Project Name
k Exp
e (PatType -> Info PatType
forall a. a -> Info a
Info PatType
kt) SrcLoc
loc
checkExp (Negate UncheckedExp
arg SrcLoc
loc) = do
  Exp
arg' <- String -> [PrimType] -> Exp -> TermTypeM Exp
require String
"numeric negation" [PrimType]
anyNumberType (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
arg
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> ExpBase f vn
Negate Exp
arg' SrcLoc
loc
checkExp (Not UncheckedExp
arg SrcLoc
loc) = do
  Exp
arg' <- String -> [PrimType] -> Exp -> TermTypeM Exp
require String
"logical negation" (PrimType
Bool PrimType -> [PrimType] -> [PrimType]
forall a. a -> [a] -> [a]
: [PrimType]
anyIntType) (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
arg
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> ExpBase f vn
Not Exp
arg' SrcLoc
loc
checkExp e :: UncheckedExp
e@(AppExp Apply {} NoInfo AppRes
_) = (Exp, ApplyOp) -> Exp
forall a b. (a, b) -> a
fst ((Exp, ApplyOp) -> Exp)
-> TermTypeM (Exp, ApplyOp) -> TermTypeM Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UncheckedExp -> TermTypeM (Exp, ApplyOp)
checkApplyExp UncheckedExp
e
checkExp (AppExp (LetPat [SizeBinder Name]
sizes PatBase NoInfo Name
pat UncheckedExp
e UncheckedExp
body SrcLoc
loc) NoInfo AppRes
_) =
  TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e) ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
e' Occurrences
e_occs -> do
    -- Not technically an ascription, but we want the pattern to have
    -- exactly the type of 'e'.
    PatType
t <- Exp -> TermTypeM PatType
expType Exp
e'
    case Occurrences -> Maybe Occurrence
anyConsumption Occurrences
e_occs of
      Just Occurrence
c ->
        let msg :: String
msg = String
"type computed with consumption at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
forall a. Located a => a -> String
locStr (Occurrence -> SrcLoc
location Occurrence
c)
         in Usage -> String -> PatType -> TermTypeM ()
forall (m :: * -> *) dim as.
(MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>
Usage -> String -> TypeBase dim as -> m ()
zeroOrderType (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"consumption in right-hand side of 'let'-binding") String
msg PatType
t
      Maybe Occurrence
_ -> () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    TermTypeM Exp -> TermTypeM Exp
forall a. TermTypeM a -> TermTypeM a
incLevel (TermTypeM Exp -> TermTypeM Exp)
-> (([SizeBinder VName] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([SizeBinder VName] -> TermTypeM Exp)
-> TermTypeM Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SizeBinder Name]
-> ([SizeBinder VName] -> TermTypeM Exp) -> TermTypeM Exp
forall a.
[SizeBinder Name]
-> ([SizeBinder VName] -> TermTypeM a) -> TermTypeM a
bindingSizes [SizeBinder Name]
sizes (([SizeBinder VName] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([SizeBinder VName] -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \[SizeBinder VName]
sizes' ->
      [SizeBinder VName]
-> PatBase NoInfo Name
-> InferredType
-> (Pat -> TermTypeM Exp)
-> TermTypeM Exp
forall a.
[SizeBinder VName]
-> PatBase NoInfo Name
-> InferredType
-> (Pat -> TermTypeM a)
-> TermTypeM a
bindingPat [SizeBinder VName]
sizes' PatBase NoInfo Name
pat (PatType -> InferredType
Ascribed PatType
t) ((Pat -> TermTypeM Exp) -> TermTypeM Exp)
-> (Pat -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Pat
pat' -> do
        Exp
body' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
body
        (PatType
body_t, [VName]
retext) <-
          SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType SrcLoc
loc ([SizeBinder VName] -> Map VName Ident
sizesMap [SizeBinder VName]
sizes' Map VName Ident -> Map VName Ident -> Map VName Ident
forall a. Semigroup a => a -> a -> a
<> Pat -> Map VName Ident
forall (f :: * -> *).
Functor f =>
PatBase f VName -> Map VName (IdentBase f VName)
patternMap Pat
pat') (PatType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
body'

        Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp ([SizeBinder VName]
-> Pat -> Exp -> Exp -> SrcLoc -> AppExpBase Info VName
forall (f :: * -> *) vn.
[SizeBinder vn]
-> PatBase f vn
-> ExpBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetPat [SizeBinder VName]
sizes' Pat
pat' Exp
e' Exp
body' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
body_t [VName]
retext)
  where
    sizesMap :: [SizeBinder VName] -> Map VName Ident
sizesMap = (SizeBinder VName -> Map VName Ident)
-> [SizeBinder VName] -> Map VName Ident
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SizeBinder VName -> Map VName Ident
forall vn. SizeBinder vn -> Map vn (IdentBase Info vn)
onSize
    onSize :: SizeBinder vn -> Map vn (IdentBase Info vn)
onSize SizeBinder vn
size =
      vn -> IdentBase Info vn -> Map vn (IdentBase Info vn)
forall k a. k -> a -> Map k a
M.singleton (SizeBinder vn -> vn
forall vn. SizeBinder vn -> vn
sizeName SizeBinder vn
size) (IdentBase Info vn -> Map vn (IdentBase Info vn))
-> IdentBase Info vn -> Map vn (IdentBase Info vn)
forall a b. (a -> b) -> a -> b
$
        vn -> Info PatType -> SrcLoc -> IdentBase Info vn
forall (f :: * -> *) vn.
vn -> f PatType -> SrcLoc -> IdentBase f vn
Ident (SizeBinder vn -> vn
forall vn. SizeBinder vn -> vn
sizeName SizeBinder vn
size) (PatType -> Info PatType
forall a. a -> Info a
Info (ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> PrimType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int64)) (SizeBinder vn -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf SizeBinder vn
size)
checkExp (AppExp (LetFun Name
name ([TypeParamBase Name]
tparams, [PatBase NoInfo Name]
params, Maybe (TypeExp Name)
maybe_retdecl, NoInfo StructRetType
NoInfo, UncheckedExp
e) UncheckedExp
body SrcLoc
loc) NoInfo AppRes
_) =
  TermTypeM
  ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
-> (([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
    -> Occurrences -> TermTypeM Exp)
-> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially ((Name, Maybe (TypeExp Name), [TypeParamBase Name],
 [PatBase NoInfo Name], UncheckedExp, SrcLoc)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
checkBinding (Name
name, Maybe (TypeExp Name)
maybe_retdecl, [TypeParamBase Name]
tparams, [PatBase NoInfo Name]
params, UncheckedExp
e, SrcLoc
loc)) ((([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
  -> Occurrences -> TermTypeM Exp)
 -> TermTypeM Exp)
-> (([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
    -> Occurrences -> TermTypeM Exp)
-> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
    \([TypeParam]
tparams', [Pat]
params', Maybe (TypeExp VName)
maybe_retdecl', StructRetType
rettype, Exp
e') Occurrences
closure -> do
      Aliasing
closure' <- [Pat] -> Occurrences -> TermTypeM Aliasing
lexicalClosure [Pat]
params' Occurrences
closure

      [(Namespace, Name)] -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
name)] (TermTypeM Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ do
        VName
name' <- Namespace -> Name -> SrcLoc -> TermTypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
name SrcLoc
loc

        let arrow :: (PName, TypeBase dim ())
-> RetTypeBase dim () -> RetTypeBase dim ()
arrow (PName
xp, TypeBase dim ()
xt) RetTypeBase dim ()
yt = [VName] -> TypeBase dim () -> RetTypeBase dim ()
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] (TypeBase dim () -> RetTypeBase dim ())
-> TypeBase dim () -> RetTypeBase dim ()
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase dim () -> TypeBase dim ()
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase dim () -> TypeBase dim ())
-> ScalarTypeBase dim () -> TypeBase dim ()
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> TypeBase dim ()
-> RetTypeBase dim ()
-> ScalarTypeBase dim ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow () PName
xp TypeBase dim ()
xt RetTypeBase dim ()
yt
            RetType [VName]
_ StructType
ftype = (Pat -> StructRetType -> StructRetType)
-> StructRetType -> [Pat] -> StructRetType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PName, StructType) -> StructRetType -> StructRetType
forall dim.
(PName, TypeBase dim ())
-> RetTypeBase dim () -> RetTypeBase dim ()
arrow ((PName, StructType) -> StructRetType -> StructRetType)
-> (Pat -> (PName, StructType))
-> Pat
-> StructRetType
-> StructRetType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> (PName, StructType)
patternParam) StructRetType
rettype [Pat]
params'
            entry :: ValBinding
entry = Locality -> [TypeParam] -> PatType -> ValBinding
BoundV Locality
Local [TypeParam]
tparams' (PatType -> ValBinding) -> PatType -> ValBinding
forall a b. (a -> b) -> a -> b
$ StructType
ftype StructType -> Aliasing -> PatType
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Aliasing
closure'
            bindF :: TermScope -> TermScope
bindF TermScope
scope =
              TermScope
scope
                { scopeVtable :: Map VName ValBinding
scopeVtable =
                    VName -> ValBinding -> Map VName ValBinding -> Map VName ValBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
name' ValBinding
entry (Map VName ValBinding -> Map VName ValBinding)
-> Map VName ValBinding -> Map VName ValBinding
forall a b. (a -> b) -> a -> b
$ TermScope -> Map VName ValBinding
scopeVtable TermScope
scope,
                  scopeNameMap :: NameMap
scopeNameMap =
                    (Namespace, Name) -> QualName VName -> NameMap -> NameMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Namespace
Term, Name
name) (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name') (NameMap -> NameMap) -> NameMap -> NameMap
forall a b. (a -> b) -> a -> b
$
                      TermScope -> NameMap
scopeNameMap TermScope
scope
                }
        Exp
body' <- (TermScope -> TermScope) -> TermTypeM Exp -> TermTypeM Exp
forall a. (TermScope -> TermScope) -> TermTypeM a -> TermTypeM a
localScope TermScope -> TermScope
bindF (TermTypeM Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
body

        -- We fake an ident here, but it's OK as it can't be a size
        -- anyway.
        let fake_ident :: Ident
fake_ident = VName -> Info PatType -> SrcLoc -> Ident
forall (f :: * -> *) vn.
vn -> f PatType -> SrcLoc -> IdentBase f vn
Ident VName
name' (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct StructType
ftype) SrcLoc
forall a. Monoid a => a
mempty
        (PatType
body_t, [VName]
ext) <-
          SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType SrcLoc
loc (VName -> Ident -> Map VName Ident
forall k a. k -> a -> Map k a
M.singleton VName
name' Ident
fake_ident)
            (PatType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
body'

        Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
          AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp
            ( VName
-> ([TypeParam], [Pat], Maybe (TypeExp VName), Info StructRetType,
    Exp)
-> Exp
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
vn
-> ([TypeParamBase vn], [PatBase f vn], Maybe (TypeExp vn),
    f StructRetType, ExpBase f vn)
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetFun
                VName
name'
                ([TypeParam]
tparams', [Pat]
params', Maybe (TypeExp VName)
maybe_retdecl', StructRetType -> Info StructRetType
forall a. a -> Info a
Info StructRetType
rettype, Exp
e')
                Exp
body'
                SrcLoc
loc
            )
            (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
body_t [VName]
ext)
checkExp (AppExp (LetWith IdentBase NoInfo Name
dest IdentBase NoInfo Name
src SliceBase NoInfo Name
slice UncheckedExp
ve UncheckedExp
body SrcLoc
loc) NoInfo AppRes
_) =
  TermTypeM Ident
-> (Ident -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (IdentBase NoInfo Name -> TermTypeM Ident
checkIdent IdentBase NoInfo Name
src) ((Ident -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Ident -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Ident
src' Occurrences
_ -> do
    Slice
slice' <- SliceBase NoInfo Name -> TermTypeM Slice
checkSlice SliceBase NoInfo Name
slice
    (StructType
t, StructType
_) <- SrcLoc -> Name -> Level -> TermTypeM (StructType, StructType)
newArrayType (IdentBase NoInfo Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf IdentBase NoInfo Name
src) Name
"src" (Level -> TermTypeM (StructType, StructType))
-> Level -> TermTypeM (StructType, StructType)
forall a b. (a -> b) -> a -> b
$ Slice -> Level
sliceDims Slice
slice'
    Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"type of target array") StructType
t (StructType -> TermTypeM ()) -> StructType -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType) -> PatType -> StructType
forall a b. (a -> b) -> a -> b
$ Info PatType -> PatType
forall a. Info a -> a
unInfo (Info PatType -> PatType) -> Info PatType -> PatType
forall a b. (a -> b) -> a -> b
$ Ident -> Info PatType
forall (f :: * -> *) vn. IdentBase f vn -> f PatType
identType Ident
src'

    -- Need the fully normalised type here to get the proper aliasing information.
    PatType
src_t <- PatType -> TermTypeM PatType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully (PatType -> TermTypeM PatType) -> PatType -> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ Info PatType -> PatType
forall a. Info a -> a
unInfo (Info PatType -> PatType) -> Info PatType -> PatType
forall a b. (a -> b) -> a -> b
$ Ident -> Info PatType
forall (f :: * -> *) vn. IdentBase f vn -> f PatType
identType Ident
src'

    (StructType
elemt, [VName]
_) <- Maybe (SrcLoc, Rigidity)
-> Slice -> StructType -> TermTypeM (StructType, [VName])
forall as.
Maybe (SrcLoc, Rigidity)
-> Slice
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape ((SrcLoc, Rigidity) -> Maybe (SrcLoc, Rigidity)
forall a. a -> Maybe a
Just (SrcLoc
loc, Rigidity
Nonrigid)) Slice
slice' (StructType -> TermTypeM (StructType, [VName]))
-> TermTypeM StructType -> TermTypeM (StructType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
t

    Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PatType -> Bool
forall shape as. TypeBase shape as -> Bool
unique PatType
src_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Doc -> TermTypeM ()
forall (m :: * -> *) b. MonadTypeChecker m => SrcLoc -> Doc -> m b
notConsumable SrcLoc
loc (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
pquote (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall v. IsName v => v -> Doc
pprName (Name -> Doc) -> Name -> Doc
forall a b. (a -> b) -> a -> b
$ IdentBase NoInfo Name -> Name
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName IdentBase NoInfo Name
src

    TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (String -> StructType -> Exp -> TermTypeM Exp
unifies String
"type of target array" (StructType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct StructType
elemt) (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
ve) ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
ve' Occurrences
_ -> do
      PatType
ve_t <- Exp -> TermTypeM PatType
expTypeFully Exp
ve'
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VName -> Alias
AliasBound (Ident -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName Ident
src') Alias -> Aliasing -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
ve_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        IdentBase NoInfo Name -> UncheckedExp -> SrcLoc -> TermTypeM ()
forall arr src a.
(Pretty arr, Pretty src) =>
arr -> src -> SrcLoc -> TermTypeM a
badLetWithValue IdentBase NoInfo Name
src UncheckedExp
ve SrcLoc
loc

      IdentBase NoInfo Name
-> PatType -> (Ident -> TermTypeM Exp) -> TermTypeM Exp
forall a.
IdentBase NoInfo Name
-> PatType -> (Ident -> TermTypeM a) -> TermTypeM a
bindingIdent IdentBase NoInfo Name
dest (PatType
src_t PatType -> Aliasing -> PatType
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Aliasing
forall a. Set a
S.empty) ((Ident -> TermTypeM Exp) -> TermTypeM Exp)
-> (Ident -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Ident
dest' -> do
        Exp
body' <- Ident -> TermTypeM Exp -> TermTypeM Exp
forall a. Ident -> TermTypeM a -> TermTypeM a
consuming Ident
src' (TermTypeM Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
body
        (PatType
body_t, [VName]
ext) <-
          SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType SrcLoc
loc (VName -> Ident -> Map VName Ident
forall k a. k -> a -> Map k a
M.singleton (Ident -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName Ident
dest') Ident
dest')
            (PatType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
body'
        Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Ident
-> Ident -> Slice -> Exp -> Exp -> SrcLoc -> AppExpBase Info VName
forall (f :: * -> *) vn.
IdentBase f vn
-> IdentBase f vn
-> SliceBase f vn
-> ExpBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetWith Ident
dest' Ident
src' Slice
slice' Exp
ve' Exp
body' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
body_t [VName]
ext)
checkExp (Update UncheckedExp
src SliceBase NoInfo Name
slice UncheckedExp
ve SrcLoc
loc) = do
  Slice
slice' <- SliceBase NoInfo Name -> TermTypeM Slice
checkSlice SliceBase NoInfo Name
slice
  (StructType
t, StructType
_) <- SrcLoc -> Name -> Level -> TermTypeM (StructType, StructType)
newArrayType (UncheckedExp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf UncheckedExp
src) Name
"src" (Level -> TermTypeM (StructType, StructType))
-> Level -> TermTypeM (StructType, StructType)
forall a b. (a -> b) -> a -> b
$ Slice -> Level
sliceDims Slice
slice'
  (StructType
elemt, [VName]
_) <- Maybe (SrcLoc, Rigidity)
-> Slice -> StructType -> TermTypeM (StructType, [VName])
forall as.
Maybe (SrcLoc, Rigidity)
-> Slice
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape ((SrcLoc, Rigidity) -> Maybe (SrcLoc, Rigidity)
forall a. a -> Maybe a
Just (SrcLoc
loc, Rigidity
Nonrigid)) Slice
slice' (StructType -> TermTypeM (StructType, [VName]))
-> TermTypeM StructType -> TermTypeM (StructType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
t

  TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
ve TermTypeM Exp -> (Exp -> TermTypeM Exp) -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> StructType -> Exp -> TermTypeM Exp
unifies String
"type of target array" StructType
elemt) ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
ve' Occurrences
_ ->
    TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
src TermTypeM Exp -> (Exp -> TermTypeM Exp) -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> StructType -> Exp -> TermTypeM Exp
unifies String
"type of target array" StructType
t) ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
src' Occurrences
_ -> do
      PatType
src_t <- Exp -> TermTypeM PatType
expTypeFully Exp
src'

      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PatType -> Bool
forall shape as. TypeBase shape as -> Bool
unique PatType
src_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Doc -> TermTypeM ()
forall (m :: * -> *) b. MonadTypeChecker m => SrcLoc -> Doc -> m b
notConsumable SrcLoc
loc (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
pquote (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Doc
forall a. Pretty a => a -> Doc
ppr UncheckedExp
src

      let src_als :: Aliasing
src_als = PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
src_t
      PatType
ve_t <- Exp -> TermTypeM PatType
expTypeFully Exp
ve'
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Aliasing -> Bool
forall a. Set a -> Bool
S.null (Aliasing -> Bool) -> Aliasing -> Bool
forall a b. (a -> b) -> a -> b
$ Aliasing
src_als Aliasing -> Aliasing -> Aliasing
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
ve_t) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> UncheckedExp -> SrcLoc -> TermTypeM ()
forall arr src a.
(Pretty arr, Pretty src) =>
arr -> src -> SrcLoc -> TermTypeM a
badLetWithValue UncheckedExp
src UncheckedExp
ve SrcLoc
loc

      SrcLoc -> Aliasing -> TermTypeM ()
consume SrcLoc
loc Aliasing
src_als
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Slice -> Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn.
ExpBase f vn
-> SliceBase f vn -> ExpBase f vn -> SrcLoc -> ExpBase f vn
Update Exp
src' Slice
slice' Exp
ve' SrcLoc
loc

-- Record updates are a bit hacky, because we do not have row typing
-- (yet?).  For now, we only permit record updates where we know the
-- full type up to the field we are updating.
checkExp (RecordUpdate UncheckedExp
src [Name]
fields UncheckedExp
ve NoInfo PatType
NoInfo SrcLoc
loc) = do
  Exp
src' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
src
  Exp
ve' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
ve
  PatType
a <- Exp -> TermTypeM PatType
expTypeFully Exp
src'
  (PatType -> Name -> TermTypeM PatType)
-> PatType -> [Name] -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ((Name -> PatType -> TermTypeM PatType)
-> PatType -> Name -> TermTypeM PatType
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name -> PatType -> TermTypeM PatType)
 -> PatType -> Name -> TermTypeM PatType)
-> (Name -> PatType -> TermTypeM PatType)
-> PatType
-> Name
-> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ Usage -> Name -> PatType -> TermTypeM PatType
forall (m :: * -> *).
MonadUnify m =>
Usage -> Name -> PatType -> m PatType
mustHaveField Usage
usage) PatType
a [Name]
fields
  PatType
ve_t <- Exp -> TermTypeM PatType
expType Exp
ve'
  PatType
updated_t <- [Name] -> PatType -> PatType -> TermTypeM PatType
forall as.
[Name]
-> TypeBase (DimDecl VName) as
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
updateField [Name]
fields PatType
ve_t (PatType -> TermTypeM PatType)
-> TermTypeM PatType -> TermTypeM PatType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
src'
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Name] -> Exp -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
ExpBase f vn
-> [Name] -> ExpBase f vn -> f PatType -> SrcLoc -> ExpBase f vn
RecordUpdate Exp
src' [Name]
fields Exp
ve' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
updated_t) SrcLoc
loc
  where
    usage :: Usage
usage = SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"record update"
    updateField :: [Name]
-> TypeBase (DimDecl VName) as
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
updateField [] TypeBase (DimDecl VName) as
ve_t TypeBase (DimDecl VName) as
src_t = do
      (TypeBase (DimDecl VName) as
src_t', Map VName (DimDecl VName)
_) <- SrcLoc
-> Rigidity
-> Name
-> TypeBase (DimDecl VName) as
-> TermTypeM
     (TypeBase (DimDecl VName) as, Map VName (DimDecl VName))
forall als.
SrcLoc
-> Rigidity
-> Name
-> TypeBase (DimDecl VName) als
-> TermTypeM
     (TypeBase (DimDecl VName) als, Map VName (DimDecl VName))
allDimsFreshInType SrcLoc
loc Rigidity
Nonrigid Name
"any" TypeBase (DimDecl VName) as
src_t
      Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure ([Name] -> StructType -> StructType -> Checking
CheckingRecordUpdate [Name]
fields (TypeBase (DimDecl VName) as -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) as
src_t') (TypeBase (DimDecl VName) as -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) as
ve_t)) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify Usage
usage (TypeBase (DimDecl VName) as -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) as
src_t') (TypeBase (DimDecl VName) as -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) as
ve_t)
      -- Important that we return ve_t so that we get the right aliases.
      TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeBase (DimDecl VName) as
ve_t
    updateField (Name
f : [Name]
fs) TypeBase (DimDecl VName) as
ve_t (Scalar (Record Map Name (TypeBase (DimDecl VName) as)
m))
      | Just TypeBase (DimDecl VName) as
f_t <- Name
-> Map Name (TypeBase (DimDecl VName) as)
-> Maybe (TypeBase (DimDecl VName) as)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
f Map Name (TypeBase (DimDecl VName) as)
m = do
        TypeBase (DimDecl VName) as
f_t' <- [Name]
-> TypeBase (DimDecl VName) as
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
updateField [Name]
fs TypeBase (DimDecl VName) as
ve_t TypeBase (DimDecl VName) as
f_t
        TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeBase (DimDecl VName) as
 -> TermTypeM (TypeBase (DimDecl VName) as))
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as)
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as)
-> ScalarTypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as
forall a b. (a -> b) -> a -> b
$ Map Name (TypeBase (DimDecl VName) as)
-> ScalarTypeBase (DimDecl VName) as
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name (TypeBase (DimDecl VName) as)
 -> ScalarTypeBase (DimDecl VName) as)
-> Map Name (TypeBase (DimDecl VName) as)
-> ScalarTypeBase (DimDecl VName) as
forall a b. (a -> b) -> a -> b
$ Name
-> TypeBase (DimDecl VName) as
-> Map Name (TypeBase (DimDecl VName) as)
-> Map Name (TypeBase (DimDecl VName) as)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
f TypeBase (DimDecl VName) as
f_t' Map Name (TypeBase (DimDecl VName) as)
m
    updateField [Name]
_ TypeBase (DimDecl VName) as
_ TypeBase (DimDecl VName) as
_ =
      SrcLoc -> Notes -> Doc -> TermTypeM (TypeBase (DimDecl VName) as)
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM (TypeBase (DimDecl VName) as))
-> (Doc -> Doc) -> Doc -> TermTypeM (TypeBase (DimDecl VName) as)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"record-type-not-known" (Doc -> TermTypeM (TypeBase (DimDecl VName) as))
-> Doc -> TermTypeM (TypeBase (DimDecl VName) as)
forall a b. (a -> b) -> a -> b
$
        Doc
"Full type of"
          Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (UncheckedExp -> Doc
forall a. Pretty a => a -> Doc
ppr UncheckedExp
src)
          Doc -> Doc -> Doc
</> String -> Doc
textwrap String
" is not known at this point.  Add a type annotation to the original record to disambiguate."

--
checkExp (AppExp (Index UncheckedExp
e SliceBase NoInfo Name
slice SrcLoc
loc) NoInfo AppRes
_) = do
  Slice
slice' <- SliceBase NoInfo Name -> TermTypeM Slice
checkSlice SliceBase NoInfo Name
slice
  (StructType
t, StructType
_) <- SrcLoc -> Name -> Level -> TermTypeM (StructType, StructType)
newArrayType SrcLoc
loc Name
"e" (Level -> TermTypeM (StructType, StructType))
-> Level -> TermTypeM (StructType, StructType)
forall a b. (a -> b) -> a -> b
$ Slice -> Level
sliceDims Slice
slice'
  Exp
e' <- String -> StructType -> Exp -> TermTypeM Exp
unifies String
"being indexed at" StructType
t (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  -- XXX, the RigidSlice here will be overridden in sliceShape with a proper value.
  (PatType
t', [VName]
retext) <-
    Maybe (SrcLoc, Rigidity)
-> Slice -> PatType -> TermTypeM (PatType, [VName])
forall as.
Maybe (SrcLoc, Rigidity)
-> Slice
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape ((SrcLoc, Rigidity) -> Maybe (SrcLoc, Rigidity)
forall a. a -> Maybe a
Just (SrcLoc
loc, RigidSource -> Rigidity
Rigid (Maybe (DimDecl VName) -> String -> RigidSource
RigidSlice Maybe (DimDecl VName)
forall a. Maybe a
Nothing String
""))) Slice
slice'
      (PatType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
e'

  -- Remove aliases if the result is an overloaded type, because that
  -- will certainly not be aliased.
  PatType
t'' <- PatType -> TermTypeM PatType
noAliasesIfOverloaded PatType
t'

  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Exp -> Slice -> SrcLoc -> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn -> SliceBase f vn -> SrcLoc -> AppExpBase f vn
Index Exp
e' Slice
slice' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
t'' [VName]
retext)
checkExp (Assert UncheckedExp
e1 UncheckedExp
e2 NoInfo String
NoInfo SrcLoc
loc) = do
  Exp
e1' <- String -> [PrimType] -> Exp -> TermTypeM Exp
require String
"being asserted" [PrimType
Bool] (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e1
  Exp
e2' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e2
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Info String -> SrcLoc -> Exp
forall (f :: * -> *) vn.
ExpBase f vn -> ExpBase f vn -> f String -> SrcLoc -> ExpBase f vn
Assert Exp
e1' Exp
e2' (String -> Info String
forall a. a -> Info a
Info (UncheckedExp -> String
forall a. Pretty a => a -> String
pretty UncheckedExp
e1)) SrcLoc
loc
checkExp (Lambda [PatBase NoInfo Name]
params UncheckedExp
body Maybe (TypeExp Name)
rettype_te NoInfo (Aliasing, StructRetType)
NoInfo SrcLoc
loc) =
  TermTypeM Exp -> TermTypeM Exp
forall a. TermTypeM a -> TermTypeM a
removeSeminullOccurrences (TermTypeM Exp -> TermTypeM Exp)
-> (([TypeParam] -> [Pat] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([TypeParam] -> [Pat] -> TermTypeM Exp)
-> TermTypeM Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermTypeM Exp -> TermTypeM Exp
forall a. TermTypeM a -> TermTypeM a
noUnique (TermTypeM Exp -> TermTypeM Exp)
-> (([TypeParam] -> [Pat] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([TypeParam] -> [Pat] -> TermTypeM Exp)
-> TermTypeM Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermTypeM Exp -> TermTypeM Exp
forall a. TermTypeM a -> TermTypeM a
incLevel (TermTypeM Exp -> TermTypeM Exp)
-> (([TypeParam] -> [Pat] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([TypeParam] -> [Pat] -> TermTypeM Exp)
-> TermTypeM Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeParamBase Name]
-> [PatBase NoInfo Name]
-> ([TypeParam] -> [Pat] -> TermTypeM Exp)
-> TermTypeM Exp
forall a.
[TypeParamBase Name]
-> [PatBase NoInfo Name]
-> ([TypeParam] -> [Pat] -> TermTypeM a)
-> TermTypeM a
bindingParams [] [PatBase NoInfo Name]
params (([TypeParam] -> [Pat] -> TermTypeM Exp) -> TermTypeM Exp)
-> ([TypeParam] -> [Pat] -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \[TypeParam]
_ [Pat]
params' -> do
    Maybe (TypeExp VName, StructType, [VName])
rettype_checked <- (TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName]))
-> Maybe (TypeExp Name)
-> TermTypeM (Maybe (TypeExp VName, StructType, [VName]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName])
checkTypeExpNonrigid Maybe (TypeExp Name)
rettype_te
    let declared_rettype :: Maybe StructType
declared_rettype =
          case Maybe (TypeExp VName, StructType, [VName])
rettype_checked of
            Just (TypeExp VName
_, StructType
st, [VName]
_) -> StructType -> Maybe StructType
forall a. a -> Maybe a
Just StructType
st
            Maybe (TypeExp VName, StructType, [VName])
Nothing -> Maybe StructType
forall a. Maybe a
Nothing
    (Exp
body', Occurrences
closure) <-
      TermTypeM Exp -> TermTypeM (Exp, Occurrences)
forall a. TermTypeM a -> TermTypeM (a, Occurrences)
tapOccurrences (TermTypeM Exp -> TermTypeM (Exp, Occurrences))
-> TermTypeM Exp -> TermTypeM (Exp, Occurrences)
forall a b. (a -> b) -> a -> b
$ [Pat]
-> UncheckedExp -> Maybe StructType -> SrcLoc -> TermTypeM Exp
checkFunBody [Pat]
params' UncheckedExp
body Maybe StructType
declared_rettype SrcLoc
loc
    PatType
body_t <- Exp -> TermTypeM PatType
expTypeFully Exp
body'

    [Pat]
params'' <- (Pat -> TermTypeM Pat) -> [Pat] -> TermTypeM [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> TermTypeM Pat
forall e. ASTMappable e => e -> TermTypeM e
updateTypes [Pat]
params'

    (Maybe (TypeExp VName)
rettype', StructRetType
rettype_st) <-
      case Maybe (TypeExp VName, StructType, [VName])
rettype_checked of
        Just (TypeExp VName
te, StructType
st, [VName]
ext) -> do
          let st_structural :: TypeBase () ()
st_structural = StructType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural StructType
st
          SrcLoc -> TypeBase () () -> [Pat] -> PatType -> TermTypeM ()
checkReturnAlias SrcLoc
loc TypeBase () ()
st_structural [Pat]
params'' PatType
body_t
          (Maybe (TypeExp VName), StructRetType)
-> TermTypeM (Maybe (TypeExp VName), StructRetType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExp VName -> Maybe (TypeExp VName)
forall a. a -> Maybe a
Just TypeExp VName
te, [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext StructType
st)
        Maybe (TypeExp VName, StructType, [VName])
Nothing -> do
          StructRetType
ret <-
            [Pat] -> StructType -> TermTypeM StructRetType
forall (m :: * -> *).
MonadUnify m =>
[Pat] -> StructType -> m StructRetType
inferReturnSizes [Pat]
params'' (StructType -> TermTypeM StructRetType)
-> (PatType -> StructType) -> PatType -> TermTypeM StructRetType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> TermTypeM StructRetType)
-> PatType -> TermTypeM StructRetType
forall a b. (a -> b) -> a -> b
$
              [Pat] -> PatType -> PatType
inferReturnUniqueness [Pat]
params'' PatType
body_t
          (Maybe (TypeExp VName), StructRetType)
-> TermTypeM (Maybe (TypeExp VName), StructRetType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeExp VName)
forall a. Maybe a
Nothing, StructRetType
ret)

    [Pat] -> PatType -> SrcLoc -> TermTypeM ()
checkGlobalAliases [Pat]
params' PatType
body_t SrcLoc
loc
    Maybe Name -> [Pat] -> TermTypeM ()
verifyFunctionParams Maybe Name
forall a. Maybe a
Nothing [Pat]
params'

    Aliasing
closure' <- [Pat] -> Occurrences -> TermTypeM Aliasing
lexicalClosure [Pat]
params'' Occurrences
closure

    Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [Pat]
-> Exp
-> Maybe (TypeExp VName)
-> Info (Aliasing, StructRetType)
-> SrcLoc
-> Exp
forall (f :: * -> *) vn.
[PatBase f vn]
-> ExpBase f vn
-> Maybe (TypeExp vn)
-> f (Aliasing, StructRetType)
-> SrcLoc
-> ExpBase f vn
Lambda [Pat]
params'' Exp
body' Maybe (TypeExp VName)
rettype' ((Aliasing, StructRetType) -> Info (Aliasing, StructRetType)
forall a. a -> Info a
Info (Aliasing
closure', StructRetType
rettype_st)) SrcLoc
loc
  where
    -- Inferring the sizes of the return type of a lambda is a lot
    -- like let-generalisation.  We wish to remove any rigid sizes
    -- that were created when checking the body, except for those that
    -- are visible in types that existed before we entered the body,
    -- are parameters, or are used in parameters.
    inferReturnSizes :: [Pat] -> StructType -> m StructRetType
inferReturnSizes [Pat]
params' StructType
ret = do
      Level
cur_lvl <- m Level
forall (m :: * -> *). MonadUnify m => m Level
curLevel
      let named :: (PName, b) -> Maybe VName
named (Named VName
x, b
_) = VName -> Maybe VName
forall a. a -> Maybe a
Just VName
x
          named (PName
Unnamed, b
_) = Maybe VName
forall a. Maybe a
Nothing
          param_names :: [VName]
param_names = (Pat -> Maybe VName) -> [Pat] -> [VName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PName, StructType) -> Maybe VName
forall b. (PName, b) -> Maybe VName
named ((PName, StructType) -> Maybe VName)
-> (Pat -> (PName, StructType)) -> Pat -> Maybe VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> (PName, StructType)
patternParam) [Pat]
params'
          pos_sizes :: Names
pos_sizes =
            StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNamesPos (StructType -> Names)
-> (StructRetType -> StructType) -> StructRetType -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StructType] -> StructRetType -> StructType
forall as dim.
Monoid as =>
[TypeBase dim as] -> RetTypeBase dim as -> TypeBase dim as
foldFunType ((Pat -> StructType) -> [Pat] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> StructType
patternStructType [Pat]
params') (StructRetType -> Names) -> StructRetType -> Names
forall a b. (a -> b) -> a -> b
$
              [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] StructType
ret
          hide :: VName -> (Level, b) -> Bool
hide VName
k (Level
lvl, b
_) =
            Level
lvl Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
cur_lvl Bool -> Bool -> Bool
&& VName
k VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [VName]
param_names Bool -> Bool -> Bool
&& VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Names
pos_sizes

      Names
hidden_sizes <-
        [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList ([VName] -> Names)
-> (Constraints -> [VName]) -> Constraints -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraints -> [VName]
forall k a. Map k a -> [k]
M.keys (Constraints -> [VName])
-> (Constraints -> Constraints) -> Constraints -> [VName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> (Level, Constraint) -> Bool)
-> Constraints -> Constraints
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey VName -> (Level, Constraint) -> Bool
forall b. VName -> (Level, b) -> Bool
hide (Constraints -> Names) -> m Constraints -> m Names
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Constraints
forall (m :: * -> *). MonadUnify m => m Constraints
getConstraints

      let onDim :: DimDecl VName -> Names
onDim (NamedDim QualName VName
name)
            | QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
name VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
hidden_sizes = VName -> Names
forall a. a -> Set a
S.singleton (VName -> Names) -> VName -> Names
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
name
          onDim DimDecl VName
_ = Names
forall a. Monoid a => a
mempty

      StructRetType -> m StructRetType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StructRetType -> m StructRetType)
-> StructRetType -> m StructRetType
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType (Names -> [VName]
forall a. Set a -> [a]
S.toList (Names -> [VName]) -> Names -> [VName]
forall a b. (a -> b) -> a -> b
$ (DimDecl VName -> Names) -> [DimDecl VName] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DimDecl VName -> Names
onDim ([DimDecl VName] -> Names) -> [DimDecl VName] -> Names
forall a b. (a -> b) -> a -> b
$ StructType -> [DimDecl VName]
forall as. TypeBase (DimDecl VName) as -> [DimDecl VName]
nestedDims StructType
ret) StructType
ret
checkExp (OpSection QualName Name
op NoInfo PatType
_ SrcLoc
loc) = do
  (QualName VName
op', PatType
ftype) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
loc QualName Name
op
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ QualName VName -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
QualName vn -> f PatType -> SrcLoc -> ExpBase f vn
OpSection QualName VName
op' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
ftype) SrcLoc
loc
checkExp (OpSectionLeft QualName Name
op NoInfo PatType
_ UncheckedExp
e (NoInfo (PName, StructType, Maybe VName),
 NoInfo (PName, StructType))
_ (NoInfo PatRetType, NoInfo [VName])
_ SrcLoc
loc) = do
  (QualName VName
op', PatType
ftype) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
loc QualName Name
op
  Arg
e_arg <- UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
e
  (PatType
t1, PatType
rt, Maybe VName
argext, [VName]
retext) <- SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply SrcLoc
loc (QualName VName -> Maybe (QualName VName)
forall a. a -> Maybe a
Just QualName VName
op', Level
0) PatType
ftype Arg
e_arg
  case (PatType
ftype, PatType
rt) of
    (Scalar (Arrow Aliasing
_ PName
m1 PatType
_ PatRetType
_), Scalar (Arrow Aliasing
_ PName
m2 PatType
t2 PatRetType
rettype)) ->
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
        QualName VName
-> Info PatType
-> Exp
-> (Info (PName, StructType, Maybe VName),
    Info (PName, StructType))
-> (Info PatRetType, Info [VName])
-> SrcLoc
-> Exp
forall (f :: * -> *) vn.
QualName vn
-> f PatType
-> ExpBase f vn
-> (f (PName, StructType, Maybe VName), f (PName, StructType))
-> (f PatRetType, f [VName])
-> SrcLoc
-> ExpBase f vn
OpSectionLeft
          QualName VName
op'
          (PatType -> Info PatType
forall a. a -> Info a
Info PatType
ftype)
          (Arg -> Exp
argExp Arg
e_arg)
          ((PName, StructType, Maybe VName)
-> Info (PName, StructType, Maybe VName)
forall a. a -> Info a
Info (PName
m1, PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t1, Maybe VName
argext), (PName, StructType) -> Info (PName, StructType)
forall a. a -> Info a
Info (PName
m2, PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t2))
          (PatRetType -> Info PatRetType
forall a. a -> Info a
Info PatRetType
rettype, [VName] -> Info [VName]
forall a. a -> Info a
Info [VName]
retext)
          SrcLoc
loc
    (PatType, PatType)
_ ->
      SrcLoc -> Notes -> Doc -> TermTypeM Exp
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Exp) -> Doc -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
        Doc
"Operator section with invalid operator of type" Doc -> Doc -> Doc
<+> PatType -> Doc
forall a. Pretty a => a -> Doc
ppr PatType
ftype
checkExp (OpSectionRight QualName Name
op NoInfo PatType
_ UncheckedExp
e (NoInfo (PName, StructType),
 NoInfo (PName, StructType, Maybe VName))
_ NoInfo PatRetType
NoInfo SrcLoc
loc) = do
  (QualName VName
op', PatType
ftype) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
loc QualName Name
op
  Arg
e_arg <- UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
e
  case PatType
ftype of
    Scalar (Arrow Aliasing
as1 PName
m1 PatType
t1 (RetType [] (Scalar (Arrow Aliasing
as2 PName
m2 PatType
t2 (RetType [VName]
dims2 PatType
ret))))) -> do
      (PatType
t2', PatType
ret', Maybe VName
argext, [VName]
_) <-
        SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply
          SrcLoc
loc
          (QualName VName -> Maybe (QualName VName)
forall a. a -> Maybe a
Just QualName VName
op', Level
1)
          (ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> PName
-> PatType
-> PatRetType
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow Aliasing
as2 PName
m2 PatType
t2 (PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ [VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] (PatType -> PatRetType) -> PatType -> PatRetType
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> PName
-> PatType
-> PatRetType
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow Aliasing
as1 PName
m1 PatType
t1 (PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ [VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] PatType
ret)
          Arg
e_arg
      Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
        QualName VName
-> Info PatType
-> Exp
-> (Info (PName, StructType),
    Info (PName, StructType, Maybe VName))
-> Info PatRetType
-> SrcLoc
-> Exp
forall (f :: * -> *) vn.
QualName vn
-> f PatType
-> ExpBase f vn
-> (f (PName, StructType), f (PName, StructType, Maybe VName))
-> f PatRetType
-> SrcLoc
-> ExpBase f vn
OpSectionRight
          QualName VName
op'
          (PatType -> Info PatType
forall a. a -> Info a
Info PatType
ftype)
          (Arg -> Exp
argExp Arg
e_arg)
          ((PName, StructType) -> Info (PName, StructType)
forall a. a -> Info a
Info (PName
m1, PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t1), (PName, StructType, Maybe VName)
-> Info (PName, StructType, Maybe VName)
forall a. a -> Info a
Info (PName
m2, PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
t2', Maybe VName
argext))
          (PatRetType -> Info PatRetType
forall a. a -> Info a
Info (PatRetType -> Info PatRetType) -> PatRetType -> Info PatRetType
forall a b. (a -> b) -> a -> b
$ [VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims2 (PatType -> PatRetType) -> PatType -> PatRetType
forall a b. (a -> b) -> a -> b
$ PatType -> (Aliasing -> Aliasing) -> PatType
forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
addAliases PatType
ret (Aliasing -> Aliasing -> Aliasing
forall a. Semigroup a => a -> a -> a
<> PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
ret'))
          SrcLoc
loc
    PatType
_ ->
      SrcLoc -> Notes -> Doc -> TermTypeM Exp
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Exp) -> Doc -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
        Doc
"Operator section with invalid operator of type" Doc -> Doc -> Doc
<+> PatType -> Doc
forall a. Pretty a => a -> Doc
ppr PatType
ftype
checkExp (ProjectSection [Name]
fields NoInfo PatType
NoInfo SrcLoc
loc) = do
  PatType
a <- SrcLoc -> Name -> TermTypeM PatType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"a"
  let usage :: Usage
usage = SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"projection at"
  PatType
b <- (PatType -> Name -> TermTypeM PatType)
-> PatType -> [Name] -> TermTypeM PatType
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Name -> PatType -> TermTypeM PatType)
-> PatType -> Name -> TermTypeM PatType
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name -> PatType -> TermTypeM PatType)
 -> PatType -> Name -> TermTypeM PatType)
-> (Name -> PatType -> TermTypeM PatType)
-> PatType
-> Name
-> TermTypeM PatType
forall a b. (a -> b) -> a -> b
$ Usage -> Name -> PatType -> TermTypeM PatType
forall (m :: * -> *).
MonadUnify m =>
Usage -> Name -> PatType -> m PatType
mustHaveField Usage
usage) PatType
a [Name]
fields
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
[Name] -> f PatType -> SrcLoc -> ExpBase f vn
ProjectSection [Name]
fields (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> PName
-> PatType
-> PatRetType
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow Aliasing
forall a. Monoid a => a
mempty PName
Unnamed PatType
a (PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ [VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] PatType
b) SrcLoc
loc
checkExp (IndexSection SliceBase NoInfo Name
slice NoInfo PatType
NoInfo SrcLoc
loc) = do
  Slice
slice' <- SliceBase NoInfo Name -> TermTypeM Slice
checkSlice SliceBase NoInfo Name
slice
  (StructType
t, StructType
_) <- SrcLoc -> Name -> Level -> TermTypeM (StructType, StructType)
newArrayType SrcLoc
loc Name
"e" (Level -> TermTypeM (StructType, StructType))
-> Level -> TermTypeM (StructType, StructType)
forall a b. (a -> b) -> a -> b
$ Slice -> Level
sliceDims Slice
slice'
  (StructType
t', [VName]
retext) <- Maybe (SrcLoc, Rigidity)
-> Slice -> StructType -> TermTypeM (StructType, [VName])
forall as.
Maybe (SrcLoc, Rigidity)
-> Slice
-> TypeBase (DimDecl VName) as
-> TermTypeM (TypeBase (DimDecl VName) as, [VName])
sliceShape Maybe (SrcLoc, Rigidity)
forall a. Maybe a
Nothing Slice
slice' StructType
t
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Slice -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
SliceBase f vn -> f PatType -> SrcLoc -> ExpBase f vn
IndexSection Slice
slice' (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct (StructType -> PatType) -> StructType -> PatType
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> StructType
-> StructRetType
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow ()
forall a. Monoid a => a
mempty PName
Unnamed StructType
t (StructRetType -> ScalarTypeBase (DimDecl VName) ())
-> StructRetType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
retext StructType
t') SrcLoc
loc
checkExp (AppExp (DoLoop [VName]
_ PatBase NoInfo Name
mergepat UncheckedExp
mergeexp LoopFormBase NoInfo Name
form UncheckedExp
loopbody SrcLoc
loc) NoInfo AppRes
_) = do
  (([VName]
sparams, Pat
mergepat', Exp
mergeexp', LoopFormBase Info VName
form', Exp
loopbody'), AppRes
appres) <-
    (UncheckedExp -> TermTypeM Exp)
-> UncheckedLoop -> SrcLoc -> TermTypeM (CheckedLoop, AppRes)
checkDoLoop UncheckedExp -> TermTypeM Exp
checkExp (PatBase NoInfo Name
mergepat, UncheckedExp
mergeexp, LoopFormBase NoInfo Name
form, UncheckedExp
loopbody) SrcLoc
loc
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$
    AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp
      ([VName]
-> Pat
-> Exp
-> LoopFormBase Info VName
-> Exp
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
[VName]
-> PatBase f vn
-> ExpBase f vn
-> LoopFormBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
DoLoop [VName]
sparams Pat
mergepat' Exp
mergeexp' LoopFormBase Info VName
form' Exp
loopbody' SrcLoc
loc)
      (AppRes -> Info AppRes
forall a. a -> Info a
Info AppRes
appres)
checkExp (Constr Name
name [UncheckedExp]
es NoInfo PatType
NoInfo SrcLoc
loc) = do
  StructType
t <- SrcLoc -> Name -> TermTypeM StructType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"t"
  [Exp]
es' <- (UncheckedExp -> TermTypeM Exp)
-> [UncheckedExp] -> TermTypeM [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UncheckedExp -> TermTypeM Exp
checkExp [UncheckedExp]
es
  [PatType]
ets <- (Exp -> TermTypeM PatType) -> [Exp] -> TermTypeM [PatType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> TermTypeM PatType
expTypeFully [Exp]
es'
  Usage -> Name -> StructType -> [StructType] -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> Name -> StructType -> [StructType] -> m ()
mustHaveConstr (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"use of constructor") Name
name StructType
t (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType) -> [PatType] -> [StructType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatType]
ets)
  -- A sum value aliases *anything* that went into its construction.
  let als :: Aliasing
als = (PatType -> Aliasing) -> [PatType] -> Aliasing
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases [PatType]
ets
  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Exp] -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Name -> [ExpBase f vn] -> f PatType -> SrcLoc -> ExpBase f vn
Constr Name
name [Exp]
es' (PatType -> Info PatType
forall a. a -> Info a
Info (PatType -> Info PatType) -> PatType -> Info PatType
forall a b. (a -> b) -> a -> b
$ StructType -> PatType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct StructType
t PatType -> (Aliasing -> Aliasing) -> PatType
forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
`addAliases` (Aliasing -> Aliasing -> Aliasing
forall a. Semigroup a => a -> a -> a
<> Aliasing
als)) SrcLoc
loc
checkExp (AppExp (Match UncheckedExp
e NonEmpty (CaseBase NoInfo Name)
cs SrcLoc
loc) NoInfo AppRes
_) =
  TermTypeM Exp
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b.
TermTypeM a -> (a -> Occurrences -> TermTypeM b) -> TermTypeM b
sequentially (UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e) ((Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp)
-> (Exp -> Occurrences -> TermTypeM Exp) -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ \Exp
e' Occurrences
_ -> do
    PatType
mt <- Exp -> TermTypeM PatType
expTypeFully Exp
e'
    (NonEmpty (CaseBase Info VName)
cs', PatType
t, [VName]
retext) <- PatType
-> NonEmpty (CaseBase NoInfo Name)
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
checkCases PatType
mt NonEmpty (CaseBase NoInfo Name)
cs
    Usage -> String -> PatType -> TermTypeM ()
forall (m :: * -> *) dim as.
(MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>
Usage -> String -> TypeBase dim as -> m ()
zeroOrderType
      (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"being returned 'match'")
      String
"type returned from pattern match"
      PatType
t
    Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> TermTypeM Exp) -> Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ AppExpBase Info VName -> Info AppRes -> Exp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (Exp
-> NonEmpty (CaseBase Info VName)
-> SrcLoc
-> AppExpBase Info VName
forall (f :: * -> *) vn.
ExpBase f vn
-> NonEmpty (CaseBase f vn) -> SrcLoc -> AppExpBase f vn
Match Exp
e' NonEmpty (CaseBase Info VName)
cs' SrcLoc
loc) (AppRes -> Info AppRes
forall a. a -> Info a
Info (AppRes -> Info AppRes) -> AppRes -> Info AppRes
forall a b. (a -> b) -> a -> b
$ PatType -> [VName] -> AppRes
AppRes PatType
t [VName]
retext)
checkExp (Attr AttrInfo Name
info UncheckedExp
e SrcLoc
loc) =
  AttrInfo VName -> Exp -> SrcLoc -> Exp
forall (f :: * -> *) vn.
AttrInfo vn -> ExpBase f vn -> SrcLoc -> ExpBase f vn
Attr (AttrInfo VName -> Exp -> SrcLoc -> Exp)
-> TermTypeM (AttrInfo VName) -> TermTypeM (Exp -> SrcLoc -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrInfo Name -> TermTypeM (AttrInfo VName)
forall (m :: * -> *).
MonadTypeChecker m =>
AttrInfo Name -> m (AttrInfo VName)
checkAttr AttrInfo Name
info TermTypeM (Exp -> SrcLoc -> Exp)
-> TermTypeM Exp -> TermTypeM (SrcLoc -> Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e TermTypeM (SrcLoc -> Exp) -> TermTypeM SrcLoc -> TermTypeM Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> TermTypeM SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc

checkCases ::
  PatType ->
  NE.NonEmpty (CaseBase NoInfo Name) ->
  TermTypeM (NE.NonEmpty (CaseBase Info VName), PatType, [VName])
checkCases :: PatType
-> NonEmpty (CaseBase NoInfo Name)
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
checkCases PatType
mt NonEmpty (CaseBase NoInfo Name)
rest_cs =
  case NonEmpty (CaseBase NoInfo Name)
-> (CaseBase NoInfo Name, Maybe (NonEmpty (CaseBase NoInfo Name)))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NE.uncons NonEmpty (CaseBase NoInfo Name)
rest_cs of
    (CaseBase NoInfo Name
c, Maybe (NonEmpty (CaseBase NoInfo Name))
Nothing) -> do
      (CaseBase Info VName
c', PatType
t, [VName]
retext) <- PatType
-> CaseBase NoInfo Name
-> TermTypeM (CaseBase Info VName, PatType, [VName])
checkCase PatType
mt CaseBase NoInfo Name
c
      (NonEmpty (CaseBase Info VName), PatType, [VName])
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CaseBase Info VName
c' CaseBase Info VName
-> [CaseBase Info VName] -> NonEmpty (CaseBase Info VName)
forall a. a -> [a] -> NonEmpty a
NE.:| [], PatType
t, [VName]
retext)
    (CaseBase NoInfo Name
c, Just NonEmpty (CaseBase NoInfo Name)
cs) -> do
      (((CaseBase Info VName
c', PatType
c_t, [VName]
_), (NonEmpty (CaseBase Info VName)
cs', PatType
cs_t, [VName]
_)), Occurrences
dflow) <-
        TermTypeM
  ((CaseBase Info VName, PatType, [VName]),
   (NonEmpty (CaseBase Info VName), PatType, [VName]))
-> TermTypeM
     (((CaseBase Info VName, PatType, [VName]),
       (NonEmpty (CaseBase Info VName), PatType, [VName])),
      Occurrences)
forall a. TermTypeM a -> TermTypeM (a, Occurrences)
tapOccurrences (TermTypeM
   ((CaseBase Info VName, PatType, [VName]),
    (NonEmpty (CaseBase Info VName), PatType, [VName]))
 -> TermTypeM
      (((CaseBase Info VName, PatType, [VName]),
        (NonEmpty (CaseBase Info VName), PatType, [VName])),
       Occurrences))
-> TermTypeM
     ((CaseBase Info VName, PatType, [VName]),
      (NonEmpty (CaseBase Info VName), PatType, [VName]))
-> TermTypeM
     (((CaseBase Info VName, PatType, [VName]),
       (NonEmpty (CaseBase Info VName), PatType, [VName])),
      Occurrences)
forall a b. (a -> b) -> a -> b
$ PatType
-> CaseBase NoInfo Name
-> TermTypeM (CaseBase Info VName, PatType, [VName])
checkCase PatType
mt CaseBase NoInfo Name
c TermTypeM (CaseBase Info VName, PatType, [VName])
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
-> TermTypeM
     ((CaseBase Info VName, PatType, [VName]),
      (NonEmpty (CaseBase Info VName), PatType, [VName]))
forall a b. TermTypeM a -> TermTypeM b -> TermTypeM (a, b)
`alternative` PatType
-> NonEmpty (CaseBase NoInfo Name)
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
checkCases PatType
mt NonEmpty (CaseBase NoInfo Name)
cs
      (PatType
brancht, [VName]
retext) <- SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])
unifyBranchTypes (CaseBase NoInfo Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf CaseBase NoInfo Name
c) PatType
c_t PatType
cs_t
      let t :: PatType
t =
            PatType -> (Aliasing -> Aliasing) -> PatType
forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
addAliases
              PatType
brancht
              (Aliasing -> Aliasing -> Aliasing
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` (VName -> Alias) -> Names -> Aliasing
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map VName -> Alias
AliasBound (Occurrences -> Names
allConsumed Occurrences
dflow))
      (NonEmpty (CaseBase Info VName), PatType, [VName])
-> TermTypeM (NonEmpty (CaseBase Info VName), PatType, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CaseBase Info VName
-> NonEmpty (CaseBase Info VName) -> NonEmpty (CaseBase Info VName)
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons CaseBase Info VName
c' NonEmpty (CaseBase Info VName)
cs', PatType
t, [VName]
retext)

checkCase ::
  PatType ->
  CaseBase NoInfo Name ->
  TermTypeM (CaseBase Info VName, PatType, [VName])
checkCase :: PatType
-> CaseBase NoInfo Name
-> TermTypeM (CaseBase Info VName, PatType, [VName])
checkCase PatType
mt (CasePat PatBase NoInfo Name
p UncheckedExp
e SrcLoc
loc) =
  [SizeBinder VName]
-> PatBase NoInfo Name
-> InferredType
-> (Pat -> TermTypeM (CaseBase Info VName, PatType, [VName]))
-> TermTypeM (CaseBase Info VName, PatType, [VName])
forall a.
[SizeBinder VName]
-> PatBase NoInfo Name
-> InferredType
-> (Pat -> TermTypeM a)
-> TermTypeM a
bindingPat [] PatBase NoInfo Name
p (PatType -> InferredType
Ascribed PatType
mt) ((Pat -> TermTypeM (CaseBase Info VName, PatType, [VName]))
 -> TermTypeM (CaseBase Info VName, PatType, [VName]))
-> (Pat -> TermTypeM (CaseBase Info VName, PatType, [VName]))
-> TermTypeM (CaseBase Info VName, PatType, [VName])
forall a b. (a -> b) -> a -> b
$ \Pat
p' -> do
    Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
    (PatType
t, [VName]
retext) <- SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType SrcLoc
loc (Pat -> Map VName Ident
forall (f :: * -> *).
Functor f =>
PatBase f VName -> Map VName (IdentBase f VName)
patternMap Pat
p') (PatType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> TermTypeM PatType
expTypeFully Exp
e'
    (CaseBase Info VName, PatType, [VName])
-> TermTypeM (CaseBase Info VName, PatType, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Exp -> SrcLoc -> CaseBase Info VName
forall (f :: * -> *) vn.
PatBase f vn -> ExpBase f vn -> SrcLoc -> CaseBase f vn
CasePat Pat
p' Exp
e' SrcLoc
loc, PatType
t, [VName]
retext)

-- | An unmatched pattern. Used in in the generation of
-- unmatched pattern warnings by the type checker.
data Unmatched p
  = UnmatchedNum p [PatLit]
  | UnmatchedBool p
  | UnmatchedConstr p
  | Unmatched p
  deriving (a -> Unmatched b -> Unmatched a
(a -> b) -> Unmatched a -> Unmatched b
(forall a b. (a -> b) -> Unmatched a -> Unmatched b)
-> (forall a b. a -> Unmatched b -> Unmatched a)
-> Functor Unmatched
forall a b. a -> Unmatched b -> Unmatched a
forall a b. (a -> b) -> Unmatched a -> Unmatched b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Unmatched b -> Unmatched a
$c<$ :: forall a b. a -> Unmatched b -> Unmatched a
fmap :: (a -> b) -> Unmatched a -> Unmatched b
$cfmap :: forall a b. (a -> b) -> Unmatched a -> Unmatched b
Functor, Level -> Unmatched p -> String -> String
[Unmatched p] -> String -> String
Unmatched p -> String
(Level -> Unmatched p -> String -> String)
-> (Unmatched p -> String)
-> ([Unmatched p] -> String -> String)
-> Show (Unmatched p)
forall p. Show p => Level -> Unmatched p -> String -> String
forall p. Show p => [Unmatched p] -> String -> String
forall p. Show p => Unmatched p -> String
forall a.
(Level -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Unmatched p] -> String -> String
$cshowList :: forall p. Show p => [Unmatched p] -> String -> String
show :: Unmatched p -> String
$cshow :: forall p. Show p => Unmatched p -> String
showsPrec :: Level -> Unmatched p -> String -> String
$cshowsPrec :: forall p. Show p => Level -> Unmatched p -> String -> String
Show)

instance Pretty (Unmatched (PatBase Info VName)) where
  ppr :: Unmatched Pat -> Doc
ppr Unmatched Pat
um = case Unmatched Pat
um of
    (UnmatchedNum Pat
p [PatLit]
nums) -> Pat -> Doc
forall v (f :: * -> *).
(Eq v, IsName v, Annot f) =>
PatBase f v -> Doc
ppr' Pat
p Doc -> Doc -> Doc
<+> Doc
"where p is not one of" Doc -> Doc -> Doc
<+> [PatLit] -> Doc
forall a. Pretty a => a -> Doc
ppr [PatLit]
nums
    (UnmatchedBool Pat
p) -> Pat -> Doc
forall v (f :: * -> *).
(Eq v, IsName v, Annot f) =>
PatBase f v -> Doc
ppr' Pat
p
    (UnmatchedConstr Pat
p) -> Pat -> Doc
forall v (f :: * -> *).
(Eq v, IsName v, Annot f) =>
PatBase f v -> Doc
ppr' Pat
p
    (Unmatched Pat
p) -> Pat -> Doc
forall v (f :: * -> *).
(Eq v, IsName v, Annot f) =>
PatBase f v -> Doc
ppr' Pat
p
    where
      ppr' :: PatBase f v -> Doc
ppr' (PatAscription PatBase f v
p TypeDeclBase f v
t SrcLoc
_) = PatBase f v -> Doc
forall a. Pretty a => a -> Doc
ppr PatBase f v
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":" Doc -> Doc -> Doc
<+> TypeDeclBase f v -> Doc
forall a. Pretty a => a -> Doc
ppr TypeDeclBase f v
t
      ppr' (PatParens PatBase f v
p SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PatBase f v -> Doc
ppr' PatBase f v
p
      ppr' (PatAttr AttrInfo v
_ PatBase f v
p SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PatBase f v -> Doc
ppr' PatBase f v
p
      ppr' (Id v
v f PatType
_ SrcLoc
_) = v -> Doc
forall v. IsName v => v -> Doc
pprName v
v
      ppr' (TuplePat [PatBase f v]
pats SrcLoc
_) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PatBase f v -> Doc) -> [PatBase f v] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatBase f v -> Doc
ppr' [PatBase f v]
pats
      ppr' (RecordPat [(Name, PatBase f v)]
fs SrcLoc
_) = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Name, PatBase f v) -> Doc) -> [(Name, PatBase f v)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PatBase f v) -> Doc
ppField [(Name, PatBase f v)]
fs
        where
          ppField :: (Name, PatBase f v) -> Doc
ppField (Name
name, PatBase f v
t) = String -> Doc
text (Name -> String
nameToString Name
name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
equals Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PatBase f v -> Doc
ppr' PatBase f v
t
      ppr' Wildcard {} = Doc
"_"
      ppr' (PatLit PatLit
e f PatType
_ SrcLoc
_) = PatLit -> Doc
forall a. Pretty a => a -> Doc
ppr PatLit
e
      ppr' (PatConstr Name
n f PatType
_ [PatBase f v]
ps SrcLoc
_) = Doc
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((PatBase f v -> Doc) -> [PatBase f v] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatBase f v -> Doc
ppr' [PatBase f v]
ps)

checkUnmatched :: Exp -> TermTypeM ()
checkUnmatched :: Exp -> TermTypeM ()
checkUnmatched Exp
e = TermTypeM Exp -> TermTypeM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TermTypeM Exp -> TermTypeM ()) -> TermTypeM Exp -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ Exp -> TermTypeM ()
forall (f :: * -> *). MonadTypeChecker f => Exp -> f ()
checkUnmatched' Exp
e TermTypeM () -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ASTMapper TermTypeM -> Exp -> TermTypeM Exp
forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper TermTypeM
tv Exp
e
  where
    checkUnmatched' :: Exp -> f ()
checkUnmatched' (AppExp (Match Exp
_ NonEmpty (CaseBase Info VName)
cs SrcLoc
loc) Info AppRes
_) =
      let ps :: NonEmpty Pat
ps = (CaseBase Info VName -> Pat)
-> NonEmpty (CaseBase Info VName) -> NonEmpty Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CasePat Pat
p Exp
_ SrcLoc
_) -> Pat
p) NonEmpty (CaseBase Info VName)
cs
       in case [Pat] -> [Match]
unmatched ([Pat] -> [Match]) -> [Pat] -> [Match]
forall a b. (a -> b) -> a -> b
$ NonEmpty Pat -> [Pat]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Pat
ps of
            [] -> () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [Match]
ps' ->
              SrcLoc -> Notes -> Doc -> f ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> f ()) -> (Doc -> Doc) -> Doc -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"unmatched-cases" (Doc -> f ()) -> Doc -> f ()
forall a b. (a -> b) -> a -> b
$
                Doc
"Unmatched cases in match expression:"
                  Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 ([Doc] -> Doc
stack ((Match -> Doc) -> [Match] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Match -> Doc
forall a. Pretty a => a -> Doc
ppr [Match]
ps'))
    checkUnmatched' Exp
_ = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    tv :: ASTMapper TermTypeM
tv = ASTMapper TermTypeM
forall (m :: * -> *). Monad m => ASTMapper m
identityMapper {mapOnExp :: Exp -> TermTypeM Exp
mapOnExp = \Exp
e' -> Exp -> TermTypeM ()
forall (f :: * -> *). MonadTypeChecker f => Exp -> f ()
checkUnmatched' Exp
e' TermTypeM () -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e'}

checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident
checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident
checkIdent (Ident Name
name NoInfo PatType
_ SrcLoc
loc) = do
  (QualName [VName]
_ VName
name', PatType
vt) <- SrcLoc -> QualName Name -> TermTypeM (QualName VName, PatType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatType)
lookupVar SrcLoc
loc (Name -> QualName Name
forall v. v -> QualName v
qualName Name
name)
  Ident -> TermTypeM Ident
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ident -> TermTypeM Ident) -> Ident -> TermTypeM Ident
forall a b. (a -> b) -> a -> b
$ VName -> Info PatType -> SrcLoc -> Ident
forall (f :: * -> *) vn.
vn -> f PatType -> SrcLoc -> IdentBase f vn
Ident VName
name' (PatType -> Info PatType
forall a. a -> Info a
Info PatType
vt) SrcLoc
loc

checkSlice :: UncheckedSlice -> TermTypeM Slice
checkSlice :: SliceBase NoInfo Name -> TermTypeM Slice
checkSlice = (DimIndexBase NoInfo Name -> TermTypeM (DimIndexBase Info VName))
-> SliceBase NoInfo Name -> TermTypeM Slice
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DimIndexBase NoInfo Name -> TermTypeM (DimIndexBase Info VName)
checkDimIndex
  where
    checkDimIndex :: DimIndexBase NoInfo Name -> TermTypeM (DimIndexBase Info VName)
checkDimIndex (DimFix UncheckedExp
i) =
      Exp -> DimIndexBase Info VName
forall (f :: * -> *) vn. ExpBase f vn -> DimIndexBase f vn
DimFix (Exp -> DimIndexBase Info VName)
-> TermTypeM Exp -> TermTypeM (DimIndexBase Info VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> [PrimType] -> Exp -> TermTypeM Exp
require String
"use as index" [PrimType]
anySignedType (Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
i)
    checkDimIndex (DimSlice Maybe UncheckedExp
i Maybe UncheckedExp
j Maybe UncheckedExp
s) =
      Maybe Exp -> Maybe Exp -> Maybe Exp -> DimIndexBase Info VName
forall (f :: * -> *) vn.
Maybe (ExpBase f vn)
-> Maybe (ExpBase f vn)
-> Maybe (ExpBase f vn)
-> DimIndexBase f vn
DimSlice (Maybe Exp -> Maybe Exp -> Maybe Exp -> DimIndexBase Info VName)
-> TermTypeM (Maybe Exp)
-> TermTypeM (Maybe Exp -> Maybe Exp -> DimIndexBase Info VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UncheckedExp -> TermTypeM (Maybe Exp)
check Maybe UncheckedExp
i TermTypeM (Maybe Exp -> Maybe Exp -> DimIndexBase Info VName)
-> TermTypeM (Maybe Exp)
-> TermTypeM (Maybe Exp -> DimIndexBase Info VName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UncheckedExp -> TermTypeM (Maybe Exp)
check Maybe UncheckedExp
j TermTypeM (Maybe Exp -> DimIndexBase Info VName)
-> TermTypeM (Maybe Exp) -> TermTypeM (DimIndexBase Info VName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UncheckedExp -> TermTypeM (Maybe Exp)
check Maybe UncheckedExp
s

    check :: Maybe UncheckedExp -> TermTypeM (Maybe Exp)
check =
      TermTypeM (Maybe Exp)
-> (UncheckedExp -> TermTypeM (Maybe Exp))
-> Maybe UncheckedExp
-> TermTypeM (Maybe Exp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Exp -> TermTypeM (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing) ((UncheckedExp -> TermTypeM (Maybe Exp))
 -> Maybe UncheckedExp -> TermTypeM (Maybe Exp))
-> (UncheckedExp -> TermTypeM (Maybe Exp))
-> Maybe UncheckedExp
-> TermTypeM (Maybe Exp)
forall a b. (a -> b) -> a -> b
$
        (Exp -> Maybe Exp) -> TermTypeM Exp -> TermTypeM (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Maybe Exp
forall a. a -> Maybe a
Just (TermTypeM Exp -> TermTypeM (Maybe Exp))
-> (Exp -> TermTypeM Exp) -> Exp -> TermTypeM (Maybe Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StructType -> Exp -> TermTypeM Exp
unifies String
"use as index" (ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) ())
-> PrimType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int64) (Exp -> TermTypeM (Maybe Exp))
-> (UncheckedExp -> TermTypeM Exp)
-> UncheckedExp
-> TermTypeM (Maybe Exp)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< UncheckedExp -> TermTypeM Exp
checkExp

-- The number of dimensions affected by this slice (so the minimum
-- rank of the array we are slicing).
sliceDims :: Slice -> Int
sliceDims :: Slice -> Level
sliceDims = Slice -> Level
forall (t :: * -> *) a. Foldable t => t a -> Level
length

type Arg = (Exp, PatType, Occurrences, SrcLoc)

argExp :: Arg -> Exp
argExp :: Arg -> Exp
argExp (Exp
e, PatType
_, Occurrences
_, SrcLoc
_) = Exp
e

argType :: Arg -> PatType
argType :: Arg -> PatType
argType (Exp
_, PatType
t, Occurrences
_, SrcLoc
_) = PatType
t

checkArg :: UncheckedExp -> TermTypeM Arg
checkArg :: UncheckedExp -> TermTypeM Arg
checkArg UncheckedExp
arg = do
  (Exp
arg', Occurrences
dflow) <- TermTypeM Exp -> TermTypeM (Exp, Occurrences)
forall a. TermTypeM a -> TermTypeM (a, Occurrences)
collectOccurrences (TermTypeM Exp -> TermTypeM (Exp, Occurrences))
-> TermTypeM Exp -> TermTypeM (Exp, Occurrences)
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
arg
  PatType
arg_t <- Exp -> TermTypeM PatType
expType Exp
arg'
  Arg -> TermTypeM Arg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
arg', PatType
arg_t, Occurrences
dflow, Exp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Exp
arg')

instantiateDimsInReturnType ::
  SrcLoc ->
  Maybe (QualName VName) ->
  RetTypeBase (DimDecl VName) als ->
  TermTypeM (TypeBase (DimDecl VName) als, [VName])
instantiateDimsInReturnType :: SrcLoc
-> Maybe (QualName VName)
-> RetTypeBase (DimDecl VName) als
-> TermTypeM (TypeBase (DimDecl VName) als, [VName])
instantiateDimsInReturnType SrcLoc
tloc Maybe (QualName VName)
fname =
  SrcLoc
-> Rigidity
-> RetTypeBase (DimDecl VName) als
-> TermTypeM (TypeBase (DimDecl VName) als, [VName])
forall (m :: * -> *) als.
MonadUnify m =>
SrcLoc
-> Rigidity
-> RetTypeBase (DimDecl VName) als
-> m (TypeBase (DimDecl VName) als, [VName])
instantiateEmptyArrayDims SrcLoc
tloc (Rigidity
 -> RetTypeBase (DimDecl VName) als
 -> TermTypeM (TypeBase (DimDecl VName) als, [VName]))
-> Rigidity
-> RetTypeBase (DimDecl VName) als
-> TermTypeM (TypeBase (DimDecl VName) als, [VName])
forall a b. (a -> b) -> a -> b
$ RigidSource -> Rigidity
Rigid (RigidSource -> Rigidity) -> RigidSource -> Rigidity
forall a b. (a -> b) -> a -> b
$ Maybe (QualName VName) -> RigidSource
RigidRet Maybe (QualName VName)
fname

-- Some information about the function/operator we are trying to
-- apply, and how many arguments it has previously accepted.  Used for
-- generating nicer type errors.
type ApplyOp = (Maybe (QualName VName), Int)

-- | Extract all those names that are bound inside the type.
boundInsideType :: TypeBase (DimDecl VName) as -> S.Set VName
boundInsideType :: TypeBase (DimDecl VName) as -> Names
boundInsideType (Array as
_ Uniqueness
_ ScalarTypeBase (DimDecl VName) ()
t ShapeDecl (DimDecl VName)
_) = StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType (ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar ScalarTypeBase (DimDecl VName) ()
t)
boundInsideType (Scalar Prim {}) = Names
forall a. Monoid a => a
mempty
boundInsideType (Scalar (TypeVar as
_ Uniqueness
_ TypeName
_ [TypeArg (DimDecl VName)]
targs)) = (TypeArg (DimDecl VName) -> Names)
-> [TypeArg (DimDecl VName)] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeArg (DimDecl VName) -> Names
f [TypeArg (DimDecl VName)]
targs
  where
    f :: TypeArg (DimDecl VName) -> Names
f (TypeArgType StructType
t SrcLoc
_) = StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType StructType
t
    f TypeArgDim {} = Names
forall a. Monoid a => a
mempty
boundInsideType (Scalar (Record Map Name (TypeBase (DimDecl VName) as)
fs)) = (TypeBase (DimDecl VName) as -> Names)
-> Map Name (TypeBase (DimDecl VName) as) -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeBase (DimDecl VName) as -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType Map Name (TypeBase (DimDecl VName) as)
fs
boundInsideType (Scalar (Sum Map Name [TypeBase (DimDecl VName) as]
cs)) = ([TypeBase (DimDecl VName) as] -> Names)
-> Map Name [TypeBase (DimDecl VName) as] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((TypeBase (DimDecl VName) as -> Names)
-> [TypeBase (DimDecl VName) as] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeBase (DimDecl VName) as -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType) Map Name [TypeBase (DimDecl VName) as]
cs
boundInsideType (Scalar (Arrow as
_ PName
pn TypeBase (DimDecl VName) as
t1 (RetType [VName]
dims TypeBase (DimDecl VName) as
t2))) =
  Names
pn' Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) as -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType TypeBase (DimDecl VName) as
t1 Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList [VName]
dims Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) as -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType TypeBase (DimDecl VName) as
t2
  where
    pn' :: Names
pn' = case PName
pn of
      PName
Unnamed -> Names
forall a. Monoid a => a
mempty
      Named VName
v -> VName -> Names
forall a. a -> Set a
S.singleton VName
v

-- Returns the sizes of the immediate type produced,
-- the sizes of parameter types, and the sizes of return types.
dimUses :: StructType -> (Names, Names)
dimUses :: StructType -> (Names, Names)
dimUses = (State (Names, Names) (TypeBase () ())
 -> (Names, Names) -> (Names, Names))
-> (Names, Names)
-> State (Names, Names) (TypeBase () ())
-> (Names, Names)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Names, Names) (TypeBase () ())
-> (Names, Names) -> (Names, Names)
forall s a. State s a -> s -> s
execState (Names, Names)
forall a. Monoid a => a
mempty (State (Names, Names) (TypeBase () ()) -> (Names, Names))
-> (StructType -> State (Names, Names) (TypeBase () ()))
-> StructType
-> (Names, Names)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Names
 -> DimPos -> DimDecl VName -> StateT (Names, Names) Identity ())
-> StructType -> State (Names, Names) (TypeBase () ())
forall (f :: * -> *) fdim tdim als.
Applicative f =>
(Names -> DimPos -> fdim -> f tdim)
-> TypeBase fdim als -> f (TypeBase tdim als)
traverseDims Names
-> DimPos -> DimDecl VName -> StateT (Names, Names) Identity ()
forall a (f :: * -> *).
(Ord a, MonadState (Set a, Set a) f) =>
Set a -> DimPos -> DimDecl a -> f ()
f
  where
    f :: Set a -> DimPos -> DimDecl a -> f ()
f Set a
bound DimPos
_ (NamedDim QualName a
v) | QualName a -> a
forall vn. QualName vn -> vn
qualLeaf QualName a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
bound = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    f Set a
_ DimPos
PosImmediate (NamedDim QualName a
v) = ((Set a, Set a) -> (Set a, Set a)) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((a -> Set a
forall a. a -> Set a
S.singleton (QualName a -> a
forall vn. QualName vn -> vn
qualLeaf QualName a
v), Set a
forall a. Monoid a => a
mempty) (Set a, Set a) -> (Set a, Set a) -> (Set a, Set a)
forall a. Semigroup a => a -> a -> a
<>)
    f Set a
_ DimPos
PosParam (NamedDim QualName a
v) = ((Set a, Set a) -> (Set a, Set a)) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set a
forall a. Monoid a => a
mempty, a -> Set a
forall a. a -> Set a
S.singleton (QualName a -> a
forall vn. QualName vn -> vn
qualLeaf QualName a
v)) (Set a, Set a) -> (Set a, Set a) -> (Set a, Set a)
forall a. Semigroup a => a -> a -> a
<>)
    f Set a
_ DimPos
_ DimDecl a
_ = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

checkApply ::
  SrcLoc ->
  ApplyOp ->
  PatType ->
  Arg ->
  TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply :: SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply
  SrcLoc
loc
  (Maybe (QualName VName)
fname, Level
_)
  (Scalar (Arrow Aliasing
as PName
pname PatType
tp1 PatRetType
tp2))
  (Exp
argexp, PatType
argtype, Occurrences
dflow, SrcLoc
argloc) =
    Checking
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (Maybe (QualName VName)
-> Exp -> StructType -> StructType -> Checking
CheckingApply Maybe (QualName VName)
fname Exp
argexp (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
tp1) (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
argtype)) (TermTypeM (PatType, PatType, Maybe VName, [VName])
 -> TermTypeM (PatType, PatType, Maybe VName, [VName]))
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
forall a b. (a -> b) -> a -> b
$ do
      Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
expect (SrcLoc -> String -> Usage
mkUsage SrcLoc
argloc String
"use as function argument") (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
tp1) (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
argtype)

      -- Perform substitutions of instantiated variables in the types.
      PatType
tp1' <- PatType -> TermTypeM PatType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully PatType
tp1
      (PatType
tp2', [VName]
ext) <- SrcLoc
-> Maybe (QualName VName)
-> PatRetType
-> TermTypeM (PatType, [VName])
forall als.
SrcLoc
-> Maybe (QualName VName)
-> RetTypeBase (DimDecl VName) als
-> TermTypeM (TypeBase (DimDecl VName) als, [VName])
instantiateDimsInReturnType SrcLoc
loc Maybe (QualName VName)
fname (PatRetType -> TermTypeM (PatType, [VName]))
-> TermTypeM PatRetType -> TermTypeM (PatType, [VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PatRetType -> TermTypeM PatRetType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully PatRetType
tp2
      PatType
argtype' <- PatType -> TermTypeM PatType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully PatType
argtype

      -- Check whether this would produce an impossible return type.
      let (Names
tp2_produced_dims, Names
tp2_paramdims) = StructType -> (Names, Names)
dimUses (StructType -> (Names, Names)) -> StructType -> (Names, Names)
forall a b. (a -> b) -> a -> b
$ PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
tp2'
          problematic :: Names
problematic = [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList [VName]
ext Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> PatType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
boundInsideType PatType
argtype'
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((VName -> Bool) -> Names -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
problematic) (Names
tp2_paramdims Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Names
tp2_produced_dims)) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ do
        SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> (Doc -> Doc) -> Doc -> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"existential-param-ret" (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Existential size would appear in function parameter of return type:"
            Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (PatRetType -> Doc
forall a. Pretty a => a -> Doc
ppr ([VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext PatType
tp2'))
            Doc -> Doc -> Doc
</> String -> Doc
textwrap String
"This is usually because a higher-order function is used with functional arguments that return existential sizes or locally named sizes, which are then used as parameters of other function arguments."

      Occurrences -> TermTypeM ()
occur [Aliasing -> SrcLoc -> Occurrence
observation Aliasing
as SrcLoc
loc]

      Occurrences -> TermTypeM ()
checkOccurrences Occurrences
dflow

      case Occurrences -> Maybe Occurrence
anyConsumption Occurrences
dflow of
        Just Occurrence
c ->
          let msg :: String
msg = String
"type of expression with consumption at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
forall a. Located a => a -> String
locStr (Occurrence -> SrcLoc
location Occurrence
c)
           in Usage -> String -> PatType -> TermTypeM ()
forall (m :: * -> *) dim as.
(MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>
Usage -> String -> TypeBase dim as -> m ()
zeroOrderType (SrcLoc -> String -> Usage
mkUsage SrcLoc
argloc String
"potential consumption in expression") String
msg PatType
tp1
        Maybe Occurrence
_ -> () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Occurrences
occurs <- (Occurrences
dflow Occurrences -> Occurrences -> Occurrences
`seqOccurrences`) (Occurrences -> Occurrences)
-> TermTypeM Occurrences -> TermTypeM Occurrences
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcLoc -> PatType -> Diet -> TermTypeM Occurrences
consumeArg SrcLoc
argloc PatType
argtype' (PatType -> Diet
forall shape as. TypeBase shape as -> Diet
diet PatType
tp1')

      SrcLoc -> Aliasing -> TermTypeM ()
checkIfConsumable SrcLoc
loc (Aliasing -> TermTypeM ()) -> Aliasing -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ (VName -> Alias) -> Names -> Aliasing
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map VName -> Alias
AliasBound (Names -> Aliasing) -> Names -> Aliasing
forall a b. (a -> b) -> a -> b
$ Occurrences -> Names
allConsumed Occurrences
occurs
      Occurrences -> TermTypeM ()
occur Occurrences
occurs

      -- Unification ignores uniqueness in higher-order arguments, so
      -- we check for that here.
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PatType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural PatType
argtype' TypeBase () () -> TypeBase () () -> Bool
`subtypeOf` PatType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural PatType
tp1') (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty Doc
"Uniqueness does not match."

      (Maybe VName
argext, VName -> Maybe (Subst StructRetType)
parsubst) <-
        case PName
pname of
          Named VName
pname'
            | (Scalar (Prim (Signed IntType
Int64))) <- PatType
tp1' -> do
              (DimDecl VName
d, Maybe VName
argext) <- Maybe (QualName VName)
-> Exp -> TermTypeM (DimDecl VName, Maybe VName)
dimFromArg Maybe (QualName VName)
fname Exp
argexp
              (Maybe VName, VName -> Maybe (Subst StructRetType))
-> TermTypeM (Maybe VName, VName -> Maybe (Subst StructRetType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Maybe VName
argext,
                  (VName
-> Map VName (Subst StructRetType) -> Maybe (Subst StructRetType)
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` VName -> Subst StructRetType -> Map VName (Subst StructRetType)
forall k a. k -> a -> Map k a
M.singleton VName
pname' (DimDecl VName -> Subst StructRetType
forall t. DimDecl VName -> Subst t
SizeSubst DimDecl VName
d))
                )
          PName
_ -> (Maybe VName, VName -> Maybe (Subst StructRetType))
-> TermTypeM (Maybe VName, VName -> Maybe (Subst StructRetType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VName
forall a. Maybe a
Nothing, Maybe (Subst StructRetType) -> VName -> Maybe (Subst StructRetType)
forall a b. a -> b -> a
const Maybe (Subst StructRetType)
forall a. Maybe a
Nothing)
      let tp2'' :: PatType
tp2'' = (VName -> Maybe (Subst StructRetType)) -> PatType -> PatType
forall a.
Substitutable a =>
(VName -> Maybe (Subst StructRetType)) -> a -> a
applySubst VName -> Maybe (Subst StructRetType)
parsubst (PatType -> PatType) -> PatType -> PatType
forall a b. (a -> b) -> a -> b
$ PatType -> Diet -> PatType -> PatType
returnType PatType
tp2' (PatType -> Diet
forall shape as. TypeBase shape as -> Diet
diet PatType
tp1') PatType
argtype'

      (PatType, PatType, Maybe VName, [VName])
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatType
tp1', PatType
tp2'', Maybe VName
argext, [VName]
ext)
checkApply SrcLoc
loc ApplyOp
fname tfun :: PatType
tfun@(Scalar TypeVar {}) Arg
arg = do
  StructType
tv <- SrcLoc -> Name -> TermTypeM StructType
forall (m :: * -> *) als dim.
(MonadUnify m, Monoid als) =>
SrcLoc -> Name -> m (TypeBase dim als)
newTypeVar SrcLoc
loc Name
"b"
  -- Change the uniqueness of the argument type because we never want
  -- to infer that a function is consuming.
  let argt_nonunique :: StructType
argt_nonunique = PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (Arg -> PatType
argType Arg
arg) StructType -> Uniqueness -> StructType
forall dim as. TypeBase dim as -> Uniqueness -> TypeBase dim as
`setUniqueness` Uniqueness
Nonunique
  Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"use as function") (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
tfun) (StructType -> TermTypeM ()) -> StructType -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> StructType
-> StructRetType
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow ()
forall a. Monoid a => a
mempty PName
Unnamed StructType
argt_nonunique (StructRetType -> ScalarTypeBase (DimDecl VName) ())
-> StructRetType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] StructType
tv
  PatType
tfun' <- PatType -> TermTypeM PatType
forall (m :: * -> *). MonadUnify m => PatType -> m PatType
normPatType PatType
tfun
  SrcLoc
-> ApplyOp
-> PatType
-> Arg
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
checkApply SrcLoc
loc ApplyOp
fname PatType
tfun' Arg
arg
checkApply SrcLoc
loc (Maybe (QualName VName)
fname, Level
prev_applied) PatType
ftype (Exp
argexp, PatType
_, Occurrences
_, SrcLoc
_) = do
  let fname' :: Doc
fname' = Doc -> (QualName VName -> Doc) -> Maybe (QualName VName) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"expression" (Doc -> Doc
pquote (Doc -> Doc) -> (QualName VName -> Doc) -> QualName VName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualName VName -> Doc
forall a. Pretty a => a -> Doc
ppr) Maybe (QualName VName)
fname

  SrcLoc
-> Notes
-> Doc
-> TermTypeM (PatType, PatType, Maybe VName, [VName])
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM (PatType, PatType, Maybe VName, [VName]))
-> Doc -> TermTypeM (PatType, PatType, Maybe VName, [VName])
forall a b. (a -> b) -> a -> b
$
    if Level
prev_applied Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
0
      then
        Doc
"Cannot apply" Doc -> Doc -> Doc
<+> Doc
fname' Doc -> Doc -> Doc
<+> Doc
"as function, as it has type:"
          Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (PatType -> Doc
forall a. Pretty a => a -> Doc
ppr PatType
ftype)
      else
        Doc
"Cannot apply" Doc -> Doc -> Doc
<+> Doc
fname' Doc -> Doc -> Doc
<+> Doc
"to argument #" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Level -> Doc
forall a. Pretty a => a -> Doc
ppr (Level
prev_applied Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
1)
          Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (String -> Doc
forall a. Pretty a => a -> Doc
shorten (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
flatten (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
argexp) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
","
          Doc -> Doc -> Doc
<+/> Doc
"as"
          Doc -> Doc -> Doc
<+> Doc
fname'
          Doc -> Doc -> Doc
<+> Doc
"only takes"
          Doc -> Doc -> Doc
<+> Level -> Doc
forall a. Pretty a => a -> Doc
ppr Level
prev_applied
          Doc -> Doc -> Doc
<+> Doc
arguments Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
  where
    arguments :: Doc
arguments
      | Level
prev_applied Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
1 = Doc
"argument"
      | Bool
otherwise = Doc
"arguments"

-- | @returnType ret_type arg_diet arg_type@ gives result of applying
-- an argument the given types to a function with the given return
-- type, consuming the argument with the given diet.
returnType ::
  PatType ->
  Diet ->
  PatType ->
  PatType
returnType :: PatType -> Diet -> PatType -> PatType
returnType (Array Aliasing
_ Uniqueness
Unique ScalarTypeBase (DimDecl VName) ()
et ShapeDecl (DimDecl VName)
shape) Diet
_ PatType
_ =
  Aliasing
-> Uniqueness
-> ScalarTypeBase (DimDecl VName) ()
-> ShapeDecl (DimDecl VName)
-> PatType
forall dim as.
as
-> Uniqueness
-> ScalarTypeBase dim ()
-> ShapeDecl dim
-> TypeBase dim as
Array Aliasing
forall a. Monoid a => a
mempty Uniqueness
Unique ScalarTypeBase (DimDecl VName) ()
et ShapeDecl (DimDecl VName)
shape
returnType (Array Aliasing
als Uniqueness
Nonunique ScalarTypeBase (DimDecl VName) ()
et ShapeDecl (DimDecl VName)
shape) Diet
d PatType
arg =
  Aliasing
-> Uniqueness
-> ScalarTypeBase (DimDecl VName) ()
-> ShapeDecl (DimDecl VName)
-> PatType
forall dim as.
as
-> Uniqueness
-> ScalarTypeBase dim ()
-> ShapeDecl dim
-> TypeBase dim as
Array (Aliasing
als Aliasing -> Aliasing -> Aliasing
forall a. Semigroup a => a -> a -> a
<> Aliasing
arg_als) Uniqueness
Unique ScalarTypeBase (DimDecl VName) ()
et ShapeDecl (DimDecl VName)
shape -- Intentional!
  where
    arg_als :: Aliasing
arg_als = PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases (PatType -> Aliasing) -> PatType -> Aliasing
forall a b. (a -> b) -> a -> b
$ PatType -> Diet -> PatType
forall as shape.
Monoid as =>
TypeBase shape as -> Diet -> TypeBase shape as
maskAliases PatType
arg Diet
d
returnType (Scalar (Record Map Name PatType
fs)) Diet
d PatType
arg =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ (PatType -> PatType) -> Map Name PatType -> Map Name PatType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PatType
et -> PatType -> Diet -> PatType -> PatType
returnType PatType
et Diet
d PatType
arg) Map Name PatType
fs
returnType (Scalar (Prim PrimType
t)) Diet
_ PatType
_ =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. PrimType -> ScalarTypeBase dim as
Prim PrimType
t
returnType (Scalar (TypeVar Aliasing
_ Uniqueness
Unique TypeName
t [TypeArg (DimDecl VName)]
targs)) Diet
_ PatType
_ =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar Aliasing
forall a. Monoid a => a
mempty Uniqueness
Unique TypeName
t [TypeArg (DimDecl VName)]
targs
returnType (Scalar (TypeVar Aliasing
als Uniqueness
Nonunique TypeName
t [TypeArg (DimDecl VName)]
targs)) Diet
d PatType
arg =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar (Aliasing
als Aliasing -> Aliasing -> Aliasing
forall a. Semigroup a => a -> a -> a
<> Aliasing
arg_als) Uniqueness
Unique TypeName
t [TypeArg (DimDecl VName)]
targs -- Intentional!
  where
    arg_als :: Aliasing
arg_als = PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases (PatType -> Aliasing) -> PatType -> Aliasing
forall a b. (a -> b) -> a -> b
$ PatType -> Diet -> PatType
forall as shape.
Monoid as =>
TypeBase shape as -> Diet -> TypeBase shape as
maskAliases PatType
arg Diet
d
returnType (Scalar (Arrow Aliasing
old_als PName
v PatType
t1 (RetType [VName]
dims PatType
t2))) Diet
d PatType
arg =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Aliasing
-> PName
-> PatType
-> PatRetType
-> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow Aliasing
als PName
v (PatType
t1 PatType -> Aliasing -> PatType
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Aliasing
forall a. Monoid a => a
mempty) (PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> PatRetType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ [VName] -> PatType -> PatRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims (PatType -> PatRetType) -> PatType -> PatRetType
forall a b. (a -> b) -> a -> b
$ PatType
t2 PatType -> Aliasing -> PatType
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Aliasing
als
  where
    -- Make sure to propagate the aliases of an existing closure.
    als :: Aliasing
als = Aliasing
old_als Aliasing -> Aliasing -> Aliasing
forall a. Semigroup a => a -> a -> a
<> PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases (PatType -> Diet -> PatType
forall as shape.
Monoid as =>
TypeBase shape as -> Diet -> TypeBase shape as
maskAliases PatType
arg Diet
d)
returnType (Scalar (Sum Map Name [PatType]
cs)) Diet
d PatType
arg =
  ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Map Name [PatType] -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum (Map Name [PatType] -> ScalarTypeBase (DimDecl VName) Aliasing)
-> Map Name [PatType] -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ (([PatType] -> [PatType])
-> Map Name [PatType] -> Map Name [PatType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([PatType] -> [PatType])
 -> Map Name [PatType] -> Map Name [PatType])
-> ((PatType -> PatType) -> [PatType] -> [PatType])
-> (PatType -> PatType)
-> Map Name [PatType]
-> Map Name [PatType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatType -> PatType) -> [PatType] -> [PatType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\PatType
et -> PatType -> Diet -> PatType -> PatType
returnType PatType
et Diet
d PatType
arg) Map Name [PatType]
cs

-- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from
-- the parts of @t@ that are denoted as consumed by the 'Diet' @d@.
maskAliases ::
  Monoid as =>
  TypeBase shape as ->
  Diet ->
  TypeBase shape as
maskAliases :: TypeBase shape as -> Diet -> TypeBase shape as
maskAliases TypeBase shape as
t Diet
Consume = TypeBase shape as
t TypeBase shape as -> as -> TypeBase shape as
forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` as
forall a. Monoid a => a
mempty
maskAliases TypeBase shape as
t Diet
Observe = TypeBase shape as
t
maskAliases (Scalar (Record Map Name (TypeBase shape as)
ets)) (RecordDiet Map Name Diet
ds) =
  ScalarTypeBase shape as -> TypeBase shape as
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase shape as -> TypeBase shape as)
-> ScalarTypeBase shape as -> TypeBase shape as
forall a b. (a -> b) -> a -> b
$ Map Name (TypeBase shape as) -> ScalarTypeBase shape as
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name (TypeBase shape as) -> ScalarTypeBase shape as)
-> Map Name (TypeBase shape as) -> ScalarTypeBase shape as
forall a b. (a -> b) -> a -> b
$ (TypeBase shape as -> Diet -> TypeBase shape as)
-> Map Name (TypeBase shape as)
-> Map Name Diet
-> Map Name (TypeBase shape as)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase shape as -> Diet -> TypeBase shape as
forall as shape.
Monoid as =>
TypeBase shape as -> Diet -> TypeBase shape as
maskAliases Map Name (TypeBase shape as)
ets Map Name Diet
ds
maskAliases (Scalar (Sum Map Name [TypeBase shape as]
ets)) (SumDiet Map Name [Diet]
ds) =
  ScalarTypeBase shape as -> TypeBase shape as
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase shape as -> TypeBase shape as)
-> ScalarTypeBase shape as -> TypeBase shape as
forall a b. (a -> b) -> a -> b
$ Map Name [TypeBase shape as] -> ScalarTypeBase shape as
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum (Map Name [TypeBase shape as] -> ScalarTypeBase shape as)
-> Map Name [TypeBase shape as] -> ScalarTypeBase shape as
forall a b. (a -> b) -> a -> b
$ ([TypeBase shape as] -> [Diet] -> [TypeBase shape as])
-> Map Name [TypeBase shape as]
-> Map Name [Diet]
-> Map Name [TypeBase shape as]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith ((TypeBase shape as -> Diet -> TypeBase shape as)
-> [TypeBase shape as] -> [Diet] -> [TypeBase shape as]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeBase shape as -> Diet -> TypeBase shape as
forall as shape.
Monoid as =>
TypeBase shape as -> Diet -> TypeBase shape as
maskAliases) Map Name [TypeBase shape as]
ets Map Name [Diet]
ds
maskAliases TypeBase shape as
t FuncDiet {} = TypeBase shape as
t
maskAliases TypeBase shape as
_ Diet
_ = String -> TypeBase shape as
forall a. HasCallStack => String -> a
error String
"Invalid arguments passed to maskAliases."

consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM [Occurrence]
consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM Occurrences
consumeArg SrcLoc
loc (Scalar (Record Map Name PatType
ets)) (RecordDiet Map Name Diet
ds) =
  [Occurrences] -> Occurrences
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Occurrences] -> Occurrences)
-> (Map Name Occurrences -> [Occurrences])
-> Map Name Occurrences
-> Occurrences
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Occurrences -> [Occurrences]
forall k a. Map k a -> [a]
M.elems (Map Name Occurrences -> Occurrences)
-> TermTypeM (Map Name Occurrences) -> TermTypeM Occurrences
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PatType, Diet) -> TermTypeM Occurrences)
-> Map Name (PatType, Diet) -> TermTypeM (Map Name Occurrences)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((PatType -> Diet -> TermTypeM Occurrences)
-> (PatType, Diet) -> TermTypeM Occurrences
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((PatType -> Diet -> TermTypeM Occurrences)
 -> (PatType, Diet) -> TermTypeM Occurrences)
-> (PatType -> Diet -> TermTypeM Occurrences)
-> (PatType, Diet)
-> TermTypeM Occurrences
forall a b. (a -> b) -> a -> b
$ SrcLoc -> PatType -> Diet -> TermTypeM Occurrences
consumeArg SrcLoc
loc) ((PatType -> Diet -> (PatType, Diet))
-> Map Name PatType -> Map Name Diet -> Map Name (PatType, Diet)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) Map Name PatType
ets Map Name Diet
ds)
consumeArg SrcLoc
loc (Scalar (Sum Map Name [PatType]
ets)) (SumDiet Map Name [Diet]
ds) =
  [Occurrences] -> Occurrences
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Occurrences] -> Occurrences)
-> TermTypeM [Occurrences] -> TermTypeM Occurrences
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PatType, Diet) -> TermTypeM Occurrences)
-> [(PatType, Diet)] -> TermTypeM [Occurrences]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((PatType -> Diet -> TermTypeM Occurrences)
-> (PatType, Diet) -> TermTypeM Occurrences
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((PatType -> Diet -> TermTypeM Occurrences)
 -> (PatType, Diet) -> TermTypeM Occurrences)
-> (PatType -> Diet -> TermTypeM Occurrences)
-> (PatType, Diet)
-> TermTypeM Occurrences
forall a b. (a -> b) -> a -> b
$ SrcLoc -> PatType -> Diet -> TermTypeM Occurrences
consumeArg SrcLoc
loc) ([[(PatType, Diet)]] -> [(PatType, Diet)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(PatType, Diet)]] -> [(PatType, Diet)])
-> [[(PatType, Diet)]] -> [(PatType, Diet)]
forall a b. (a -> b) -> a -> b
$ Map Name [(PatType, Diet)] -> [[(PatType, Diet)]]
forall k a. Map k a -> [a]
M.elems (Map Name [(PatType, Diet)] -> [[(PatType, Diet)]])
-> Map Name [(PatType, Diet)] -> [[(PatType, Diet)]]
forall a b. (a -> b) -> a -> b
$ ([PatType] -> [Diet] -> [(PatType, Diet)])
-> Map Name [PatType]
-> Map Name [Diet]
-> Map Name [(PatType, Diet)]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith [PatType] -> [Diet] -> [(PatType, Diet)]
forall a b. [a] -> [b] -> [(a, b)]
zip Map Name [PatType]
ets Map Name [Diet]
ds)
consumeArg SrcLoc
loc (Array Aliasing
_ Uniqueness
Nonunique ScalarTypeBase (DimDecl VName) ()
_ ShapeDecl (DimDecl VName)
_) Diet
Consume =
  SrcLoc -> Notes -> Doc -> TermTypeM Occurrences
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Occurrences)
-> (Doc -> Doc) -> Doc -> TermTypeM Occurrences
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"consuming-parameter" (Doc -> TermTypeM Occurrences) -> Doc -> TermTypeM Occurrences
forall a b. (a -> b) -> a -> b
$
    Doc
"Consuming parameter passed non-unique argument."
consumeArg SrcLoc
loc (Scalar (TypeVar Aliasing
_ Uniqueness
Nonunique TypeName
_ [TypeArg (DimDecl VName)]
_)) Diet
Consume =
  SrcLoc -> Notes -> Doc -> TermTypeM Occurrences
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Occurrences)
-> (Doc -> Doc) -> Doc -> TermTypeM Occurrences
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"consuming-parameter" (Doc -> TermTypeM Occurrences) -> Doc -> TermTypeM Occurrences
forall a b. (a -> b) -> a -> b
$
    Doc
"Consuming parameter passed non-unique argument."
consumeArg SrcLoc
loc (Scalar (Arrow Aliasing
_ PName
_ PatType
t1 PatRetType
_)) (FuncDiet Diet
d Diet
_)
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PatType -> Diet -> Bool
forall dim as. TypeBase dim as -> Diet -> Bool
contravariantArg PatType
t1 Diet
d =
    SrcLoc -> Notes -> Doc -> TermTypeM Occurrences
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM Occurrences)
-> (Doc -> Doc) -> Doc -> TermTypeM Occurrences
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"consuming-argument" (Doc -> TermTypeM Occurrences) -> Doc -> TermTypeM Occurrences
forall a b. (a -> b) -> a -> b
$
      Doc
"Non-consuming higher-order parameter passed consuming argument."
  where
    contravariantArg :: TypeBase dim as -> Diet -> Bool
contravariantArg (Array as
_ Uniqueness
Unique ScalarTypeBase dim ()
_ ShapeDecl dim
_) Diet
Observe =
      Bool
False
    contravariantArg (Scalar (TypeVar as
_ Uniqueness
Unique TypeName
_ [TypeArg dim]
_)) Diet
Observe =
      Bool
False
    contravariantArg (Scalar (Record Map Name (TypeBase dim as)
ets)) (RecordDiet Map Name Diet
ds) =
      Map Name Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((TypeBase dim as -> Diet -> Bool)
-> Map Name (TypeBase dim as) -> Map Name Diet -> Map Name Bool
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase dim as -> Diet -> Bool
contravariantArg Map Name (TypeBase dim as)
ets Map Name Diet
ds)
    contravariantArg (Scalar (Arrow as
_ PName
_ TypeBase dim as
tp (RetType [VName]
_ TypeBase dim as
tr))) (FuncDiet Diet
dp Diet
dr) =
      TypeBase dim as -> Diet -> Bool
contravariantArg TypeBase dim as
tp Diet
dp Bool -> Bool -> Bool
&& TypeBase dim as -> Diet -> Bool
contravariantArg TypeBase dim as
tr Diet
dr
    contravariantArg TypeBase dim as
_ Diet
_ =
      Bool
True
consumeArg SrcLoc
loc PatType
at Diet
Consume = Occurrences -> TermTypeM Occurrences
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Aliasing -> SrcLoc -> Occurrence
consumption (PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
at) SrcLoc
loc]
consumeArg SrcLoc
loc PatType
at Diet
_ = Occurrences -> TermTypeM Occurrences
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Aliasing -> SrcLoc -> Occurrence
observation (PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
at) SrcLoc
loc]

-- | Type-check a single expression in isolation.  This expression may
-- turn out to be polymorphic, in which case the list of type
-- parameters will be non-empty.
checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)
checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)
checkOneExp UncheckedExp
e = ((([TypeParam], Exp), Occurrences) -> ([TypeParam], Exp))
-> TypeM (([TypeParam], Exp), Occurrences)
-> TypeM ([TypeParam], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([TypeParam], Exp), Occurrences) -> ([TypeParam], Exp)
forall a b. (a, b) -> a
fst (TypeM (([TypeParam], Exp), Occurrences)
 -> TypeM ([TypeParam], Exp))
-> (TermTypeM ([TypeParam], Exp)
    -> TypeM (([TypeParam], Exp), Occurrences))
-> TermTypeM ([TypeParam], Exp)
-> TypeM ([TypeParam], Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermTypeM ([TypeParam], Exp)
-> TypeM (([TypeParam], Exp), Occurrences)
forall a. TermTypeM a -> TypeM (a, Occurrences)
runTermTypeM (TermTypeM ([TypeParam], Exp) -> TypeM ([TypeParam], Exp))
-> TermTypeM ([TypeParam], Exp) -> TypeM ([TypeParam], Exp)
forall a b. (a -> b) -> a -> b
$ do
  Exp
e' <- UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
e
  let t :: StructType
t = PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType) -> PatType -> StructType
forall a b. (a -> b) -> a -> b
$ Exp -> PatType
typeOf Exp
e'
  ([TypeParam]
tparams, [Pat]
_, StructRetType
_) <-
    Name
-> SrcLoc
-> [TypeParam]
-> [Pat]
-> StructType
-> TermTypeM ([TypeParam], [Pat], StructRetType)
letGeneralise (String -> Name
nameFromString String
"<exp>") (UncheckedExp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf UncheckedExp
e) [] [] StructType
t
  Names -> TermTypeM ()
fixOverloadedTypes (Names -> TermTypeM ()) -> Names -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ StructType -> Names
forall as dim. Monoid as => TypeBase dim as -> Names
typeVars StructType
t
  Exp
e'' <- Exp -> TermTypeM Exp
forall e. ASTMappable e => e -> TermTypeM e
updateTypes Exp
e'
  Exp -> TermTypeM ()
checkUnmatched Exp
e''
  Exp -> TermTypeM ()
causalityCheck Exp
e''
  Exp -> TermTypeM ()
literalOverflowCheck Exp
e''
  ([TypeParam], Exp) -> TermTypeM ([TypeParam], Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeParam]
tparams, Exp
e'')

-- Verify that all sum type constructors and empty array literals have
-- a size that is known (rigid or a type parameter).  This is to
-- ensure that we can actually determine their shape at run-time.
causalityCheck :: Exp -> TermTypeM ()
causalityCheck :: Exp -> TermTypeM ()
causalityCheck Exp
binding_body = do
  Constraints
constraints <- TermTypeM Constraints
forall (m :: * -> *). MonadUnify m => m Constraints
getConstraints

  let checkCausality :: Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
what Names
known TypeBase (DimDecl VName) as
t SrcLoc
loc
        | (VName
d, SrcLoc
dloc) : [(VName, SrcLoc)]
_ <-
            (VName -> Maybe (VName, SrcLoc)) -> [VName] -> [(VName, SrcLoc)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Constraints -> Names -> VName -> Maybe (VName, SrcLoc)
forall a a.
Ord a =>
Map a (a, Constraint) -> Set a -> a -> Maybe (a, SrcLoc)
unknown Constraints
constraints Names
known) ([VName] -> [(VName, SrcLoc)]) -> [VName] -> [(VName, SrcLoc)]
forall a b. (a -> b) -> a -> b
$
              Names -> [VName]
forall a. Set a -> [a]
S.toList (Names -> [VName]) -> Names -> [VName]
forall a b. (a -> b) -> a -> b
$ StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNames (StructType -> Names) -> StructType -> Names
forall a b. (a -> b) -> a -> b
$ TypeBase (DimDecl VName) as -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) as
t =
          t (Either TypeError) a -> Maybe (t (Either TypeError) a)
forall a. a -> Maybe a
Just (t (Either TypeError) a -> Maybe (t (Either TypeError) a))
-> t (Either TypeError) a -> Maybe (t (Either TypeError) a)
forall a b. (a -> b) -> a -> b
$ Either TypeError a -> t (Either TypeError) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either TypeError a -> t (Either TypeError) a)
-> Either TypeError a -> t (Either TypeError) a
forall a b. (a -> b) -> a -> b
$ Doc
-> SrcLoc
-> VName
-> SrcLoc
-> TypeBase (DimDecl VName) as
-> Either TypeError a
forall v a b b.
(IsName v, Pretty a, Located b) =>
Doc -> SrcLoc -> v -> b -> a -> Either TypeError b
causality Doc
what SrcLoc
loc VName
d SrcLoc
dloc TypeBase (DimDecl VName) as
t
        | Bool
otherwise = Maybe (t (Either TypeError) a)
forall a. Maybe a
Nothing

      checkParamCausality :: Names -> Pat -> Maybe (t (Either TypeError) a)
checkParamCausality Names
known Pat
p =
        Doc -> Names -> PatType -> SrcLoc -> Maybe (t (Either TypeError) a)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality (Pat -> Doc
forall a. Pretty a => a -> Doc
ppr Pat
p) Names
known (Pat -> PatType
patternType Pat
p) (Pat -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Pat
p)

      onExp ::
        S.Set VName ->
        Exp ->
        StateT (S.Set VName) (Either TypeError) Exp

      onExp :: Names -> Exp -> StateT Names (Either TypeError) Exp
onExp Names
known (Var QualName VName
v (Info PatType
t) SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality (Doc -> Doc
pquote (QualName VName -> Doc
forall a. Pretty a => a -> Doc
ppr QualName VName
v)) Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (ProjectSection [Name]
_ (Info PatType
t) SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
"projection section" Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (IndexSection Slice
_ (Info PatType
t) SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
"projection section" Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (OpSectionRight QualName VName
_ (Info PatType
t) Exp
_ (Info (PName, StructType), Info (PName, StructType, Maybe VName))
_ Info PatRetType
_ SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
"operator section" Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (OpSectionLeft QualName VName
_ (Info PatType
t) Exp
_ (Info (PName, StructType, Maybe VName), Info (PName, StructType))
_ (Info PatRetType, Info [VName])
_ SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
"operator section" Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (ArrayLit [] (Info PatType
t) SrcLoc
loc)
        | Just StateT Names (Either TypeError) Exp
bad <- Doc
-> Names
-> PatType
-> SrcLoc
-> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) as a.
MonadTrans t =>
Doc
-> Names
-> TypeBase (DimDecl VName) as
-> SrcLoc
-> Maybe (t (Either TypeError) a)
checkCausality Doc
"empty array" Names
known PatType
t SrcLoc
loc =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known (Lambda [Pat]
params Exp
_ Maybe (TypeExp VName)
_ Info (Aliasing, StructRetType)
_ SrcLoc
_)
        | StateT Names (Either TypeError) Exp
bad : [StateT Names (Either TypeError) Exp]
_ <- (Pat -> Maybe (StateT Names (Either TypeError) Exp))
-> [Pat] -> [StateT Names (Either TypeError) Exp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Names -> Pat -> Maybe (StateT Names (Either TypeError) Exp)
forall (t :: (* -> *) -> * -> *) a.
MonadTrans t =>
Names -> Pat -> Maybe (t (Either TypeError) a)
checkParamCausality Names
known) [Pat]
params =
          StateT Names (Either TypeError) Exp
bad
      onExp Names
known e :: Exp
e@(AppExp (LetPat [SizeBinder VName]
_ Pat
_ Exp
bindee_e Exp
body_e SrcLoc
_) (Info AppRes
res)) = do
        Names
-> Exp -> Exp -> [VName] -> StateT Names (Either TypeError) ()
sequencePoint Names
known Exp
bindee_e Exp
body_e ([VName] -> StateT Names (Either TypeError) ())
-> [VName] -> StateT Names (Either TypeError) ()
forall a b. (a -> b) -> a -> b
$ AppRes -> [VName]
appResExt AppRes
res
        Exp -> StateT Names (Either TypeError) Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
      onExp Names
known e :: Exp
e@(AppExp (Apply Exp
f Exp
arg (Info (Diet
_, Maybe VName
p)) SrcLoc
_) (Info AppRes
res)) = do
        Names
-> Exp -> Exp -> [VName] -> StateT Names (Either TypeError) ()
sequencePoint Names
known Exp
arg Exp
f ([VName] -> StateT Names (Either TypeError) ())
-> [VName] -> StateT Names (Either TypeError) ()
forall a b. (a -> b) -> a -> b
$ Maybe VName -> [VName]
forall a. Maybe a -> [a]
maybeToList Maybe VName
p [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ AppRes -> [VName]
appResExt AppRes
res
        Exp -> StateT Names (Either TypeError) Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
      onExp
        Names
known
        e :: Exp
e@(AppExp (BinOp (QualName VName
f, SrcLoc
floc) Info PatType
ft (Exp
x, Info (StructType
_, Maybe VName
xp)) (Exp
y, Info (StructType
_, Maybe VName
yp)) SrcLoc
_) (Info AppRes
res)) = do
          Names
args_known <-
            Either TypeError Names -> StateT Names (Either TypeError) Names
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either TypeError Names -> StateT Names (Either TypeError) Names)
-> Either TypeError Names -> StateT Names (Either TypeError) Names
forall a b. (a -> b) -> a -> b
$
              StateT Names (Either TypeError) ()
-> Names -> Either TypeError Names
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Names
-> Exp -> Exp -> [VName] -> StateT Names (Either TypeError) ()
sequencePoint Names
known Exp
x Exp
y ([VName] -> StateT Names (Either TypeError) ())
-> [VName] -> StateT Names (Either TypeError) ()
forall a b. (a -> b) -> a -> b
$ [Maybe VName] -> [VName]
forall a. [Maybe a] -> [a]
catMaybes [Maybe VName
xp, Maybe VName
yp]) Names
forall a. Monoid a => a
mempty
          StateT Names (Either TypeError) Exp
-> StateT Names (Either TypeError) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Names (Either TypeError) Exp
 -> StateT Names (Either TypeError) ())
-> StateT Names (Either TypeError) Exp
-> StateT Names (Either TypeError) ()
forall a b. (a -> b) -> a -> b
$ Names -> Exp -> StateT Names (Either TypeError) Exp
onExp (Names
args_known Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names
known) (QualName VName -> Info PatType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
QualName vn -> f PatType -> SrcLoc -> ExpBase f vn
Var QualName VName
f Info PatType
ft SrcLoc
floc)
          (Names -> Names) -> StateT Names (Either TypeError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Names
args_known Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList (AppRes -> [VName]
appResExt AppRes
res)) Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<>)
          Exp -> StateT Names (Either TypeError) Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
      onExp Names
known e :: Exp
e@(AppExp AppExpBase Info VName
e' (Info AppRes
res)) = do
        Names
-> AppExpBase Info VName -> StateT Names (Either TypeError) ()
forall a.
ASTMappable a =>
Names -> a -> StateT Names (Either TypeError) ()
recurse Names
known AppExpBase Info VName
e'
        (Names -> Names) -> StateT Names (Either TypeError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList (AppRes -> [VName]
appResExt AppRes
res))
        Exp -> StateT Names (Either TypeError) Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
      onExp Names
known Exp
e = do
        Names -> Exp -> StateT Names (Either TypeError) ()
forall a.
ASTMappable a =>
Names -> a -> StateT Names (Either TypeError) ()
recurse Names
known Exp
e
        Exp -> StateT Names (Either TypeError) Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e

      recurse :: Names -> a -> StateT Names (Either TypeError) ()
recurse Names
known = StateT Names (Either TypeError) a
-> StateT Names (Either TypeError) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Names (Either TypeError) a
 -> StateT Names (Either TypeError) ())
-> (a -> StateT Names (Either TypeError) a)
-> a
-> StateT Names (Either TypeError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTMapper (StateT Names (Either TypeError))
-> a -> StateT Names (Either TypeError) a
forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper (StateT Names (Either TypeError))
mapper
        where
          mapper :: ASTMapper (StateT Names (Either TypeError))
mapper = ASTMapper (StateT Names (Either TypeError))
forall (m :: * -> *). Monad m => ASTMapper m
identityMapper {mapOnExp :: Exp -> StateT Names (Either TypeError) Exp
mapOnExp = Names -> Exp -> StateT Names (Either TypeError) Exp
onExp Names
known}

      sequencePoint :: Names
-> Exp -> Exp -> [VName] -> StateT Names (Either TypeError) ()
sequencePoint Names
known Exp
x Exp
y [VName]
ext = do
        Names
new_known <- Either TypeError Names -> StateT Names (Either TypeError) Names
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either TypeError Names -> StateT Names (Either TypeError) Names)
-> Either TypeError Names -> StateT Names (Either TypeError) Names
forall a b. (a -> b) -> a -> b
$ StateT Names (Either TypeError) Exp
-> Names -> Either TypeError Names
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Names -> Exp -> StateT Names (Either TypeError) Exp
onExp Names
known Exp
x) Names
forall a. Monoid a => a
mempty
        StateT Names (Either TypeError) Exp
-> StateT Names (Either TypeError) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Names (Either TypeError) Exp
 -> StateT Names (Either TypeError) ())
-> StateT Names (Either TypeError) Exp
-> StateT Names (Either TypeError) ()
forall a b. (a -> b) -> a -> b
$ Names -> Exp -> StateT Names (Either TypeError) Exp
onExp (Names
new_known Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names
known) Exp
y
        (Names -> Names) -> StateT Names (Either TypeError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Names
new_known Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList [VName]
ext) Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<>)

  (TypeError -> TermTypeM ())
-> (Exp -> TermTypeM ()) -> Either TypeError Exp -> TermTypeM ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TypeError -> TermTypeM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TermTypeM () -> Exp -> TermTypeM ()
forall a b. a -> b -> a
const (TermTypeM () -> Exp -> TermTypeM ())
-> TermTypeM () -> Exp -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Either TypeError Exp -> TermTypeM ())
-> Either TypeError Exp -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    StateT Names (Either TypeError) Exp
-> Names -> Either TypeError Exp
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Names -> Exp -> StateT Names (Either TypeError) Exp
onExp Names
forall a. Monoid a => a
mempty Exp
binding_body) Names
forall a. Monoid a => a
mempty
  where
    unknown :: Map a (a, Constraint) -> Set a -> a -> Maybe (a, SrcLoc)
unknown Map a (a, Constraint)
constraints Set a
known a
v = do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
known
      SrcLoc
loc <- Map a (a, Constraint) -> a -> Maybe SrcLoc
forall k a. Ord k => Map k (a, Constraint) -> k -> Maybe SrcLoc
unknowable Map a (a, Constraint)
constraints a
v
      (a, SrcLoc) -> Maybe (a, SrcLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, SrcLoc
loc)

    unknowable :: Map k (a, Constraint) -> k -> Maybe SrcLoc
unknowable Map k (a, Constraint)
constraints k
v =
      case (a, Constraint) -> Constraint
forall a b. (a, b) -> b
snd ((a, Constraint) -> Constraint)
-> Maybe (a, Constraint) -> Maybe Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Map k (a, Constraint) -> Maybe (a, Constraint)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
v Map k (a, Constraint)
constraints of
        Just (UnknowableSize SrcLoc
loc RigidSource
_) -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
loc
        Maybe Constraint
_ -> Maybe SrcLoc
forall a. Maybe a
Nothing

    causality :: Doc -> SrcLoc -> v -> b -> a -> Either TypeError b
causality Doc
what SrcLoc
loc v
d b
dloc a
t =
      TypeError -> Either TypeError b
forall a b. a -> Either a b
Left (TypeError -> Either TypeError b)
-> (Doc -> TypeError) -> Doc -> Either TypeError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Notes -> Doc -> TypeError
TypeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TypeError) -> (Doc -> Doc) -> Doc -> TypeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"causality-check" (Doc -> Either TypeError b) -> Doc -> Either TypeError b
forall a b. (a -> b) -> a -> b
$
        Doc
"Causality check: size" Doc -> Doc -> Doc
<+/> Doc -> Doc
pquote (v -> Doc
forall v. IsName v => v -> Doc
pprName v
d)
          Doc -> Doc -> Doc
<+/> Doc
"needed for type of"
          Doc -> Doc -> Doc
<+> Doc
what Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon
          Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
t)
          Doc -> Doc -> Doc
</> Doc
"But"
          Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (v -> Doc
forall v. IsName v => v -> Doc
pprName v
d)
          Doc -> Doc -> Doc
<+> Doc
"is computed at"
          Doc -> Doc -> Doc
<+/> String -> Doc
text (SrcLoc -> b -> String
forall a b. (Located a, Located b) => a -> b -> String
locStrRel SrcLoc
loc b
dloc) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
          Doc -> Doc -> Doc
</> Doc
""
          Doc -> Doc -> Doc
</> Doc
"Hint:"
          Doc -> Doc -> Doc
<+> Doc -> Doc
align
            ( String -> Doc
textwrap String
"Bind the expression producing" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (v -> Doc
forall v. IsName v => v -> Doc
pprName v
d)
                Doc -> Doc -> Doc
<+> Doc
"with 'let' beforehand."
            )

-- | Traverse the expression, emitting warnings if any of the literals overflow
-- their inferred types
--
-- Note: currently unable to detect float underflow (such as 1e-400 -> 0)
literalOverflowCheck :: Exp -> TermTypeM ()
literalOverflowCheck :: Exp -> TermTypeM ()
literalOverflowCheck = TermTypeM Exp -> TermTypeM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TermTypeM Exp -> TermTypeM ())
-> (Exp -> TermTypeM Exp) -> Exp -> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> TermTypeM Exp
forall (f :: * -> *). MonadTypeChecker f => Exp -> f Exp
check
  where
    check :: Exp -> f Exp
check e :: Exp
e@(IntLit Integer
x Info PatType
ty SrcLoc
loc) =
      Exp
e Exp -> f () -> f Exp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Info PatType
ty of
        Info (Scalar (Prim PrimType
t)) -> Bool -> Integer -> PrimType -> SrcLoc -> f ()
forall (f :: * -> *) loc a a.
(MonadTypeChecker f, Located loc, Pretty a, Pretty a) =>
Bool -> a -> a -> loc -> f ()
warnBounds (Integer -> PrimType -> Bool
forall a. Integral a => a -> PrimType -> Bool
inBoundsI Integer
x PrimType
t) Integer
x PrimType
t SrcLoc
loc
        Info PatType
_ -> String -> f ()
forall a. HasCallStack => String -> a
error String
"Inferred type of int literal is not a number"
    check e :: Exp
e@(FloatLit Double
x Info PatType
ty SrcLoc
loc) =
      Exp
e Exp -> f () -> f Exp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Info PatType
ty of
        Info (Scalar (Prim (FloatType FloatType
t))) -> Bool -> Double -> FloatType -> SrcLoc -> f ()
forall (f :: * -> *) loc a a.
(MonadTypeChecker f, Located loc, Pretty a, Pretty a) =>
Bool -> a -> a -> loc -> f ()
warnBounds (Double -> FloatType -> Bool
forall a. RealFloat a => a -> FloatType -> Bool
inBoundsF Double
x FloatType
t) Double
x FloatType
t SrcLoc
loc
        Info PatType
_ -> String -> f ()
forall a. HasCallStack => String -> a
error String
"Inferred type of float literal is not a float"
    check e :: Exp
e@(Negate (IntLit Integer
x Info PatType
ty SrcLoc
loc1) SrcLoc
loc2) =
      Exp
e Exp -> f () -> f Exp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Info PatType
ty of
        Info (Scalar (Prim PrimType
t)) -> Bool -> Integer -> PrimType -> SrcLoc -> f ()
forall (f :: * -> *) loc a a.
(MonadTypeChecker f, Located loc, Pretty a, Pretty a) =>
Bool -> a -> a -> loc -> f ()
warnBounds (Integer -> PrimType -> Bool
forall a. Integral a => a -> PrimType -> Bool
inBoundsI (- Integer
x) PrimType
t) (- Integer
x) PrimType
t (SrcLoc
loc1 SrcLoc -> SrcLoc -> SrcLoc
forall a. Semigroup a => a -> a -> a
<> SrcLoc
loc2)
        Info PatType
_ -> String -> f ()
forall a. HasCallStack => String -> a
error String
"Inferred type of int literal is not a number"
    check Exp
e = ASTMapper f -> Exp -> f Exp
forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper f
forall (m :: * -> *). Monad m => ASTMapper m
identityMapper {mapOnExp :: Exp -> f Exp
mapOnExp = Exp -> f Exp
check} Exp
e
    bitWidth :: IntType -> Level
bitWidth IntType
ty = Level
8 Level -> Level -> Level
forall a. Num a => a -> a -> a
* IntType -> Level
forall a. Num a => IntType -> a
intByteSize IntType
ty :: Int
    inBoundsI :: a -> PrimType -> Bool
inBoundsI a
x (Signed IntType
t) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= -a
2 a -> Level -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ (IntType -> Level
bitWidth IntType
t Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
1) Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
2 a -> Level -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ (IntType -> Level
bitWidth IntType
t Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
1)
    inBoundsI a
x (Unsigned IntType
t) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
2 a -> Level -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ IntType -> Level
bitWidth IntType
t
    inBoundsI a
x (FloatType FloatType
Float16) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Half -> Bool
forall a. RealFloat a => a -> Bool
isInfinite (a -> Half
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Half)
    inBoundsI a
x (FloatType FloatType
Float32) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite (a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Float)
    inBoundsI a
x (FloatType FloatType
Float64) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Double)
    inBoundsI a
_ PrimType
Bool = String -> Bool
forall a. HasCallStack => String -> a
error String
"Inferred type of int literal is not a number"
    inBoundsF :: a -> FloatType -> Bool
inBoundsF a
x FloatType
Float16 = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite (a -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
x :: Float)
    inBoundsF a
x FloatType
Float32 = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite (a -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
x :: Float)
    inBoundsF a
x FloatType
Float64 = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x
    warnBounds :: Bool -> a -> a -> loc -> f ()
warnBounds Bool
inBounds a
x a
ty loc
loc =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inBounds (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        loc -> Notes -> Doc -> f ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError loc
loc Notes
forall a. Monoid a => a
mempty (Doc -> f ()) -> (Doc -> Doc) -> Doc -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"literal-out-of-bounds" (Doc -> f ()) -> Doc -> f ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Literal " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
x
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" out of bounds for inferred type "
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
ty
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

-- | Type-check a top-level (or module-level) function definition.
-- Despite the name, this is also used for checking constant
-- definitions, by treating them as 0-ary functions.
checkFunDef ::
  ( Name,
    Maybe UncheckedTypeExp,
    [UncheckedTypeParam],
    [UncheckedPat],
    UncheckedExp,
    SrcLoc
  ) ->
  TypeM
    ( VName,
      [TypeParam],
      [Pat],
      Maybe (TypeExp VName),
      StructRetType,
      Exp
    )
checkFunDef :: (Name, Maybe (TypeExp Name), [TypeParamBase Name],
 [PatBase NoInfo Name], UncheckedExp, SrcLoc)
-> TypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
checkFunDef (Name
fname, Maybe (TypeExp Name)
maybe_retdecl, [TypeParamBase Name]
tparams, [PatBase NoInfo Name]
params, UncheckedExp
body, SrcLoc
loc) =
  (((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
   Exp),
  Occurrences)
 -> (VName, [TypeParam], [Pat], Maybe (TypeExp VName),
     StructRetType, Exp))
-> TypeM
     ((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp),
      Occurrences)
-> TypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
  Exp),
 Occurrences)
-> (VName, [TypeParam], [Pat], Maybe (TypeExp VName),
    StructRetType, Exp)
forall a b. (a, b) -> a
fst (TypeM
   ((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
     Exp),
    Occurrences)
 -> TypeM
      (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp))
-> (TermTypeM
      (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp)
    -> TypeM
         ((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
           Exp),
          Occurrences))
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
-> TypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermTypeM
  (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
   Exp)
-> TypeM
     ((VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp),
      Occurrences)
forall a. TermTypeM a -> TypeM (a, Occurrences)
runTermTypeM (TermTypeM
   (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
    Exp)
 -> TypeM
      (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp))
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
-> TypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall a b. (a -> b) -> a -> b
$ do
    ([TypeParam]
tparams', [Pat]
params', Maybe (TypeExp VName)
maybe_retdecl', RetType [VName]
dims StructType
rettype', Exp
body') <-
      (Name, Maybe (TypeExp Name), [TypeParamBase Name],
 [PatBase NoInfo Name], UncheckedExp, SrcLoc)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
checkBinding (Name
fname, Maybe (TypeExp Name)
maybe_retdecl, [TypeParamBase Name]
tparams, [PatBase NoInfo Name]
params, UncheckedExp
body, SrcLoc
loc)

    -- Since this is a top-level function, we also resolve overloaded
    -- types, using either defaults or complaining about ambiguities.
    Names -> TermTypeM ()
fixOverloadedTypes (Names -> TermTypeM ()) -> Names -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
      StructType -> Names
forall as dim. Monoid as => TypeBase dim as -> Names
typeVars StructType
rettype' Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> (Pat -> Names) -> [Pat] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PatType -> Names
forall as dim. Monoid as => TypeBase dim as -> Names
typeVars (PatType -> Names) -> (Pat -> PatType) -> Pat -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> PatType
patternType) [Pat]
params'

    -- Then replace all inferred types in the body and parameters.
    Exp
body'' <- Exp -> TermTypeM Exp
forall e. ASTMappable e => e -> TermTypeM e
updateTypes Exp
body'
    [Pat]
params'' <- [Pat] -> TermTypeM [Pat]
forall e. ASTMappable e => e -> TermTypeM e
updateTypes [Pat]
params'
    Maybe (TypeExp VName)
maybe_retdecl'' <- (TypeExp VName -> TermTypeM (TypeExp VName))
-> Maybe (TypeExp VName) -> TermTypeM (Maybe (TypeExp VName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeExp VName -> TermTypeM (TypeExp VName)
forall e. ASTMappable e => e -> TermTypeM e
updateTypes Maybe (TypeExp VName)
maybe_retdecl'
    StructType
rettype'' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
rettype'

    -- Check if pattern matches are exhaustive and yield
    -- errors if not.
    Exp -> TermTypeM ()
checkUnmatched Exp
body''

    -- Check if the function body can actually be evaluated.
    Exp -> TermTypeM ()
causalityCheck Exp
body''

    Exp -> TermTypeM ()
literalOverflowCheck Exp
body''

    [(Namespace, Name)]
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
fname)] (TermTypeM
   (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
    Exp)
 -> TermTypeM
      (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
       Exp))
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall a b. (a -> b) -> a -> b
$ do
      VName
fname' <- Namespace -> Name -> SrcLoc -> TermTypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
fname SrcLoc
loc
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> String
nameToString Name
fname String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
doNotShadow) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> (Doc -> Doc) -> Doc -> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"may-not-be-redefined" (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
          Doc
"The" Doc -> Doc -> Doc
<+> Name -> Doc
forall v. IsName v => v -> Doc
pprName Name
fname Doc -> Doc -> Doc
<+> Doc
"operator may not be redefined."

      (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
 Exp)
-> TermTypeM
     (VName, [TypeParam], [Pat], Maybe (TypeExp VName), StructRetType,
      Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VName
fname', [TypeParam]
tparams', [Pat]
params'', Maybe (TypeExp VName)
maybe_retdecl'', [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims StructType
rettype'', Exp
body'')

-- | This is "fixing" as in "setting them", not "correcting them".  We
-- only make very conservative fixing.
fixOverloadedTypes :: Names -> TermTypeM ()
fixOverloadedTypes :: Names -> TermTypeM ()
fixOverloadedTypes Names
tyvars_at_toplevel =
  TermTypeM Constraints
forall (m :: * -> *). MonadUnify m => m Constraints
getConstraints TermTypeM Constraints
-> (Constraints -> TermTypeM ()) -> TermTypeM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((VName, Constraint) -> TermTypeM ())
-> [(VName, Constraint)] -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VName, Constraint) -> TermTypeM ()
forall (m :: * -> *).
(MonadUnify m, MonadTypeChecker m) =>
(VName, Constraint) -> m ()
fixOverloaded ([(VName, Constraint)] -> TermTypeM ())
-> (Constraints -> [(VName, Constraint)])
-> Constraints
-> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName Constraint -> [(VName, Constraint)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName Constraint -> [(VName, Constraint)])
-> (Constraints -> Map VName Constraint)
-> Constraints
-> [(VName, Constraint)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level, Constraint) -> Constraint)
-> Constraints -> Map VName Constraint
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Level, Constraint) -> Constraint
forall a b. (a, b) -> b
snd
  where
    fixOverloaded :: (VName, Constraint) -> m ()
fixOverloaded (VName
v, Overloaded [PrimType]
ots Usage
usage)
      | IntType -> PrimType
Signed IntType
Int32 PrimType -> [PrimType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PrimType]
ots = do
        Usage -> StructType -> StructType -> m ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify Usage
usage (ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (()
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar () Uniqueness
Nonunique (VName -> TypeName
typeName VName
v) [])) (StructType -> m ()) -> StructType -> m ()
forall a b. (a -> b) -> a -> b
$
          ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) ())
-> PrimType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int32
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VName
v VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
tyvars_at_toplevel) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Usage -> Doc -> m ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc -> m ()
warn Usage
usage Doc
"Defaulting ambiguous type to i32."
      | FloatType -> PrimType
FloatType FloatType
Float64 PrimType -> [PrimType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PrimType]
ots = do
        Usage -> StructType -> StructType -> m ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify Usage
usage (ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (()
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar () Uniqueness
Nonunique (VName -> TypeName
typeName VName
v) [])) (StructType -> m ()) -> StructType -> m ()
forall a b. (a -> b) -> a -> b
$
          ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) ())
-> PrimType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ FloatType -> PrimType
FloatType FloatType
Float64
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VName
v VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
tyvars_at_toplevel) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Usage -> Doc -> m ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc -> m ()
warn Usage
usage Doc
"Defaulting ambiguous type to f64."
      | Bool
otherwise =
        Usage -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Usage
usage Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"ambiguous-type" (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Type is ambiguous (could be one of" Doc -> Doc -> Doc
<+> [Doc] -> Doc
commasep ((PrimType -> Doc) -> [PrimType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr [PrimType]
ots) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")."
            Doc -> Doc -> Doc
</> Doc
"Add a type annotation to disambiguate the type."
    fixOverloaded (VName
v, NoConstraint Liftedness
_ Usage
usage) = do
      -- See #1552.
      Usage -> StructType -> StructType -> m ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
unify Usage
usage (ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (()
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar () Uniqueness
Nonunique (VName -> TypeName
typeName VName
v) [])) (StructType -> m ()) -> StructType -> m ()
forall a b. (a -> b) -> a -> b
$
        ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall dim as. [TypeBase dim as] -> ScalarTypeBase dim as
tupleRecord []
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VName
v VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
tyvars_at_toplevel) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Usage -> Doc -> m ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc -> m ()
warn Usage
usage Doc
"Defaulting ambiguous type to ()."
    fixOverloaded (VName
_, Equality Usage
usage) =
      Usage -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Usage
usage Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"ambiguous-type" (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        Doc
"Type is ambiguous (must be equality type)."
          Doc -> Doc -> Doc
</> Doc
"Add a type annotation to disambiguate the type."
    fixOverloaded (VName
_, HasFields Map Name StructType
fs Usage
usage) =
      Usage -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Usage
usage Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"ambiguous-type" (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        Doc
"Type is ambiguous.  Must be record with fields:"
          Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 ([Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Name, StructType) -> Doc) -> [(Name, StructType)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, StructType) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
field ([(Name, StructType)] -> [Doc]) -> [(Name, StructType)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> [(Name, StructType)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name StructType
fs)
          Doc -> Doc -> Doc
</> Doc
"Add a type annotation to disambiguate the type."
      where
        field :: (a, a) -> Doc
field (a
l, a
t) = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
<+> Doc -> Doc
align (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
t)
    fixOverloaded (VName
_, HasConstrs Map Name [StructType]
cs Usage
usage) =
      Usage -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Usage
usage Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"ambiguous-type" (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        Doc
"Type is ambiguous (must be a sum type with constructors:"
          Doc -> Doc -> Doc
<+> ScalarTypeBase (DimDecl VName) () -> Doc
forall a. Pretty a => a -> Doc
ppr (Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum Map Name [StructType]
cs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")."
          Doc -> Doc -> Doc
</> Doc
"Add a type annotation to disambiguate the type."
    fixOverloaded (VName
v, Size Maybe (DimDecl VName)
Nothing Usage
usage) =
      Usage -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Usage
usage Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Doc
"Size" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
v) Doc -> Doc -> Doc
<+> Doc
"is ambiguous.\n"
    fixOverloaded (VName, Constraint)
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

hiddenParamNames :: [Pat] -> Names
hiddenParamNames :: [Pat] -> Names
hiddenParamNames [Pat]
params = Names
hidden
  where
    param_all_names :: Names
param_all_names = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> [Names] -> Names
forall a b. (a -> b) -> a -> b
$ (Pat -> Names) -> [Pat] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Names
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set vn
patNames [Pat]
params
    named :: (PName, b) -> Maybe VName
named (Named VName
x, b
_) = VName -> Maybe VName
forall a. a -> Maybe a
Just VName
x
    named (PName
Unnamed, b
_) = Maybe VName
forall a. Maybe a
Nothing
    param_names :: Names
param_names =
      [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList ([VName] -> Names) -> [VName] -> Names
forall a b. (a -> b) -> a -> b
$ (Pat -> Maybe VName) -> [Pat] -> [VName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PName, StructType) -> Maybe VName
forall b. (PName, b) -> Maybe VName
named ((PName, StructType) -> Maybe VName)
-> (Pat -> (PName, StructType)) -> Pat -> Maybe VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> (PName, StructType)
patternParam) [Pat]
params
    hidden :: Names
hidden = Names
param_all_names Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Names
param_names

inferredReturnType :: SrcLoc -> [Pat] -> PatType -> TermTypeM StructType
inferredReturnType :: SrcLoc -> [Pat] -> PatType -> TermTypeM StructType
inferredReturnType SrcLoc
loc [Pat]
params PatType
t =
  -- The inferred type may refer to names that are bound by the
  -- parameter patterns, but which will not be visible in the type.
  -- These we must turn into fresh type variables, which will be
  -- existential in the return type.
  ((PatType, [VName]) -> StructType)
-> TermTypeM (PatType, [VName]) -> TermTypeM StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType)
-> ((PatType, [VName]) -> PatType)
-> (PatType, [VName])
-> StructType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatType, [VName]) -> PatType
forall a b. (a, b) -> a
fst) (TermTypeM (PatType, [VName]) -> TermTypeM StructType)
-> TermTypeM (PatType, [VName]) -> TermTypeM StructType
forall a b. (a -> b) -> a -> b
$
    SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType
      SrcLoc
loc
      ((VName -> Ident -> Bool) -> Map VName Ident -> Map VName Ident
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> Ident -> Bool
forall a b. a -> b -> a
const (Bool -> Ident -> Bool)
-> (VName -> Bool) -> VName -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
hidden)) (Map VName Ident -> Map VName Ident)
-> Map VName Ident -> Map VName Ident
forall a b. (a -> b) -> a -> b
$ (Pat -> Map VName Ident) -> [Pat] -> Map VName Ident
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> Map VName Ident
forall (f :: * -> *).
Functor f =>
PatBase f VName -> Map VName (IdentBase f VName)
patternMap [Pat]
params)
      (PatType -> TermTypeM (PatType, [VName]))
-> PatType -> TermTypeM (PatType, [VName])
forall a b. (a -> b) -> a -> b
$ [Pat] -> PatType -> PatType
inferReturnUniqueness [Pat]
params PatType
t
  where
    hidden :: Names
hidden = [Pat] -> Names
hiddenParamNames [Pat]
params

checkReturnAlias :: SrcLoc -> TypeBase () () -> [Pat] -> PatType -> TermTypeM ()
checkReturnAlias :: SrcLoc -> TypeBase () () -> [Pat] -> PatType -> TermTypeM ()
checkReturnAlias SrcLoc
loc TypeBase () ()
rettp [Pat]
params =
  (Set (Uniqueness, VName)
 -> (Uniqueness, Names) -> TermTypeM (Set (Uniqueness, VName)))
-> Set (Uniqueness, VName) -> [(Uniqueness, Names)] -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ([Pat]
-> Set (Uniqueness, VName)
-> (Uniqueness, Names)
-> TermTypeM (Set (Uniqueness, VName))
forall (t :: * -> *).
Foldable t =>
t Pat
-> Set (Uniqueness, VName)
-> (Uniqueness, Names)
-> TermTypeM (Set (Uniqueness, VName))
checkReturnAlias' [Pat]
params) Set (Uniqueness, VName)
forall a. Set a
S.empty ([(Uniqueness, Names)] -> TermTypeM ())
-> (PatType -> [(Uniqueness, Names)]) -> PatType -> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeBase () () -> PatType -> [(Uniqueness, Names)]
forall shape as shape.
TypeBase shape as
-> TypeBase shape Aliasing -> [(Uniqueness, Names)]
returnAliasing TypeBase () ()
rettp
  where
    checkReturnAlias' :: t Pat
-> Set (Uniqueness, VName)
-> (Uniqueness, Names)
-> TermTypeM (Set (Uniqueness, VName))
checkReturnAlias' t Pat
params' Set (Uniqueness, VName)
seen (Uniqueness
Unique, Names
names)
      | (VName -> Bool) -> [VName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` ((Uniqueness, VName) -> VName) -> Set (Uniqueness, VName) -> Names
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Uniqueness, VName) -> VName
forall a b. (a, b) -> b
snd Set (Uniqueness, VName)
seen) ([VName] -> Bool) -> [VName] -> Bool
forall a b. (a -> b) -> a -> b
$ Names -> [VName]
forall a. Set a -> [a]
S.toList Names
names =
        SrcLoc -> TermTypeM (Set (Uniqueness, VName))
forall a. SrcLoc -> TermTypeM a
uniqueReturnAliased SrcLoc
loc
      | Bool
otherwise = do
        t Pat -> Names -> TermTypeM ()
forall (t :: * -> *). Foldable t => t Pat -> Names -> TermTypeM ()
notAliasingParam t Pat
params' Names
names
        Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName)))
-> Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName))
forall a b. (a -> b) -> a -> b
$ Set (Uniqueness, VName)
seen Set (Uniqueness, VName)
-> Set (Uniqueness, VName) -> Set (Uniqueness, VName)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Uniqueness -> Names -> Set (Uniqueness, VName)
forall t t. (Ord t, Ord t) => t -> Set t -> Set (t, t)
tag Uniqueness
Unique Names
names
    checkReturnAlias' t Pat
_ Set (Uniqueness, VName)
seen (Uniqueness
Nonunique, Names
names)
      | ((Uniqueness, VName) -> Bool) -> [(Uniqueness, VName)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Uniqueness, VName) -> Set (Uniqueness, VName) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Uniqueness, VName)
seen) ([(Uniqueness, VName)] -> Bool) -> [(Uniqueness, VName)] -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Uniqueness, VName) -> [(Uniqueness, VName)]
forall a. Set a -> [a]
S.toList (Set (Uniqueness, VName) -> [(Uniqueness, VName)])
-> Set (Uniqueness, VName) -> [(Uniqueness, VName)]
forall a b. (a -> b) -> a -> b
$ Uniqueness -> Names -> Set (Uniqueness, VName)
forall t t. (Ord t, Ord t) => t -> Set t -> Set (t, t)
tag Uniqueness
Unique Names
names =
        SrcLoc -> TermTypeM (Set (Uniqueness, VName))
forall a. SrcLoc -> TermTypeM a
uniqueReturnAliased SrcLoc
loc
      | Bool
otherwise = Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName)))
-> Set (Uniqueness, VName) -> TermTypeM (Set (Uniqueness, VName))
forall a b. (a -> b) -> a -> b
$ Set (Uniqueness, VName)
seen Set (Uniqueness, VName)
-> Set (Uniqueness, VName) -> Set (Uniqueness, VName)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Uniqueness -> Names -> Set (Uniqueness, VName)
forall t t. (Ord t, Ord t) => t -> Set t -> Set (t, t)
tag Uniqueness
Nonunique Names
names

    notAliasingParam :: t Pat -> Names -> TermTypeM ()
notAliasingParam t Pat
params' Names
names =
      t Pat -> (Pat -> TermTypeM ()) -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t Pat
params' ((Pat -> TermTypeM ()) -> TermTypeM ())
-> (Pat -> TermTypeM ()) -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ \Pat
p ->
        let consumedNonunique :: Ident -> Bool
consumedNonunique Ident
p' =
              Bool -> Bool
not (PatType -> Bool
forall shape as. TypeBase shape as -> Bool
unique (PatType -> Bool) -> PatType -> Bool
forall a b. (a -> b) -> a -> b
$ Info PatType -> PatType
forall a. Info a -> a
unInfo (Info PatType -> PatType) -> Info PatType -> PatType
forall a b. (a -> b) -> a -> b
$ Ident -> Info PatType
forall (f :: * -> *) vn. IdentBase f vn -> f PatType
identType Ident
p') Bool -> Bool -> Bool
&& (Ident -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName Ident
p' VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
names)
         in case (Ident -> Bool) -> [Ident] -> Maybe Ident
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Ident -> Bool
consumedNonunique ([Ident] -> Maybe Ident) -> [Ident] -> Maybe Ident
forall a b. (a -> b) -> a -> b
$ Set Ident -> [Ident]
forall a. Set a -> [a]
S.toList (Set Ident -> [Ident]) -> Set Ident -> [Ident]
forall a b. (a -> b) -> a -> b
$ Pat -> Set Ident
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set (IdentBase f vn)
patIdents Pat
p of
              Just Ident
p' ->
                Name -> SrcLoc -> TermTypeM ()
returnAliased (VName -> Name
baseName (VName -> Name) -> VName -> Name
forall a b. (a -> b) -> a -> b
$ Ident -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName Ident
p') SrcLoc
loc
              Maybe Ident
Nothing ->
                () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    tag :: t -> Set t -> Set (t, t)
tag t
u = (t -> (t, t)) -> Set t -> Set (t, t)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (t
u,)

    returnAliasing :: TypeBase shape as
-> TypeBase shape Aliasing -> [(Uniqueness, Names)]
returnAliasing (Scalar (Record Map Name (TypeBase shape as)
ets1)) (Scalar (Record Map Name (TypeBase shape Aliasing)
ets2)) =
      [[(Uniqueness, Names)]] -> [(Uniqueness, Names)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Uniqueness, Names)]] -> [(Uniqueness, Names)])
-> [[(Uniqueness, Names)]] -> [(Uniqueness, Names)]
forall a b. (a -> b) -> a -> b
$ Map Name [(Uniqueness, Names)] -> [[(Uniqueness, Names)]]
forall k a. Map k a -> [a]
M.elems (Map Name [(Uniqueness, Names)] -> [[(Uniqueness, Names)]])
-> Map Name [(Uniqueness, Names)] -> [[(Uniqueness, Names)]]
forall a b. (a -> b) -> a -> b
$ (TypeBase shape as
 -> TypeBase shape Aliasing -> [(Uniqueness, Names)])
-> Map Name (TypeBase shape as)
-> Map Name (TypeBase shape Aliasing)
-> Map Name [(Uniqueness, Names)]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase shape as
-> TypeBase shape Aliasing -> [(Uniqueness, Names)]
returnAliasing Map Name (TypeBase shape as)
ets1 Map Name (TypeBase shape Aliasing)
ets2
    returnAliasing TypeBase shape as
expected TypeBase shape Aliasing
got =
      [(TypeBase shape as -> Uniqueness
forall shape as. TypeBase shape as -> Uniqueness
uniqueness TypeBase shape as
expected, (Alias -> VName) -> Aliasing -> Names
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> VName
aliasVar (Aliasing -> Names) -> Aliasing -> Names
forall a b. (a -> b) -> a -> b
$ TypeBase shape Aliasing -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases TypeBase shape Aliasing
got)]

checkBinding ::
  ( Name,
    Maybe UncheckedTypeExp,
    [UncheckedTypeParam],
    [UncheckedPat],
    UncheckedExp,
    SrcLoc
  ) ->
  TermTypeM
    ( [TypeParam],
      [Pat],
      Maybe (TypeExp VName),
      StructRetType,
      Exp
    )
checkBinding :: (Name, Maybe (TypeExp Name), [TypeParamBase Name],
 [PatBase NoInfo Name], UncheckedExp, SrcLoc)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
checkBinding (Name
fname, Maybe (TypeExp Name)
maybe_retdecl, [TypeParamBase Name]
tparams, [PatBase NoInfo Name]
params, UncheckedExp
body, SrcLoc
loc) =
  TermTypeM
  ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall a. TermTypeM a -> TermTypeM a
noUnique (TermTypeM
   ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
 -> TermTypeM
      ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> (([TypeParam]
     -> [Pat]
     -> TermTypeM
          ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> ([TypeParam]
    -> [Pat]
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermTypeM
  ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall a. TermTypeM a -> TermTypeM a
incLevel (TermTypeM
   ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
 -> TermTypeM
      ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> (([TypeParam]
     -> [Pat]
     -> TermTypeM
          ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> ([TypeParam]
    -> [Pat]
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeParamBase Name]
-> [PatBase NoInfo Name]
-> ([TypeParam]
    -> [Pat]
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall a.
[TypeParamBase Name]
-> [PatBase NoInfo Name]
-> ([TypeParam] -> [Pat] -> TermTypeM a)
-> TermTypeM a
bindingParams [TypeParamBase Name]
tparams [PatBase NoInfo Name]
params (([TypeParam]
  -> [Pat]
  -> TermTypeM
       ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
 -> TermTypeM
      ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> ([TypeParam]
    -> [Pat]
    -> TermTypeM
         ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp))
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall a b. (a -> b) -> a -> b
$ \[TypeParam]
tparams' [Pat]
params' -> do
    Maybe (TypeExp VName, StructType, [VName])
maybe_retdecl' <- (TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName]))
-> Maybe (TypeExp Name)
-> TermTypeM (Maybe (TypeExp VName, StructType, [VName]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeExp Name -> TermTypeM (TypeExp VName, StructType, [VName])
checkTypeExpNonrigid Maybe (TypeExp Name)
maybe_retdecl

    Exp
body' <-
      [Pat]
-> UncheckedExp -> Maybe StructType -> SrcLoc -> TermTypeM Exp
checkFunBody
        [Pat]
params'
        UncheckedExp
body
        ((\(TypeExp VName
_, StructType
x, [VName]
_) -> StructType
x) ((TypeExp VName, StructType, [VName]) -> StructType)
-> Maybe (TypeExp VName, StructType, [VName]) -> Maybe StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TypeExp VName, StructType, [VName])
maybe_retdecl')
        (SrcLoc
-> (TypeExp Name -> SrcLoc) -> Maybe (TypeExp Name) -> SrcLoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SrcLoc
loc TypeExp Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Maybe (TypeExp Name)
maybe_retdecl)

    [Pat]
params'' <- (Pat -> TermTypeM Pat) -> [Pat] -> TermTypeM [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> TermTypeM Pat
forall e. ASTMappable e => e -> TermTypeM e
updateTypes [Pat]
params'
    PatType
body_t <- Exp -> TermTypeM PatType
expTypeFully Exp
body'

    (Maybe (TypeExp VName)
maybe_retdecl'', StructType
rettype) <- case Maybe (TypeExp VName, StructType, [VName])
maybe_retdecl' of
      Just (TypeExp VName
retdecl', StructType
ret, [VName]
_) -> do
        let rettype_structural :: TypeBase () ()
rettype_structural = StructType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural StructType
ret
        SrcLoc -> TypeBase () () -> [Pat] -> PatType -> TermTypeM ()
checkReturnAlias SrcLoc
loc TypeBase () ()
rettype_structural [Pat]
params'' PatType
body_t

        Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PatBase NoInfo Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name]
params) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> TypeBase () () -> TermTypeM ()
nothingMustBeUnique SrcLoc
loc TypeBase () ()
rettype_structural

        StructType
ret' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
ret

        (Maybe (TypeExp VName), StructType)
-> TermTypeM (Maybe (TypeExp VName), StructType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExp VName -> Maybe (TypeExp VName)
forall a. a -> Maybe a
Just TypeExp VName
retdecl', StructType
ret')
      Maybe (TypeExp VName, StructType, [VName])
Nothing
        | [PatBase NoInfo Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name]
params ->
          (Maybe (TypeExp VName), StructType)
-> TermTypeM (Maybe (TypeExp VName), StructType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeExp VName)
forall a. Maybe a
Nothing, PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatType -> StructType) -> PatType -> StructType
forall a b. (a -> b) -> a -> b
$ PatType
body_t PatType -> Uniqueness -> PatType
forall dim as. TypeBase dim as -> Uniqueness -> TypeBase dim as
`setUniqueness` Uniqueness
Nonunique)
        | Bool
otherwise -> do
          StructType
body_t' <- SrcLoc -> [Pat] -> PatType -> TermTypeM StructType
inferredReturnType SrcLoc
loc [Pat]
params'' PatType
body_t
          (Maybe (TypeExp VName), StructType)
-> TermTypeM (Maybe (TypeExp VName), StructType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeExp VName)
forall a. Maybe a
Nothing, StructType
body_t')

    Maybe Name -> [Pat] -> TermTypeM ()
verifyFunctionParams (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
fname) [Pat]
params''

    ([TypeParam]
tparams'', [Pat]
params''', StructRetType
rettype'') <-
      Name
-> SrcLoc
-> [TypeParam]
-> [Pat]
-> StructType
-> TermTypeM ([TypeParam], [Pat], StructRetType)
letGeneralise Name
fname SrcLoc
loc [TypeParam]
tparams' [Pat]
params'' StructType
rettype

    [Pat] -> PatType -> SrcLoc -> TermTypeM ()
checkGlobalAliases [Pat]
params'' PatType
body_t SrcLoc
loc

    ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
-> TermTypeM
     ([TypeParam], [Pat], Maybe (TypeExp VName), StructRetType, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeParam]
tparams'', [Pat]
params''', Maybe (TypeExp VName)
maybe_retdecl'', StructRetType
rettype'', Exp
body')

-- | Extract all the shape names that occur in positive position
-- (roughly, left side of an arrow) in a given type.
typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName
typeDimNamesPos :: TypeBase (DimDecl VName) als -> Names
typeDimNamesPos (Scalar (Arrow als
_ PName
_ TypeBase (DimDecl VName) als
t1 (RetType [VName]
_ TypeBase (DimDecl VName) als
t2))) = TypeBase (DimDecl VName) als -> Names
forall als. TypeBase (DimDecl VName) als -> Names
onParam TypeBase (DimDecl VName) als
t1 Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) als -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNamesPos TypeBase (DimDecl VName) als
t2
  where
    onParam :: TypeBase (DimDecl VName) als -> S.Set VName
    onParam :: TypeBase (DimDecl VName) als -> Names
onParam (Scalar Arrow {}) = Names
forall a. Monoid a => a
mempty
    onParam (Scalar (Record Map Name (TypeBase (DimDecl VName) als)
fs)) = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> [Names] -> Names
forall a b. (a -> b) -> a -> b
$ (TypeBase (DimDecl VName) als -> Names)
-> [TypeBase (DimDecl VName) als] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase (DimDecl VName) als -> Names
forall als. TypeBase (DimDecl VName) als -> Names
onParam ([TypeBase (DimDecl VName) als] -> [Names])
-> [TypeBase (DimDecl VName) als] -> [Names]
forall a b. (a -> b) -> a -> b
$ Map Name (TypeBase (DimDecl VName) als)
-> [TypeBase (DimDecl VName) als]
forall k a. Map k a -> [a]
M.elems Map Name (TypeBase (DimDecl VName) als)
fs
    onParam (Scalar (TypeVar als
_ Uniqueness
_ TypeName
_ [TypeArg (DimDecl VName)]
targs)) = [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> [Names] -> Names
forall a b. (a -> b) -> a -> b
$ (TypeArg (DimDecl VName) -> Names)
-> [TypeArg (DimDecl VName)] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map TypeArg (DimDecl VName) -> Names
onTypeArg [TypeArg (DimDecl VName)]
targs
    onParam TypeBase (DimDecl VName) als
t = TypeBase (DimDecl VName) als -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNames TypeBase (DimDecl VName) als
t
    onTypeArg :: TypeArg (DimDecl VName) -> Names
onTypeArg (TypeArgDim (NamedDim QualName VName
d) SrcLoc
_) = VName -> Names
forall a. a -> Set a
S.singleton (VName -> Names) -> VName -> Names
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
d
    onTypeArg (TypeArgDim DimDecl VName
_ SrcLoc
_) = Names
forall a. Monoid a => a
mempty
    onTypeArg (TypeArgType StructType
t SrcLoc
_) = StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
onParam StructType
t
typeDimNamesPos TypeBase (DimDecl VName) als
_ = Names
forall a. Monoid a => a
mempty

checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM ()
checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM ()
checkGlobalAliases [Pat]
params PatType
body_t SrcLoc
loc = do
  Map VName ValBinding
vtable <- (TermEnv -> Map VName ValBinding)
-> TermTypeM (Map VName ValBinding)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((TermEnv -> Map VName ValBinding)
 -> TermTypeM (Map VName ValBinding))
-> (TermEnv -> Map VName ValBinding)
-> TermTypeM (Map VName ValBinding)
forall a b. (a -> b) -> a -> b
$ TermScope -> Map VName ValBinding
scopeVtable (TermScope -> Map VName ValBinding)
-> (TermEnv -> TermScope) -> TermEnv -> Map VName ValBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermEnv -> TermScope
termScope
  let isLocal :: VName -> Bool
isLocal VName
v = case VName
v VName -> Map VName ValBinding -> Maybe ValBinding
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map VName ValBinding
vtable of
        Just (BoundV Locality
Local [TypeParam]
_ PatType
_) -> Bool
True
        Maybe ValBinding
_ -> Bool
False
  let als :: [VName]
als =
        (VName -> Bool) -> [VName] -> [VName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (VName -> Bool) -> VName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Bool
isLocal) ([VName] -> [VName]) -> (Names -> [VName]) -> Names -> [VName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> [VName]
forall a. Set a -> [a]
S.toList (Names -> [VName]) -> Names -> [VName]
forall a b. (a -> b) -> a -> b
$
          PatType -> Names
boundArrayAliases PatType
body_t Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` (Pat -> Names) -> [Pat] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> Names
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set vn
patNames [Pat]
params
  case [VName]
als of
    VName
v : [VName]
_
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pat]
params ->
        SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> (Doc -> Doc) -> Doc -> TermTypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"alias-free-variable" (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Function result aliases the free variable "
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
v)
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
            Doc -> Doc -> Doc
</> Doc
"Use" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote Doc
"copy" Doc -> Doc -> Doc
<+> Doc
"to break the aliasing."
    [VName]
_ ->
      () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

inferReturnUniqueness :: [Pat] -> PatType -> PatType
inferReturnUniqueness :: [Pat] -> PatType -> PatType
inferReturnUniqueness [Pat]
params PatType
t =
  let forbidden :: Names
forbidden = PatType -> Names
aliasesMultipleTimes PatType
t
      uniques :: Names
uniques = [Pat] -> Names
uniqueParamNames [Pat]
params
      delve :: PatType -> PatType
delve (Scalar (Record Map Name PatType
fs)) =
        ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) Aliasing -> PatType)
-> ScalarTypeBase (DimDecl VName) Aliasing -> PatType
forall a b. (a -> b) -> a -> b
$ Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing)
-> Map Name PatType -> ScalarTypeBase (DimDecl VName) Aliasing
forall a b. (a -> b) -> a -> b
$ (PatType -> PatType) -> Map Name PatType -> Map Name PatType
forall a b k. (a -> b) -> Map k a -> Map k b
M.map PatType -> PatType
delve Map Name PatType
fs
      delve PatType
t'
        | (VName -> Bool) -> Names -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
uniques) (PatType -> Names
boundArrayAliases PatType
t'),
          Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Alias -> Bool) -> Aliasing -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
forbidden) (VName -> Bool) -> (Alias -> VName) -> Alias -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar) (PatType -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases PatType
t') =
          PatType
t'
        | Bool
otherwise =
          PatType
t' PatType -> Uniqueness -> PatType
forall dim as. TypeBase dim as -> Uniqueness -> TypeBase dim as
`setUniqueness` Uniqueness
Nonunique
   in PatType -> PatType
delve PatType
t

-- An alias inhibits uniqueness if it is used in disjoint values.
aliasesMultipleTimes :: PatType -> Names
aliasesMultipleTimes :: PatType -> Names
aliasesMultipleTimes = [VName] -> Names
forall a. Ord a => [a] -> Set a
S.fromList ([VName] -> Names) -> (PatType -> [VName]) -> PatType -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VName, Level) -> VName) -> [(VName, Level)] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map (VName, Level) -> VName
forall a b. (a, b) -> a
fst ([(VName, Level)] -> [VName])
-> (PatType -> [(VName, Level)]) -> PatType -> [VName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VName, Level) -> Bool) -> [(VName, Level)] -> [(VName, Level)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
> Level
1) (Level -> Bool)
-> ((VName, Level) -> Level) -> (VName, Level) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName, Level) -> Level
forall a b. (a, b) -> b
snd) ([(VName, Level)] -> [(VName, Level)])
-> (PatType -> [(VName, Level)]) -> PatType -> [(VName, Level)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName Level -> [(VName, Level)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName Level -> [(VName, Level)])
-> (PatType -> Map VName Level) -> PatType -> [(VName, Level)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatType -> Map VName Level
forall shape. TypeBase shape Aliasing -> Map VName Level
delve
  where
    delve :: TypeBase shape Aliasing -> Map VName Level
delve (Scalar (Record Map Name (TypeBase shape Aliasing)
fs)) =
      (Map VName Level -> Map VName Level -> Map VName Level)
-> Map VName Level -> [Map VName Level] -> Map VName Level
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Level -> Level -> Level)
-> Map VName Level -> Map VName Level -> Map VName Level
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Level -> Level -> Level
forall a. Num a => a -> a -> a
(+)) Map VName Level
forall a. Monoid a => a
mempty ([Map VName Level] -> Map VName Level)
-> [Map VName Level] -> Map VName Level
forall a b. (a -> b) -> a -> b
$ (TypeBase shape Aliasing -> Map VName Level)
-> [TypeBase shape Aliasing] -> [Map VName Level]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase shape Aliasing -> Map VName Level
delve ([TypeBase shape Aliasing] -> [Map VName Level])
-> [TypeBase shape Aliasing] -> [Map VName Level]
forall a b. (a -> b) -> a -> b
$ Map Name (TypeBase shape Aliasing) -> [TypeBase shape Aliasing]
forall k a. Map k a -> [a]
M.elems Map Name (TypeBase shape Aliasing)
fs
    delve TypeBase shape Aliasing
t =
      [(VName, Level)] -> Map VName Level
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, Level)] -> Map VName Level)
-> [(VName, Level)] -> Map VName Level
forall a b. (a -> b) -> a -> b
$ [VName] -> [Level] -> [(VName, Level)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Alias -> VName) -> [Alias] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Alias -> VName
aliasVar ([Alias] -> [VName]) -> [Alias] -> [VName]
forall a b. (a -> b) -> a -> b
$ Aliasing -> [Alias]
forall a. Set a -> [a]
S.toList (TypeBase shape Aliasing -> Aliasing
forall as shape. Monoid as => TypeBase shape as -> as
aliases TypeBase shape Aliasing
t)) ([Level] -> [(VName, Level)]) -> [Level] -> [(VName, Level)]
forall a b. (a -> b) -> a -> b
$ Level -> [Level]
forall a. a -> [a]
repeat (Level
1 :: Int)

uniqueParamNames :: [Pat] -> Names
uniqueParamNames :: [Pat] -> Names
uniqueParamNames =
  (Ident -> VName) -> Set Ident -> Names
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Ident -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName
    (Set Ident -> Names) -> ([Pat] -> Set Ident) -> [Pat] -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> Bool) -> Set Ident -> Set Ident
forall a. (a -> Bool) -> Set a -> Set a
S.filter (PatType -> Bool
forall shape as. TypeBase shape as -> Bool
unique (PatType -> Bool) -> (Ident -> PatType) -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info PatType -> PatType
forall a. Info a -> a
unInfo (Info PatType -> PatType)
-> (Ident -> Info PatType) -> Ident -> PatType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Info PatType
forall (f :: * -> *) vn. IdentBase f vn -> f PatType
identType)
    (Set Ident -> Set Ident)
-> ([Pat] -> Set Ident) -> [Pat] -> Set Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> Set Ident) -> [Pat] -> Set Ident
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> Set Ident
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set (IdentBase f vn)
patIdents

boundArrayAliases :: PatType -> S.Set VName
boundArrayAliases :: PatType -> Names
boundArrayAliases (Array Aliasing
als Uniqueness
_ ScalarTypeBase (DimDecl VName) ()
_ ShapeDecl (DimDecl VName)
_) = Aliasing -> Names
boundAliases Aliasing
als
boundArrayAliases (Scalar Prim {}) = Names
forall a. Monoid a => a
mempty
boundArrayAliases (Scalar (Record Map Name PatType
fs)) = (PatType -> Names) -> Map Name PatType -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PatType -> Names
boundArrayAliases Map Name PatType
fs
boundArrayAliases (Scalar (TypeVar Aliasing
als Uniqueness
_ TypeName
_ [TypeArg (DimDecl VName)]
_)) = Aliasing -> Names
boundAliases Aliasing
als
boundArrayAliases (Scalar Arrow {}) = Names
forall a. Monoid a => a
mempty
boundArrayAliases (Scalar (Sum Map Name [PatType]
fs)) =
  [Names] -> Names
forall a. Monoid a => [a] -> a
mconcat ([Names] -> Names) -> [Names] -> Names
forall a b. (a -> b) -> a -> b
$ ([PatType] -> [Names]) -> [[PatType]] -> [Names]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PatType -> Names) -> [PatType] -> [Names]
forall a b. (a -> b) -> [a] -> [b]
map PatType -> Names
boundArrayAliases) ([[PatType]] -> [Names]) -> [[PatType]] -> [Names]
forall a b. (a -> b) -> a -> b
$ Map Name [PatType] -> [[PatType]]
forall k a. Map k a -> [a]
M.elems Map Name [PatType]
fs

nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()
nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()
nothingMustBeUnique SrcLoc
loc = TypeBase () () -> TermTypeM ()
forall dim as. TypeBase dim as -> TermTypeM ()
check
  where
    check :: TypeBase dim as -> TermTypeM ()
check (Array as
_ Uniqueness
Unique ScalarTypeBase dim ()
_ ShapeDecl dim
_) = TermTypeM ()
forall a. TermTypeM a
bad
    check (Scalar (TypeVar as
_ Uniqueness
Unique TypeName
_ [TypeArg dim]
_)) = TermTypeM ()
forall a. TermTypeM a
bad
    check (Scalar (Record Map Name (TypeBase dim as)
fs)) = (TypeBase dim as -> TermTypeM ())
-> Map Name (TypeBase dim as) -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeBase dim as -> TermTypeM ()
check Map Name (TypeBase dim as)
fs
    check (Scalar (Sum Map Name [TypeBase dim as]
fs)) = ([TypeBase dim as] -> TermTypeM ())
-> Map Name [TypeBase dim as] -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((TypeBase dim as -> TermTypeM ())
-> [TypeBase dim as] -> TermTypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeBase dim as -> TermTypeM ()
check) Map Name [TypeBase dim as]
fs
    check TypeBase dim as
_ = () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    bad :: TermTypeM a
bad = SrcLoc -> Notes -> Doc -> TermTypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty Doc
"A top-level constant cannot have a unique type."

-- | Verify certain restrictions on function parameters, and bail out
-- on dubious constructions.
--
-- These restrictions apply to all functions (anonymous or otherwise).
-- Top-level functions have further restrictions that are checked
-- during let-generalisation.
verifyFunctionParams :: Maybe Name -> [Pat] -> TermTypeM ()
verifyFunctionParams :: Maybe Name -> [Pat] -> TermTypeM ()
verifyFunctionParams Maybe Name
fname [Pat]
params =
  Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (Maybe Name -> Checking
CheckingParams Maybe Name
fname) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
    Names -> [Pat] -> TermTypeM ()
forall (m :: * -> *). MonadTypeChecker m => Names -> [Pat] -> m ()
verifyParams ((Pat -> Names) -> [Pat] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> Names
forall (f :: * -> *) vn.
(Functor f, Ord vn) =>
PatBase f vn -> Set vn
patNames [Pat]
params) ([Pat] -> TermTypeM ()) -> TermTypeM [Pat] -> TermTypeM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Pat -> TermTypeM Pat) -> [Pat] -> TermTypeM [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> TermTypeM Pat
forall e. ASTMappable e => e -> TermTypeM e
updateTypes [Pat]
params
  where
    verifyParams :: Names -> [Pat] -> m ()
verifyParams Names
forbidden (Pat
p : [Pat]
ps)
      | VName
d : [VName]
_ <- Names -> [VName]
forall a. Set a -> [a]
S.toList (Names -> [VName]) -> Names -> [VName]
forall a b. (a -> b) -> a -> b
$ Pat -> Names
patternDimNames Pat
p Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Names
forbidden =
        Pat -> Notes -> Doc -> m ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError Pat
p Notes
forall a. Monoid a => a
mempty (Doc -> m ()) -> (Doc -> Doc) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"inaccessible-size" (Doc -> m ()) -> Doc -> m ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Parameter" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (Pat -> Doc
forall a. Pretty a => a -> Doc
ppr Pat
p)
            Doc -> Doc -> Doc
<+/> Doc
"refers to size" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
d)
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma
            Doc -> Doc -> Doc
<+/> String -> Doc
textwrap String
"which will not be accessible to the caller"
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma
            Doc -> Doc -> Doc
<+/> String -> Doc
textwrap String
"possibly because it is nested in a tuple or record."
            Doc -> Doc -> Doc
<+/> String -> Doc
textwrap String
"Consider ascribing an explicit type that does not reference "
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
d)
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
      | Bool
otherwise = Names -> [Pat] -> m ()
verifyParams Names
forbidden' [Pat]
ps
      where
        forbidden' :: Names
forbidden' =
          case Pat -> (PName, StructType)
patternParam Pat
p of
            (Named VName
v, StructType
_) -> Names
forbidden Names -> Names -> Names
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` VName -> Names
forall a. a -> Set a
S.singleton VName
v
            (PName, StructType)
_ -> Names
forbidden
    verifyParams Names
_ [] = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Move existentials down to the level where they are actually used
-- (i.e. have their "witnesses").  E.g. changes
--
-- @
-- ?[n].bool -> [n]bool
-- @
--
-- to
--
-- @
-- bool -> ?[n].[n]bool
-- @
injectExt :: [VName] -> StructType -> StructRetType
injectExt :: [VName] -> StructType -> StructRetType
injectExt [] StructType
ret = [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] StructType
ret
injectExt [VName]
ext StructType
ret = [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext_here (StructType -> StructRetType) -> StructType -> StructRetType
forall a b. (a -> b) -> a -> b
$ StructType -> StructType
deeper StructType
ret
  where
    (Names
immediate, Names
_) = StructType -> (Names, Names)
dimUses StructType
ret
    ([VName]
ext_here, [VName]
ext_there) = (VName -> Bool) -> [VName] -> ([VName], [VName])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
immediate) [VName]
ext
    deeper :: StructType -> StructType
deeper (Scalar (Prim PrimType
t)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim PrimType
t
    deeper (Scalar (Record Map Name StructType
fs)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name StructType -> ScalarTypeBase (DimDecl VName) ())
-> Map Name StructType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ (StructType -> StructType)
-> Map Name StructType -> Map Name StructType
forall a b k. (a -> b) -> Map k a -> Map k b
M.map StructType -> StructType
deeper Map Name StructType
fs
    deeper (Scalar (Sum Map Name [StructType]
cs)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum (Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ())
-> Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ ([StructType] -> [StructType])
-> Map Name [StructType] -> Map Name [StructType]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((StructType -> StructType) -> [StructType] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> StructType
deeper) Map Name [StructType]
cs
    deeper (Scalar (Arrow ()
als PName
p StructType
t1 (RetType [VName]
t2_ext StructType
t2))) =
      ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> StructType
-> StructRetType
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> RetTypeBase dim as
-> ScalarTypeBase dim as
Arrow ()
als PName
p StructType
t1 (StructRetType -> ScalarTypeBase (DimDecl VName) ())
-> StructRetType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
injectExt ([VName]
ext_there [VName] -> [VName] -> [VName]
forall a. Semigroup a => a -> a -> a
<> [VName]
t2_ext) StructType
t2
    deeper (Scalar (TypeVar ()
as Uniqueness
u TypeName
tn [TypeArg (DimDecl VName)]
targs)) =
      ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ ()
-> Uniqueness
-> TypeName
-> [TypeArg (DimDecl VName)]
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> Uniqueness -> TypeName -> [TypeArg dim] -> ScalarTypeBase dim as
TypeVar ()
as Uniqueness
u TypeName
tn ([TypeArg (DimDecl VName)] -> ScalarTypeBase (DimDecl VName) ())
-> [TypeArg (DimDecl VName)] -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ (TypeArg (DimDecl VName) -> TypeArg (DimDecl VName))
-> [TypeArg (DimDecl VName)] -> [TypeArg (DimDecl VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeArg (DimDecl VName) -> TypeArg (DimDecl VName)
deeperArg [TypeArg (DimDecl VName)]
targs
    deeper t :: StructType
t@Array {} = StructType
t

    deeperArg :: TypeArg (DimDecl VName) -> TypeArg (DimDecl VName)
deeperArg (TypeArgType StructType
t SrcLoc
loc) = StructType -> SrcLoc -> TypeArg (DimDecl VName)
forall dim. TypeBase dim () -> SrcLoc -> TypeArg dim
TypeArgType (StructType -> StructType
deeper StructType
t) SrcLoc
loc
    deeperArg (TypeArgDim DimDecl VName
d SrcLoc
loc) = DimDecl VName -> SrcLoc -> TypeArg (DimDecl VName)
forall dim. dim -> SrcLoc -> TypeArg dim
TypeArgDim DimDecl VName
d SrcLoc
loc

-- | Find all type variables in the given type that are covered by the
-- constraints, and produce type parameters that close over them.
--
-- The passed-in list of type parameters is always prepended to the
-- produced list of type parameters.
closeOverTypes ::
  Name ->
  SrcLoc ->
  [TypeParam] ->
  [StructType] ->
  StructType ->
  Constraints ->
  TermTypeM ([TypeParam], StructRetType)
closeOverTypes :: Name
-> SrcLoc
-> [TypeParam]
-> [StructType]
-> StructType
-> Constraints
-> TermTypeM ([TypeParam], StructRetType)
closeOverTypes Name
defname SrcLoc
defloc [TypeParam]
tparams [StructType]
paramts StructType
ret Constraints
substs = do
  ([TypeParam]
more_tparams, [VName]
retext) <-
    [Either TypeParam VName] -> ([TypeParam], [VName])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either TypeParam VName] -> ([TypeParam], [VName]))
-> ([Maybe (Either TypeParam VName)] -> [Either TypeParam VName])
-> [Maybe (Either TypeParam VName)]
-> ([TypeParam], [VName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Either TypeParam VName)] -> [Either TypeParam VName]
forall a. [Maybe a] -> [a]
catMaybes
      ([Maybe (Either TypeParam VName)] -> ([TypeParam], [VName]))
-> TermTypeM [Maybe (Either TypeParam VName)]
-> TermTypeM ([TypeParam], [VName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((VName, Constraint) -> TermTypeM (Maybe (Either TypeParam VName)))
-> [(VName, Constraint)]
-> TermTypeM [Maybe (Either TypeParam VName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (VName, Constraint) -> TermTypeM (Maybe (Either TypeParam VName))
forall (f :: * -> *).
(MonadUnify f, MonadTypeChecker f) =>
(VName, Constraint) -> f (Maybe (Either TypeParam VName))
closeOver (Map VName Constraint -> [(VName, Constraint)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName Constraint -> [(VName, Constraint)])
-> Map VName Constraint -> [(VName, Constraint)]
forall a b. (a -> b) -> a -> b
$ ((Level, Constraint) -> Constraint)
-> Constraints -> Map VName Constraint
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Level, Constraint) -> Constraint
forall a b. (a, b) -> b
snd Constraints
to_close_over)
  let mkExt :: DimDecl VName -> Maybe VName
mkExt (NamedDim QualName VName
v) =
        case VName -> Constraints -> Maybe (Level, Constraint)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v) Constraints
substs of
          Just (Level
_, UnknowableSize {}) -> VName -> Maybe VName
forall a. a -> Maybe a
Just (VName -> Maybe VName) -> VName -> Maybe VName
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v
          Maybe (Level, Constraint)
_ -> Maybe VName
forall a. Maybe a
Nothing
      mkExt ConstDim {} = Maybe VName
forall a. Maybe a
Nothing
      mkExt AnyDim {} = String -> Maybe VName
forall a. HasCallStack => String -> a
error String
"closeOverTypes: AnyDim"
  ([TypeParam], StructRetType)
-> TermTypeM ([TypeParam], StructRetType)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [TypeParam]
tparams [TypeParam] -> [TypeParam] -> [TypeParam]
forall a. [a] -> [a] -> [a]
++ [TypeParam]
more_tparams,
      [VName] -> StructType -> StructRetType
injectExt ([VName]
retext [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ (DimDecl VName -> Maybe VName) -> [DimDecl VName] -> [VName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DimDecl VName -> Maybe VName
mkExt (StructType -> [DimDecl VName]
forall as. TypeBase (DimDecl VName) as -> [DimDecl VName]
nestedDims StructType
ret)) StructType
ret
    )
  where
    t :: StructType
t = [StructType] -> StructRetType -> StructType
forall as dim.
Monoid as =>
[TypeBase dim as] -> RetTypeBase dim as -> TypeBase dim as
foldFunType [StructType]
paramts (StructRetType -> StructType) -> StructRetType -> StructType
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] StructType
ret
    to_close_over :: Constraints
to_close_over = (VName -> (Level, Constraint) -> Bool)
-> Constraints -> Constraints
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\VName
k (Level, Constraint)
_ -> VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
visible) Constraints
substs
    visible :: Names
visible = StructType -> Names
forall as dim. Monoid as => TypeBase dim as -> Names
typeVars StructType
t Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNames StructType
t

    (Names
produced_sizes, Names
param_sizes) = StructType -> (Names, Names)
dimUses StructType
t

    -- Avoid duplicate type parameters.
    closeOver :: (VName, Constraint) -> f (Maybe (Either TypeParam VName))
closeOver (VName
k, Constraint
_)
      | VName
k VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TypeParam -> VName) -> [TypeParam] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParam]
tparams =
        Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either TypeParam VName)
forall a. Maybe a
Nothing
    closeOver (VName
k, NoConstraint Liftedness
l Usage
usage) =
      Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either TypeParam VName)
 -> f (Maybe (Either TypeParam VName)))
-> Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall a b. (a -> b) -> a -> b
$ Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a. a -> Maybe a
Just (Either TypeParam VName -> Maybe (Either TypeParam VName))
-> Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a b. (a -> b) -> a -> b
$ TypeParam -> Either TypeParam VName
forall a b. a -> Either a b
Left (TypeParam -> Either TypeParam VName)
-> TypeParam -> Either TypeParam VName
forall a b. (a -> b) -> a -> b
$ Liftedness -> VName -> SrcLoc -> TypeParam
forall vn. Liftedness -> vn -> SrcLoc -> TypeParamBase vn
TypeParamType Liftedness
l VName
k (SrcLoc -> TypeParam) -> SrcLoc -> TypeParam
forall a b. (a -> b) -> a -> b
$ Usage -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Usage
usage
    closeOver (VName
k, ParamType Liftedness
l SrcLoc
loc) =
      Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either TypeParam VName)
 -> f (Maybe (Either TypeParam VName)))
-> Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall a b. (a -> b) -> a -> b
$ Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a. a -> Maybe a
Just (Either TypeParam VName -> Maybe (Either TypeParam VName))
-> Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a b. (a -> b) -> a -> b
$ TypeParam -> Either TypeParam VName
forall a b. a -> Either a b
Left (TypeParam -> Either TypeParam VName)
-> TypeParam -> Either TypeParam VName
forall a b. (a -> b) -> a -> b
$ Liftedness -> VName -> SrcLoc -> TypeParam
forall vn. Liftedness -> vn -> SrcLoc -> TypeParamBase vn
TypeParamType Liftedness
l VName
k SrcLoc
loc
    closeOver (VName
k, Size Maybe (DimDecl VName)
Nothing Usage
usage) =
      Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either TypeParam VName)
 -> f (Maybe (Either TypeParam VName)))
-> Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall a b. (a -> b) -> a -> b
$ Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a. a -> Maybe a
Just (Either TypeParam VName -> Maybe (Either TypeParam VName))
-> Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a b. (a -> b) -> a -> b
$ TypeParam -> Either TypeParam VName
forall a b. a -> Either a b
Left (TypeParam -> Either TypeParam VName)
-> TypeParam -> Either TypeParam VName
forall a b. (a -> b) -> a -> b
$ VName -> SrcLoc -> TypeParam
forall vn. vn -> SrcLoc -> TypeParamBase vn
TypeParamDim VName
k (SrcLoc -> TypeParam) -> SrcLoc -> TypeParam
forall a b. (a -> b) -> a -> b
$ Usage -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Usage
usage
    closeOver (VName
k, UnknowableSize SrcLoc
_ RigidSource
_)
      | VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
param_sizes,
        VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Names
produced_sizes = do
        Notes
notes <- SrcLoc -> DimDecl VName -> f Notes
forall a (m :: * -> *).
(Located a, MonadUnify m) =>
a -> DimDecl VName -> m Notes
dimNotes SrcLoc
defloc (DimDecl VName -> f Notes) -> DimDecl VName -> f Notes
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
k
        SrcLoc -> Notes -> Doc -> f (Maybe (Either TypeParam VName))
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
defloc Notes
notes (Doc -> f (Maybe (Either TypeParam VName)))
-> (Doc -> Doc) -> Doc -> f (Maybe (Either TypeParam VName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
withIndexLink Doc
"unknowable-param-def" (Doc -> f (Maybe (Either TypeParam VName)))
-> Doc -> f (Maybe (Either TypeParam VName))
forall a b. (a -> b) -> a -> b
$
          Doc
"Unknowable size" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
k)
            Doc -> Doc -> Doc
<+> Doc
"in parameter of"
            Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (Name -> Doc
forall v. IsName v => v -> Doc
pprName Name
defname)
            Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", which is inferred as:"
            Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
t)
      | VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
produced_sizes =
        Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either TypeParam VName)
 -> f (Maybe (Either TypeParam VName)))
-> Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall a b. (a -> b) -> a -> b
$ Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a. a -> Maybe a
Just (Either TypeParam VName -> Maybe (Either TypeParam VName))
-> Either TypeParam VName -> Maybe (Either TypeParam VName)
forall a b. (a -> b) -> a -> b
$ VName -> Either TypeParam VName
forall a b. b -> Either a b
Right VName
k
    closeOver (VName
_, Constraint
_) =
      Maybe (Either TypeParam VName)
-> f (Maybe (Either TypeParam VName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either TypeParam VName)
forall a. Maybe a
Nothing

letGeneralise ::
  Name ->
  SrcLoc ->
  [TypeParam] ->
  [Pat] ->
  StructType ->
  TermTypeM ([TypeParam], [Pat], StructRetType)
letGeneralise :: Name
-> SrcLoc
-> [TypeParam]
-> [Pat]
-> StructType
-> TermTypeM ([TypeParam], [Pat], StructRetType)
letGeneralise Name
defname SrcLoc
defloc [TypeParam]
tparams [Pat]
params StructType
rettype =
  Checking
-> TermTypeM ([TypeParam], [Pat], StructRetType)
-> TermTypeM ([TypeParam], [Pat], StructRetType)
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (Name -> Checking
CheckingLetGeneralise Name
defname) (TermTypeM ([TypeParam], [Pat], StructRetType)
 -> TermTypeM ([TypeParam], [Pat], StructRetType))
-> TermTypeM ([TypeParam], [Pat], StructRetType)
-> TermTypeM ([TypeParam], [Pat], StructRetType)
forall a b. (a -> b) -> a -> b
$ do
    Constraints
now_substs <- TermTypeM Constraints
forall (m :: * -> *). MonadUnify m => m Constraints
getConstraints

    -- Candidates for let-generalisation are those type variables that
    --
    -- (1) were not known before we checked this function, and
    --
    -- (2) are not used in the (new) definition of any type variables
    -- known before we checked this function.
    --
    -- (3) are not referenced from an overloaded type (for example,
    -- are the element types of an incompletely resolved record type).
    -- This is a bit more restrictive than I'd like, and SML for
    -- example does not have this restriction.
    --
    -- Criteria (1) and (2) is implemented by looking at the binding
    -- level of the type variables.
    let keep_type_vars :: Names
keep_type_vars = Constraints -> Names
overloadedTypeVars Constraints
now_substs

    Level
cur_lvl <- TermTypeM Level
forall (m :: * -> *). MonadUnify m => m Level
curLevel
    let candidate :: VName -> (Level, b) -> Bool
candidate VName
k (Level
lvl, b
_) = (VName
k VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Names
keep_type_vars) Bool -> Bool -> Bool
&& Level
lvl Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
cur_lvl
        new_substs :: Constraints
new_substs = (VName -> (Level, Constraint) -> Bool)
-> Constraints -> Constraints
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey VName -> (Level, Constraint) -> Bool
forall b. VName -> (Level, b) -> Bool
candidate Constraints
now_substs

    ([TypeParam]
tparams', RetType [VName]
ret_dims StructType
rettype') <-
      Name
-> SrcLoc
-> [TypeParam]
-> [StructType]
-> StructType
-> Constraints
-> TermTypeM ([TypeParam], StructRetType)
closeOverTypes
        Name
defname
        SrcLoc
defloc
        [TypeParam]
tparams
        ((Pat -> StructType) -> [Pat] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> StructType
patternStructType [Pat]
params)
        StructType
rettype
        Constraints
new_substs

    StructType
rettype'' <- StructType -> TermTypeM StructType
forall e. ASTMappable e => e -> TermTypeM e
updateTypes StructType
rettype'

    let used_sizes :: Names
used_sizes =
          (StructType -> Names) -> [StructType] -> Names
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap StructType -> Names
forall als. TypeBase (DimDecl VName) als -> Names
typeDimNames ([StructType] -> Names) -> [StructType] -> Names
forall a b. (a -> b) -> a -> b
$ StructType
rettype'' StructType -> [StructType] -> [StructType]
forall a. a -> [a] -> [a]
: (Pat -> StructType) -> [Pat] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> StructType
patternStructType [Pat]
params
    case (TypeParam -> Bool) -> [TypeParam] -> [TypeParam]
forall a. (a -> Bool) -> [a] -> [a]
filter ((VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Names
used_sizes) (VName -> Bool) -> (TypeParam -> VName) -> TypeParam -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) ([TypeParam] -> [TypeParam]) -> [TypeParam] -> [TypeParam]
forall a b. (a -> b) -> a -> b
$
      (TypeParam -> Bool) -> [TypeParam] -> [TypeParam]
forall a. (a -> Bool) -> [a] -> [a]
filter TypeParam -> Bool
forall vn. TypeParamBase vn -> Bool
isSizeParam [TypeParam]
tparams' of
      [] -> () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TypeParam
tp : [TypeParam]
_ -> SizeBinder VName -> TermTypeM ()
forall (m :: * -> *) a.
MonadTypeChecker m =>
SizeBinder VName -> m a
unusedSize (SizeBinder VName -> TermTypeM ())
-> SizeBinder VName -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ VName -> SrcLoc -> SizeBinder VName
forall vn. vn -> SrcLoc -> SizeBinder vn
SizeBinder (TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName TypeParam
tp) (TypeParam -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf TypeParam
tp)

    -- We keep those type variables that were not closed over by
    -- let-generalisation.
    (Constraints -> Constraints) -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
(Constraints -> Constraints) -> m ()
modifyConstraints ((Constraints -> Constraints) -> TermTypeM ())
-> (Constraints -> Constraints) -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ (VName -> (Level, Constraint) -> Bool)
-> Constraints -> Constraints
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey ((VName -> (Level, Constraint) -> Bool)
 -> Constraints -> Constraints)
-> (VName -> (Level, Constraint) -> Bool)
-> Constraints
-> Constraints
forall a b. (a -> b) -> a -> b
$ \VName
k (Level, Constraint)
_ -> VName
k VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (TypeParam -> VName) -> [TypeParam] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParam]
tparams'

    ([TypeParam], [Pat], StructRetType)
-> TermTypeM ([TypeParam], [Pat], StructRetType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeParam]
tparams', [Pat]
params, [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ret_dims StructType
rettype'')

checkFunBody ::
  [Pat] ->
  UncheckedExp ->
  Maybe StructType ->
  SrcLoc ->
  TermTypeM Exp
checkFunBody :: [Pat]
-> UncheckedExp -> Maybe StructType -> SrcLoc -> TermTypeM Exp
checkFunBody [Pat]
params UncheckedExp
body Maybe StructType
maybe_rettype SrcLoc
loc = do
  Exp
body' <- TermTypeM Exp -> TermTypeM Exp
forall a. TermTypeM a -> TermTypeM a
noSizeEscape (TermTypeM Exp -> TermTypeM Exp) -> TermTypeM Exp -> TermTypeM Exp
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TermTypeM Exp
checkExp UncheckedExp
body

  -- Unify body return type with return annotation, if one exists.
  case Maybe StructType
maybe_rettype of
    Just StructType
rettype -> do
      PatType
body_t <- Exp -> TermTypeM PatType
expTypeFully Exp
body'
      -- We need to turn any sizes provided by "hidden" parameter
      -- names into existential sizes instead.
      let hidden :: Names
hidden = [Pat] -> Names
hiddenParamNames [Pat]
params
      (PatType
body_t', [VName]
_) <-
        SrcLoc
-> Map VName Ident -> PatType -> TermTypeM (PatType, [VName])
unscopeType
          SrcLoc
loc
          ( (VName -> Ident -> Bool) -> Map VName Ident -> Map VName Ident
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> Ident -> Bool
forall a b. a -> b -> a
const (Bool -> Ident -> Bool)
-> (VName -> Bool) -> VName -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Names -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Names
hidden)) (Map VName Ident -> Map VName Ident)
-> Map VName Ident -> Map VName Ident
forall a b. (a -> b) -> a -> b
$
              (Pat -> Map VName Ident) -> [Pat] -> Map VName Ident
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pat -> Map VName Ident
forall (f :: * -> *).
Functor f =>
PatBase f VName -> Map VName (IdentBase f VName)
patternMap [Pat]
params
          )
          PatType
body_t

      let usage :: Usage
usage = SrcLoc -> String -> Usage
mkUsage (UncheckedExp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf UncheckedExp
body) String
"return type annotation"
      Checking -> TermTypeM () -> TermTypeM ()
forall a. Checking -> TermTypeM a -> TermTypeM a
onFailure (StructType -> StructType -> Checking
CheckingReturn StructType
rettype (PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
body_t')) (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        Usage -> StructType -> StructType -> TermTypeM ()
forall (m :: * -> *).
MonadUnify m =>
Usage -> StructType -> StructType -> m ()
expect Usage
usage StructType
rettype (StructType -> TermTypeM ()) -> StructType -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$ PatType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatType
body_t'

      -- We also have to make sure that uniqueness matches.  This is done
      -- explicitly, because uniqueness is ignored by unification.
      StructType
rettype' <- StructType -> TermTypeM StructType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully StructType
rettype
      PatType
body_t'' <- PatType -> TermTypeM PatType
forall a (m :: * -> *). (Substitutable a, MonadUnify m) => a -> m a
normTypeFully PatType
body_t' -- Substs may have changed.
      Bool -> TermTypeM () -> TermTypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PatType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural PatType
body_t'' TypeBase () () -> TypeBase () () -> Bool
`subtypeOf` StructType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural StructType
rettype') (TermTypeM () -> TermTypeM ()) -> TermTypeM () -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
        SrcLoc -> Notes -> Doc -> TermTypeM ()
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError (UncheckedExp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf UncheckedExp
body) Notes
forall a. Monoid a => a
mempty (Doc -> TermTypeM ()) -> Doc -> TermTypeM ()
forall a b. (a -> b) -> a -> b
$
          Doc
"Body type" Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (PatType -> Doc
forall a. Pretty a => a -> Doc
ppr PatType
body_t'')
            Doc -> Doc -> Doc
</> Doc
"is not a subtype of annotated type"
            Doc -> Doc -> Doc
</> Level -> Doc -> Doc
indent Level
2 (StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
rettype')
    Maybe StructType
Nothing -> () -> TermTypeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Exp -> TermTypeM Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body'

arrayOfM ::
  (Pretty (ShapeDecl dim), Monoid as) =>
  SrcLoc ->
  TypeBase dim as ->
  ShapeDecl dim ->
  Uniqueness ->
  TermTypeM (TypeBase dim as)
arrayOfM :: SrcLoc
-> TypeBase dim as
-> ShapeDecl dim
-> Uniqueness
-> TermTypeM (TypeBase dim as)
arrayOfM SrcLoc
loc TypeBase dim as
t ShapeDecl dim
shape Uniqueness
u = do
  Usage -> String -> TypeBase dim as -> TermTypeM ()
forall (m :: * -> *) dim as.
(MonadUnify m, Pretty (ShapeDecl dim), Monoid as) =>
Usage -> String -> TypeBase dim as -> m ()
arrayElemType (SrcLoc -> String -> Usage
mkUsage SrcLoc
loc String
"use as array element") String
"type used in array" TypeBase dim as
t
  TypeBase dim as -> TermTypeM (TypeBase dim as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeBase dim as -> TermTypeM (TypeBase dim as))
-> TypeBase dim as -> TermTypeM (TypeBase dim as)
forall a b. (a -> b) -> a -> b
$ TypeBase dim as -> ShapeDecl dim -> Uniqueness -> TypeBase dim as
forall as dim.
Monoid as =>
TypeBase dim as -> ShapeDecl dim -> Uniqueness -> TypeBase dim as
arrayOf TypeBase dim as
t ShapeDecl dim
shape Uniqueness
u