module Language.Futhark.TypeChecker.Types
( checkTypeExp,
renameRetType,
checkForDuplicateNames,
checkTypeParams,
typeParamToArg,
Subst (..),
substFromAbbr,
TypeSubs,
Substitutable (..),
substTypesAny,
mustBeExplicitInType,
mustBeExplicitInBinding,
determineSizeWitnesses,
)
where
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.List (find, foldl', sort, unzip4, (\\))
import Data.Map.Strict qualified as M
import Data.Set qualified as S
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty
import Language.Futhark
import Language.Futhark.Traversals
import Language.Futhark.TypeChecker.Monad
mustBeExplicitAux :: StructType -> M.Map VName Bool
mustBeExplicitAux :: StructType -> Map VName Bool
mustBeExplicitAux StructType
t =
forall s a. State s a -> s -> s
execState (forall (f :: * -> *) fdim tdim als.
Applicative f =>
(Set VName -> DimPos -> fdim -> f tdim)
-> TypeBase fdim als -> f (TypeBase tdim als)
traverseDims forall {m :: * -> *}.
MonadState (Map VName Bool) m =>
Set VName -> DimPos -> ExpBase Info VName -> m ()
onDim StructType
t) forall a. Monoid a => a
mempty
where
onDim :: Set VName -> DimPos -> ExpBase Info VName -> m ()
onDim Set VName
bound DimPos
_ (Var QualName VName
d Info StructType
_ SrcLoc
_)
| forall vn. QualName vn -> vn
qualLeaf QualName VName
d forall a. Ord a => a -> Set a -> Bool
`S.member` Set VName
bound =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Map VName Bool
s -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Bool -> Bool -> Bool
(&&) (forall vn. QualName vn -> vn
qualLeaf QualName VName
d) Bool
False Map VName Bool
s
onDim Set VName
_ DimPos
PosImmediate (Var QualName VName
d Info StructType
_ SrcLoc
_) =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \Map VName Bool
s -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Bool -> Bool -> Bool
(&&) (forall vn. QualName vn -> vn
qualLeaf QualName VName
d) Bool
False Map VName Bool
s
onDim Set VName
_ DimPos
_ ExpBase Info VName
e =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr (\VName
v -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Bool -> Bool -> Bool
(&&) VName
v Bool
True)) forall a b. (a -> b) -> a -> b
$ FV -> Set VName
fvVars forall a b. (a -> b) -> a -> b
$ ExpBase Info VName -> FV
freeInExp ExpBase Info VName
e
determineSizeWitnesses :: StructType -> (S.Set VName, S.Set VName)
determineSizeWitnesses :: StructType -> (Set VName, Set VName)
determineSizeWitnesses StructType
t =
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys) (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys) forall a b. (a -> b) -> a -> b
$
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
M.partition Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
StructType -> Map VName Bool
mustBeExplicitAux StructType
t
mustBeExplicitInBinding :: StructType -> S.Set VName
mustBeExplicitInBinding :: StructType -> Set VName
mustBeExplicitInBinding StructType
bind_t =
let ([TypeBase (ExpBase Info VName) Diet]
ts, StructType
ret) = forall dim as.
TypeBase dim as -> ([TypeBase dim Diet], TypeBase dim NoUniqueness)
unfoldFunType StructType
bind_t
alsoRet :: Map VName Bool -> Map VName Bool
alsoRet = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Bool -> Bool -> Bool
(&&) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Set a -> [a]
S.toList (FV -> Set VName
fvVars (forall u. TypeBase (ExpBase Info VName) u -> FV
freeInType StructType
ret))) (forall a. a -> [a]
repeat Bool
True)
in forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Map VName Bool -> Map VName Bool
alsoRet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map VName Bool -> StructType -> Map VName Bool
onType forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct [TypeBase (ExpBase Info VName) Diet]
ts
where
onType :: Map VName Bool -> StructType -> Map VName Bool
onType Map VName Bool
uses StructType
t = Map VName Bool
uses forall a. Semigroup a => a -> a -> a
<> StructType -> Map VName Bool
mustBeExplicitAux StructType
t
mustBeExplicitInType :: StructType -> S.Set VName
mustBeExplicitInType :: StructType -> Set VName
mustBeExplicitInType = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructType -> (Set VName, Set VName)
determineSizeWitnesses
renameRetType :: MonadTypeChecker m => ResRetType -> m ResRetType
renameRetType :: forall (m :: * -> *).
MonadTypeChecker m =>
ResRetType -> m ResRetType
renameRetType (RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st)
| [VName]
dims forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = do
[VName]
dims' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadTypeChecker m => VName -> m VName
newName [VName]
dims
let mkSubst :: VName -> Subst t
mkSubst = forall t. ExpBase Info VName -> Subst t
ExpSubst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip QualName VName -> SrcLoc -> ExpBase Info VName
sizeFromName forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> QualName v
qualName
m :: Map VName (Subst t)
m = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
dims forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t}. VName -> Subst t
mkSubst [VName]
dims'
st' :: TypeBase (ExpBase Info VName) Uniqueness
st' = forall a. Substitutable a => TypeSubs -> a -> a
applySubst (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall {t}. Map VName (Subst t)
m) TypeBase (ExpBase Info VName) Uniqueness
st
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims' TypeBase (ExpBase Info VName) Uniqueness
st'
| Bool
otherwise =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st
evalTypeExp ::
MonadTypeChecker m =>
TypeExp NoInfo Name ->
m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp :: forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp (TEVar QualName Name
name SrcLoc
loc) = do
(QualName VName
name', [TypeParam]
ps, StructRetType
t, Liftedness
l) <- forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc
-> QualName Name
-> m (QualName VName, [TypeParam], StructRetType, Liftedness)
lookupType SrcLoc
loc QualName Name
name
ResRetType
t' <- forall (m :: * -> *).
MonadTypeChecker m =>
ResRetType -> m ResRetType
renameRetType forall a b. (a -> b) -> a -> b
$ forall u.
Uniqueness -> RetTypeBase (ExpBase Info VName) u -> ResRetType
toResRet Uniqueness
Nonunique StructRetType
t
case [TypeParam]
ps of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. QualName vn -> SrcLoc -> TypeExp f vn
TEVar QualName VName
name' SrcLoc
loc, [], ResRetType
t', Liftedness
l)
[TypeParam]
_ ->
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Type constructor"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall ann. [Doc ann] -> Doc ann
hsep (forall a ann. Pretty a => a -> Doc ann
pretty QualName Name
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [TypeParam]
ps))
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"used without any arguments."
evalTypeExp (TEParens TypeExp NoInfo Name
te SrcLoc
loc) = do
(TypeExp Info VName
te', [VName]
svars, ResRetType
ts, Liftedness
ls) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
te
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. TypeExp f vn -> SrcLoc -> TypeExp f vn
TEParens TypeExp Info VName
te' SrcLoc
loc, [VName]
svars, ResRetType
ts, Liftedness
ls)
evalTypeExp (TETuple [TypeExp NoInfo Name]
ts SrcLoc
loc) = do
([TypeExp Info VName]
ts', [[VName]]
svars, [ResRetType]
ts_s, [Liftedness]
ls) <- forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp [TypeExp NoInfo Name]
ts
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn. [TypeExp f vn] -> SrcLoc -> TypeExp f vn
TETuple [TypeExp Info VName]
ts' SrcLoc
loc,
forall a. Monoid a => [a] -> a
mconcat [[VName]]
svars,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall dim as. RetTypeBase dim as -> [VName]
retDims [ResRetType]
ts_s) forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim as. [TypeBase dim as] -> ScalarTypeBase dim as
tupleRecord forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall dim as. RetTypeBase dim as -> TypeBase dim as
retType [ResRetType]
ts_s,
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => a -> a -> a
max Liftedness
Unlifted [Liftedness]
ls
)
evalTypeExp t :: TypeExp NoInfo Name
t@(TERecord [(Name, TypeExp NoInfo Name)]
fs SrcLoc
loc) = do
let field_names :: [Name]
field_names = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, TypeExp NoInfo Name)]
fs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => [a] -> [a]
sort [Name]
field_names forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
sort (forall a. Ord a => [a] -> [a]
nubOrd [Name]
field_names)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Duplicate record fields in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeExp NoInfo Name
t forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
Map Name (TypeExp Info VName, [VName], ResRetType, Liftedness)
checked <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TypeExp NoInfo Name)]
fs
let fs' :: Map Name (TypeExp Info VName)
fs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TypeExp Info VName
x, [VName]
_, ResRetType
_, Liftedness
_) -> TypeExp Info VName
x) Map Name (TypeExp Info VName, [VName], ResRetType, Liftedness)
checked
fs_svars :: [VName]
fs_svars = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TypeExp Info VName
_, [VName]
y, ResRetType
_, Liftedness
_) -> [VName]
y) Map Name (TypeExp Info VName, [VName], ResRetType, Liftedness)
checked
ts_s :: Map Name ResRetType
ts_s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TypeExp Info VName
_, [VName]
_, ResRetType
z, Liftedness
_) -> ResRetType
z) Map Name (TypeExp Info VName, [VName], ResRetType, Liftedness)
checked
ls :: Map Name Liftedness
ls = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TypeExp Info VName
_, [VName]
_, ResRetType
_, Liftedness
v) -> Liftedness
v) Map Name (TypeExp Info VName, [VName], ResRetType, Liftedness)
checked
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
[(Name, TypeExp f vn)] -> SrcLoc -> TypeExp f vn
TERecord (forall k a. Map k a -> [(k, a)]
M.toList Map Name (TypeExp Info VName)
fs') SrcLoc
loc,
[VName]
fs_svars,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall dim as. RetTypeBase dim as -> [VName]
retDims Map Name ResRetType
ts_s) forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall dim as. RetTypeBase dim as -> TypeBase dim as
retType Map Name ResRetType
ts_s,
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => a -> a -> a
max Liftedness
Unlifted Map Name Liftedness
ls
)
evalTypeExp (TEArray SizeExp NoInfo Name
d TypeExp NoInfo Name
t SrcLoc
loc) = do
([VName]
d_svars, SizeExp Info VName
d', ExpBase Info VName
d'') <- forall {m :: * -> *}.
MonadTypeChecker m =>
SizeExp NoInfo Name
-> m ([VName], SizeExp Info VName, ExpBase Info VName)
checkSizeExp SizeExp NoInfo Name
d
(TypeExp Info VName
t', [VName]
svars, RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
l) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t
case (Liftedness
l, forall u dim. u -> Shape dim -> TypeBase dim u -> TypeBase dim u
arrayOfWithAliases Uniqueness
Nonunique (forall dim. [dim] -> Shape dim
Shape [ExpBase Info VName
d'']) TypeBase (ExpBase Info VName) Uniqueness
st) of
(Liftedness
Unlifted, TypeBase (ExpBase Info VName) Uniqueness
st') ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
SizeExp f vn -> TypeExp f vn -> SrcLoc -> TypeExp f vn
TEArray SizeExp Info VName
d' TypeExp Info VName
t' SrcLoc
loc,
[VName]
svars,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
d_svars forall a. [a] -> [a] -> [a]
++ [VName]
dims) TypeBase (ExpBase Info VName) Uniqueness
st',
Liftedness
Unlifted
)
(Liftedness
SizeLifted, TypeBase (ExpBase Info VName) Uniqueness
_) ->
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Cannot create array with elements of size-lifted type"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty TypeExp NoInfo Name
t)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(might cause irregular array)."
(Liftedness
Lifted, TypeBase (ExpBase Info VName) Uniqueness
_) ->
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Cannot create array with elements of lifted type"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty TypeExp NoInfo Name
t)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(might contain function)."
where
checkSizeExp :: SizeExp NoInfo Name
-> m ([VName], SizeExp Info VName, ExpBase Info VName)
checkSizeExp (SizeExpAny SrcLoc
dloc) = do
VName
dv <- forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newTypeName Name
"d"
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VName
dv], forall (f :: * -> *) vn. SrcLoc -> SizeExp f vn
SizeExpAny SrcLoc
dloc, QualName VName -> SrcLoc -> ExpBase Info VName
sizeFromName (forall v. v -> QualName v
qualName VName
dv) SrcLoc
dloc)
checkSizeExp (SizeExp ExpBase NoInfo Name
e SrcLoc
dloc) = do
ExpBase Info VName
e' <- forall (m :: * -> *).
MonadTypeChecker m =>
ExpBase NoInfo Name -> m (ExpBase Info VName)
checkExpForSize ExpBase NoInfo Name
e
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> SizeExp f vn
SizeExp ExpBase Info VName
e' SrcLoc
dloc, ExpBase Info VName
e')
evalTypeExp (TEUnique TypeExp NoInfo Name
t SrcLoc
loc) = do
(TypeExp Info VName
t', [VName]
svars, RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
l) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {dim} {u}. TypeBase dim u -> Bool
mayContainArray TypeBase (ExpBase Info VName) Uniqueness
st) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc () -> m ()
warn SrcLoc
loc forall a b. (a -> b) -> a -> b
$
Doc ()
"Declaring" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty TypeBase (ExpBase Info VName) Uniqueness
st) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"as unique has no effect."
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. TypeExp f vn -> SrcLoc -> TypeExp f vn
TEUnique TypeExp Info VName
t' SrcLoc
loc, [VName]
svars, forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness
st forall dim u1 u2. TypeBase dim u1 -> u2 -> TypeBase dim u2
`setUniqueness` Uniqueness
Unique, Liftedness
l)
where
mayContainArray :: TypeBase dim u -> Bool
mayContainArray (Scalar Prim {}) = Bool
False
mayContainArray Array {} = Bool
True
mayContainArray (Scalar (Record Map Name (TypeBase dim u)
fs)) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeBase dim u -> Bool
mayContainArray Map Name (TypeBase dim u)
fs
mayContainArray (Scalar TypeVar {}) = Bool
True
mayContainArray (Scalar Arrow {}) = Bool
False
mayContainArray (Scalar (Sum Map Name [TypeBase dim u]
cs)) = (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any) TypeBase dim u -> Bool
mayContainArray Map Name [TypeBase dim u]
cs
evalTypeExp (TEArrow (Just Name
v) TypeExp NoInfo Name
t1 TypeExp NoInfo Name
t2 SrcLoc
loc) = do
(TypeExp Info VName
t1', [VName]
svars1, RetType [VName]
dims1 TypeBase (ExpBase Info VName) Uniqueness
st1, Liftedness
_) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t1
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
v)] forall a b. (a -> b) -> a -> b
$ do
VName
v' <- forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
v SrcLoc
loc
forall (m :: * -> *) a.
MonadTypeChecker m =>
VName -> BoundV -> m a -> m a
bindVal VName
v' ([TypeParam] -> StructType -> BoundV
BoundV [] forall a b. (a -> b) -> a -> b
$ forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st1) forall a b. (a -> b) -> a -> b
$ do
(TypeExp Info VName
t2', [VName]
svars2, RetType [VName]
dims2 TypeBase (ExpBase Info VName) Uniqueness
st2, Liftedness
_) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t2
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
Maybe vn -> TypeExp f vn -> TypeExp f vn -> SrcLoc -> TypeExp f vn
TEArrow (forall a. a -> Maybe a
Just VName
v') TypeExp Info VName
t1' TypeExp Info VName
t2' SrcLoc
loc,
[VName]
svars1 forall a. [a] -> [a] -> [a]
++ [VName]
dims1 forall a. [a] -> [a] -> [a]
++ [VName]
svars2,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow Uniqueness
Nonunique (VName -> PName
Named VName
v') (forall shape. TypeBase shape Diet -> Diet
diet forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness
-> TypeBase (ExpBase Info VName) Diet
resToParam TypeBase (ExpBase Info VName) Uniqueness
st1) (forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st1) (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims2 TypeBase (ExpBase Info VName) Uniqueness
st2),
Liftedness
Lifted
)
evalTypeExp (TEArrow Maybe Name
Nothing TypeExp NoInfo Name
t1 TypeExp NoInfo Name
t2 SrcLoc
loc) = do
(TypeExp Info VName
t1', [VName]
svars1, RetType [VName]
dims1 TypeBase (ExpBase Info VName) Uniqueness
st1, Liftedness
_) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t1
(TypeExp Info VName
t2', [VName]
svars2, RetType [VName]
dims2 TypeBase (ExpBase Info VName) Uniqueness
st2, Liftedness
_) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t2
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
Maybe vn -> TypeExp f vn -> TypeExp f vn -> SrcLoc -> TypeExp f vn
TEArrow forall a. Maybe a
Nothing TypeExp Info VName
t1' TypeExp Info VName
t2' SrcLoc
loc,
[VName]
svars1 forall a. [a] -> [a] -> [a]
++ [VName]
dims1 forall a. [a] -> [a] -> [a]
++ [VName]
svars2,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$
forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow Uniqueness
Nonunique PName
Unnamed (forall shape. TypeBase shape Diet -> Diet
diet forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness
-> TypeBase (ExpBase Info VName) Diet
resToParam TypeBase (ExpBase Info VName) Uniqueness
st1) (forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st1) forall a b. (a -> b) -> a -> b
$
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims2 TypeBase (ExpBase Info VName) Uniqueness
st2,
Liftedness
Lifted
)
evalTypeExp (TEDim [Name]
dims TypeExp NoInfo Name
t SrcLoc
loc) = do
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced (forall a b. (a -> b) -> [a] -> [b]
map (Namespace
Term,) [Name]
dims) forall a b. (a -> b) -> a -> b
$ do
[VName]
dims' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term) SrcLoc
loc) [Name]
dims
forall {m :: * -> *} {a}.
MonadTypeChecker m =>
[VName] -> m a -> m a
bindDims [VName]
dims' forall a b. (a -> b) -> a -> b
$ do
(TypeExp Info VName
t', [VName]
svars, RetType [VName]
t_dims TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
l) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
t
let (Set VName
witnessed, Set VName
_) = StructType -> (Set VName, Set VName)
determineSizeWitnesses forall a b. (a -> b) -> a -> b
$ forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set VName
witnessed) [VName]
dims' of
Just VName
d ->
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"unused-existential" forall a b. (a -> b) -> a -> b
$
Doc ()
"Existential size "
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName VName
d)
forall a. Semigroup a => a -> a -> a
<> Doc ()
" not used as array size."
Maybe VName
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
[vn] -> TypeExp f vn -> SrcLoc -> TypeExp f vn
TEDim [VName]
dims' TypeExp Info VName
t' SrcLoc
loc,
[VName]
svars,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
dims' forall a. [a] -> [a] -> [a]
++ [VName]
t_dims) TypeBase (ExpBase Info VName) Uniqueness
st,
forall a. Ord a => a -> a -> a
max Liftedness
l Liftedness
SizeLifted
)
where
bindDims :: [VName] -> m a -> m a
bindDims [] m a
m = m a
m
bindDims (VName
d : [VName]
ds) m a
m =
forall (m :: * -> *) a.
MonadTypeChecker m =>
VName -> BoundV -> m a -> m a
bindVal VName
d ([TypeParam] -> StructType -> BoundV
BoundV [] forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. PrimType -> ScalarTypeBase dim u
Prim forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int64) forall a b. (a -> b) -> a -> b
$ [VName] -> m a -> m a
bindDims [VName]
ds m a
m
evalTypeExp t :: TypeExp NoInfo Name
t@(TESum [(Name, [TypeExp NoInfo Name])]
cs SrcLoc
loc) = do
let constructors :: [Name]
constructors = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, [TypeExp NoInfo Name])]
cs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => [a] -> [a]
sort [Name]
constructors forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
sort (forall a. Ord a => [a] -> [a]
nubOrd [Name]
constructors)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Duplicate constructors in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeExp NoInfo Name
t
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
constructors forall a. Ord a => a -> a -> Bool
< Int
256) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty Doc ()
"Sum types must have less than 256 constructors."
Map Name [(TypeExp Info VName, [VName], ResRetType, Liftedness)]
checked <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, [TypeExp NoInfo Name])]
cs
let cs' :: Map Name [TypeExp Info VName]
cs' = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\(TypeExp Info VName
x, [VName]
_, ResRetType
_, Liftedness
_) -> TypeExp Info VName
x) Map Name [(TypeExp Info VName, [VName], ResRetType, Liftedness)]
checked
cs_svars :: [VName]
cs_svars = (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (\(TypeExp Info VName
_, [VName]
y, ResRetType
_, Liftedness
_) -> [VName]
y) Map Name [(TypeExp Info VName, [VName], ResRetType, Liftedness)]
checked
ts_s :: Map Name [ResRetType]
ts_s = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\(TypeExp Info VName
_, [VName]
_, ResRetType
z, Liftedness
_) -> ResRetType
z) Map Name [(TypeExp Info VName, [VName], ResRetType, Liftedness)]
checked
ls :: [Liftedness]
ls = (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\(TypeExp Info VName
_, [VName]
_, ResRetType
_, Liftedness
v) -> Liftedness
v) Map Name [(TypeExp Info VName, [VName], ResRetType, Liftedness)]
checked
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn.
[(Name, [TypeExp f vn])] -> SrcLoc -> TypeExp f vn
TESum (forall k a. Map k a -> [(k, a)]
M.toList Map Name [TypeExp Info VName]
cs') SrcLoc
loc,
[VName]
cs_svars,
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall dim as. RetTypeBase dim as -> [VName]
retDims) Map Name [ResRetType]
ts_s) forall a b. (a -> b) -> a -> b
$
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$
forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall a b. (a -> b) -> a -> b
$
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> b) -> [a] -> [b]
map forall dim as. RetTypeBase dim as -> TypeBase dim as
retType) Map Name [ResRetType]
ts_s,
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => a -> a -> a
max Liftedness
Unlifted [Liftedness]
ls
)
evalTypeExp ote :: TypeExp NoInfo Name
ote@TEApply {} = do
(QualName Name
tname, SrcLoc
tname_loc, [TypeArgExp NoInfo Name]
targs) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (QualName Name, SrcLoc, [TypeArgExp NoInfo Name])
rootAndArgs TypeExp NoInfo Name
ote
(QualName VName
tname', [TypeParam]
ps, StructRetType
tname_t, Liftedness
l) <- forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc
-> QualName Name
-> m (QualName VName, [TypeParam], StructRetType, Liftedness)
lookupType SrcLoc
tloc QualName Name
tname
RetType [VName]
t_dims TypeBase (ExpBase Info VName) Uniqueness
t <- forall (m :: * -> *).
MonadTypeChecker m =>
ResRetType -> m ResRetType
renameRetType forall a b. (a -> b) -> a -> b
$ forall u.
Uniqueness -> RetTypeBase (ExpBase Info VName) u -> ResRetType
toResRet Uniqueness
Nonunique StructRetType
tname_t
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeParam]
ps forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArgExp NoInfo Name]
targs
then
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
tloc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Type constructor"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty QualName Name
tname)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"requires"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeParam]
ps)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"arguments, but provided"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArgExp NoInfo Name]
targs) forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
else do
([TypeArgExp Info VName]
targs', [[VName]]
dims, [Map VName (Subst StructRetType)]
substs) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {m :: * -> *} {k}.
(MonadTypeChecker m, Eq k, IsName k) =>
TypeParamBase k
-> TypeArgExp NoInfo Name
-> m (TypeArgExp Info VName, [VName], Map k (Subst StructRetType))
checkArgApply [TypeParam]
ps [TypeArgExp NoInfo Name]
targs
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\TypeExp Info VName
x TypeArgExp Info VName
y -> forall (f :: * -> *) vn.
TypeExp f vn -> TypeArgExp f vn -> SrcLoc -> TypeExp f vn
TEApply TypeExp Info VName
x TypeArgExp Info VName
y SrcLoc
tloc) (forall (f :: * -> *) vn. QualName vn -> SrcLoc -> TypeExp f vn
TEVar QualName VName
tname' SrcLoc
tname_loc) [TypeArgExp Info VName]
targs',
[],
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
t_dims forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => [a] -> a
mconcat [[VName]]
dims) forall a b. (a -> b) -> a -> b
$
forall a. Substitutable a => TypeSubs -> a -> a
applySubst (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall a. Monoid a => [a] -> a
mconcat [Map VName (Subst StructRetType)]
substs) TypeBase (ExpBase Info VName) Uniqueness
t,
Liftedness
l
)
where
tloc :: SrcLoc
tloc = forall a. Located a => a -> SrcLoc
srclocOf TypeExp NoInfo Name
ote
rootAndArgs ::
MonadTypeChecker m =>
TypeExp NoInfo Name ->
m (QualName Name, SrcLoc, [TypeArgExp NoInfo Name])
rootAndArgs :: forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (QualName Name, SrcLoc, [TypeArgExp NoInfo Name])
rootAndArgs (TEVar QualName Name
qn SrcLoc
loc) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName Name
qn, SrcLoc
loc, [])
rootAndArgs (TEApply TypeExp NoInfo Name
op TypeArgExp NoInfo Name
arg SrcLoc
_) = do
(QualName Name
op', SrcLoc
loc, [TypeArgExp NoInfo Name]
args) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (QualName Name, SrcLoc, [TypeArgExp NoInfo Name])
rootAndArgs TypeExp NoInfo Name
op
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName Name
op', SrcLoc
loc, [TypeArgExp NoInfo Name]
args forall a. [a] -> [a] -> [a]
++ [TypeArgExp NoInfo Name
arg])
rootAndArgs TypeExp NoInfo Name
te' =
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError (forall a. Located a => a -> SrcLoc
srclocOf TypeExp NoInfo Name
te') forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty TypeExp NoInfo Name
te') forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"is not a type constructor."
checkSizeExp :: SizeExp NoInfo Name -> m (TypeArgExp Info VName, [VName], Subst t)
checkSizeExp (SizeExp ExpBase NoInfo Name
e SrcLoc
dloc) = do
ExpBase Info VName
e' <- forall (m :: * -> *).
MonadTypeChecker m =>
ExpBase NoInfo Name -> m (ExpBase Info VName)
checkExpForSize ExpBase NoInfo Name
e
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn. SizeExp f vn -> TypeArgExp f vn
TypeArgExpSize (forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> SizeExp f vn
SizeExp ExpBase Info VName
e' SrcLoc
dloc),
[],
forall t. ExpBase Info VName -> Subst t
ExpSubst ExpBase Info VName
e'
)
checkSizeExp (SizeExpAny SrcLoc
loc) = do
VName
d <- forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newTypeName Name
"d"
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn. SizeExp f vn -> TypeArgExp f vn
TypeArgExpSize (forall (f :: * -> *) vn. SrcLoc -> SizeExp f vn
SizeExpAny SrcLoc
loc),
[VName
d],
forall t. ExpBase Info VName -> Subst t
ExpSubst forall a b. (a -> b) -> a -> b
$ QualName VName -> SrcLoc -> ExpBase Info VName
sizeFromName (forall v. v -> QualName v
qualName VName
d) SrcLoc
loc
)
checkArgApply :: TypeParamBase k
-> TypeArgExp NoInfo Name
-> m (TypeArgExp Info VName, [VName], Map k (Subst StructRetType))
checkArgApply (TypeParamDim k
pv SrcLoc
_) (TypeArgExpSize SizeExp NoInfo Name
d) = do
(TypeArgExp Info VName
d', [VName]
svars, Subst StructRetType
subst) <- forall {m :: * -> *} {t}.
MonadTypeChecker m =>
SizeExp NoInfo Name -> m (TypeArgExp Info VName, [VName], Subst t)
checkSizeExp SizeExp NoInfo Name
d
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeArgExp Info VName
d', [VName]
svars, forall k a. k -> a -> Map k a
M.singleton k
pv Subst StructRetType
subst)
checkArgApply (TypeParamType Liftedness
_ k
pv SrcLoc
_) (TypeArgExpType TypeExp NoInfo Name
te) = do
(TypeExp Info VName
te', [VName]
svars, RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
_) <- forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
te
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall (f :: * -> *) vn. TypeExp f vn -> TypeArgExp f vn
TypeArgExpType TypeExp Info VName
te',
[VName]
svars forall a. [a] -> [a] -> [a]
++ [VName]
dims,
forall k a. k -> a -> Map k a
M.singleton k
pv forall a b. (a -> b) -> a -> b
$ forall t. [TypeParam] -> t -> Subst t
Subst [] forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] forall a b. (a -> b) -> a -> b
$ forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st
)
checkArgApply TypeParamBase k
p TypeArgExp NoInfo Name
a =
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
tloc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Type argument"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeArgExp NoInfo Name
a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"not valid for a type parameter"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeParamBase k
p forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
checkTypeExp ::
MonadTypeChecker m =>
TypeExp NoInfo Name ->
m (TypeExp Info VName, [VName], ResRetType, Liftedness)
checkTypeExp :: forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
checkTypeExp TypeExp NoInfo Name
te = do
forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name -> m ()
checkForDuplicateNamesInType TypeExp NoInfo Name
te
forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
evalTypeExp TypeExp NoInfo Name
te
checkForDuplicateNames ::
MonadTypeChecker m => [UncheckedTypeParam] -> [UncheckedPat t] -> m ()
checkForDuplicateNames :: forall (m :: * -> *) t.
MonadTypeChecker m =>
[UncheckedTypeParam] -> [UncheckedPat t] -> m ()
checkForDuplicateNames [UncheckedTypeParam]
tps [UncheckedPat t]
pats = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {b} {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (Namespace, b) SrcLoc) (t m), Pretty b,
MonadTypeChecker m, MonadTrans t, Ord b) =>
TypeParamBase b -> t m ()
checkTypeParam [UncheckedTypeParam]
tps
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {b} {t :: (* -> *) -> * -> *} {m :: * -> *} {f :: * -> *}
{t}.
(MonadState (Map (Namespace, b) SrcLoc) (t m), Pretty b,
MonadTypeChecker m, MonadTrans t, Ord b) =>
PatBase f b t -> t m ()
checkPat [UncheckedPat t]
pats
where
checkTypeParam :: TypeParamBase b -> t m ()
checkTypeParam (TypeParamType Liftedness
_ b
v SrcLoc
loc) = forall {a} {b} {a} {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (a, b) a) (t m), Located a, Pretty b,
MonadTypeChecker m, MonadTrans t, Ord b, Ord a) =>
a -> b -> a -> t m ()
seen Namespace
Type b
v SrcLoc
loc
checkTypeParam (TypeParamDim b
v SrcLoc
loc) = forall {a} {b} {a} {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (a, b) a) (t m), Located a, Pretty b,
MonadTypeChecker m, MonadTrans t, Ord b, Ord a) =>
a -> b -> a -> t m ()
seen Namespace
Term b
v SrcLoc
loc
checkPat :: PatBase f b t -> t m ()
checkPat (Id b
v f t
_ SrcLoc
loc) = forall {a} {b} {a} {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (a, b) a) (t m), Located a, Pretty b,
MonadTypeChecker m, MonadTrans t, Ord b, Ord a) =>
a -> b -> a -> t m ()
seen Namespace
Term b
v SrcLoc
loc
checkPat (PatParens PatBase f b t
p SrcLoc
_) = PatBase f b t -> t m ()
checkPat PatBase f b t
p
checkPat (PatAttr AttrInfo b
_ PatBase f b t
p SrcLoc
_) = PatBase f b t -> t m ()
checkPat PatBase f b t
p
checkPat Wildcard {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPat (TuplePat [PatBase f b t]
ps SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PatBase f b t -> t m ()
checkPat [PatBase f b t]
ps
checkPat (RecordPat [(Name, PatBase f b t)]
fs SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PatBase f b t -> t m ()
checkPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, PatBase f b t)]
fs
checkPat (PatAscription PatBase f b t
p TypeExp f b
_ SrcLoc
_) = PatBase f b t -> t m ()
checkPat PatBase f b t
p
checkPat PatLit {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkPat (PatConstr Name
_ f t
_ [PatBase f b t]
ps SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PatBase f b t -> t m ()
checkPat [PatBase f b t]
ps
seen :: a -> b -> a -> t m ()
seen a
ns b
v a
loc = do
Maybe a
already <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (a
ns, b
v)
case Maybe a
already of
Just a
prev_loc ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError a
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Name"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty b
v)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"also bound at"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> String
locStr a
prev_loc) forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
Maybe a
Nothing ->
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (a
ns, b
v) a
loc
checkForDuplicateNamesInType ::
MonadTypeChecker m =>
TypeExp NoInfo Name ->
m ()
checkForDuplicateNamesInType :: forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name -> m ()
checkForDuplicateNamesInType = forall {a} {m :: * -> *} {f :: * -> *}.
(MonadTypeChecker m, Pretty a, Ord a) =>
Map a SrcLoc -> TypeExp f a -> m ()
check forall a. Monoid a => a
mempty
where
bad :: a -> loc -> a -> m a
bad a
v loc
loc a
prev_loc =
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError loc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Name"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty a
v)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"also bound at"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> String
locStr a
prev_loc) forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
check :: Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen (TEArrow (Just a
v) TypeExp f a
t1 TypeExp f a
t2 SrcLoc
loc)
| Just SrcLoc
prev_loc <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
v Map a SrcLoc
seen =
forall {m :: * -> *} {a} {loc} {a} {a}.
(MonadTypeChecker m, Pretty a, Located loc, Located a) =>
a -> loc -> a -> m a
bad a
v SrcLoc
loc SrcLoc
prev_loc
| Bool
otherwise =
Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen' TypeExp f a
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen' TypeExp f a
t2
where
seen' :: Map a SrcLoc
seen' = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
v SrcLoc
loc Map a SrcLoc
seen
check Map a SrcLoc
seen (TEArrow Maybe a
Nothing TypeExp f a
t1 TypeExp f a
t2 SrcLoc
_) =
Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t2
check Map a SrcLoc
seen (TETuple [TypeExp f a]
ts SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen) [TypeExp f a]
ts
check Map a SrcLoc
seen (TERecord [(Name, TypeExp f a)]
fs SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, TypeExp f a)]
fs
check Map a SrcLoc
seen (TEUnique TypeExp f a
t SrcLoc
_) = Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t
check Map a SrcLoc
seen (TESum [(Name, [TypeExp f a])]
cs SrcLoc
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, [TypeExp f a])]
cs
check Map a SrcLoc
seen (TEApply TypeExp f a
t1 (TypeArgExpType TypeExp f a
t2) SrcLoc
_) =
Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t2
check Map a SrcLoc
seen (TEApply TypeExp f a
t1 TypeArgExpSize {} SrcLoc
_) =
Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t1
check Map a SrcLoc
seen (TEDim (a
v : [a]
vs) TypeExp f a
t SrcLoc
loc)
| Just SrcLoc
prev_loc <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
v Map a SrcLoc
seen =
forall {m :: * -> *} {a} {loc} {a} {a}.
(MonadTypeChecker m, Pretty a, Located loc, Located a) =>
a -> loc -> a -> m a
bad a
v SrcLoc
loc SrcLoc
prev_loc
| Bool
otherwise =
Map a SrcLoc -> TypeExp f a -> m ()
check (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
v SrcLoc
loc Map a SrcLoc
seen) (forall (f :: * -> *) vn.
[vn] -> TypeExp f vn -> SrcLoc -> TypeExp f vn
TEDim [a]
vs TypeExp f a
t SrcLoc
loc)
check Map a SrcLoc
seen (TEDim [] TypeExp f a
t SrcLoc
_) =
Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
t
check Map a SrcLoc
_ TEArray {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
check Map a SrcLoc
_ TEVar {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
check Map a SrcLoc
seen (TEParens TypeExp f a
te SrcLoc
_) = Map a SrcLoc -> TypeExp f a -> m ()
check Map a SrcLoc
seen TypeExp f a
te
checkTypeParams ::
MonadTypeChecker m =>
[TypeParamBase Name] ->
([TypeParamBase VName] -> m a) ->
m a
checkTypeParams :: forall (m :: * -> *) a.
MonadTypeChecker m =>
[UncheckedTypeParam] -> ([TypeParam] -> m a) -> m a
checkTypeParams [UncheckedTypeParam]
ps [TypeParam] -> m a
m =
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced (forall a b. (a -> b) -> [a] -> [b]
map forall {b}. TypeParamBase b -> (Namespace, b)
typeParamSpace [UncheckedTypeParam]
ps) forall a b. (a -> b) -> a -> b
$
[TypeParam] -> m a
m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (Namespace, Name) SrcLoc) (t m),
MonadTypeChecker m, MonadTrans t) =>
UncheckedTypeParam -> t m TypeParam
checkTypeParam [UncheckedTypeParam]
ps) forall a. Monoid a => a
mempty
where
typeParamSpace :: TypeParamBase b -> (Namespace, b)
typeParamSpace (TypeParamDim b
pv SrcLoc
_) = (Namespace
Term, b
pv)
typeParamSpace (TypeParamType Liftedness
_ b
pv SrcLoc
_) = (Namespace
Type, b
pv)
checkParamName :: Namespace -> Name -> SrcLoc -> t m VName
checkParamName Namespace
ns Name
v SrcLoc
loc = do
Maybe SrcLoc
seen <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
ns, Name
v)
case Maybe SrcLoc
seen of
Just SrcLoc
prev ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Doc ()
"Type parameter"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Name
v)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"previously defined at"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> String
locStr SrcLoc
prev) forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
Maybe SrcLoc
Nothing -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Namespace
ns, Name
v) SrcLoc
loc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
ns Name
v SrcLoc
loc
checkTypeParam :: UncheckedTypeParam -> t m TypeParam
checkTypeParam (TypeParamDim Name
pv SrcLoc
loc) =
forall vn. vn -> SrcLoc -> TypeParamBase vn
TypeParamDim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (Namespace, Name) SrcLoc) (t m),
MonadTypeChecker m, MonadTrans t) =>
Namespace -> Name -> SrcLoc -> t m VName
checkParamName Namespace
Term Name
pv SrcLoc
loc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
checkTypeParam (TypeParamType Liftedness
l Name
pv SrcLoc
loc) =
forall vn. Liftedness -> vn -> SrcLoc -> TypeParamBase vn
TypeParamType Liftedness
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadState (Map (Namespace, Name) SrcLoc) (t m),
MonadTypeChecker m, MonadTrans t) =>
Namespace -> Name -> SrcLoc -> t m VName
checkParamName Namespace
Type Name
pv SrcLoc
loc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
typeParamToArg :: TypeParam -> StructTypeArg
typeParamToArg :: TypeParam -> StructTypeArg
typeParamToArg (TypeParamDim VName
v SrcLoc
ploc) =
forall dim. dim -> TypeArg dim
TypeArgDim forall a b. (a -> b) -> a -> b
$ QualName VName -> SrcLoc -> ExpBase Info VName
sizeFromName (forall v. v -> QualName v
qualName VName
v) SrcLoc
ploc
typeParamToArg (TypeParamType Liftedness
_ VName
v SrcLoc
_) =
forall dim. TypeBase dim NoUniqueness -> TypeArg dim
TypeArgType forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar forall a. Monoid a => a
mempty (forall v. v -> QualName v
qualName VName
v) []
data Subst t = Subst [TypeParam] t | ExpSubst Exp
deriving (Int -> Subst t -> ShowS
forall t. Show t => Int -> Subst t -> ShowS
forall t. Show t => [Subst t] -> ShowS
forall t. Show t => Subst t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Subst t] -> ShowS
$cshowList :: forall t. Show t => [Subst t] -> ShowS
show :: Subst t -> String
$cshow :: forall t. Show t => Subst t -> String
showsPrec :: Int -> Subst t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Subst t -> ShowS
Show)
instance Pretty t => Pretty (Subst t) where
pretty :: forall ann. Subst t -> Doc ann
pretty (Subst [] t
t) = forall a ann. Pretty a => a -> Doc ann
pretty t
t
pretty (Subst [TypeParam]
tps t
t) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [TypeParam]
tps) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty t
t
pretty (ExpSubst ExpBase Info VName
e) = forall a ann. Pretty a => a -> Doc ann
pretty ExpBase Info VName
e
instance Functor Subst where
fmap :: forall a b. (a -> b) -> Subst a -> Subst b
fmap a -> b
f (Subst [TypeParam]
ps a
t) = forall t. [TypeParam] -> t -> Subst t
Subst [TypeParam]
ps forall a b. (a -> b) -> a -> b
$ a -> b
f a
t
fmap a -> b
_ (ExpSubst ExpBase Info VName
e) = forall t. ExpBase Info VName -> Subst t
ExpSubst ExpBase Info VName
e
substFromAbbr :: TypeBinding -> Subst StructRetType
substFromAbbr :: TypeBinding -> Subst StructRetType
substFromAbbr (TypeAbbr Liftedness
_ [TypeParam]
ps StructRetType
rt) = forall t. [TypeParam] -> t -> Subst t
Subst [TypeParam]
ps StructRetType
rt
type TypeSubs = VName -> Maybe (Subst StructRetType)
class Substitutable a where
applySubst :: TypeSubs -> a -> a
instance Substitutable (RetTypeBase Size Uniqueness) where
applySubst :: TypeSubs -> ResRetType -> ResRetType
applySubst TypeSubs
f (RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
t) =
let RetType [VName]
more_dims TypeBase (ExpBase Info VName) Uniqueness
t' = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet VName -> Maybe (Subst ResRetType)
f' TypeBase (ExpBase Info VName) Uniqueness
t
in forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
dims forall a. [a] -> [a] -> [a]
++ [VName]
more_dims) TypeBase (ExpBase Info VName) Uniqueness
t'
where
f' :: VName -> Maybe (Subst ResRetType)
f' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSubs
f
instance Substitutable (RetTypeBase Size NoUniqueness) where
applySubst :: TypeSubs -> StructRetType -> StructRetType
applySubst TypeSubs
f (RetType [VName]
dims StructType
t) =
let RetType [VName]
more_dims StructType
t' = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet TypeSubs
f StructType
t
in forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
dims forall a. [a] -> [a] -> [a]
++ [VName]
more_dims) StructType
t'
instance Substitutable StructType where
applySubst :: TypeSubs -> StructType -> StructType
applySubst = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> TypeBase (ExpBase Info VName) as
substTypesAny
instance Substitutable ParamType where
applySubst :: TypeSubs
-> TypeBase (ExpBase Info VName) Diet
-> TypeBase (ExpBase Info VName) Diet
applySubst TypeSubs
f = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> TypeBase (ExpBase Info VName) as
substTypesAny forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Diet
Observe) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSubs
f
instance Substitutable (TypeBase Size Uniqueness) where
applySubst :: TypeSubs
-> TypeBase (ExpBase Info VName) Uniqueness
-> TypeBase (ExpBase Info VName) Uniqueness
applySubst TypeSubs
f = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> TypeBase (ExpBase Info VName) as
substTypesAny forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Uniqueness
Nonunique) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSubs
f
instance Substitutable Exp where
applySubst :: TypeSubs -> ExpBase Info VName -> ExpBase Info VName
applySubst TypeSubs
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp
where
mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp (Var (QualName [VName]
_ VName
v) Info StructType
_ SrcLoc
_)
| Just (ExpSubst ExpBase Info VName
e') <- TypeSubs
f VName
v = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpBase Info VName
e'
mapOnExp ExpBase Info VName
e' = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper Identity
mapper ExpBase Info VName
e'
mapper :: ASTMapper Identity
mapper =
ASTMapper
{ ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp,
mapOnName :: VName -> Identity VName
mapOnName = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
mapOnStructType :: StructType -> Identity StructType
mapOnStructType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnParamType :: TypeBase (ExpBase Info VName) Diet
-> Identity (TypeBase (ExpBase Info VName) Diet)
mapOnParamType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnResRetType :: ResRetType -> Identity ResRetType
mapOnResRetType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f
}
instance Substitutable d => Substitutable (Shape d) where
applySubst :: TypeSubs -> Shape d -> Shape d
applySubst TypeSubs
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f
instance Substitutable (Pat StructType) where
applySubst :: TypeSubs -> Pat StructType -> Pat StructType
applySubst TypeSubs
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper Identity
mapper
where
mapper :: ASTMapper Identity
mapper =
ASTMapper
{ mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnName :: VName -> Identity VName
mapOnName = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
mapOnStructType :: StructType -> Identity StructType
mapOnStructType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnParamType :: TypeBase (ExpBase Info VName) Diet
-> Identity (TypeBase (ExpBase Info VName) Diet)
mapOnParamType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnResRetType :: ResRetType -> Identity ResRetType
mapOnResRetType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f
}
instance Substitutable (Pat ParamType) where
applySubst :: TypeSubs
-> Pat (TypeBase (ExpBase Info VName) Diet)
-> Pat (TypeBase (ExpBase Info VName) Diet)
applySubst TypeSubs
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper Identity
mapper
where
mapper :: ASTMapper Identity
mapper =
ASTMapper
{ mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnName :: VName -> Identity VName
mapOnName = forall (f :: * -> *) a. Applicative f => a -> f a
pure,
mapOnStructType :: StructType -> Identity StructType
mapOnStructType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnParamType :: TypeBase (ExpBase Info VName) Diet
-> Identity (TypeBase (ExpBase Info VName) Diet)
mapOnParamType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f,
mapOnResRetType :: ResRetType -> Identity ResRetType
mapOnResRetType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
f
}
applyType ::
Monoid als =>
[TypeParam] ->
TypeBase Size als ->
[StructTypeArg] ->
TypeBase Size als
applyType :: forall als.
Monoid als =>
[TypeParam]
-> TypeBase (ExpBase Info VName) als
-> [StructTypeArg]
-> TypeBase (ExpBase Info VName) als
applyType [TypeParam]
ps TypeBase (ExpBase Info VName) als
t [StructTypeArg]
args = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> TypeBase (ExpBase Info VName) as
substTypesAny (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map VName (Subst (RetTypeBase (ExpBase Info VName) als))
substs) TypeBase (ExpBase Info VName) als
t
where
substs :: Map VName (Subst (RetTypeBase (ExpBase Info VName) als))
substs = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {as} {a}.
(Monoid as, Eq a, IsName a) =>
TypeParamBase a
-> StructTypeArg
-> (a, Subst (RetTypeBase (ExpBase Info VName) as))
mkSubst [TypeParam]
ps [StructTypeArg]
args
mkSubst :: TypeParamBase a
-> StructTypeArg
-> (a, Subst (RetTypeBase (ExpBase Info VName) as))
mkSubst (TypeParamDim a
pv SrcLoc
_) (TypeArgDim ExpBase Info VName
e) =
(a
pv, forall t. ExpBase Info VName -> Subst t
ExpSubst ExpBase Info VName
e)
mkSubst (TypeParamType Liftedness
_ a
pv SrcLoc
_) (TypeArgType StructType
at) =
(a
pv, forall t. [TypeParam] -> t -> Subst t
Subst [] forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. Monoid a => a
mempty StructType
at)
mkSubst TypeParamBase a
p StructTypeArg
a =
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"applyType mkSubst: cannot substitute " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyString StructTypeArg
a forall a. [a] -> [a] -> [a]
++ String
" for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyString TypeParamBase a
p
substTypesRet ::
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase Size as))) ->
TypeBase Size as ->
RetTypeBase Size as
substTypesRet :: forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
lookupSubst TypeBase (ExpBase Info VName) as
ot =
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType) forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> (a, s)
runState (forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType TypeBase (ExpBase Info VName) as
ot) []
where
freshDims :: RetTypeBase (ExpBase Info VName) as
-> f (RetTypeBase (ExpBase Info VName) as)
freshDims (RetType [] TypeBase (ExpBase Info VName) as
t) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] TypeBase (ExpBase Info VName) as
t
freshDims (RetType [VName]
ext TypeBase (ExpBase Info VName) as
t) = do
[VName]
seen_ext <- forall s (m :: * -> *). MonadState s m => m s
get
if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
seen_ext) [VName]
ext
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext TypeBase (ExpBase Info VName) as
t
else do
let start :: Int
start = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map VName -> Int
baseTag [VName]
seen_ext
ext' :: [VName]
ext' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Int -> VName
VName (forall a b. (a -> b) -> [a] -> [b]
map VName -> Name
baseName [VName]
ext) [Int
start forall a. Num a => a -> a -> a
+ Int
1 ..]
mkSubst :: VName -> Subst t
mkSubst = forall t. ExpBase Info VName -> Subst t
ExpSubst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip QualName VName -> SrcLoc -> ExpBase Info VName
sizeFromName forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> QualName v
qualName
extsubsts :: Map VName (Subst t)
extsubsts = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
ext forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t}. VName -> Subst t
mkSubst [VName]
ext'
RetType [] TypeBase (ExpBase Info VName) as
t' = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall {t}. Map VName (Subst t)
extsubsts) TypeBase (ExpBase Info VName) as
t
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext' TypeBase (ExpBase Info VName) as
t'
onType ::
forall as.
Monoid as =>
TypeBase Size as ->
State [VName] (TypeBase Size as)
onType :: forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType (Array as
u Shape (ExpBase Info VName)
shape ScalarTypeBase (ExpBase Info VName) NoUniqueness
et) =
forall u dim. u -> Shape dim -> TypeBase dim u -> TypeBase dim u
arrayOfWithAliases as
u (forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
lookupSubst' Shape (ExpBase Info VName)
shape)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar ScalarTypeBase (ExpBase Info VName) NoUniqueness
et)
onType (Scalar (Prim PrimType
t)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. PrimType -> ScalarTypeBase dim u
Prim PrimType
t
onType (Scalar (TypeVar as
u QualName VName
v [StructTypeArg]
targs)) = do
[StructTypeArg]
targs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
MonadState [VName] m =>
StructTypeArg -> m StructTypeArg
subsTypeArg [StructTypeArg]
targs
case VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
lookupSubst forall a b. (a -> b) -> a -> b
$ forall vn. QualName vn -> vn
qualLeaf QualName VName
v of
Just (Subst [TypeParam]
ps RetTypeBase (ExpBase Info VName) as
rt) -> do
RetType [VName]
ext TypeBase (ExpBase Info VName) as
t <- forall {f :: * -> *} {as}.
(MonadState [VName] f, Monoid as) =>
RetTypeBase (ExpBase Info VName) as
-> f (RetTypeBase (ExpBase Info VName) as)
freshDims RetTypeBase (ExpBase Info VName) as
rt
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([VName]
ext ++)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Semigroup a => a -> a -> a
<> as
u) forall a b. (a -> b) -> a -> b
$ forall als.
Monoid als =>
[TypeParam]
-> TypeBase (ExpBase Info VName) als
-> [StructTypeArg]
-> TypeBase (ExpBase Info VName) als
applyType [TypeParam]
ps (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const as
u) TypeBase (ExpBase Info VName) as
t) [StructTypeArg]
targs'
Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar as
u QualName VName
v [StructTypeArg]
targs'
onType (Scalar (Record Map Name (TypeBase (ExpBase Info VName) as)
ts)) =
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType Map Name (TypeBase (ExpBase Info VName) as)
ts
onType (Scalar (Arrow as
als PName
v Diet
d StructType
t1 ResRetType
t2)) =
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow as
als PName
v Diet
d forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType StructType
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {as}.
(MonadState [VName] f, Monoid as) =>
RetTypeBase (ExpBase Info VName) as
-> f (RetTypeBase (ExpBase Info VName) as)
onRetType ResRetType
t2)
onType (Scalar (Sum Map Name [TypeBase (ExpBase Info VName) as]
ts)) =
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType) Map Name [TypeBase (ExpBase Info VName) as]
ts
onRetType :: RetTypeBase (ExpBase Info VName) as
-> m (RetTypeBase (ExpBase Info VName) as)
onRetType (RetType [VName]
dims TypeBase (ExpBase Info VName) as
t) = do
[VName]
ext <- forall s (m :: * -> *). MonadState s m => m s
get
let (TypeBase (ExpBase Info VName) as
t', [VName]
ext') = forall s a. State s a -> s -> (a, s)
runState (forall as.
Monoid as =>
TypeBase (ExpBase Info VName) as
-> State [VName] (TypeBase (ExpBase Info VName) as)
onType TypeBase (ExpBase Info VName) as
t) [VName]
ext
new_ext :: [VName]
new_ext = [VName]
ext' forall a. Eq a => [a] -> [a] -> [a]
\\ [VName]
ext
case TypeBase (ExpBase Info VName) as
t of
Scalar Arrow {} -> do
forall s (m :: * -> *). MonadState s m => s -> m ()
put [VName]
ext'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims TypeBase (ExpBase Info VName) as
t'
TypeBase (ExpBase Info VName) as
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
new_ext forall a. Semigroup a => a -> a -> a
<> [VName]
dims) TypeBase (ExpBase Info VName) as
t'
subsTypeArg :: StructTypeArg -> m StructTypeArg
subsTypeArg (TypeArgType StructType
t) = do
let RetType [VName]
dims StructType
t' = forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet TypeSubs
lookupSubst' StructType
t
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([VName]
dims ++)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim. TypeBase dim NoUniqueness -> TypeArg dim
TypeArgType StructType
t'
subsTypeArg (TypeArgDim ExpBase Info VName
v) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim. dim -> TypeArg dim
TypeArgDim forall a b. (a -> b) -> a -> b
$ forall a. Substitutable a => TypeSubs -> a -> a
applySubst TypeSubs
lookupSubst' ExpBase Info VName
v
lookupSubst' :: TypeSubs
lookupSubst' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const NoUniqueness
NoUniqueness)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
lookupSubst
substTypesAny ::
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase Size as))) ->
TypeBase Size as ->
TypeBase Size as
substTypesAny :: forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> TypeBase (ExpBase Info VName) as
substTypesAny VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
lookupSubst TypeBase (ExpBase Info VName) as
ot =
case forall as.
Monoid as =>
(VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as)))
-> TypeBase (ExpBase Info VName) as
-> RetTypeBase (ExpBase Info VName) as
substTypesRet VName -> Maybe (Subst (RetTypeBase (ExpBase Info VName) as))
lookupSubst TypeBase (ExpBase Info VName) as
ot of
RetType [] TypeBase (ExpBase Info VName) as
ot' -> TypeBase (ExpBase Info VName) as
ot'
RetType [VName]
dims TypeBase (ExpBase Info VName) as
ot' ->
let toAny :: ExpBase Info VName -> ExpBase Info VName
toAny (Var QualName VName
v Info StructType
_ SrcLoc
_) | forall vn. QualName vn -> vn
qualLeaf QualName VName
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
dims = ExpBase Info VName
anySize
toAny ExpBase Info VName
d = ExpBase Info VName
d
in forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExpBase Info VName -> ExpBase Info VName
toAny TypeBase (ExpBase Info VName) as
ot'