module Language.Futhark.TypeChecker
( checkProg,
checkExp,
checkDec,
checkModExp,
Notes,
TypeError (..),
prettyTypeError,
prettyTypeErrorNoLoc,
Warnings,
initialEnv,
envWithImports,
)
where
import Control.Monad
import Control.Monad.Except
import Data.Bifunctor
import Data.Either
import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Ord
import Data.Set qualified as S
import Futhark.FreshNames hiding (newName)
import Futhark.Util.Pretty hiding (space)
import Language.Futhark
import Language.Futhark.Semantic
import Language.Futhark.TypeChecker.Modules
import Language.Futhark.TypeChecker.Monad
import Language.Futhark.TypeChecker.Terms
import Language.Futhark.TypeChecker.Types
import Prelude hiding (abs, mod)
checkProg ::
Imports ->
VNameSource ->
ImportName ->
UncheckedProg ->
(Warnings, Either TypeError (FileModule, VNameSource))
checkProg :: Imports
-> VNameSource
-> ImportName
-> UncheckedProg
-> (Warnings, Either TypeError (FileModule, VNameSource))
checkProg Imports
files VNameSource
src ImportName
name UncheckedProg
prog =
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM FileModule
-> (Warnings, Either TypeError (FileModule, VNameSource))
forall a.
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM a
-> (Warnings, Either TypeError (a, VNameSource))
runTypeM Env
initialEnv ImportTable
files' ImportName
name VNameSource
src UncheckedExp -> TypeM (ExpBase Info VName)
checkSizeExp (TypeM FileModule
-> (Warnings, Either TypeError (FileModule, VNameSource)))
-> TypeM FileModule
-> (Warnings, Either TypeError (FileModule, VNameSource))
forall a b. (a -> b) -> a -> b
$ UncheckedProg -> TypeM FileModule
checkProgM UncheckedProg
prog
where
files' :: ImportTable
files' = (FileModule -> Env) -> Map ImportName FileModule -> ImportTable
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FileModule -> Env
fileEnv (Map ImportName FileModule -> ImportTable)
-> Map ImportName FileModule -> ImportTable
forall a b. (a -> b) -> a -> b
$ Imports -> Map ImportName FileModule
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList Imports
files
checkExp ::
Imports ->
VNameSource ->
Env ->
UncheckedExp ->
(Warnings, Either TypeError ([TypeParam], Exp))
checkExp :: Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings,
Either TypeError ([TypeParamBase VName], ExpBase Info VName))
checkExp Imports
files VNameSource
src Env
env UncheckedExp
e =
(Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource)
-> Either TypeError ([TypeParamBase VName], ExpBase Info VName))
-> (Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource))
-> (Warnings,
Either TypeError ([TypeParamBase VName], ExpBase Info VName))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((([TypeParamBase VName], ExpBase Info VName), VNameSource)
-> ([TypeParamBase VName], ExpBase Info VName))
-> Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource)
-> Either TypeError ([TypeParamBase VName], ExpBase Info VName)
forall a b. (a -> b) -> Either TypeError a -> Either TypeError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([TypeParamBase VName], ExpBase Info VName), VNameSource)
-> ([TypeParamBase VName], ExpBase Info VName)
forall a b. (a, b) -> a
fst) ((Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource))
-> (Warnings,
Either TypeError ([TypeParamBase VName], ExpBase Info VName)))
-> (Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource))
-> (Warnings,
Either TypeError ([TypeParamBase VName], ExpBase Info VName))
forall a b. (a -> b) -> a -> b
$ Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM ([TypeParamBase VName], ExpBase Info VName)
-> (Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource))
forall a.
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM a
-> (Warnings, Either TypeError (a, VNameSource))
runTypeM Env
env ImportTable
files' (FilePath -> ImportName
mkInitialImport FilePath
"") VNameSource
src UncheckedExp -> TypeM (ExpBase Info VName)
checkSizeExp (TypeM ([TypeParamBase VName], ExpBase Info VName)
-> (Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource)))
-> TypeM ([TypeParamBase VName], ExpBase Info VName)
-> (Warnings,
Either
TypeError
(([TypeParamBase VName], ExpBase Info VName), VNameSource))
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> TypeM ([TypeParamBase VName], ExpBase Info VName)
checkOneExp UncheckedExp
e
where
files' :: ImportTable
files' = (FileModule -> Env) -> Map ImportName FileModule -> ImportTable
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FileModule -> Env
fileEnv (Map ImportName FileModule -> ImportTable)
-> Map ImportName FileModule -> ImportTable
forall a b. (a -> b) -> a -> b
$ Imports -> Map ImportName FileModule
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList Imports
files
checkDec ::
Imports ->
VNameSource ->
Env ->
ImportName ->
UncheckedDec ->
(Warnings, Either TypeError (Env, Dec, VNameSource))
checkDec :: Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
checkDec Imports
files VNameSource
src Env
env ImportName
name UncheckedDec
d =
(Either TypeError ((Env, Dec), VNameSource)
-> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError ((Env, Dec), VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((((Env, Dec), VNameSource) -> (Env, Dec, VNameSource))
-> Either TypeError ((Env, Dec), VNameSource)
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> Either TypeError a -> Either TypeError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Env, Dec), VNameSource) -> (Env, Dec, VNameSource)
forall {a} {b} {c}. ((a, b), c) -> (a, b, c)
massage) ((Warnings, Either TypeError ((Env, Dec), VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> (Warnings, Either TypeError ((Env, Dec), VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM (Env, Dec)
-> (Warnings, Either TypeError ((Env, Dec), VNameSource))
forall a.
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM a
-> (Warnings, Either TypeError (a, VNameSource))
runTypeM Env
env ImportTable
files' ImportName
name VNameSource
src UncheckedExp -> TypeM (ExpBase Info VName)
checkSizeExp (TypeM (Env, Dec)
-> (Warnings, Either TypeError ((Env, Dec), VNameSource)))
-> TypeM (Env, Dec)
-> (Warnings, Either TypeError ((Env, Dec), VNameSource))
forall a b. (a -> b) -> a -> b
$ do
(TySet
_, Env
env', Dec
d') <- UncheckedDec -> TypeM (TySet, Env, Dec)
checkOneDec UncheckedDec
d
(Env, Dec) -> TypeM (Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env, Dec
d')
where
massage :: ((a, b), c) -> (a, b, c)
massage ((a
env', b
d'), c
src') =
(a
env', b
d', c
src')
files' :: ImportTable
files' = (FileModule -> Env) -> Map ImportName FileModule -> ImportTable
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FileModule -> Env
fileEnv (Map ImportName FileModule -> ImportTable)
-> Map ImportName FileModule -> ImportTable
forall a b. (a -> b) -> a -> b
$ Imports -> Map ImportName FileModule
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList Imports
files
checkModExp ::
Imports ->
VNameSource ->
Env ->
ModExpBase NoInfo Name ->
(Warnings, Either TypeError (MTy, ModExpBase Info VName))
checkModExp :: Imports
-> VNameSource
-> Env
-> ModExpBase NoInfo Name
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
checkModExp Imports
files VNameSource
src Env
env ModExpBase NoInfo Name
me =
(Either TypeError ((MTy, ModExpBase Info VName), VNameSource)
-> Either TypeError (MTy, ModExpBase Info VName))
-> (Warnings,
Either TypeError ((MTy, ModExpBase Info VName), VNameSource))
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((((MTy, ModExpBase Info VName), VNameSource)
-> (MTy, ModExpBase Info VName))
-> Either TypeError ((MTy, ModExpBase Info VName), VNameSource)
-> Either TypeError (MTy, ModExpBase Info VName)
forall a b. (a -> b) -> Either TypeError a -> Either TypeError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MTy, ModExpBase Info VName), VNameSource)
-> (MTy, ModExpBase Info VName)
forall a b. (a, b) -> a
fst) ((Warnings,
Either TypeError ((MTy, ModExpBase Info VName), VNameSource))
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName)))
-> (TypeM (MTy, ModExpBase Info VName)
-> (Warnings,
Either TypeError ((MTy, ModExpBase Info VName), VNameSource)))
-> TypeM (MTy, ModExpBase Info VName)
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM (MTy, ModExpBase Info VName)
-> (Warnings,
Either TypeError ((MTy, ModExpBase Info VName), VNameSource))
forall a.
Env
-> ImportTable
-> ImportName
-> VNameSource
-> (UncheckedExp -> TypeM (ExpBase Info VName))
-> TypeM a
-> (Warnings, Either TypeError (a, VNameSource))
runTypeM Env
env ImportTable
files' (FilePath -> ImportName
mkInitialImport FilePath
"") VNameSource
src UncheckedExp -> TypeM (ExpBase Info VName)
checkSizeExp (TypeM (MTy, ModExpBase Info VName)
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName)))
-> TypeM (MTy, ModExpBase Info VName)
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
forall a b. (a -> b) -> a -> b
$ do
(TySet
_abs, MTy
mty, ModExpBase Info VName
me') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
me
(MTy, ModExpBase Info VName) -> TypeM (MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTy
mty, ModExpBase Info VName
me')
where
files' :: ImportTable
files' = (FileModule -> Env) -> Map ImportName FileModule -> ImportTable
forall a b k. (a -> b) -> Map k a -> Map k b
M.map FileModule -> Env
fileEnv (Map ImportName FileModule -> ImportTable)
-> Map ImportName FileModule -> ImportTable
forall a b. (a -> b) -> a -> b
$ Imports -> Map ImportName FileModule
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList Imports
files
initialEnv :: Env
initialEnv :: Env
initialEnv =
Env
intrinsicsModule
{ envModTable :: Map VName Mod
envModTable = Map VName Mod
initialModTable,
envNameMap :: NameMap
envNameMap =
(Namespace, Name) -> QualName VName -> NameMap -> NameMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
(Namespace
Term, FilePath -> Name
nameFromString FilePath
"intrinsics")
(VName -> QualName VName
forall v. v -> QualName v
qualName VName
intrinsics_v)
NameMap
topLevelNameMap
}
where
initialTypeTable :: Map VName TypeBinding
initialTypeTable = [(VName, TypeBinding)] -> Map VName TypeBinding
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, TypeBinding)] -> Map VName TypeBinding)
-> [(VName, TypeBinding)] -> Map VName TypeBinding
forall a b. (a -> b) -> a -> b
$ ((VName, Intrinsic) -> Maybe (VName, TypeBinding))
-> [(VName, Intrinsic)] -> [(VName, TypeBinding)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (VName, Intrinsic) -> Maybe (VName, TypeBinding)
forall {a}. (a, Intrinsic) -> Maybe (a, TypeBinding)
addIntrinsicT ([(VName, Intrinsic)] -> [(VName, TypeBinding)])
-> [(VName, Intrinsic)] -> [(VName, TypeBinding)]
forall a b. (a -> b) -> a -> b
$ Map VName Intrinsic -> [(VName, Intrinsic)]
forall k a. Map k a -> [(k, a)]
M.toList Map VName Intrinsic
intrinsics
initialModTable :: Map VName Mod
initialModTable = VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
intrinsics_v (Env -> Mod
ModEnv Env
intrinsicsModule)
intrinsics_v :: VName
intrinsics_v = Name -> Int -> VName
VName (FilePath -> Name
nameFromString FilePath
"intrinsics") Int
0
intrinsicsModule :: Env
intrinsicsModule = Map VName BoundV
-> Map VName TypeBinding
-> Map VName MTy
-> Map VName Mod
-> NameMap
-> Env
Env Map VName BoundV
forall a. Monoid a => a
mempty Map VName TypeBinding
initialTypeTable Map VName MTy
forall a. Monoid a => a
mempty Map VName Mod
forall a. Monoid a => a
mempty NameMap
intrinsicsNameMap
addIntrinsicT :: (a, Intrinsic) -> Maybe (a, TypeBinding)
addIntrinsicT (a
name, IntrinsicType Liftedness
l [TypeParamBase VName]
ps StructType
t) =
(a, TypeBinding) -> Maybe (a, TypeBinding)
forall a. a -> Maybe a
Just (a
name, Liftedness -> [TypeParamBase VName] -> StructRetType -> TypeBinding
TypeAbbr Liftedness
l [TypeParamBase VName]
ps (StructRetType -> TypeBinding) -> StructRetType -> TypeBinding
forall a b. (a -> b) -> a -> b
$ [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] StructType
t)
addIntrinsicT (a, Intrinsic)
_ =
Maybe (a, TypeBinding)
forall a. Maybe a
Nothing
envWithImports :: Imports -> Env -> Env
envWithImports :: Imports -> Env -> Env
envWithImports Imports
imports Env
env =
[Env] -> Env
forall a. Monoid a => [a] -> a
mconcat (((ImportName, FileModule) -> Env) -> Imports -> [Env]
forall a b. (a -> b) -> [a] -> [b]
map (FileModule -> Env
fileEnv (FileModule -> Env)
-> ((ImportName, FileModule) -> FileModule)
-> (ImportName, FileModule)
-> Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, FileModule) -> FileModule
forall a b. (a, b) -> b
snd) (Imports -> Imports
forall a. [a] -> [a]
reverse Imports
imports)) Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env
checkProgM :: UncheckedProg -> TypeM FileModule
checkProgM :: UncheckedProg -> TypeM FileModule
checkProgM (Prog Maybe DocComment
doc [UncheckedDec]
decs) = do
[UncheckedDec] -> TypeM ()
checkForDuplicateDecs [UncheckedDec]
decs
(TySet
abs, Env
env, [Dec]
decs', Env
full_env) <- [UncheckedDec] -> TypeM (TySet, Env, [Dec], Env)
checkDecs [UncheckedDec]
decs
FileModule -> TypeM FileModule
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet -> Env -> Prog -> Env -> FileModule
FileModule TySet
abs Env
env (Maybe DocComment -> [Dec] -> Prog
forall (f :: * -> *) vn.
Maybe DocComment -> [DecBase f vn] -> ProgBase f vn
Prog Maybe DocComment
doc [Dec]
decs') Env
full_env)
dupDefinitionError ::
(MonadTypeChecker m) =>
Namespace ->
Name ->
SrcLoc ->
SrcLoc ->
m a
dupDefinitionError :: forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> SrcLoc -> m a
dupDefinitionError Namespace
space Name
name SrcLoc
loc1 SrcLoc
loc2 =
SrcLoc -> Notes -> Doc () -> m a
forall loc a. Located loc => loc -> Notes -> Doc () -> m a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc1 Notes
forall a. Monoid a => a
mempty (Doc () -> m a) -> Doc () -> m a
forall a b. (a -> b) -> a -> b
$
Doc ()
"Duplicate definition of"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Namespace -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. Namespace -> Doc ann
pretty Namespace
space
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ()
forall a. Name -> Doc a
forall v a. IsName v => v -> Doc a
prettyName Name
name
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Previously defined at"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FilePath -> Doc ()
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SrcLoc -> FilePath
forall a. Located a => a -> FilePath
locStr SrcLoc
loc2)
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
checkForDuplicateDecs :: [DecBase NoInfo Name] -> TypeM ()
checkForDuplicateDecs :: [UncheckedDec] -> TypeM ()
checkForDuplicateDecs =
(Map (Namespace, Name) SrcLoc
-> UncheckedDec -> TypeM (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc -> [UncheckedDec] -> TypeM ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ((UncheckedDec
-> Map (Namespace, Name) SrcLoc
-> TypeM (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc
-> UncheckedDec
-> TypeM (Map (Namespace, Name) SrcLoc)
forall a b c. (a -> b -> c) -> b -> a -> c
flip UncheckedDec
-> Map (Namespace, Name) SrcLoc
-> TypeM (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *} {f :: * -> *}.
MonadTypeChecker m =>
DecBase f Name
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
f) Map (Namespace, Name) SrcLoc
forall a. Monoid a => a
mempty
where
check :: Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
namespace Name
name SrcLoc
loc Map (Namespace, Name) SrcLoc
known =
case (Namespace, Name) -> Map (Namespace, Name) SrcLoc -> Maybe SrcLoc
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
namespace, Name
name) Map (Namespace, Name) SrcLoc
known of
Just SrcLoc
loc' ->
Namespace
-> Name -> SrcLoc -> SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> SrcLoc -> m a
dupDefinitionError Namespace
namespace Name
name SrcLoc
loc SrcLoc
loc'
Maybe SrcLoc
_ -> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
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
namespace, Name
name) SrcLoc
loc Map (Namespace, Name) SrcLoc
known
f :: DecBase f Name
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
f (ValDec ValBindBase f Name
vb) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Term (ValBindBase f Name -> Name
forall (f :: * -> *) vn. ValBindBase f vn -> vn
valBindName ValBindBase f Name
vb) (ValBindBase f Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf ValBindBase f Name
vb)
f (TypeDec (TypeBind Name
name Liftedness
_ [TypeParamBase Name]
_ TypeExp f Name
_ f StructRetType
_ Maybe DocComment
_ SrcLoc
loc)) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Type Name
name SrcLoc
loc
f (SigDec (SigBind Name
name SigExpBase f Name
_ Maybe DocComment
_ SrcLoc
loc)) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Signature Name
name SrcLoc
loc
f (ModDec (ModBind Name
name [ModParamBase f Name]
_ Maybe (SigExpBase f Name, f (Map VName VName))
_ ModExpBase f Name
_ Maybe DocComment
_ SrcLoc
loc)) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Term Name
name SrcLoc
loc
f OpenDec {} = Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
f LocalDec {} = Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
f ImportDec {} = Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
bindingTypeParams :: [TypeParam] -> TypeM a -> TypeM a
bindingTypeParams :: forall a. [TypeParamBase VName] -> TypeM a -> TypeM a
bindingTypeParams [TypeParamBase VName]
tparams = Env -> TypeM a -> TypeM a
forall a. Env -> TypeM a -> TypeM a
localEnv Env
env
where
env :: Env
env = [Env] -> Env
forall a. Monoid a => [a] -> a
mconcat ([Env] -> Env) -> [Env] -> Env
forall a b. (a -> b) -> a -> b
$ (TypeParamBase VName -> Env) -> [TypeParamBase VName] -> [Env]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase VName -> Env
typeParamEnv [TypeParamBase VName]
tparams
typeParamEnv :: TypeParamBase VName -> Env
typeParamEnv (TypeParamDim VName
v SrcLoc
_) =
Env
forall a. Monoid a => a
mempty
{ envVtable :: Map VName BoundV
envVtable =
VName -> BoundV -> Map VName BoundV
forall k a. k -> a -> Map k a
M.singleton VName
v (BoundV -> Map VName BoundV) -> BoundV -> Map VName BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParamBase VName] -> StructType -> BoundV
BoundV [] (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (ExpBase Info VName) NoUniqueness
forall dim u. PrimType -> ScalarTypeBase dim u
Prim (PrimType -> ScalarTypeBase (ExpBase Info VName) NoUniqueness)
-> PrimType -> ScalarTypeBase (ExpBase Info VName) NoUniqueness
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int64)
}
typeParamEnv (TypeParamType Liftedness
l VName
v SrcLoc
_) =
Env
forall a. Monoid a => a
mempty
{ envTypeTable :: Map VName TypeBinding
envTypeTable =
VName -> TypeBinding -> Map VName TypeBinding
forall k a. k -> a -> Map k a
M.singleton VName
v (TypeBinding -> Map VName TypeBinding)
-> TypeBinding -> Map VName TypeBinding
forall a b. (a -> b) -> a -> b
$
Liftedness -> [TypeParamBase VName] -> StructRetType -> TypeBinding
TypeAbbr Liftedness
l [] (StructRetType -> TypeBinding)
-> (ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> StructRetType)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> TypeBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] (StructType -> StructRetType)
-> (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> StructRetType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> TypeBinding)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness -> TypeBinding
forall a b. (a -> b) -> a -> b
$
NoUniqueness
-> QualName VName
-> [TypeArg (ExpBase Info VName)]
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar NoUniqueness
forall a. Monoid a => a
mempty (VName -> QualName VName
forall v. v -> QualName v
qualName VName
v) []
}
checkTypeDecl ::
UncheckedTypeExp ->
TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
checkTypeDecl :: TypeExp NoInfo Name
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
checkTypeDecl TypeExp NoInfo Name
te = do
(TypeExp Info VName
te', [VName]
svars, RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
l) <- TypeExp NoInfo Name
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
checkTypeExp TypeExp NoInfo Name
te
([VName], TypeExp Info VName, StructType, Liftedness)
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VName]
svars [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ [VName]
dims, TypeExp Info VName
te', TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
st, Liftedness
l)
checkSpecs :: [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs :: [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [] = (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, Env
forall a. Monoid a => a
mempty, [])
checkSpecs (ValSpec Name
name [TypeParamBase Name]
tparams TypeExp NoInfo Name
vtype NoInfo StructType
NoInfo Maybe DocComment
doc SrcLoc
loc : [SpecBase NoInfo Name]
specs) =
[(Namespace, Name)]
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
name)] (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
name SrcLoc
loc
([TypeParamBase VName]
tparams', TypeExp Info VName
vtype', StructType
vtype_t) <-
[TypeParamBase Name]
-> ([TypeParamBase VName]
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType))
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[TypeParamBase Name] -> ([TypeParamBase VName] -> m a) -> m a
checkTypeParams [TypeParamBase Name]
tparams (([TypeParamBase VName]
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType))
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType))
-> ([TypeParamBase VName]
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType))
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
forall a b. (a -> b) -> a -> b
$ \[TypeParamBase VName]
tparams' -> [TypeParamBase VName]
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
forall a. [TypeParamBase VName] -> TypeM a -> TypeM a
bindingTypeParams [TypeParamBase VName]
tparams' (TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType))
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
forall a b. (a -> b) -> a -> b
$ do
([VName]
ext, TypeExp Info VName
vtype', StructType
vtype_t, Liftedness
_) <- TypeExp NoInfo Name
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
checkTypeDecl TypeExp NoInfo Name
vtype
Bool -> TypeM () -> TypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([VName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
ext) (TypeM () -> TypeM ()) -> TypeM () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"All function parameters must have non-anonymous sizes."
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Hint: add size parameters to"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (VName -> Doc ()
forall a. VName -> Doc a
forall v a. IsName v => v -> Doc a
prettyName VName
name')
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
([TypeParamBase VName], TypeExp Info VName, StructType)
-> TypeM ([TypeParamBase VName], TypeExp Info VName, StructType)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeParamBase VName]
tparams', TypeExp Info VName
vtype', StructType
vtype_t)
let binding :: BoundV
binding = [TypeParamBase VName] -> StructType -> BoundV
BoundV [TypeParamBase VName]
tparams' StructType
vtype_t
valenv :: Env
valenv =
Env
forall a. Monoid a => a
mempty
{ envVtable :: Map VName BoundV
envVtable = VName -> BoundV -> Map VName BoundV
forall k a. k -> a -> Map k a
M.singleton VName
name' BoundV
binding,
envNameMap :: NameMap
envNameMap = (Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name'
}
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- Env
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. Env -> TypeM a -> TypeM a
localEnv Env
valenv (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abstypes,
Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
valenv,
VName
-> [TypeParamBase VName]
-> TypeExp Info VName
-> Info StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase Info VName
forall (f :: * -> *) vn.
vn
-> [TypeParamBase vn]
-> TypeExp f vn
-> f StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
ValSpec VName
name' [TypeParamBase VName]
tparams' TypeExp Info VName
vtype' (StructType -> Info StructType
forall a. a -> Info a
Info StructType
vtype_t) Maybe DocComment
doc SrcLoc
loc SpecBase Info VName
-> [SpecBase Info VName] -> [SpecBase Info VName]
forall a. a -> [a] -> [a]
: [SpecBase Info VName]
specs'
)
checkSpecs (TypeAbbrSpec TypeBindBase NoInfo Name
tdec : [SpecBase NoInfo Name]
specs) =
[(Namespace, Name)]
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Type, TypeBindBase NoInfo Name -> Name
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBindBase NoInfo Name
tdec)] (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ do
(Env
tenv, TypeBindBase Info VName
tdec') <- TypeBindBase NoInfo Name -> TypeM (Env, TypeBindBase Info VName)
checkTypeBind TypeBindBase NoInfo Name
tdec
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- Env
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. Env -> TypeM a -> TypeM a
localEnv Env
tenv (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abstypes,
Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
tenv,
TypeBindBase Info VName -> SpecBase Info VName
forall (f :: * -> *) vn. TypeBindBase f vn -> SpecBase f vn
TypeAbbrSpec TypeBindBase Info VName
tdec' SpecBase Info VName
-> [SpecBase Info VName] -> [SpecBase Info VName]
forall a. a -> [a] -> [a]
: [SpecBase Info VName]
specs'
)
checkSpecs (TypeSpec Liftedness
l Name
name [TypeParamBase Name]
ps Maybe DocComment
doc SrcLoc
loc : [SpecBase NoInfo Name]
specs) =
[TypeParamBase Name]
-> ([TypeParamBase VName]
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
forall (m :: * -> *) a.
MonadTypeChecker m =>
[TypeParamBase Name] -> ([TypeParamBase VName] -> m a) -> m a
checkTypeParams [TypeParamBase Name]
ps (([TypeParamBase VName]
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> ([TypeParamBase VName]
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ \[TypeParamBase VName]
ps' ->
[(Namespace, Name)]
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Type, Name
name)] (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Type Name
name SrcLoc
loc
let tenv :: Env
tenv =
Env
forall a. Monoid a => a
mempty
{ envNameMap :: NameMap
envNameMap =
(Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Type, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name',
envTypeTable :: Map VName TypeBinding
envTypeTable =
VName -> TypeBinding -> Map VName TypeBinding
forall k a. k -> a -> Map k a
M.singleton VName
name' (TypeBinding -> Map VName TypeBinding)
-> TypeBinding -> Map VName TypeBinding
forall a b. (a -> b) -> a -> b
$
Liftedness -> [TypeParamBase VName] -> StructRetType -> TypeBinding
TypeAbbr Liftedness
l [TypeParamBase VName]
ps' (StructRetType -> TypeBinding)
-> (ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> StructRetType)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> TypeBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] (StructType -> StructRetType)
-> (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
-> StructRetType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarTypeBase (ExpBase Info VName) NoUniqueness -> StructType
forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar (ScalarTypeBase (ExpBase Info VName) NoUniqueness -> TypeBinding)
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness -> TypeBinding
forall a b. (a -> b) -> a -> b
$
NoUniqueness
-> QualName VName
-> [TypeArg (ExpBase Info VName)]
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar NoUniqueness
forall a. Monoid a => a
mempty (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name') ([TypeArg (ExpBase Info VName)]
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness)
-> [TypeArg (ExpBase Info VName)]
-> ScalarTypeBase (ExpBase Info VName) NoUniqueness
forall a b. (a -> b) -> a -> b
$
(TypeParamBase VName -> TypeArg (ExpBase Info VName))
-> [TypeParamBase VName] -> [TypeArg (ExpBase Info VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase VName -> TypeArg (ExpBase Info VName)
typeParamToArg [TypeParamBase VName]
ps'
}
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- Env
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. Env -> TypeM a -> TypeM a
localEnv Env
tenv (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( QualName VName -> Liftedness -> TySet -> TySet
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name') Liftedness
l TySet
abstypes,
Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
tenv,
Liftedness
-> VName
-> [TypeParamBase VName]
-> Maybe DocComment
-> SrcLoc
-> SpecBase Info VName
forall (f :: * -> *) vn.
Liftedness
-> vn
-> [TypeParamBase vn]
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
TypeSpec Liftedness
l VName
name' [TypeParamBase VName]
ps' Maybe DocComment
doc SrcLoc
loc SpecBase Info VName
-> [SpecBase Info VName] -> [SpecBase Info VName]
forall a. a -> [a] -> [a]
: [SpecBase Info VName]
specs'
)
checkSpecs (ModSpec Name
name SigExpBase NoInfo Name
sig Maybe DocComment
doc SrcLoc
loc : [SpecBase NoInfo Name]
specs) =
[(Namespace, Name)]
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
name)] (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
name SrcLoc
loc
(TySet
_sig_abs, MTy
mty, SigExpBase Info VName
sig') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
sig
let senv :: Env
senv =
Env
forall a. Monoid a => a
mempty
{ envNameMap :: NameMap
envNameMap = (Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name',
envModTable :: Map VName Mod
envModTable = VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
name' (Mod -> Map VName Mod) -> Mod -> Map VName Mod
forall a b. (a -> b) -> a -> b
$ MTy -> Mod
mtyMod MTy
mty
}
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- Env
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. Env -> TypeM a -> TypeM a
localEnv Env
senv (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (QualName VName -> QualName VName) -> TySet -> TySet
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (VName -> QualName VName -> QualName VName
forall v. v -> QualName v -> QualName v
qualify VName
name') (MTy -> TySet
mtyAbs MTy
mty) TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
abstypes,
Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
senv,
VName
-> SigExpBase Info VName
-> Maybe DocComment
-> SrcLoc
-> SpecBase Info VName
forall (f :: * -> *) vn.
vn
-> SigExpBase f vn -> Maybe DocComment -> SrcLoc -> SpecBase f vn
ModSpec VName
name' SigExpBase Info VName
sig' Maybe DocComment
doc SrcLoc
loc SpecBase Info VName
-> [SpecBase Info VName] -> [SpecBase Info VName]
forall a. a -> [a] -> [a]
: [SpecBase Info VName]
specs'
)
checkSpecs (IncludeSpec SigExpBase NoInfo Name
e SrcLoc
loc : [SpecBase NoInfo Name]
specs) = do
(TySet
e_abs, TySet
env_abs, Env
e_env, SigExpBase Info VName
e') <- SigExpBase NoInfo Name
-> TypeM (TySet, TySet, Env, SigExpBase Info VName)
checkSigExpToEnv SigExpBase NoInfo Name
e
(QualName VName -> TypeM ()) -> [QualName VName] -> TypeM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (QualName Name -> TypeM ()
forall {e} {m :: * -> *}.
(MonadError e m, MonadTypeChecker m) =>
QualName Name -> m ()
warnIfShadowing (QualName Name -> TypeM ())
-> (QualName VName -> QualName Name) -> QualName VName -> TypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName -> Name) -> QualName VName -> QualName Name
forall a b. (a -> b) -> QualName a -> QualName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VName -> Name
baseName) ([QualName VName] -> TypeM ()) -> [QualName VName] -> TypeM ()
forall a b. (a -> b) -> a -> b
$ TySet -> [QualName VName]
forall k a. Map k a -> [k]
M.keys TySet
env_abs
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- Env
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. Env -> TypeM a -> TypeM a
localEnv Env
e_env (TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName]))
-> TypeM (TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a b. (a -> b) -> a -> b
$ [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, Env, [SpecBase Info VName])
-> TypeM (TySet, Env, [SpecBase Info VName])
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
e_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
env_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
abstypes,
Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
e_env,
SigExpBase Info VName -> SrcLoc -> SpecBase Info VName
forall (f :: * -> *) vn. SigExpBase f vn -> SrcLoc -> SpecBase f vn
IncludeSpec SigExpBase Info VName
e' SrcLoc
loc SpecBase Info VName
-> [SpecBase Info VName] -> [SpecBase Info VName]
forall a. a -> [a] -> [a]
: [SpecBase Info VName]
specs'
)
where
warnIfShadowing :: QualName Name -> m ()
warnIfShadowing QualName Name
qn =
(SrcLoc
-> QualName Name
-> m (QualName VName, [TypeParamBase VName], StructRetType,
Liftedness)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc
-> QualName Name
-> m (QualName VName, [TypeParamBase VName], StructRetType,
Liftedness)
lookupType SrcLoc
loc QualName Name
qn m (QualName VName, [TypeParamBase VName], StructRetType,
Liftedness)
-> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> QualName Name -> m ()
forall {m :: * -> *} {a}.
(MonadTypeChecker m, Pretty a) =>
a -> m ()
warnAbout QualName Name
qn)
m () -> (e -> m ()) -> m ()
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnAbout :: a -> m ()
warnAbout a
qn =
SrcLoc -> Doc () -> m ()
forall loc. Located loc => loc -> 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 ()
"Inclusion shadows type" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (a -> Doc ()
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
qn) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"."
checkSigExp :: SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp :: SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp (SigParens SigExpBase NoInfo Name
e SrcLoc
loc) = do
(TySet
abs, MTy
mty, SigExpBase Info VName
e') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
e
(TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, MTy
mty, SigExpBase Info VName -> SrcLoc -> SigExpBase Info VName
forall (f :: * -> *) vn.
SigExpBase f vn -> SrcLoc -> SigExpBase f vn
SigParens SigExpBase Info VName
e' SrcLoc
loc)
checkSigExp (SigVar QualName Name
name NoInfo (Map VName VName)
NoInfo SrcLoc
loc) = do
(QualName VName
name', MTy
mty) <- SrcLoc -> QualName Name -> TypeM (QualName VName, MTy)
lookupMTy SrcLoc
loc QualName Name
name
(MTy
mty', Map VName VName
substs) <- MTy -> TypeM (MTy, Map VName VName)
newNamesForMTy MTy
mty
(TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTy -> TySet
mtyAbs MTy
mty', MTy
mty', QualName VName
-> Info (Map VName VName) -> SrcLoc -> SigExpBase Info VName
forall (f :: * -> *) vn.
QualName vn -> f (Map VName VName) -> SrcLoc -> SigExpBase f vn
SigVar QualName VName
name' (Map VName VName -> Info (Map VName VName)
forall a. a -> Info a
Info Map VName VName
substs) SrcLoc
loc)
checkSigExp (SigSpecs [SpecBase NoInfo Name]
specs SrcLoc
loc) = do
[SpecBase NoInfo Name] -> TypeM ()
checkForDuplicateSpecs [SpecBase NoInfo Name]
specs
(TySet
abstypes, Env
env, [SpecBase Info VName]
specs') <- [SpecBase NoInfo Name] -> TypeM (TySet, Env, [SpecBase Info VName])
checkSpecs [SpecBase NoInfo Name]
specs
(TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abstypes, TySet -> Mod -> MTy
MTy TySet
abstypes (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ Env -> Mod
ModEnv Env
env, [SpecBase Info VName] -> SrcLoc -> SigExpBase Info VName
forall (f :: * -> *) vn.
[SpecBase f vn] -> SrcLoc -> SigExpBase f vn
SigSpecs [SpecBase Info VName]
specs' SrcLoc
loc)
checkSigExp (SigWith SigExpBase NoInfo Name
s (TypeRef QualName Name
tname [TypeParamBase Name]
ps TypeExp NoInfo Name
te SrcLoc
trloc) SrcLoc
loc) = do
(TySet
abs, TySet
s_abs, Env
s_env, SigExpBase Info VName
s') <- SigExpBase NoInfo Name
-> TypeM (TySet, TySet, Env, SigExpBase Info VName)
checkSigExpToEnv SigExpBase NoInfo Name
s
[TypeParamBase Name]
-> ([TypeParamBase VName]
-> TypeM (TySet, MTy, SigExpBase Info VName))
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[TypeParamBase Name] -> ([TypeParamBase VName] -> m a) -> m a
checkTypeParams [TypeParamBase Name]
ps (([TypeParamBase VName]
-> TypeM (TySet, MTy, SigExpBase Info VName))
-> TypeM (TySet, MTy, SigExpBase Info VName))
-> ([TypeParamBase VName]
-> TypeM (TySet, MTy, SigExpBase Info VName))
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ \[TypeParamBase VName]
ps' -> do
([VName]
ext, TypeExp Info VName
te', StructType
te_t, Liftedness
_) <- [TypeParamBase VName]
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
forall a. [TypeParamBase VName] -> TypeM a -> TypeM a
bindingTypeParams [TypeParamBase VName]
ps' (TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness))
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
forall a b. (a -> b) -> a -> b
$ TypeExp NoInfo Name
-> TypeM ([VName], TypeExp Info VName, StructType, Liftedness)
checkTypeDecl TypeExp NoInfo Name
te
Bool -> TypeM () -> TypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([VName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
ext) (TypeM () -> TypeM ()) -> TypeM () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
TypeExp Info VName -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError TypeExp Info VName
te' Notes
forall a. Monoid a => a
mempty Doc ()
"Anonymous dimensions are not allowed here."
(QualName VName
tname', TySet
s_abs', Env
s_env') <- SrcLoc
-> TySet
-> Env
-> QualName Name
-> [TypeParamBase VName]
-> StructType
-> TypeM (QualName VName, TySet, Env)
refineEnv SrcLoc
loc TySet
s_abs Env
s_env QualName Name
tname [TypeParamBase VName]
ps' StructType
te_t
(TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, TySet -> Mod -> MTy
MTy TySet
s_abs' (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ Env -> Mod
ModEnv Env
s_env', SigExpBase Info VName
-> TypeRefBase Info VName -> SrcLoc -> SigExpBase Info VName
forall (f :: * -> *) vn.
SigExpBase f vn -> TypeRefBase f vn -> SrcLoc -> SigExpBase f vn
SigWith SigExpBase Info VName
s' (QualName VName
-> [TypeParamBase VName]
-> TypeExp Info VName
-> SrcLoc
-> TypeRefBase Info VName
forall (f :: * -> *) vn.
QualName vn
-> [TypeParamBase vn] -> TypeExp f vn -> SrcLoc -> TypeRefBase f vn
TypeRef QualName VName
tname' [TypeParamBase VName]
ps' TypeExp Info VName
te' SrcLoc
trloc) SrcLoc
loc)
checkSigExp (SigArrow Maybe Name
maybe_pname SigExpBase NoInfo Name
e1 SigExpBase NoInfo Name
e2 SrcLoc
loc) = do
(TySet
e1_abs, MTy TySet
s_abs Mod
e1_mod, SigExpBase Info VName
e1') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
e1
(Env
env_for_e2, Maybe VName
maybe_pname') <-
case Maybe Name
maybe_pname of
Just Name
pname -> [(Namespace, Name)]
-> TypeM (Env, Maybe VName) -> TypeM (Env, Maybe VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
pname)] (TypeM (Env, Maybe VName) -> TypeM (Env, Maybe VName))
-> TypeM (Env, Maybe VName) -> TypeM (Env, Maybe VName)
forall a b. (a -> b) -> a -> b
$ do
VName
pname' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
pname SrcLoc
loc
(Env, Maybe VName) -> TypeM (Env, Maybe VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Env
forall a. Monoid a => a
mempty
{ envNameMap :: NameMap
envNameMap = (Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
pname) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
pname',
envModTable :: Map VName Mod
envModTable = VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
pname' Mod
e1_mod
},
VName -> Maybe VName
forall a. a -> Maybe a
Just VName
pname'
)
Maybe Name
Nothing ->
(Env, Maybe VName) -> TypeM (Env, Maybe VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
forall a. Monoid a => a
mempty, Maybe VName
forall a. Maybe a
Nothing)
(TySet
e2_abs, MTy
e2_mod, SigExpBase Info VName
e2') <- Env
-> TypeM (TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. Env -> TypeM a -> TypeM a
localEnv Env
env_for_e2 (TypeM (TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName))
-> TypeM (TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
e2
(TySet, MTy, SigExpBase Info VName)
-> TypeM (TySet, MTy, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
e1_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
e2_abs,
TySet -> Mod -> MTy
MTy TySet
forall a. Monoid a => a
mempty (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ FunSig -> Mod
ModFun (FunSig -> Mod) -> FunSig -> Mod
forall a b. (a -> b) -> a -> b
$ TySet -> Mod -> MTy -> FunSig
FunSig TySet
s_abs Mod
e1_mod MTy
e2_mod,
Maybe VName
-> SigExpBase Info VName
-> SigExpBase Info VName
-> SrcLoc
-> SigExpBase Info VName
forall (f :: * -> *) vn.
Maybe vn
-> SigExpBase f vn -> SigExpBase f vn -> SrcLoc -> SigExpBase f vn
SigArrow Maybe VName
maybe_pname' SigExpBase Info VName
e1' SigExpBase Info VName
e2' SrcLoc
loc
)
checkSigExpToEnv ::
SigExpBase NoInfo Name ->
TypeM (TySet, TySet, Env, SigExpBase Info VName)
checkSigExpToEnv :: SigExpBase NoInfo Name
-> TypeM (TySet, TySet, Env, SigExpBase Info VName)
checkSigExpToEnv SigExpBase NoInfo Name
e = do
(TySet
abs, MTy TySet
mod_abs Mod
mod, SigExpBase Info VName
e') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
e
case Mod
mod of
ModEnv Env
env -> (TySet, TySet, Env, SigExpBase Info VName)
-> TypeM (TySet, TySet, Env, SigExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, TySet
mod_abs, Env
env, SigExpBase Info VName
e')
ModFun {} -> SrcLoc -> TypeM (TySet, TySet, Env, SigExpBase Info VName)
forall (m :: * -> *) a. MonadTypeChecker m => SrcLoc -> m a
unappliedFunctor (SrcLoc -> TypeM (TySet, TySet, Env, SigExpBase Info VName))
-> SrcLoc -> TypeM (TySet, TySet, Env, SigExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ SigExpBase NoInfo Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf SigExpBase NoInfo Name
e
checkSigBind :: SigBindBase NoInfo Name -> TypeM (TySet, Env, SigBindBase Info VName)
checkSigBind :: SigBindBase NoInfo Name
-> TypeM (TySet, Env, SigBindBase Info VName)
checkSigBind (SigBind Name
name SigExpBase NoInfo Name
e Maybe DocComment
doc SrcLoc
loc) = do
(TySet
abs, MTy
env, SigExpBase Info VName
e') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
e
[(Namespace, Name)]
-> TypeM (TySet, Env, SigBindBase Info VName)
-> TypeM (TySet, Env, SigBindBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Signature, Name
name)] (TypeM (TySet, Env, SigBindBase Info VName)
-> TypeM (TySet, Env, SigBindBase Info VName))
-> TypeM (TySet, Env, SigBindBase Info VName)
-> TypeM (TySet, Env, SigBindBase Info VName)
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Signature Name
name SrcLoc
loc
(TySet, Env, SigBindBase Info VName)
-> TypeM (TySet, Env, SigBindBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abs,
Env
forall a. Monoid a => a
mempty
{ envSigTable :: Map VName MTy
envSigTable = VName -> MTy -> Map VName MTy
forall k a. k -> a -> Map k a
M.singleton VName
name' MTy
env,
envNameMap :: NameMap
envNameMap = (Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Signature, Name
name) (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name')
},
VName
-> SigExpBase Info VName
-> Maybe DocComment
-> SrcLoc
-> SigBindBase Info VName
forall (f :: * -> *) vn.
vn
-> SigExpBase f vn
-> Maybe DocComment
-> SrcLoc
-> SigBindBase f vn
SigBind VName
name' SigExpBase Info VName
e' Maybe DocComment
doc SrcLoc
loc
)
checkOneModExp ::
ModExpBase NoInfo Name ->
TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp :: ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp (ModParens ModExpBase NoInfo Name
e SrcLoc
loc) = do
(TySet
abs, MTy
mty, ModExpBase Info VName
e') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
e
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, MTy
mty, ModExpBase Info VName -> SrcLoc -> ModExpBase Info VName
forall (f :: * -> *) vn.
ModExpBase f vn -> SrcLoc -> ModExpBase f vn
ModParens ModExpBase Info VName
e' SrcLoc
loc)
checkOneModExp (ModDecs [UncheckedDec]
decs SrcLoc
loc) = do
[UncheckedDec] -> TypeM ()
checkForDuplicateDecs [UncheckedDec]
decs
(TySet
abstypes, Env
env, [Dec]
decs', Env
_) <- [UncheckedDec] -> TypeM (TySet, Env, [Dec], Env)
checkDecs [UncheckedDec]
decs
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abstypes,
TySet -> Mod -> MTy
MTy TySet
abstypes (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ Env -> Mod
ModEnv Env
env,
[Dec] -> SrcLoc -> ModExpBase Info VName
forall (f :: * -> *) vn.
[DecBase f vn] -> SrcLoc -> ModExpBase f vn
ModDecs [Dec]
decs' SrcLoc
loc
)
checkOneModExp (ModVar QualName Name
v SrcLoc
loc) = do
(QualName VName
v', Mod
env) <- SrcLoc -> QualName Name -> TypeM (QualName VName, Mod)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, Mod)
lookupMod SrcLoc
loc QualName Name
v
Bool -> TypeM () -> TypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
( VName -> Name
baseName (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v') Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Name
nameFromString FilePath
"intrinsics"
Bool -> Bool -> Bool
&& VName -> Int
baseTag (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIntrinsicTag
)
(TypeM () -> TypeM ()) -> TypeM () -> TypeM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty Doc ()
"The 'intrinsics' module may not be used in module expressions."
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, TySet -> Mod -> MTy
MTy TySet
forall a. Monoid a => a
mempty Mod
env, QualName VName -> SrcLoc -> ModExpBase Info VName
forall (f :: * -> *) vn. QualName vn -> SrcLoc -> ModExpBase f vn
ModVar QualName VName
v' SrcLoc
loc)
checkOneModExp (ModImport FilePath
name NoInfo ImportName
NoInfo SrcLoc
loc) = do
(ImportName
name', Env
env) <- SrcLoc -> FilePath -> TypeM (ImportName, Env)
lookupImport SrcLoc
loc FilePath
name
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
forall a. Monoid a => a
mempty,
TySet -> Mod -> MTy
MTy TySet
forall a. Monoid a => a
mempty (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ Env -> Mod
ModEnv Env
env,
FilePath -> Info ImportName -> SrcLoc -> ModExpBase Info VName
forall (f :: * -> *) vn.
FilePath -> f ImportName -> SrcLoc -> ModExpBase f vn
ModImport FilePath
name (ImportName -> Info ImportName
forall a. a -> Info a
Info ImportName
name') SrcLoc
loc
)
checkOneModExp (ModApply ModExpBase NoInfo Name
f ModExpBase NoInfo Name
e NoInfo (Map VName VName)
NoInfo NoInfo (Map VName VName)
NoInfo SrcLoc
loc) = do
(TySet
f_abs, MTy
f_mty, ModExpBase Info VName
f') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
f
case MTy -> Mod
mtyMod MTy
f_mty of
ModFun FunSig
functor -> do
(TySet
e_abs, MTy
e_mty, ModExpBase Info VName
e') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
e
(MTy
mty, Map VName VName
psubsts, Map VName VName
rsubsts) <- Loc
-> FunSig -> MTy -> TypeM (MTy, Map VName VName, Map VName VName)
applyFunctor (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc) FunSig
functor MTy
e_mty
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( MTy -> TySet
mtyAbs MTy
mty TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
f_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
e_abs,
MTy
mty,
ModExpBase Info VName
-> ModExpBase Info VName
-> Info (Map VName VName)
-> Info (Map VName VName)
-> SrcLoc
-> ModExpBase Info VName
forall (f :: * -> *) vn.
ModExpBase f vn
-> ModExpBase f vn
-> f (Map VName VName)
-> f (Map VName VName)
-> SrcLoc
-> ModExpBase f vn
ModApply ModExpBase Info VName
f' ModExpBase Info VName
e' (Map VName VName -> Info (Map VName VName)
forall a. a -> Info a
Info Map VName VName
psubsts) (Map VName VName -> Info (Map VName VName)
forall a. a -> Info a
Info Map VName VName
rsubsts) SrcLoc
loc
)
Mod
_ ->
SrcLoc
-> Notes -> Doc () -> TypeM (TySet, MTy, ModExpBase Info VName)
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty Doc ()
"Cannot apply non-parametric module."
checkOneModExp (ModAscript ModExpBase NoInfo Name
me SigExpBase NoInfo Name
se NoInfo (Map VName VName)
NoInfo SrcLoc
loc) = do
(TySet
me_abs, MTy
me_mod, ModExpBase Info VName
me') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
me
(TySet
se_abs, MTy
se_mty, SigExpBase Info VName
se') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
se
Map VName VName
match_subst <- Either TypeError (Map VName VName) -> TypeM (Map VName VName)
forall a. Either TypeError a -> TypeM a
badOnLeft (Either TypeError (Map VName VName) -> TypeM (Map VName VName))
-> Either TypeError (Map VName VName) -> TypeM (Map VName VName)
forall a b. (a -> b) -> a -> b
$ MTy -> MTy -> Loc -> Either TypeError (Map VName VName)
matchMTys MTy
me_mod MTy
se_mty (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc)
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
se_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
me_abs, MTy
se_mty, ModExpBase Info VName
-> SigExpBase Info VName
-> Info (Map VName VName)
-> SrcLoc
-> ModExpBase Info VName
forall (f :: * -> *) vn.
ModExpBase f vn
-> SigExpBase f vn
-> f (Map VName VName)
-> SrcLoc
-> ModExpBase f vn
ModAscript ModExpBase Info VName
me' SigExpBase Info VName
se' (Map VName VName -> Info (Map VName VName)
forall a. a -> Info a
Info Map VName VName
match_subst) SrcLoc
loc)
checkOneModExp (ModLambda ModParamBase NoInfo Name
param Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e ModExpBase NoInfo Name
body_e SrcLoc
loc) =
ModParamBase NoInfo Name
-> (ModParamBase Info VName
-> TySet -> Mod -> TypeM (TySet, MTy, ModExpBase Info VName))
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a.
ModParamBase NoInfo Name
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
withModParam ModParamBase NoInfo Name
param ((ModParamBase Info VName
-> TySet -> Mod -> TypeM (TySet, MTy, ModExpBase Info VName))
-> TypeM (TySet, MTy, ModExpBase Info VName))
-> (ModParamBase Info VName
-> TySet -> Mod -> TypeM (TySet, MTy, ModExpBase Info VName))
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ \ModParamBase Info VName
param' TySet
param_abs Mod
param_mod -> do
(TySet
abs, Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e', ModExpBase Info VName
body_e', MTy
mty) <-
Maybe (SigExpBase NoInfo Name)
-> ModExpBase NoInfo Name
-> SrcLoc
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
checkModBody ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name
forall a b. (a, b) -> a
fst ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name)
-> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> Maybe (SigExpBase NoInfo Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e) ModExpBase NoInfo Name
body_e SrcLoc
loc
(TySet, MTy, ModExpBase Info VName)
-> TypeM (TySet, MTy, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abs,
TySet -> Mod -> MTy
MTy TySet
forall a. Monoid a => a
mempty (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ FunSig -> Mod
ModFun (FunSig -> Mod) -> FunSig -> Mod
forall a b. (a -> b) -> a -> b
$ TySet -> Mod -> MTy -> FunSig
FunSig TySet
param_abs Mod
param_mod MTy
mty,
ModParamBase Info VName
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
-> ModExpBase Info VName
-> SrcLoc
-> ModExpBase Info VName
forall (f :: * -> *) vn.
ModParamBase f vn
-> Maybe (SigExpBase f vn, f (Map VName VName))
-> ModExpBase f vn
-> SrcLoc
-> ModExpBase f vn
ModLambda ModParamBase Info VName
param' Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e' ModExpBase Info VName
body_e' SrcLoc
loc
)
checkOneModExpToEnv :: ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName)
checkOneModExpToEnv :: ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName)
checkOneModExpToEnv ModExpBase NoInfo Name
e = do
(TySet
e_abs, MTy TySet
abs Mod
mod, ModExpBase Info VName
e') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
e
case Mod
mod of
ModEnv Env
env -> (TySet, Env, ModExpBase Info VName)
-> TypeM (TySet, Env, ModExpBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
e_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
abs, Env
env, ModExpBase Info VName
e')
ModFun {} -> SrcLoc -> TypeM (TySet, Env, ModExpBase Info VName)
forall (m :: * -> *) a. MonadTypeChecker m => SrcLoc -> m a
unappliedFunctor (SrcLoc -> TypeM (TySet, Env, ModExpBase Info VName))
-> SrcLoc -> TypeM (TySet, Env, ModExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ ModExpBase NoInfo Name -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf ModExpBase NoInfo Name
e
withModParam ::
ModParamBase NoInfo Name ->
(ModParamBase Info VName -> TySet -> Mod -> TypeM a) ->
TypeM a
withModParam :: forall a.
ModParamBase NoInfo Name
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
withModParam (ModParam Name
pname SigExpBase NoInfo Name
psig_e NoInfo [VName]
NoInfo SrcLoc
loc) ModParamBase Info VName -> TySet -> Mod -> TypeM a
m = do
(TySet
_abs, MTy TySet
p_abs Mod
p_mod, SigExpBase Info VName
psig_e') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
psig_e
[(Namespace, Name)] -> TypeM a -> TypeM a
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
pname)] (TypeM a -> TypeM a) -> TypeM a -> TypeM a
forall a b. (a -> b) -> a -> b
$ do
VName
pname' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
pname SrcLoc
loc
let in_body_env :: Env
in_body_env = Env
forall a. Monoid a => a
mempty {envModTable :: Map VName Mod
envModTable = VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
pname' Mod
p_mod}
Env -> TypeM a -> TypeM a
forall a. Env -> TypeM a -> TypeM a
localEnv Env
in_body_env (TypeM a -> TypeM a) -> TypeM a -> TypeM a
forall a b. (a -> b) -> a -> b
$
ModParamBase Info VName -> TySet -> Mod -> TypeM a
m (VName
-> SigExpBase Info VName
-> Info [VName]
-> SrcLoc
-> ModParamBase Info VName
forall (f :: * -> *) vn.
vn -> SigExpBase f vn -> f [VName] -> SrcLoc -> ModParamBase f vn
ModParam VName
pname' SigExpBase Info VName
psig_e' ([VName] -> Info [VName]
forall a. a -> Info a
Info ([VName] -> Info [VName]) -> [VName] -> Info [VName]
forall a b. (a -> b) -> a -> b
$ (QualName VName -> VName) -> [QualName VName] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf ([QualName VName] -> [VName]) -> [QualName VName] -> [VName]
forall a b. (a -> b) -> a -> b
$ TySet -> [QualName VName]
forall k a. Map k a -> [k]
M.keys TySet
p_abs) SrcLoc
loc) TySet
p_abs Mod
p_mod
withModParams ::
[ModParamBase NoInfo Name] ->
([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) ->
TypeM a
withModParams :: forall a.
[ModParamBase NoInfo Name]
-> ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a
withModParams [] [(ModParamBase Info VName, TySet, Mod)] -> TypeM a
m = [(ModParamBase Info VName, TySet, Mod)] -> TypeM a
m []
withModParams (ModParamBase NoInfo Name
p : [ModParamBase NoInfo Name]
ps) [(ModParamBase Info VName, TySet, Mod)] -> TypeM a
m =
ModParamBase NoInfo Name
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
forall a.
ModParamBase NoInfo Name
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
withModParam ModParamBase NoInfo Name
p ((ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a)
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
forall a b. (a -> b) -> a -> b
$ \ModParamBase Info VName
p' TySet
pabs Mod
pmod ->
[ModParamBase NoInfo Name]
-> ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a
forall a.
[ModParamBase NoInfo Name]
-> ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a
withModParams [ModParamBase NoInfo Name]
ps (([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a)
-> ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a
forall a b. (a -> b) -> a -> b
$ \[(ModParamBase Info VName, TySet, Mod)]
ps' -> [(ModParamBase Info VName, TySet, Mod)] -> TypeM a
m ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a)
-> [(ModParamBase Info VName, TySet, Mod)] -> TypeM a
forall a b. (a -> b) -> a -> b
$ (ModParamBase Info VName
p', TySet
pabs, Mod
pmod) (ModParamBase Info VName, TySet, Mod)
-> [(ModParamBase Info VName, TySet, Mod)]
-> [(ModParamBase Info VName, TySet, Mod)]
forall a. a -> [a] -> [a]
: [(ModParamBase Info VName, TySet, Mod)]
ps'
checkModBody ::
Maybe (SigExpBase NoInfo Name) ->
ModExpBase NoInfo Name ->
SrcLoc ->
TypeM
( TySet,
Maybe (SigExp, Info (M.Map VName VName)),
ModExp,
MTy
)
checkModBody :: Maybe (SigExpBase NoInfo Name)
-> ModExpBase NoInfo Name
-> SrcLoc
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
checkModBody Maybe (SigExpBase NoInfo Name)
maybe_fsig_e ModExpBase NoInfo Name
body_e SrcLoc
loc = TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
forall a. TypeM a -> TypeM a
enteringModule (TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy))
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
forall a b. (a -> b) -> a -> b
$ do
(TySet
body_e_abs, MTy
body_mty, ModExpBase Info VName
body_e') <- ModExpBase NoInfo Name -> TypeM (TySet, MTy, ModExpBase Info VName)
checkOneModExp ModExpBase NoInfo Name
body_e
case Maybe (SigExpBase NoInfo Name)
maybe_fsig_e of
Maybe (SigExpBase NoInfo Name)
Nothing ->
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( MTy -> TySet
mtyAbs MTy
body_mty TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
body_e_abs,
Maybe (SigExpBase Info VName, Info (Map VName VName))
forall a. Maybe a
Nothing,
ModExpBase Info VName
body_e',
MTy
body_mty
)
Just SigExpBase NoInfo Name
fsig_e -> do
(TySet
fsig_abs, MTy
fsig_mty, SigExpBase Info VName
fsig_e') <- SigExpBase NoInfo Name -> TypeM (TySet, MTy, SigExpBase Info VName)
checkSigExp SigExpBase NoInfo Name
fsig_e
Map VName VName
fsig_subst <- Either TypeError (Map VName VName) -> TypeM (Map VName VName)
forall a. Either TypeError a -> TypeM a
badOnLeft (Either TypeError (Map VName VName) -> TypeM (Map VName VName))
-> Either TypeError (Map VName VName) -> TypeM (Map VName VName)
forall a b. (a -> b) -> a -> b
$ MTy -> MTy -> Loc -> Either TypeError (Map VName VName)
matchMTys MTy
body_mty MTy
fsig_mty (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc)
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
fsig_abs TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
body_e_abs,
(SigExpBase Info VName, Info (Map VName VName))
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
forall a. a -> Maybe a
Just (SigExpBase Info VName
fsig_e', Map VName VName -> Info (Map VName VName)
forall a. a -> Info a
Info Map VName VName
fsig_subst),
ModExpBase Info VName
body_e',
MTy
fsig_mty
)
checkModBind :: ModBindBase NoInfo Name -> TypeM (TySet, Env, ModBindBase Info VName)
checkModBind :: ModBindBase NoInfo Name
-> TypeM (TySet, Env, ModBindBase Info VName)
checkModBind (ModBind Name
name [] Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e ModExpBase NoInfo Name
e Maybe DocComment
doc SrcLoc
loc) = do
(TySet
e_abs, Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e', ModExpBase Info VName
e', MTy
mty) <- Maybe (SigExpBase NoInfo Name)
-> ModExpBase NoInfo Name
-> SrcLoc
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
checkModBody ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name
forall a b. (a, b) -> a
fst ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name)
-> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> Maybe (SigExpBase NoInfo Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e) ModExpBase NoInfo Name
e SrcLoc
loc
[(Namespace, Name)]
-> TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
name)] (TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName))
-> TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
name SrcLoc
loc
(TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
e_abs,
Env
forall a. Monoid a => a
mempty
{ envModTable :: Map VName Mod
envModTable = VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
name' (Mod -> Map VName Mod) -> Mod -> Map VName Mod
forall a b. (a -> b) -> a -> b
$ MTy -> Mod
mtyMod MTy
mty,
envNameMap :: NameMap
envNameMap = (Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name'
},
VName
-> [ModParamBase Info VName]
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
-> ModExpBase Info VName
-> Maybe DocComment
-> SrcLoc
-> ModBindBase Info VName
forall (f :: * -> *) vn.
vn
-> [ModParamBase f vn]
-> Maybe (SigExpBase f vn, f (Map VName VName))
-> ModExpBase f vn
-> Maybe DocComment
-> SrcLoc
-> ModBindBase f vn
ModBind VName
name' [] Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e' ModExpBase Info VName
e' Maybe DocComment
doc SrcLoc
loc
)
checkModBind (ModBind Name
name (ModParamBase NoInfo Name
p : [ModParamBase NoInfo Name]
ps) Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e ModExpBase NoInfo Name
body_e Maybe DocComment
doc SrcLoc
loc) = do
(TySet
abs, [ModParamBase Info VName]
params', Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e', ModExpBase Info VName
body_e', FunSig
funsig) <-
ModParamBase NoInfo Name
-> (ModParamBase Info VName
-> TySet
-> Mod
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
forall a.
ModParamBase NoInfo Name
-> (ModParamBase Info VName -> TySet -> Mod -> TypeM a) -> TypeM a
withModParam ModParamBase NoInfo Name
p ((ModParamBase Info VName
-> TySet
-> Mod
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> (ModParamBase Info VName
-> TySet
-> Mod
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
forall a b. (a -> b) -> a -> b
$ \ModParamBase Info VName
p' TySet
p_abs Mod
p_mod ->
[ModParamBase NoInfo Name]
-> ([(ModParamBase Info VName, TySet, Mod)]
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
forall a.
[ModParamBase NoInfo Name]
-> ([(ModParamBase Info VName, TySet, Mod)] -> TypeM a) -> TypeM a
withModParams [ModParamBase NoInfo Name]
ps (([(ModParamBase Info VName, TySet, Mod)]
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> ([(ModParamBase Info VName, TySet, Mod)]
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig))
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
forall a b. (a -> b) -> a -> b
$ \[(ModParamBase Info VName, TySet, Mod)]
params_stuff -> do
let ([ModParamBase Info VName]
ps', [TySet]
ps_abs, [Mod]
ps_mod) = [(ModParamBase Info VName, TySet, Mod)]
-> ([ModParamBase Info VName], [TySet], [Mod])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(ModParamBase Info VName, TySet, Mod)]
params_stuff
(TySet
abs, Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e', ModExpBase Info VName
body_e', MTy
mty) <- Maybe (SigExpBase NoInfo Name)
-> ModExpBase NoInfo Name
-> SrcLoc
-> TypeM
(TySet, Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, MTy)
checkModBody ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name
forall a b. (a, b) -> a
fst ((SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> SigExpBase NoInfo Name)
-> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
-> Maybe (SigExpBase NoInfo Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SigExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_fsig_e) ModExpBase NoInfo Name
body_e SrcLoc
loc
let addParam :: (TySet, Mod) -> MTy -> MTy
addParam (TySet
x, Mod
y) MTy
mty' = TySet -> Mod -> MTy
MTy TySet
forall a. Monoid a => a
mempty (Mod -> MTy) -> Mod -> MTy
forall a b. (a -> b) -> a -> b
$ FunSig -> Mod
ModFun (FunSig -> Mod) -> FunSig -> Mod
forall a b. (a -> b) -> a -> b
$ TySet -> Mod -> MTy -> FunSig
FunSig TySet
x Mod
y MTy
mty'
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
-> TypeM
(TySet, [ModParamBase Info VName],
Maybe (SigExpBase Info VName, Info (Map VName VName)),
ModExpBase Info VName, FunSig)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abs,
ModParamBase Info VName
p' ModParamBase Info VName
-> [ModParamBase Info VName] -> [ModParamBase Info VName]
forall a. a -> [a] -> [a]
: [ModParamBase Info VName]
ps',
Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e',
ModExpBase Info VName
body_e',
TySet -> Mod -> MTy -> FunSig
FunSig TySet
p_abs Mod
p_mod (MTy -> FunSig) -> MTy -> FunSig
forall a b. (a -> b) -> a -> b
$ ((TySet, Mod) -> MTy -> MTy) -> MTy -> [(TySet, Mod)] -> MTy
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TySet, Mod) -> MTy -> MTy
addParam MTy
mty ([(TySet, Mod)] -> MTy) -> [(TySet, Mod)] -> MTy
forall a b. (a -> b) -> a -> b
$ [TySet] -> [Mod] -> [(TySet, Mod)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TySet]
ps_abs [Mod]
ps_mod
)
[(Namespace, Name)]
-> TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Term, Name
name)] (TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName))
-> TypeM (TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Term Name
name SrcLoc
loc
(TySet, Env, ModBindBase Info VName)
-> TypeM (TySet, Env, ModBindBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
abs,
Env
forall a. Monoid a => a
mempty
{ envModTable :: Map VName Mod
envModTable =
VName -> Mod -> Map VName Mod
forall k a. k -> a -> Map k a
M.singleton VName
name' (Mod -> Map VName Mod) -> Mod -> Map VName Mod
forall a b. (a -> b) -> a -> b
$ FunSig -> Mod
ModFun FunSig
funsig,
envNameMap :: NameMap
envNameMap =
(Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name'
},
VName
-> [ModParamBase Info VName]
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
-> ModExpBase Info VName
-> Maybe DocComment
-> SrcLoc
-> ModBindBase Info VName
forall (f :: * -> *) vn.
vn
-> [ModParamBase f vn]
-> Maybe (SigExpBase f vn, f (Map VName VName))
-> ModExpBase f vn
-> Maybe DocComment
-> SrcLoc
-> ModBindBase f vn
ModBind VName
name' [ModParamBase Info VName]
params' Maybe (SigExpBase Info VName, Info (Map VName VName))
maybe_fsig_e' ModExpBase Info VName
body_e' Maybe DocComment
doc SrcLoc
loc
)
checkForDuplicateSpecs :: [SpecBase NoInfo Name] -> TypeM ()
checkForDuplicateSpecs :: [SpecBase NoInfo Name] -> TypeM ()
checkForDuplicateSpecs =
(Map (Namespace, Name) SrcLoc
-> SpecBase NoInfo Name -> TypeM (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc
-> [SpecBase NoInfo Name]
-> TypeM ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ((SpecBase NoInfo Name
-> Map (Namespace, Name) SrcLoc
-> TypeM (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc
-> SpecBase NoInfo Name
-> TypeM (Map (Namespace, Name) SrcLoc)
forall a b c. (a -> b -> c) -> b -> a -> c
flip SpecBase NoInfo Name
-> Map (Namespace, Name) SrcLoc
-> TypeM (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *} {f :: * -> *}.
MonadTypeChecker m =>
SpecBase f Name
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
f) Map (Namespace, Name) SrcLoc
forall a. Monoid a => a
mempty
where
check :: Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
namespace Name
name SrcLoc
loc Map (Namespace, Name) SrcLoc
known =
case (Namespace, Name) -> Map (Namespace, Name) SrcLoc -> Maybe SrcLoc
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
namespace, Name
name) Map (Namespace, Name) SrcLoc
known of
Just SrcLoc
loc' ->
Namespace
-> Name -> SrcLoc -> SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> SrcLoc -> m a
dupDefinitionError Namespace
namespace Name
name SrcLoc
loc SrcLoc
loc'
Maybe SrcLoc
_ -> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc))
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
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
namespace, Name
name) SrcLoc
loc Map (Namespace, Name) SrcLoc
known
f :: SpecBase f Name
-> Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
f (ValSpec Name
name [TypeParamBase Name]
_ TypeExp f Name
_ f StructType
_ Maybe DocComment
_ SrcLoc
loc) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Term Name
name SrcLoc
loc
f (TypeAbbrSpec (TypeBind Name
name Liftedness
_ [TypeParamBase Name]
_ TypeExp f Name
_ f StructRetType
_ Maybe DocComment
_ SrcLoc
loc)) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Type Name
name SrcLoc
loc
f (TypeSpec Liftedness
_ Name
name [TypeParamBase Name]
_ Maybe DocComment
_ SrcLoc
loc) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Type Name
name SrcLoc
loc
f (ModSpec Name
name SigExpBase f Name
_ Maybe DocComment
_ SrcLoc
loc) =
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
forall {m :: * -> *}.
MonadTypeChecker m =>
Namespace
-> Name
-> SrcLoc
-> Map (Namespace, Name) SrcLoc
-> m (Map (Namespace, Name) SrcLoc)
check Namespace
Term Name
name SrcLoc
loc
f IncludeSpec {} =
Map (Namespace, Name) SrcLoc -> m (Map (Namespace, Name) SrcLoc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
checkTypeBind ::
TypeBindBase NoInfo Name ->
TypeM (Env, TypeBindBase Info VName)
checkTypeBind :: TypeBindBase NoInfo Name -> TypeM (Env, TypeBindBase Info VName)
checkTypeBind (TypeBind Name
name Liftedness
l [TypeParamBase Name]
tps TypeExp NoInfo Name
te NoInfo StructRetType
NoInfo Maybe DocComment
doc SrcLoc
loc) =
[TypeParamBase Name]
-> ([TypeParamBase VName] -> TypeM (Env, TypeBindBase Info VName))
-> TypeM (Env, TypeBindBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[TypeParamBase Name] -> ([TypeParamBase VName] -> m a) -> m a
checkTypeParams [TypeParamBase Name]
tps (([TypeParamBase VName] -> TypeM (Env, TypeBindBase Info VName))
-> TypeM (Env, TypeBindBase Info VName))
-> ([TypeParamBase VName] -> TypeM (Env, TypeBindBase Info VName))
-> TypeM (Env, TypeBindBase Info VName)
forall a b. (a -> b) -> a -> b
$ \[TypeParamBase VName]
tps' -> do
(TypeExp Info VName
te', [VName]
svars, RetType [VName]
dims TypeBase (ExpBase Info VName) Uniqueness
t, Liftedness
l') <- [TypeParamBase VName]
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
forall a. [TypeParamBase VName] -> TypeM a -> TypeM a
bindingTypeParams [TypeParamBase VName]
tps' (TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness))
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
forall a b. (a -> b) -> a -> b
$ TypeExp NoInfo Name
-> TypeM (TypeExp Info VName, [VName], ResRetType, Liftedness)
forall (m :: * -> *).
MonadTypeChecker m =>
TypeExp NoInfo Name
-> m (TypeExp Info VName, [VName], ResRetType, Liftedness)
checkTypeExp TypeExp NoInfo Name
te
let (Set VName
witnessed, Set VName
_) = StructType -> (Set VName, Set VName)
determineSizeWitnesses (StructType -> (Set VName, Set VName))
-> StructType -> (Set VName, Set VName)
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
t
case (VName -> Bool) -> [VName] -> Maybe VName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (VName -> Set VName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set VName
witnessed) [VName]
svars of
Just VName
_ ->
Loc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError (TypeExp NoInfo Name -> Loc
forall a. Located a => a -> Loc
locOf TypeExp NoInfo Name
te) Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> (Doc () -> Doc ()) -> Doc () -> TypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"anonymous-nonconstructive" (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Type abbreviation contains an anonymous size not used constructively as an array size."
Maybe VName
Nothing ->
() -> TypeM ()
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let elab_t :: StructRetType
elab_t = [VName] -> StructType -> StructRetType
forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType ([VName]
svars [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ [VName]
dims) (StructType -> StructRetType) -> StructType -> StructRetType
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
t
let used_dims :: Set VName
used_dims = FV -> Set VName
fvVars (FV -> Set VName) -> FV -> Set VName
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> FV
forall u. TypeBase (ExpBase Info VName) u -> FV
freeInType TypeBase (ExpBase Info VName) Uniqueness
t
case (TypeParamBase VName -> Bool)
-> [TypeParamBase VName] -> [TypeParamBase VName]
forall a. (a -> Bool) -> [a] -> [a]
filter ((VName -> Set VName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set VName
used_dims) (VName -> Bool)
-> (TypeParamBase VName -> VName) -> TypeParamBase VName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParamBase VName -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) ([TypeParamBase VName] -> [TypeParamBase VName])
-> [TypeParamBase VName] -> [TypeParamBase VName]
forall a b. (a -> b) -> a -> b
$
(TypeParamBase VName -> Bool)
-> [TypeParamBase VName] -> [TypeParamBase VName]
forall a. (a -> Bool) -> [a] -> [a]
filter TypeParamBase VName -> Bool
forall vn. TypeParamBase vn -> Bool
isSizeParam [TypeParamBase VName]
tps' of
[] -> () -> TypeM ()
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TypeParamBase VName
tp : [TypeParamBase VName]
_ ->
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Size parameter" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (TypeParamBase VName -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. TypeParamBase VName -> Doc ann
pretty TypeParamBase VName
tp) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"unused."
case (Liftedness
l, Liftedness
l') of
(Liftedness
_, Liftedness
Lifted)
| Liftedness
l Liftedness -> Liftedness -> Bool
forall a. Ord a => a -> a -> Bool
< Liftedness
Lifted ->
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Non-lifted type abbreviations may not contain functions."
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Hint: consider using 'type^'."
(Liftedness
_, Liftedness
SizeLifted)
| Liftedness
l Liftedness -> Liftedness -> Bool
forall a. Ord a => a -> a -> Bool
< Liftedness
SizeLifted ->
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Non-size-lifted type abbreviations may not contain size-lifted types."
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Hint: consider using 'type~'."
(Liftedness
Unlifted, Liftedness
_)
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [VName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([VName] -> Bool) -> [VName] -> Bool
forall a b. (a -> b) -> a -> b
$ [VName]
svars [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ [VName]
dims ->
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Non-lifted type abbreviations may not use existential sizes in their definition."
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Hint: use 'type~' or add size parameters to"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (Name -> Doc ()
forall a. Name -> Doc a
forall v a. IsName v => v -> Doc a
prettyName Name
name)
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
(Liftedness, Liftedness)
_ -> () -> TypeM ()
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[(Namespace, Name)]
-> TypeM (Env, TypeBindBase Info VName)
-> TypeM (Env, TypeBindBase Info VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
[(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace
Type, Name
name)] (TypeM (Env, TypeBindBase Info VName)
-> TypeM (Env, TypeBindBase Info VName))
-> TypeM (Env, TypeBindBase Info VName)
-> TypeM (Env, TypeBindBase Info VName)
forall a b. (a -> b) -> a -> b
$ do
VName
name' <- Namespace -> Name -> SrcLoc -> TypeM VName
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
Type Name
name SrcLoc
loc
(Env, TypeBindBase Info VName)
-> TypeM (Env, TypeBindBase Info VName)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Env
forall a. Monoid a => a
mempty
{ envTypeTable :: Map VName TypeBinding
envTypeTable =
VName -> TypeBinding -> Map VName TypeBinding
forall k a. k -> a -> Map k a
M.singleton VName
name' (TypeBinding -> Map VName TypeBinding)
-> TypeBinding -> Map VName TypeBinding
forall a b. (a -> b) -> a -> b
$ Liftedness -> [TypeParamBase VName] -> StructRetType -> TypeBinding
TypeAbbr Liftedness
l [TypeParamBase VName]
tps' StructRetType
elab_t,
envNameMap :: NameMap
envNameMap =
(Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Type, Name
name) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
name'
},
VName
-> Liftedness
-> [TypeParamBase VName]
-> TypeExp Info VName
-> Info StructRetType
-> Maybe DocComment
-> SrcLoc
-> TypeBindBase Info VName
forall (f :: * -> *) vn.
vn
-> Liftedness
-> [TypeParamBase vn]
-> TypeExp f vn
-> f StructRetType
-> Maybe DocComment
-> SrcLoc
-> TypeBindBase f vn
TypeBind VName
name' Liftedness
l [TypeParamBase VName]
tps' TypeExp Info VName
te' (StructRetType -> Info StructRetType
forall a. a -> Info a
Info StructRetType
elab_t) Maybe DocComment
doc SrcLoc
loc
)
entryPoint :: [Pat ParamType] -> Maybe (TypeExp Info VName) -> ResRetType -> EntryPoint
entryPoint :: [Pat ParamType]
-> Maybe (TypeExp Info VName) -> ResRetType -> EntryPoint
entryPoint [Pat ParamType]
params Maybe (TypeExp Info VName)
orig_ret_te (RetType [VName]
_ret TypeBase (ExpBase Info VName) Uniqueness
orig_ret) =
[EntryParam] -> EntryType -> EntryPoint
EntryPoint ((Pat ParamType -> EntryParam) -> [Pat ParamType] -> [EntryParam]
forall a b. (a -> b) -> [a] -> [b]
map Pat ParamType -> EntryParam
forall {u}.
PatBase Info VName (TypeBase (ExpBase Info VName) u) -> EntryParam
patternEntry [Pat ParamType]
params [EntryParam] -> [EntryParam] -> [EntryParam]
forall a. [a] -> [a] -> [a]
++ [EntryParam]
more_params) EntryType
rettype'
where
([EntryParam]
more_params, EntryType
rettype') = Maybe (TypeExp Info VName)
-> StructType -> ([EntryParam], EntryType)
onRetType Maybe (TypeExp Info VName)
orig_ret_te (StructType -> ([EntryParam], EntryType))
-> StructType -> ([EntryParam], EntryType)
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
orig_ret
patternEntry :: PatBase Info VName (TypeBase (ExpBase Info VName) u) -> EntryParam
patternEntry (PatParens PatBase Info VName (TypeBase (ExpBase Info VName) u)
p SrcLoc
_) =
PatBase Info VName (TypeBase (ExpBase Info VName) u) -> EntryParam
patternEntry PatBase Info VName (TypeBase (ExpBase Info VName) u)
p
patternEntry (PatAscription PatBase Info VName (TypeBase (ExpBase Info VName) u)
p TypeExp Info VName
te SrcLoc
_) =
Name -> EntryType -> EntryParam
EntryParam (PatBase Info VName (TypeBase (ExpBase Info VName) u) -> Name
forall {f :: * -> *} {t}. PatBase f VName t -> Name
patternName PatBase Info VName (TypeBase (ExpBase Info VName) u)
p) (EntryType -> EntryParam) -> EntryType -> EntryParam
forall a b. (a -> b) -> a -> b
$ StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType (PatBase Info VName (TypeBase (ExpBase Info VName) u) -> StructType
forall u. Pat (TypeBase (ExpBase Info VName) u) -> StructType
patternStructType PatBase Info VName (TypeBase (ExpBase Info VName) u)
p) (TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just TypeExp Info VName
te)
patternEntry PatBase Info VName (TypeBase (ExpBase Info VName) u)
p =
Name -> EntryType -> EntryParam
EntryParam (PatBase Info VName (TypeBase (ExpBase Info VName) u) -> Name
forall {f :: * -> *} {t}. PatBase f VName t -> Name
patternName PatBase Info VName (TypeBase (ExpBase Info VName) u)
p) (EntryType -> EntryParam) -> EntryType -> EntryParam
forall a b. (a -> b) -> a -> b
$ StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType (PatBase Info VName (TypeBase (ExpBase Info VName) u) -> StructType
forall u. Pat (TypeBase (ExpBase Info VName) u) -> StructType
patternStructType PatBase Info VName (TypeBase (ExpBase Info VName) u)
p) Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing
patternName :: PatBase f VName t -> Name
patternName (Id VName
x f t
_ SrcLoc
_) = VName -> Name
baseName VName
x
patternName (PatParens PatBase f VName t
p SrcLoc
_) = PatBase f VName t -> Name
patternName PatBase f VName t
p
patternName PatBase f VName t
_ = Name
"_"
pname :: PName -> Name
pname (Named VName
v) = VName -> Name
baseName VName
v
pname PName
Unnamed = Name
"_"
onRetType :: Maybe (TypeExp Info VName)
-> StructType -> ([EntryParam], EntryType)
onRetType (Just (TEArrow Maybe VName
p TypeExp Info VName
t1_te TypeExp Info VName
t2_te SrcLoc
_)) (Scalar (Arrow NoUniqueness
_ PName
_ Diet
_ StructType
t1 (RetType [VName]
_ TypeBase (ExpBase Info VName) Uniqueness
t2))) =
let ([EntryParam]
xs, EntryType
y) = Maybe (TypeExp Info VName)
-> StructType -> ([EntryParam], EntryType)
onRetType (TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just TypeExp Info VName
t2_te) (StructType -> ([EntryParam], EntryType))
-> StructType -> ([EntryParam], EntryType)
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
t2
in (Name -> EntryType -> EntryParam
EntryParam (Name -> (VName -> Name) -> Maybe VName -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
"_" VName -> Name
baseName Maybe VName
p) (StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType StructType
t1 (TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just TypeExp Info VName
t1_te)) EntryParam -> [EntryParam] -> [EntryParam]
forall a. a -> [a] -> [a]
: [EntryParam]
xs, EntryType
y)
onRetType Maybe (TypeExp Info VName)
_ (Scalar (Arrow NoUniqueness
_ PName
p Diet
_ StructType
t1 (RetType [VName]
_ TypeBase (ExpBase Info VName) Uniqueness
t2))) =
let ([EntryParam]
xs, EntryType
y) = Maybe (TypeExp Info VName)
-> StructType -> ([EntryParam], EntryType)
onRetType Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing (StructType -> ([EntryParam], EntryType))
-> StructType -> ([EntryParam], EntryType)
forall a b. (a -> b) -> a -> b
$ TypeBase (ExpBase Info VName) Uniqueness -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase (ExpBase Info VName) Uniqueness
t2
in (Name -> EntryType -> EntryParam
EntryParam (PName -> Name
pname PName
p) (StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType StructType
t1 Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing) EntryParam -> [EntryParam] -> [EntryParam]
forall a. a -> [a] -> [a]
: [EntryParam]
xs, EntryType
y)
onRetType Maybe (TypeExp Info VName)
te StructType
t =
([], StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType StructType
t Maybe (TypeExp Info VName)
te)
checkEntryPoint ::
SrcLoc ->
[TypeParam] ->
[Pat ParamType] ->
Maybe (TypeExp Info VName) ->
ResRetType ->
TypeM ()
checkEntryPoint :: SrcLoc
-> [TypeParamBase VName]
-> [Pat ParamType]
-> Maybe (TypeExp Info VName)
-> ResRetType
-> TypeM ()
checkEntryPoint SrcLoc
loc [TypeParamBase VName]
tparams [Pat ParamType]
params Maybe (TypeExp Info VName)
maybe_tdecl ResRetType
rettype
| (TypeParamBase VName -> Bool) -> [TypeParamBase VName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeParamBase VName -> Bool
forall vn. TypeParamBase vn -> Bool
isTypeParam [TypeParamBase VName]
tparams =
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink
Doc ()
"polymorphic-entry"
Doc ()
"Entry point functions may not be polymorphic."
| Bool -> Bool
not ((ParamType -> Bool) -> [ParamType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ParamType -> Bool
forall dim as. TypeBase dim as -> Bool
orderZero [ParamType]
param_ts)
Bool -> Bool -> Bool
|| Bool -> Bool
not (StructType -> Bool
forall dim as. TypeBase dim as -> Bool
orderZero StructType
rettype') =
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink
Doc ()
"higher-order-entry"
Doc ()
"Entry point functions may not be higher-order."
| Set VName
sizes_only_in_ret <-
[VName] -> Set VName
forall a. Ord a => [a] -> Set a
S.fromList ((TypeParamBase VName -> VName) -> [TypeParamBase VName] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase VName -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParamBase VName]
tparams)
Set VName -> Set VName -> Set VName
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` FV -> Set VName
fvVars (StructType -> FV
forall u. TypeBase (ExpBase Info VName) u -> FV
freeInType StructType
rettype')
Set VName -> Set VName -> Set VName
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` (ParamType -> Set VName) -> [ParamType] -> Set VName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (FV -> Set VName
fvVars (FV -> Set VName) -> (ParamType -> FV) -> ParamType -> Set VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamType -> FV
forall u. TypeBase (ExpBase Info VName) u -> FV
freeInType) [ParamType]
param_ts,
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set VName -> Bool
forall a. Set a -> Bool
S.null Set VName
sizes_only_in_ret =
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink
Doc ()
"size-polymorphic-entry"
Doc ()
"Entry point functions must not be size-polymorphic in their return type."
| (Set VName
constructive, Set VName
_) <- (ParamType -> (Set VName, Set VName))
-> [ParamType] -> (Set VName, Set VName)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (StructType -> (Set VName, Set VName)
determineSizeWitnesses (StructType -> (Set VName, Set VName))
-> (ParamType -> StructType) -> ParamType -> (Set VName, Set VName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamType -> StructType
forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct) [ParamType]
param_ts,
Just TypeParamBase VName
p <- (TypeParamBase VName -> Bool)
-> [TypeParamBase VName] -> Maybe (TypeParamBase VName)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((VName -> Set VName -> Bool) -> Set VName -> VName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip VName -> Set VName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Set VName
constructive (VName -> Bool)
-> (TypeParamBase VName -> VName) -> TypeParamBase VName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParamBase VName -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParamBase VName]
tparams =
TypeParamBase VName -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError TypeParamBase VName
p Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> (Doc () -> Doc ()) -> Doc () -> TypeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"nonconstructive-entry" (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Entry point size parameter "
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> TypeParamBase VName -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. TypeParamBase VName -> Doc ann
pretty TypeParamBase VName
p
Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
" only used non-constructively."
| Pat ParamType
p : [Pat ParamType]
_ <- (Pat ParamType -> Bool) -> [Pat ParamType] -> [Pat ParamType]
forall a. (a -> Bool) -> [a] -> [a]
filter Pat ParamType -> Bool
nastyParameter [Pat ParamType]
params =
Pat ParamType -> Doc () -> TypeM ()
forall loc. Located loc => loc -> Doc () -> TypeM ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc () -> m ()
warn Pat ParamType
p (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Entry point parameter\n"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Pat ParamType -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. Pat ParamType -> Doc ann
pretty Pat ParamType
p)
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"\nwill have an opaque type, so the entry point will likely not be callable."
| Maybe (TypeExp Info VName)
-> TypeBase (ExpBase Info VName) Uniqueness -> Bool
forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyReturnType Maybe (TypeExp Info VName)
maybe_tdecl TypeBase (ExpBase Info VName) Uniqueness
rettype_t =
SrcLoc -> Doc () -> TypeM ()
forall loc. Located loc => loc -> Doc () -> TypeM ()
forall (m :: * -> *) loc.
(MonadTypeChecker m, Located loc) =>
loc -> Doc () -> m ()
warn SrcLoc
loc (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc ()
"Entry point return type\n"
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (ResRetType -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. ResRetType -> Doc ann
pretty ResRetType
rettype)
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"\nwill have an opaque type, so the result will likely not be usable."
| Bool
otherwise =
() -> TypeM ()
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
(RetType [VName]
_ TypeBase (ExpBase Info VName) Uniqueness
rettype_t) = ResRetType
rettype
([ParamType]
rettype_params, StructType
rettype') = TypeBase (ExpBase Info VName) Uniqueness
-> ([ParamType], StructType)
forall dim as.
TypeBase dim as -> ([TypeBase dim Diet], TypeBase dim NoUniqueness)
unfoldFunType TypeBase (ExpBase Info VName) Uniqueness
rettype_t
param_ts :: [ParamType]
param_ts = (Pat ParamType -> ParamType) -> [Pat ParamType] -> [ParamType]
forall a b. (a -> b) -> [a] -> [b]
map Pat ParamType -> ParamType
forall d u. Pat (TypeBase d u) -> TypeBase d u
patternType [Pat ParamType]
params [ParamType] -> [ParamType] -> [ParamType]
forall a. [a] -> [a] -> [a]
++ [ParamType]
rettype_params
checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind)
checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind)
checkValBind (ValBind Maybe (NoInfo EntryPoint)
entry Name
fname Maybe (TypeExp NoInfo Name)
maybe_tdecl NoInfo ResRetType
NoInfo [TypeParamBase Name]
tparams [PatBase NoInfo Name ParamType]
params UncheckedExp
body Maybe DocComment
doc [AttrInfo Name]
attrs SrcLoc
loc) = do
Bool
top_level <- TypeM Bool
atTopLevel
Bool -> TypeM () -> TypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
top_level Bool -> Bool -> Bool
&& Maybe (NoInfo EntryPoint) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NoInfo EntryPoint)
entry) (TypeM () -> TypeM ()) -> TypeM () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"nested-entry" Doc ()
"Entry points may not be declared inside modules."
(VName
fname', [TypeParamBase VName]
tparams', [Pat ParamType]
params', Maybe (TypeExp Info VName)
maybe_tdecl', ResRetType
rettype, ExpBase Info VName
body') <-
(Name, Maybe (TypeExp NoInfo Name), [TypeParamBase Name],
[PatBase NoInfo Name ParamType], UncheckedExp, SrcLoc)
-> TypeM
(VName, [TypeParamBase VName], [Pat ParamType],
Maybe (TypeExp Info VName), ResRetType, ExpBase Info VName)
checkFunDef (Name
fname, Maybe (TypeExp NoInfo Name)
maybe_tdecl, [TypeParamBase Name]
tparams, [PatBase NoInfo Name ParamType]
params, UncheckedExp
body, SrcLoc
loc)
let entry' :: Maybe (Info EntryPoint)
entry' = EntryPoint -> Info EntryPoint
forall a. a -> Info a
Info ([Pat ParamType]
-> Maybe (TypeExp Info VName) -> ResRetType -> EntryPoint
entryPoint [Pat ParamType]
params' Maybe (TypeExp Info VName)
maybe_tdecl' ResRetType
rettype) Info EntryPoint
-> Maybe (NoInfo EntryPoint) -> Maybe (Info EntryPoint)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (NoInfo EntryPoint)
entry
case Maybe (Info EntryPoint)
entry' of
Just Info EntryPoint
_ -> SrcLoc
-> [TypeParamBase VName]
-> [Pat ParamType]
-> Maybe (TypeExp Info VName)
-> ResRetType
-> TypeM ()
checkEntryPoint SrcLoc
loc [TypeParamBase VName]
tparams' [Pat ParamType]
params' Maybe (TypeExp Info VName)
maybe_tdecl' ResRetType
rettype
Maybe (Info EntryPoint)
_ -> () -> TypeM ()
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[AttrInfo VName]
attrs' <- (AttrInfo Name -> TypeM (AttrInfo VName))
-> [AttrInfo Name] -> TypeM [AttrInfo VName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM AttrInfo Name -> TypeM (AttrInfo VName)
forall (m :: * -> *).
MonadTypeChecker m =>
AttrInfo Name -> m (AttrInfo VName)
checkAttr [AttrInfo Name]
attrs
let vb :: ValBind
vb = Maybe (Info EntryPoint)
-> VName
-> Maybe (TypeExp Info VName)
-> Info ResRetType
-> [TypeParamBase VName]
-> [Pat ParamType]
-> ExpBase Info VName
-> Maybe DocComment
-> [AttrInfo VName]
-> SrcLoc
-> ValBind
forall (f :: * -> *) vn.
Maybe (f EntryPoint)
-> vn
-> Maybe (TypeExp f vn)
-> f ResRetType
-> [TypeParamBase vn]
-> [PatBase f vn ParamType]
-> ExpBase f vn
-> Maybe DocComment
-> [AttrInfo vn]
-> SrcLoc
-> ValBindBase f vn
ValBind Maybe (Info EntryPoint)
entry' VName
fname' Maybe (TypeExp Info VName)
maybe_tdecl' (ResRetType -> Info ResRetType
forall a. a -> Info a
Info ResRetType
rettype) [TypeParamBase VName]
tparams' [Pat ParamType]
params' ExpBase Info VName
body' Maybe DocComment
doc [AttrInfo VName]
attrs' SrcLoc
loc
(Env, ValBind) -> TypeM (Env, ValBind)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Env
forall a. Monoid a => a
mempty
{ envVtable :: Map VName BoundV
envVtable =
VName -> BoundV -> Map VName BoundV
forall k a. k -> a -> Map k a
M.singleton VName
fname' (BoundV -> Map VName BoundV) -> BoundV -> Map VName BoundV
forall a b. (a -> b) -> a -> b
$ ([TypeParamBase VName] -> StructType -> BoundV)
-> ([TypeParamBase VName], StructType) -> BoundV
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [TypeParamBase VName] -> StructType -> BoundV
BoundV (([TypeParamBase VName], StructType) -> BoundV)
-> ([TypeParamBase VName], StructType) -> BoundV
forall a b. (a -> b) -> a -> b
$ ValBind -> ([TypeParamBase VName], StructType)
valBindTypeScheme ValBind
vb,
envNameMap :: NameMap
envNameMap =
(Namespace, Name) -> QualName VName -> NameMap
forall k a. k -> a -> Map k a
M.singleton (Namespace
Term, Name
fname) (QualName VName -> NameMap) -> QualName VName -> NameMap
forall a b. (a -> b) -> a -> b
$ VName -> QualName VName
forall v. v -> QualName v
qualName VName
fname'
},
ValBind
vb
)
nastyType :: (Monoid als) => TypeBase dim als -> Bool
nastyType :: forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType (Scalar Prim {}) = Bool
False
nastyType t :: TypeBase dim als
t@Array {} = TypeBase dim als -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType (TypeBase dim als -> Bool) -> TypeBase dim als -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> TypeBase dim als -> TypeBase dim als
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1 TypeBase dim als
t
nastyType TypeBase dim als
_ = Bool
True
nastyReturnType :: (Monoid als) => Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyReturnType :: forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyReturnType Maybe (TypeExp Info VName)
Nothing (Scalar (Arrow als
_ PName
_ Diet
_ TypeBase dim NoUniqueness
t1 (RetType [VName]
_ TypeBase dim Uniqueness
t2))) =
TypeBase dim NoUniqueness -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType TypeBase dim NoUniqueness
t1 Bool -> Bool -> Bool
|| Maybe (TypeExp Info VName) -> TypeBase dim Uniqueness -> Bool
forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyReturnType Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing TypeBase dim Uniqueness
t2
nastyReturnType (Just (TEArrow Maybe VName
_ TypeExp Info VName
te1 TypeExp Info VName
te2 SrcLoc
_)) (Scalar (Arrow als
_ PName
_ Diet
_ TypeBase dim NoUniqueness
t1 (RetType [VName]
_ TypeBase dim Uniqueness
t2))) =
(Bool -> Bool
not (TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te1) Bool -> Bool -> Bool
&& TypeBase dim NoUniqueness -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType TypeBase dim NoUniqueness
t1)
Bool -> Bool -> Bool
|| Maybe (TypeExp Info VName) -> TypeBase dim Uniqueness -> Bool
forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyReturnType (TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just TypeExp Info VName
te2) TypeBase dim Uniqueness
t2
nastyReturnType (Just TypeExp Info VName
te) TypeBase dim als
_
| TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te = Bool
False
nastyReturnType Maybe (TypeExp Info VName)
te TypeBase dim als
t
| Just [TypeBase dim als]
ts <- TypeBase dim als -> Maybe [TypeBase dim als]
forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
isTupleRecord TypeBase dim als
t =
case Maybe (TypeExp Info VName)
te of
Just (TETuple [TypeExp Info VName]
tes SrcLoc
_) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool)
-> [Maybe (TypeExp Info VName)] -> [TypeBase dim als] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyType' ((TypeExp Info VName -> Maybe (TypeExp Info VName))
-> [TypeExp Info VName] -> [Maybe (TypeExp Info VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just [TypeExp Info VName]
tes) [TypeBase dim als]
ts
Maybe (TypeExp Info VName)
_ -> (TypeBase dim als -> Bool) -> [TypeBase dim als] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeBase dim als -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType [TypeBase dim als]
ts
| Bool
otherwise = Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
forall als dim.
Monoid als =>
Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyType' Maybe (TypeExp Info VName)
te TypeBase dim als
t
where
nastyType' :: Maybe (TypeExp Info VName) -> TypeBase dim als -> Bool
nastyType' (Just TypeExp Info VName
te') TypeBase dim als
_ | TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te' = Bool
False
nastyType' Maybe (TypeExp Info VName)
_ TypeBase dim als
t' = TypeBase dim als -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType TypeBase dim als
t'
nastyParameter :: Pat ParamType -> Bool
nastyParameter :: Pat ParamType -> Bool
nastyParameter Pat ParamType
p = ParamType -> Bool
forall als dim. Monoid als => TypeBase dim als -> Bool
nastyType (Pat ParamType -> ParamType
forall d u. Pat (TypeBase d u) -> TypeBase d u
patternType Pat ParamType
p) Bool -> Bool -> Bool
&& Bool -> Bool
not (Pat ParamType -> Bool
forall {t}. PatBase Info VName t -> Bool
ascripted Pat ParamType
p)
where
ascripted :: PatBase Info VName t -> Bool
ascripted (PatAscription PatBase Info VName t
_ TypeExp Info VName
te SrcLoc
_) = TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te
ascripted (PatParens PatBase Info VName t
p' SrcLoc
_) = PatBase Info VName t -> Bool
ascripted PatBase Info VName t
p'
ascripted PatBase Info VName t
_ = Bool
False
niceTypeExp :: TypeExp Info VName -> Bool
niceTypeExp :: TypeExp Info VName -> Bool
niceTypeExp (TEVar (QualName [] VName
_) SrcLoc
_) = Bool
True
niceTypeExp (TEApply TypeExp Info VName
te TypeArgExpSize {} SrcLoc
_) = TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te
niceTypeExp (TEArray SizeExp Info VName
_ TypeExp Info VName
te SrcLoc
_) = TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te
niceTypeExp (TEUnique TypeExp Info VName
te SrcLoc
_) = TypeExp Info VName -> Bool
niceTypeExp TypeExp Info VName
te
niceTypeExp TypeExp Info VName
_ = Bool
False
checkOneDec :: DecBase NoInfo Name -> TypeM (TySet, Env, DecBase Info VName)
checkOneDec :: UncheckedDec -> TypeM (TySet, Env, Dec)
checkOneDec (ModDec ModBindBase NoInfo Name
struct) = do
(TySet
abs, Env
modenv, ModBindBase Info VName
struct') <- ModBindBase NoInfo Name
-> TypeM (TySet, Env, ModBindBase Info VName)
checkModBind ModBindBase NoInfo Name
struct
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, Env
modenv, ModBindBase Info VName -> Dec
forall (f :: * -> *) vn. ModBindBase f vn -> DecBase f vn
ModDec ModBindBase Info VName
struct')
checkOneDec (SigDec SigBindBase NoInfo Name
sig) = do
(TySet
abs, Env
sigenv, SigBindBase Info VName
sig') <- SigBindBase NoInfo Name
-> TypeM (TySet, Env, SigBindBase Info VName)
checkSigBind SigBindBase NoInfo Name
sig
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abs, Env
sigenv, SigBindBase Info VName -> Dec
forall (f :: * -> *) vn. SigBindBase f vn -> DecBase f vn
SigDec SigBindBase Info VName
sig')
checkOneDec (TypeDec TypeBindBase NoInfo Name
tdec) = do
(Env
tenv, TypeBindBase Info VName
tdec') <- TypeBindBase NoInfo Name -> TypeM (Env, TypeBindBase Info VName)
checkTypeBind TypeBindBase NoInfo Name
tdec
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, Env
tenv, TypeBindBase Info VName -> Dec
forall (f :: * -> *) vn. TypeBindBase f vn -> DecBase f vn
TypeDec TypeBindBase Info VName
tdec')
checkOneDec (OpenDec ModExpBase NoInfo Name
x SrcLoc
loc) = do
(TySet
x_abs, Env
x_env, ModExpBase Info VName
x') <- ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName)
checkOneModExpToEnv ModExpBase NoInfo Name
x
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
x_abs, Env
x_env, ModExpBase Info VName -> SrcLoc -> Dec
forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec ModExpBase Info VName
x' SrcLoc
loc)
checkOneDec (LocalDec UncheckedDec
d SrcLoc
loc) = do
(TySet
abstypes, Env
env, Dec
d') <- UncheckedDec -> TypeM (TySet, Env, Dec)
checkOneDec UncheckedDec
d
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
abstypes, Env
env, Dec -> SrcLoc -> Dec
forall (f :: * -> *) vn. DecBase f vn -> SrcLoc -> DecBase f vn
LocalDec Dec
d' SrcLoc
loc)
checkOneDec (ImportDec FilePath
name NoInfo ImportName
NoInfo SrcLoc
loc) = do
(ImportName
name', Env
env) <- SrcLoc -> FilePath -> TypeM (ImportName, Env)
lookupImport SrcLoc
loc FilePath
name
Bool -> TypeM () -> TypeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isBuiltin FilePath
name) (TypeM () -> TypeM ()) -> TypeM () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
SrcLoc -> Notes -> Doc () -> TypeM ()
forall loc a. Located loc => loc -> Notes -> Doc () -> TypeM a
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc () -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc () -> TypeM ()) -> Doc () -> TypeM ()
forall a b. (a -> b) -> a -> b
$
FilePath -> Doc ()
forall ann. FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FilePath
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"may not be explicitly imported."
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, Env
env, FilePath -> Info ImportName -> SrcLoc -> Dec
forall (f :: * -> *) vn.
FilePath -> f ImportName -> SrcLoc -> DecBase f vn
ImportDec FilePath
name (ImportName -> Info ImportName
forall a. a -> Info a
Info ImportName
name') SrcLoc
loc)
checkOneDec (ValDec ValBindBase NoInfo Name
vb) = do
(Env
env, ValBind
vb') <- ValBindBase NoInfo Name -> TypeM (Env, ValBind)
checkValBind ValBindBase NoInfo Name
vb
(TySet, Env, Dec) -> TypeM (TySet, Env, Dec)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, Env
env, ValBind -> Dec
forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec ValBind
vb')
checkDecs :: [DecBase NoInfo Name] -> TypeM (TySet, Env, [DecBase Info VName], Env)
checkDecs :: [UncheckedDec] -> TypeM (TySet, Env, [Dec], Env)
checkDecs (UncheckedDec
d : [UncheckedDec]
ds) = do
(TySet
d_abstypes, Env
d_env, Dec
d') <- UncheckedDec -> TypeM (TySet, Env, Dec)
checkOneDec UncheckedDec
d
(TySet
ds_abstypes, Env
ds_env, [Dec]
ds', Env
full_env) <- Env
-> TypeM (TySet, Env, [Dec], Env) -> TypeM (TySet, Env, [Dec], Env)
forall a. Env -> TypeM a -> TypeM a
localEnv Env
d_env (TypeM (TySet, Env, [Dec], Env) -> TypeM (TySet, Env, [Dec], Env))
-> TypeM (TySet, Env, [Dec], Env) -> TypeM (TySet, Env, [Dec], Env)
forall a b. (a -> b) -> a -> b
$ [UncheckedDec] -> TypeM (TySet, Env, [Dec], Env)
checkDecs [UncheckedDec]
ds
(TySet, Env, [Dec], Env) -> TypeM (TySet, Env, [Dec], Env)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( TySet
d_abstypes TySet -> TySet -> TySet
forall a. Semigroup a => a -> a -> a
<> TySet
ds_abstypes,
case Dec
d' of
LocalDec {} -> Env
ds_env
ImportDec {} -> Env
ds_env
Dec
_ -> Env
ds_env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
d_env,
Dec
d' Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
ds',
Env
full_env
)
checkDecs [] = do
Env
full_env <- TypeM Env
askEnv
(TySet, Env, [Dec], Env) -> TypeM (TySet, Env, [Dec], Env)
forall a. a -> TypeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySet
forall a. Monoid a => a
mempty, Env
forall a. Monoid a => a
mempty, [], Env
full_env)