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