{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Main monad in which the type checker runs, as well as ancillary
-- data definitions.
module Language.Futhark.TypeChecker.Monad
  ( TypeM
  , runTypeM
  , askEnv
  , askImportName
  , checkQualNameWithEnv
  , bindSpaced
  , qualifyTypeVars
  , lookupMTy
  , lookupImport
  , localEnv

  , TypeError(..)
  , unexpectedType
  , undefinedType
  , unappliedFunctor
  , unknownVariableError
  , underscoreUse
  , Notes
  , aNote

  , MonadTypeChecker(..)
  , checkName
  , badOnLeft

  , module Language.Futhark.Warnings

  , Env(..)
  , TySet
  , FunSig(..)
  , ImportTable
  , NameMap
  , BoundV(..)
  , Mod(..)
  , TypeBinding(..)
  , MTy(..)

  , anySignedType
  , anyUnsignedType
  , anyIntType
  , anyFloatType
  , anyNumberType
  , anyPrimType

  , Namespace(..)
  , intrinsicsNameMap
  , topLevelNameMap
  )
where

import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.RWS.Strict
import Control.Monad.Identity
import Data.List (isPrefixOf, find)
import Data.Loc
import Data.Maybe
import Data.Either
import qualified Data.Map.Strict as M
import qualified Data.Set as S

import Prelude hiding (mapM, mod)

import Language.Futhark
import Language.Futhark.Semantic
import Language.Futhark.Traversals
import Language.Futhark.Warnings
import Futhark.FreshNames hiding (newName)
import qualified Futhark.FreshNames
import Futhark.Util.Pretty hiding (space)
import Futhark.Util.Console

-- | A note with extra information regarding a type error.
newtype Note = Note Doc

newtype Notes = Notes [Note]
  deriving (b -> Notes -> Notes
NonEmpty Notes -> Notes
Notes -> Notes -> Notes
(Notes -> Notes -> Notes)
-> (NonEmpty Notes -> Notes)
-> (forall b. Integral b => b -> Notes -> Notes)
-> Semigroup Notes
forall b. Integral b => b -> Notes -> Notes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Notes -> Notes
$cstimes :: forall b. Integral b => b -> Notes -> Notes
sconcat :: NonEmpty Notes -> Notes
$csconcat :: NonEmpty Notes -> Notes
<> :: Notes -> Notes -> Notes
$c<> :: Notes -> Notes -> Notes
Semigroup, Semigroup Notes
Notes
Semigroup Notes
-> Notes
-> (Notes -> Notes -> Notes)
-> ([Notes] -> Notes)
-> Monoid Notes
[Notes] -> Notes
Notes -> Notes -> Notes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Notes] -> Notes
$cmconcat :: [Notes] -> Notes
mappend :: Notes -> Notes -> Notes
$cmappend :: Notes -> Notes -> Notes
mempty :: Notes
$cmempty :: Notes
$cp1Monoid :: Semigroup Notes
Monoid)

instance Pretty Note where
  ppr :: Note -> Doc
ppr (Note Doc
msg) = Doc
"Note:" Doc -> Doc -> Doc
<+> Doc -> Doc
align Doc
msg

instance Pretty Notes where
  ppr :: Notes -> Doc
ppr (Notes [Note]
notes) = (Note -> Doc) -> [Note] -> Doc
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Doc
lineDoc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Doc
line)Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> (Note -> Doc) -> Note -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Doc
forall a. Pretty a => a -> Doc
ppr) [Note]
notes

aNote :: Pretty a => a -> Notes
aNote :: a -> Notes
aNote = [Note] -> Notes
Notes ([Note] -> Notes) -> (a -> [Note]) -> a -> Notes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> [Note]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note -> [Note]) -> (a -> Note) -> a -> [Note]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Note
Note (Doc -> Note) -> (a -> Doc) -> a -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
ppr

-- | Information about an error during type checking.
data TypeError = TypeError SrcLoc Notes Doc

instance Pretty TypeError where
  ppr :: TypeError -> Doc
ppr (TypeError SrcLoc
loc Notes
notes Doc
msg) =
    String -> Doc
text (String -> String
inRed (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Error at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SrcLoc -> String
forall a. Located a => a -> String
locStr SrcLoc
loc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":") Doc -> Doc -> Doc
</>
    Doc
msg Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Notes -> Doc
forall a. Pretty a => a -> Doc
ppr Notes
notes

unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a
unexpectedType :: SrcLoc -> StructType -> [StructType] -> m a
unexpectedType SrcLoc
loc StructType
_ [] =
  SrcLoc -> Notes -> Doc -> m 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 -> m a) -> Doc -> m a
forall a b. (a -> b) -> a -> b
$
  Doc
"Type of expression at" Doc -> Doc -> Doc
<+> String -> Doc
text (SrcLoc -> String
forall a. Located a => a -> String
locStr SrcLoc
loc) Doc -> Doc -> Doc
<+>
  Doc
"cannot have any type - possibly a bug in the type checker."
unexpectedType SrcLoc
loc StructType
t [StructType]
ts =
  SrcLoc -> Notes -> Doc -> m 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 -> m a) -> Doc -> m a
forall a b. (a -> b) -> a -> b
$
  Doc
"Type of expression at" Doc -> Doc -> Doc
<+> String -> Doc
text (SrcLoc -> String
forall a. Located a => a -> String
locStr SrcLoc
loc) Doc -> Doc -> Doc
<+> Doc
"must be one of" Doc -> Doc -> Doc
<+>
  [Doc] -> Doc
commasep ((StructType -> Doc) -> [StructType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
forall a. Pretty a => a -> Doc
ppr [StructType]
ts) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", but is" Doc -> Doc -> Doc
<+>
  StructType -> Doc
forall a. Pretty a => a -> Doc
ppr StructType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

undefinedType :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a
undefinedType :: SrcLoc -> QualName Name -> m a
undefinedType SrcLoc
loc QualName Name
name =
  SrcLoc -> Notes -> Doc -> m 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 -> m a) -> Doc -> m a
forall a b. (a -> b) -> a -> b
$ Doc
"Unknown type" Doc -> Doc -> Doc
<+> QualName Name -> Doc
forall a. Pretty a => a -> Doc
ppr QualName Name
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

unappliedFunctor :: MonadTypeChecker m => SrcLoc -> m a
unappliedFunctor :: SrcLoc -> m a
unappliedFunctor SrcLoc
loc =
  SrcLoc -> Notes -> Doc -> m 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 have parametric module here."

unknownVariableError :: MonadTypeChecker m =>
                        Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError :: Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
space QualName Name
name SrcLoc
loc =
  SrcLoc -> Notes -> Doc -> m 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 -> m a) -> Doc -> m a
forall a b. (a -> b) -> a -> b
$
  Doc
"Unknown" Doc -> Doc -> Doc
<+> Namespace -> Doc
forall a. Pretty a => a -> Doc
ppr Namespace
space Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (QualName Name -> Doc
forall a. Pretty a => a -> Doc
ppr QualName Name
name)

underscoreUse :: MonadTypeChecker m =>
                 SrcLoc -> QualName Name -> m a
underscoreUse :: SrcLoc -> QualName Name -> m a
underscoreUse SrcLoc
loc QualName Name
name =
  SrcLoc -> Notes -> Doc -> m 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 -> m a) -> Doc -> m a
forall a b. (a -> b) -> a -> b
$ Doc
"Use of" Doc -> Doc -> Doc
<+> Doc -> Doc
pquote (QualName Name -> Doc
forall a. Pretty a => a -> Doc
ppr QualName Name
name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
  Doc
": variables prefixed with underscore may not be accessed."

type ImportTable = M.Map String Env

data Context = Context { Context -> Env
contextEnv :: Env
                       , Context -> ImportTable
contextImportTable :: ImportTable
                       , Context -> ImportName
contextImportName :: ImportName
                       }

-- | The type checker runs in this monad.
newtype TypeM a = TypeM (RWST
                         Context            -- Reader
                         Warnings           -- Writer
                         VNameSource        -- State
                         (Except TypeError) -- Inner monad
                         a)
  deriving (Applicative TypeM
a -> TypeM a
Applicative TypeM
-> (forall a b. TypeM a -> (a -> TypeM b) -> TypeM b)
-> (forall a b. TypeM a -> TypeM b -> TypeM b)
-> (forall a. a -> TypeM a)
-> Monad TypeM
TypeM a -> (a -> TypeM b) -> TypeM b
TypeM a -> TypeM b -> TypeM b
forall a. a -> TypeM a
forall a b. TypeM a -> TypeM b -> TypeM b
forall a b. TypeM a -> (a -> TypeM b) -> TypeM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TypeM a
$creturn :: forall a. a -> TypeM a
>> :: TypeM a -> TypeM b -> TypeM b
$c>> :: forall a b. TypeM a -> TypeM b -> TypeM b
>>= :: TypeM a -> (a -> TypeM b) -> TypeM b
$c>>= :: forall a b. TypeM a -> (a -> TypeM b) -> TypeM b
$cp1Monad :: Applicative TypeM
Monad, a -> TypeM b -> TypeM a
(a -> b) -> TypeM a -> TypeM b
(forall a b. (a -> b) -> TypeM a -> TypeM b)
-> (forall a b. a -> TypeM b -> TypeM a) -> Functor TypeM
forall a b. a -> TypeM b -> TypeM a
forall a b. (a -> b) -> TypeM a -> TypeM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TypeM b -> TypeM a
$c<$ :: forall a b. a -> TypeM b -> TypeM a
fmap :: (a -> b) -> TypeM a -> TypeM b
$cfmap :: forall a b. (a -> b) -> TypeM a -> TypeM b
Functor, Functor TypeM
a -> TypeM a
Functor TypeM
-> (forall a. a -> TypeM a)
-> (forall a b. TypeM (a -> b) -> TypeM a -> TypeM b)
-> (forall a b c. (a -> b -> c) -> TypeM a -> TypeM b -> TypeM c)
-> (forall a b. TypeM a -> TypeM b -> TypeM b)
-> (forall a b. TypeM a -> TypeM b -> TypeM a)
-> Applicative TypeM
TypeM a -> TypeM b -> TypeM b
TypeM a -> TypeM b -> TypeM a
TypeM (a -> b) -> TypeM a -> TypeM b
(a -> b -> c) -> TypeM a -> TypeM b -> TypeM c
forall a. a -> TypeM a
forall a b. TypeM a -> TypeM b -> TypeM a
forall a b. TypeM a -> TypeM b -> TypeM b
forall a b. TypeM (a -> b) -> TypeM a -> TypeM b
forall a b c. (a -> b -> c) -> TypeM a -> TypeM b -> TypeM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: TypeM a -> TypeM b -> TypeM a
$c<* :: forall a b. TypeM a -> TypeM b -> TypeM a
*> :: TypeM a -> TypeM b -> TypeM b
$c*> :: forall a b. TypeM a -> TypeM b -> TypeM b
liftA2 :: (a -> b -> c) -> TypeM a -> TypeM b -> TypeM c
$cliftA2 :: forall a b c. (a -> b -> c) -> TypeM a -> TypeM b -> TypeM c
<*> :: TypeM (a -> b) -> TypeM a -> TypeM b
$c<*> :: forall a b. TypeM (a -> b) -> TypeM a -> TypeM b
pure :: a -> TypeM a
$cpure :: forall a. a -> TypeM a
$cp1Applicative :: Functor TypeM
Applicative,
            MonadReader Context,
            MonadWriter Warnings,
            MonadState VNameSource,
            MonadError TypeError)

runTypeM :: Env -> ImportTable -> ImportName -> VNameSource
         -> TypeM a
         -> Either TypeError (a, Warnings, VNameSource)
runTypeM :: Env
-> ImportTable
-> ImportName
-> VNameSource
-> TypeM a
-> Either TypeError (a, Warnings, VNameSource)
runTypeM Env
env ImportTable
imports ImportName
fpath VNameSource
src (TypeM RWST Context Warnings VNameSource (Except TypeError) a
m) = do
  (a
x, VNameSource
src', Warnings
ws) <- Except TypeError (a, VNameSource, Warnings)
-> Either TypeError (a, VNameSource, Warnings)
forall e a. Except e a -> Either e a
runExcept (Except TypeError (a, VNameSource, Warnings)
 -> Either TypeError (a, VNameSource, Warnings))
-> Except TypeError (a, VNameSource, Warnings)
-> Either TypeError (a, VNameSource, Warnings)
forall a b. (a -> b) -> a -> b
$ RWST Context Warnings VNameSource (Except TypeError) a
-> Context
-> VNameSource
-> Except TypeError (a, VNameSource, Warnings)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST Context Warnings VNameSource (Except TypeError) a
m (Env -> ImportTable -> ImportName -> Context
Context Env
env ImportTable
imports ImportName
fpath) VNameSource
src
  (a, Warnings, VNameSource)
-> Either TypeError (a, Warnings, VNameSource)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Warnings
ws, VNameSource
src')

askEnv :: TypeM Env
askEnv :: TypeM Env
askEnv = (Context -> Env) -> TypeM Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> Env
contextEnv

-- | The name of the current file/import.
askImportName :: TypeM ImportName
askImportName :: TypeM ImportName
askImportName = (Context -> ImportName) -> TypeM ImportName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> ImportName
contextImportName

lookupMTy :: SrcLoc -> QualName Name -> TypeM (QualName VName, MTy)
lookupMTy :: SrcLoc -> QualName Name -> TypeM (QualName VName, MTy)
lookupMTy SrcLoc
loc QualName Name
qn = do
  (Env
scope, qn' :: QualName VName
qn'@(QualName [VName]
_ VName
name)) <- Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
Signature QualName Name
qn SrcLoc
loc
  (QualName VName
qn',) (MTy -> (QualName VName, MTy))
-> TypeM MTy -> TypeM (QualName VName, MTy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeM MTy -> (MTy -> TypeM MTy) -> Maybe MTy -> TypeM MTy
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeM MTy
forall a. TypeM a
explode MTy -> TypeM MTy
forall (m :: * -> *) a. Monad m => a -> m a
return (VName -> Map VName MTy -> Maybe MTy
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name (Map VName MTy -> Maybe MTy) -> Map VName MTy -> Maybe MTy
forall a b. (a -> b) -> a -> b
$ Env -> Map VName MTy
envSigTable Env
scope)
  where explode :: TypeM a
explode = Namespace -> QualName Name -> SrcLoc -> TypeM a
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
Signature QualName Name
qn SrcLoc
loc

lookupImport :: SrcLoc -> FilePath -> TypeM (FilePath, Env)
lookupImport :: SrcLoc -> String -> TypeM (String, Env)
lookupImport SrcLoc
loc String
file = do
  ImportTable
imports <- (Context -> ImportTable) -> TypeM ImportTable
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> ImportTable
contextImportTable
  ImportName
my_path <- (Context -> ImportName) -> TypeM ImportName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> ImportName
contextImportName
  let canonical_import :: String
canonical_import = ImportName -> String
includeToString (ImportName -> String) -> ImportName -> String
forall a b. (a -> b) -> a -> b
$ ImportName -> String -> SrcLoc -> ImportName
mkImportFrom ImportName
my_path String
file SrcLoc
loc
  case String -> ImportTable -> Maybe Env
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
canonical_import ImportTable
imports of
    Maybe Env
Nothing    -> SrcLoc -> Notes -> Doc -> TypeM (String, Env)
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 (String, Env)) -> Doc -> TypeM (String, Env)
forall a b. (a -> b) -> a -> b
$
                  Doc
"Unknown import" Doc -> Doc -> Doc
<+> Doc -> Doc
dquotes (String -> Doc
text String
canonical_import) Doc -> Doc -> Doc
</>
                  Doc
"Known:" Doc -> Doc -> Doc
<+> [Doc] -> Doc
commasep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text (ImportTable -> [String]
forall k a. Map k a -> [k]
M.keys ImportTable
imports))
    Just Env
scope -> (String, Env) -> TypeM (String, Env)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
canonical_import, Env
scope)

localEnv :: Env -> TypeM a -> TypeM a
localEnv :: Env -> TypeM a -> TypeM a
localEnv Env
env = (Context -> Context) -> TypeM a -> TypeM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context -> Context) -> TypeM a -> TypeM a)
-> (Context -> Context) -> TypeM a -> TypeM a
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
  let env' :: Env
env' = Env
env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Context -> Env
contextEnv Context
ctx
  in Context
ctx { contextEnv :: Env
contextEnv = Env
env' }

class Monad m => MonadTypeChecker m where
  warn :: Located loc => loc -> String -> m ()

  newName :: VName -> m VName
  newID :: Name -> m VName

  bindNameMap :: NameMap -> m a -> m a
  bindVal :: VName -> BoundV -> m a -> m a

  checkQualName :: Namespace -> QualName Name -> SrcLoc -> m (QualName VName)

  lookupType :: SrcLoc -> QualName Name -> m (QualName VName, [TypeParam], StructType, Liftedness)
  lookupMod :: SrcLoc -> QualName Name -> m (QualName VName, Mod)
  lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatternType)

  checkNamedDim :: SrcLoc -> QualName Name -> m (QualName VName)
  checkNamedDim SrcLoc
loc QualName Name
v = do
    (QualName VName
v', PatternType
t) <- SrcLoc -> QualName Name -> m (QualName VName, PatternType)
forall (m :: * -> *).
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m (QualName VName, PatternType)
lookupVar SrcLoc
loc QualName Name
v
    case PatternType
t of
      Scalar (Prim (Signed IntType
Int32)) -> QualName VName -> m (QualName VName)
forall (m :: * -> *) a. Monad m => a -> m a
return QualName VName
v'
      PatternType
_ -> SrcLoc -> Notes -> Doc -> m (QualName VName)
forall (m :: * -> *) loc a.
(MonadTypeChecker m, Located loc) =>
loc -> Notes -> Doc -> m a
typeError SrcLoc
loc Notes
forall a. Monoid a => a
mempty (Doc -> m (QualName VName)) -> Doc -> m (QualName VName)
forall a b. (a -> b) -> a -> b
$
           Doc
"Dimension declaration" Doc -> Doc -> Doc
<+> QualName Name -> Doc
forall a. Pretty a => a -> Doc
ppr QualName Name
v Doc -> Doc -> Doc
<+> Doc
"should be of type i32."

  typeError :: Located loc => loc -> Notes -> Doc -> m a

checkName :: MonadTypeChecker m => Namespace -> Name -> SrcLoc -> m VName
checkName :: Namespace -> Name -> SrcLoc -> m VName
checkName Namespace
space Name
name SrcLoc
loc = QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf (QualName VName -> VName) -> m (QualName VName) -> m VName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace -> QualName Name -> SrcLoc -> m (QualName VName)
forall (m :: * -> *).
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m (QualName VName)
checkQualName Namespace
space (Name -> QualName Name
forall v. v -> QualName v
qualName Name
name) SrcLoc
loc

bindSpaced :: MonadTypeChecker m => [(Namespace, Name)] -> m a -> m a
bindSpaced :: [(Namespace, Name)] -> m a -> m a
bindSpaced [(Namespace, Name)]
names m a
body = do
  [VName]
names' <- ((Namespace, Name) -> m VName) -> [(Namespace, Name)] -> m [VName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> m VName
forall (m :: * -> *). MonadTypeChecker m => Name -> m VName
newID (Name -> m VName)
-> ((Namespace, Name) -> Name) -> (Namespace, Name) -> m VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace, Name) -> Name
forall a b. (a, b) -> b
snd) [(Namespace, Name)]
names
  let mapping :: Map (Namespace, Name) (QualName VName)
mapping = [((Namespace, Name), QualName VName)]
-> Map (Namespace, Name) (QualName VName)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Namespace, Name)]
-> [QualName VName] -> [((Namespace, Name), QualName VName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Namespace, Name)]
names ([QualName VName] -> [((Namespace, Name), QualName VName)])
-> [QualName VName] -> [((Namespace, Name), QualName VName)]
forall a b. (a -> b) -> a -> b
$ (VName -> QualName VName) -> [VName] -> [QualName VName]
forall a b. (a -> b) -> [a] -> [b]
map VName -> QualName VName
forall v. v -> QualName v
qualName [VName]
names')
  Map (Namespace, Name) (QualName VName) -> m a -> m a
forall (m :: * -> *) a.
MonadTypeChecker m =>
Map (Namespace, Name) (QualName VName) -> m a -> m a
bindNameMap Map (Namespace, Name) (QualName VName)
mapping m a
body

instance MonadTypeChecker TypeM where
  warn :: loc -> String -> TypeM ()
warn loc
loc String
problem = Warnings -> TypeM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Warnings -> TypeM ()) -> Warnings -> TypeM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> Warnings
singleWarning (loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf loc
loc) String
problem

  newName :: VName -> TypeM VName
newName VName
s = do VNameSource
src <- TypeM VNameSource
forall s (m :: * -> *). MonadState s m => m s
get
                 let (VName
s', VNameSource
src') = VNameSource -> VName -> (VName, VNameSource)
Futhark.FreshNames.newName VNameSource
src VName
s
                 VNameSource -> TypeM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put VNameSource
src'
                 VName -> TypeM VName
forall (m :: * -> *) a. Monad m => a -> m a
return VName
s'

  newID :: Name -> TypeM VName
newID Name
s = VName -> TypeM VName
forall (m :: * -> *). MonadTypeChecker m => VName -> m VName
newName (VName -> TypeM VName) -> VName -> TypeM VName
forall a b. (a -> b) -> a -> b
$ Name -> Int -> VName
VName Name
s Int
0

  bindNameMap :: Map (Namespace, Name) (QualName VName) -> TypeM a -> TypeM a
bindNameMap Map (Namespace, Name) (QualName VName)
m = (Context -> Context) -> TypeM a -> TypeM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context -> Context) -> TypeM a -> TypeM a)
-> (Context -> Context) -> TypeM a -> TypeM a
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
    let env :: Env
env = Context -> Env
contextEnv Context
ctx
    in Context
ctx { contextEnv :: Env
contextEnv = Env
env { envNameMap :: Map (Namespace, Name) (QualName VName)
envNameMap = Map (Namespace, Name) (QualName VName)
m Map (Namespace, Name) (QualName VName)
-> Map (Namespace, Name) (QualName VName)
-> Map (Namespace, Name) (QualName VName)
forall a. Semigroup a => a -> a -> a
<> Env -> Map (Namespace, Name) (QualName VName)
envNameMap Env
env } }

  bindVal :: VName -> BoundV -> TypeM a -> TypeM a
bindVal VName
v BoundV
t = (Context -> Context) -> TypeM a -> TypeM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context -> Context) -> TypeM a -> TypeM a)
-> (Context -> Context) -> TypeM a -> TypeM a
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
    Context
ctx { contextEnv :: Env
contextEnv = (Context -> Env
contextEnv Context
ctx)
                       { envVtable :: Map VName BoundV
envVtable = VName -> BoundV -> Map VName BoundV -> Map VName BoundV
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v BoundV
t (Map VName BoundV -> Map VName BoundV)
-> Map VName BoundV -> Map VName BoundV
forall a b. (a -> b) -> a -> b
$ Env -> Map VName BoundV
envVtable (Env -> Map VName BoundV) -> Env -> Map VName BoundV
forall a b. (a -> b) -> a -> b
$ Context -> Env
contextEnv Context
ctx } }

  checkQualName :: Namespace -> QualName Name -> SrcLoc -> TypeM (QualName VName)
checkQualName Namespace
space QualName Name
name SrcLoc
loc = (Env, QualName VName) -> QualName VName
forall a b. (a, b) -> b
snd ((Env, QualName VName) -> QualName VName)
-> TypeM (Env, QualName VName) -> TypeM (QualName VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
space QualName Name
name SrcLoc
loc

  lookupType :: SrcLoc
-> QualName Name
-> TypeM (QualName VName, [TypeParam], StructType, Liftedness)
lookupType SrcLoc
loc QualName Name
qn = do
    Env
outer_env <- TypeM Env
askEnv
    (Env
scope, qn' :: QualName VName
qn'@(QualName [VName]
qs VName
name)) <- Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
Type QualName Name
qn SrcLoc
loc
    case VName -> Map VName TypeBinding -> Maybe TypeBinding
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name (Map VName TypeBinding -> Maybe TypeBinding)
-> Map VName TypeBinding -> Maybe TypeBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TypeBinding
envTypeTable Env
scope of
      Maybe TypeBinding
Nothing -> SrcLoc
-> QualName Name
-> TypeM (QualName VName, [TypeParam], StructType, Liftedness)
forall (m :: * -> *) a.
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m a
undefinedType SrcLoc
loc QualName Name
qn
      Just (TypeAbbr Liftedness
l [TypeParam]
ps StructType
def) -> (QualName VName, [TypeParam], StructType, Liftedness)
-> TypeM (QualName VName, [TypeParam], StructType, Liftedness)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualName VName
qn', [TypeParam]
ps, Env -> [VName] -> [VName] -> StructType -> StructType
forall t. ASTMappable t => Env -> [VName] -> [VName] -> t -> t
qualifyTypeVars Env
outer_env [VName]
forall a. Monoid a => a
mempty [VName]
qs StructType
def, Liftedness
l)

  lookupMod :: SrcLoc -> QualName Name -> TypeM (QualName VName, Mod)
lookupMod SrcLoc
loc QualName Name
qn = do
    (Env
scope, qn' :: QualName VName
qn'@(QualName [VName]
_ VName
name)) <- Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
Term QualName Name
qn SrcLoc
loc
    case VName -> Map VName Mod -> Maybe Mod
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name (Map VName Mod -> Maybe Mod) -> Map VName Mod -> Maybe Mod
forall a b. (a -> b) -> a -> b
$ Env -> Map VName Mod
envModTable Env
scope of
      Maybe Mod
Nothing -> Namespace -> QualName Name -> SrcLoc -> TypeM (QualName VName, Mod)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
Term QualName Name
qn SrcLoc
loc
      Just Mod
m  -> (QualName VName, Mod) -> TypeM (QualName VName, Mod)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualName VName
qn', Mod
m)

  lookupVar :: SrcLoc -> QualName Name -> TypeM (QualName VName, PatternType)
lookupVar SrcLoc
loc QualName Name
qn = do
    Env
outer_env <- TypeM Env
askEnv
    (Env
env, qn' :: QualName VName
qn'@(QualName [VName]
qs VName
name)) <- Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
Term QualName Name
qn SrcLoc
loc
    case VName -> Map VName BoundV -> Maybe BoundV
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name (Map VName BoundV -> Maybe BoundV)
-> Map VName BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ Env -> Map VName BoundV
envVtable Env
env of
      Maybe BoundV
Nothing -> Namespace
-> QualName Name -> SrcLoc -> TypeM (QualName VName, PatternType)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
Term QualName Name
qn SrcLoc
loc
      Just (BoundV [TypeParam]
_ StructType
t)
        | String
"_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` VName -> String
baseString VName
name -> SrcLoc -> QualName Name -> TypeM (QualName VName, PatternType)
forall (m :: * -> *) a.
MonadTypeChecker m =>
SrcLoc -> QualName Name -> m a
underscoreUse SrcLoc
loc QualName Name
qn
        | Bool
otherwise ->
            case StructType -> Either ([(PName, StructType)], StructType) StructType
forall dim as.
TypeBase dim as
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
getType StructType
t of
              Left{} -> SrcLoc -> Notes -> Doc -> TypeM (QualName VName, PatternType)
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 (QualName VName, PatternType))
-> Doc -> TypeM (QualName VName, PatternType)
forall a b. (a -> b) -> a -> b
$
                        Doc
"Attempt to use function" Doc -> Doc -> Doc
<+> VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
name Doc -> Doc -> Doc
<+> Doc
"as value."
              Right StructType
t' -> (QualName VName, PatternType)
-> TypeM (QualName VName, PatternType)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualName VName
qn', StructType -> PatternType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct (StructType -> PatternType) -> StructType -> PatternType
forall a b. (a -> b) -> a -> b
$
                                       Env -> [VName] -> [VName] -> StructType -> StructType
forall t. ASTMappable t => Env -> [VName] -> [VName] -> t -> t
qualifyTypeVars Env
outer_env [VName]
forall a. Monoid a => a
mempty [VName]
qs StructType
t')

  typeError :: loc -> Notes -> Doc -> TypeM a
typeError loc
loc Notes
notes Doc
s = TypeError -> TypeM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeError -> TypeM a) -> TypeError -> TypeM a
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Notes -> Doc -> TypeError
TypeError (loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf loc
loc) Notes
notes Doc
s

-- | Extract from a type either a function type comprising a list of
-- parameter types and a return type, or a first-order type.
getType :: TypeBase dim as
        -> Either ([(PName, TypeBase dim as)], TypeBase dim as)
                  (TypeBase dim as)
getType :: TypeBase dim as
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
getType (Scalar (Arrow as
_ PName
v TypeBase dim as
t1 TypeBase dim as
t2)) =
  case TypeBase dim as
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
forall dim as.
TypeBase dim as
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
getType TypeBase dim as
t2 of
    Left ([(PName, TypeBase dim as)]
ps, TypeBase dim as
r) -> ([(PName, TypeBase dim as)], TypeBase dim as)
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
forall a b. a -> Either a b
Left ((PName
v, TypeBase dim as
t1) (PName, TypeBase dim as)
-> [(PName, TypeBase dim as)] -> [(PName, TypeBase dim as)]
forall a. a -> [a] -> [a]
: [(PName, TypeBase dim as)]
ps, TypeBase dim as
r)
    Right TypeBase dim as
_ -> ([(PName, TypeBase dim as)], TypeBase dim as)
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
forall a b. a -> Either a b
Left ([(PName
v, TypeBase dim as
t1)], TypeBase dim as
t2)
getType TypeBase dim as
t = TypeBase dim as
-> Either
     ([(PName, TypeBase dim as)], TypeBase dim as) (TypeBase dim as)
forall a b. b -> Either a b
Right TypeBase dim as
t

checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName)
checkQualNameWithEnv Namespace
space qn :: QualName Name
qn@(QualName [Name]
quals Name
name) SrcLoc
loc = do
  Env
env <- TypeM Env
askEnv
  Env -> [Name] -> TypeM (Env, QualName VName)
forall (m :: * -> *).
MonadTypeChecker m =>
Env -> [Name] -> m (Env, QualName VName)
descend Env
env [Name]
quals
  where descend :: Env -> [Name] -> m (Env, QualName VName)
descend Env
scope []
          | Just QualName VName
name' <- (Namespace, Name)
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
space, Name
name) (Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName))
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall a b. (a -> b) -> a -> b
$ Env -> Map (Namespace, Name) (QualName VName)
envNameMap Env
scope =
              (Env, QualName VName) -> m (Env, QualName VName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
scope, QualName VName
name')
          | Bool
otherwise =
              Namespace -> QualName Name -> SrcLoc -> m (Env, QualName VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
space QualName Name
qn SrcLoc
loc

        descend Env
scope (Name
q:[Name]
qs)
          | Just (QualName [VName]
_ VName
q') <- (Namespace, Name)
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
Term, Name
q) (Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName))
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall a b. (a -> b) -> a -> b
$ Env -> Map (Namespace, Name) (QualName VName)
envNameMap Env
scope,
            Just Mod
res <- VName -> Map VName Mod -> Maybe Mod
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
q' (Map VName Mod -> Maybe Mod) -> Map VName Mod -> Maybe Mod
forall a b. (a -> b) -> a -> b
$ Env -> Map VName Mod
envModTable Env
scope =
              case Mod
res of
                ModEnv Env
q_scope -> do
                  (Env
scope', QualName [VName]
qs' VName
name') <- Env -> [Name] -> m (Env, QualName VName)
descend Env
q_scope [Name]
qs
                  (Env, QualName VName) -> m (Env, QualName VName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
scope', [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName (VName
q'VName -> [VName] -> [VName]
forall a. a -> [a] -> [a]
:[VName]
qs') VName
name')
                ModFun{} -> SrcLoc -> m (Env, QualName VName)
forall (m :: * -> *) a. MonadTypeChecker m => SrcLoc -> m a
unappliedFunctor SrcLoc
loc
          | Bool
otherwise =
              Namespace -> QualName Name -> SrcLoc -> m (Env, QualName VName)
forall (m :: * -> *) a.
MonadTypeChecker m =>
Namespace -> QualName Name -> SrcLoc -> m a
unknownVariableError Namespace
space QualName Name
qn SrcLoc
loc

-- Try to prepend qualifiers to the type names such that they
-- represent how to access the type in some scope.
qualifyTypeVars :: ASTMappable t => Env -> [VName] -> [VName] -> t -> t
qualifyTypeVars :: Env -> [VName] -> [VName] -> t -> t
qualifyTypeVars Env
outer_env [VName]
except [VName]
ref_qs = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (t -> Identity t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTMapper Identity -> t -> Identity t
forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap ASTMapper Identity
mapper
  where mapper :: ASTMapper Identity
mapper = ASTMapper :: forall (m :: * -> *).
(ExpBase Info VName -> m (ExpBase Info VName))
-> (VName -> m VName)
-> (QualName VName -> m (QualName VName))
-> (StructType -> m StructType)
-> (PatternType -> m PatternType)
-> ASTMapper m
ASTMapper { mapOnExp :: ExpBase Info VName -> Identity (ExpBase Info VName)
mapOnExp = ExpBase Info VName -> Identity (ExpBase Info VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           , mapOnName :: VName -> Identity VName
mapOnName = VName -> Identity VName
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           , mapOnQualName :: QualName VName -> Identity (QualName VName)
mapOnQualName = QualName VName -> Identity (QualName VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName VName -> Identity (QualName VName))
-> (QualName VName -> QualName VName)
-> QualName VName
-> Identity (QualName VName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualName VName -> QualName VName
qual
                           , mapOnStructType :: StructType -> Identity StructType
mapOnStructType = StructType -> Identity StructType
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           , mapOnPatternType :: PatternType -> Identity PatternType
mapOnPatternType = PatternType -> Identity PatternType
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                           }
        qual :: QualName VName -> QualName VName
qual (QualName [VName]
orig_qs VName
name)
          | VName
name VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
except Bool -> Bool -> Bool
|| [VName] -> VName -> Env -> Bool
reachable [VName]
orig_qs VName
name Env
outer_env =
              [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName [VName]
orig_qs VName
name
          | Bool
otherwise =
              [VName] -> [VName] -> QualName VName -> QualName VName
prependAsNecessary [] [VName]
ref_qs (QualName VName -> QualName VName)
-> QualName VName -> QualName VName
forall a b. (a -> b) -> a -> b
$ [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName [VName]
orig_qs VName
name

        prependAsNecessary :: [VName] -> [VName] -> QualName VName -> QualName VName
prependAsNecessary [VName]
qs [VName]
rem_qs (QualName [VName]
orig_qs VName
name)
          | [VName] -> VName -> Env -> Bool
reachable ([VName]
qs[VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++[VName]
orig_qs) VName
name Env
outer_env = [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName ([VName]
qs[VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++[VName]
orig_qs) VName
name
          | Bool
otherwise = case [VName]
rem_qs of
                          VName
q:[VName]
rem_qs' -> [VName] -> [VName] -> QualName VName -> QualName VName
prependAsNecessary ([VName]
qs[VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++[VName
q]) [VName]
rem_qs' ([VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName [VName]
orig_qs VName
name)
                          []       -> [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName ([VName]
qs[VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++[VName]
orig_qs) VName
name

        reachable :: [VName] -> VName -> Env -> Bool
reachable [] VName
name Env
env =
          VName
name VName -> Map VName BoundV -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Env -> Map VName BoundV
envVtable Env
env Bool -> Bool -> Bool
||
          Maybe TypeBinding -> Bool
forall a. Maybe a -> Bool
isJust ((TypeBinding -> Bool) -> [TypeBinding] -> Maybe TypeBinding
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TypeBinding -> Bool
matches ([TypeBinding] -> Maybe TypeBinding)
-> [TypeBinding] -> Maybe TypeBinding
forall a b. (a -> b) -> a -> b
$ Map VName TypeBinding -> [TypeBinding]
forall k a. Map k a -> [a]
M.elems (Env -> Map VName TypeBinding
envTypeTable Env
env))
          where matches :: TypeBinding -> Bool
matches (TypeAbbr Liftedness
_ [TypeParam]
_ (Scalar (TypeVar ()
_ Uniqueness
_ (TypeName [VName]
x_qs VName
name') [TypeArg (DimDecl VName)]
_))) =
                  [VName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
x_qs Bool -> Bool -> Bool
&& VName
name VName -> VName -> Bool
forall a. Eq a => a -> a -> Bool
== VName
name'
                matches TypeBinding
_ = Bool
False

        reachable (VName
q:[VName]
qs') VName
name Env
env
          | Just (ModEnv Env
env') <- VName -> Map VName Mod -> Maybe Mod
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
q (Map VName Mod -> Maybe Mod) -> Map VName Mod -> Maybe Mod
forall a b. (a -> b) -> a -> b
$ Env -> Map VName Mod
envModTable Env
env =
              [VName] -> VName -> Env -> Bool
reachable [VName]
qs' VName
name Env
env'
          | Bool
otherwise = Bool
False

badOnLeft :: Either TypeError a -> TypeM a
badOnLeft :: Either TypeError a -> TypeM a
badOnLeft = (TypeError -> TypeM a)
-> (a -> TypeM a) -> Either TypeError a -> TypeM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TypeError -> TypeM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> TypeM a
forall (m :: * -> *) a. Monad m => a -> m a
return

anySignedType :: [PrimType]
anySignedType :: [PrimType]
anySignedType = (IntType -> PrimType) -> [IntType] -> [PrimType]
forall a b. (a -> b) -> [a] -> [b]
map IntType -> PrimType
Signed [IntType
forall a. Bounded a => a
minBound .. IntType
forall a. Bounded a => a
maxBound]

anyUnsignedType :: [PrimType]
anyUnsignedType :: [PrimType]
anyUnsignedType = (IntType -> PrimType) -> [IntType] -> [PrimType]
forall a b. (a -> b) -> [a] -> [b]
map IntType -> PrimType
Unsigned [IntType
forall a. Bounded a => a
minBound .. IntType
forall a. Bounded a => a
maxBound]

anyIntType :: [PrimType]
anyIntType :: [PrimType]
anyIntType = [PrimType]
anySignedType [PrimType] -> [PrimType] -> [PrimType]
forall a. [a] -> [a] -> [a]
++ [PrimType]
anyUnsignedType

anyFloatType :: [PrimType]
anyFloatType :: [PrimType]
anyFloatType = (FloatType -> PrimType) -> [FloatType] -> [PrimType]
forall a b. (a -> b) -> [a] -> [b]
map FloatType -> PrimType
FloatType [FloatType
forall a. Bounded a => a
minBound .. FloatType
forall a. Bounded a => a
maxBound]

anyNumberType :: [PrimType]
anyNumberType :: [PrimType]
anyNumberType = [PrimType]
anyIntType [PrimType] -> [PrimType] -> [PrimType]
forall a. [a] -> [a] -> [a]
++ [PrimType]
anyFloatType

anyPrimType :: [PrimType]
anyPrimType :: [PrimType]
anyPrimType = PrimType
Bool PrimType -> [PrimType] -> [PrimType]
forall a. a -> [a] -> [a]
: [PrimType]
anyIntType [PrimType] -> [PrimType] -> [PrimType]
forall a. [a] -> [a] -> [a]
++ [PrimType]
anyFloatType

--- Name handling

intrinsicsNameMap :: NameMap
intrinsicsNameMap :: Map (Namespace, Name) (QualName VName)
intrinsicsNameMap = [((Namespace, Name), QualName VName)]
-> Map (Namespace, Name) (QualName VName)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((Namespace, Name), QualName VName)]
 -> Map (Namespace, Name) (QualName VName))
-> [((Namespace, Name), QualName VName)]
-> Map (Namespace, Name) (QualName VName)
forall a b. (a -> b) -> a -> b
$ ((VName, Intrinsic) -> ((Namespace, Name), QualName VName))
-> [(VName, Intrinsic)] -> [((Namespace, Name), QualName VName)]
forall a b. (a -> b) -> [a] -> [b]
map (VName, Intrinsic) -> ((Namespace, Name), QualName VName)
mapping ([(VName, Intrinsic)] -> [((Namespace, Name), QualName VName)])
-> [(VName, Intrinsic)] -> [((Namespace, Name), QualName VName)]
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
  where mapping :: (VName, Intrinsic) -> ((Namespace, Name), QualName VName)
mapping (VName
v, IntrinsicType{}) = ((Namespace
Type, VName -> Name
baseName VName
v), [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName [] VName
v)
        mapping (VName
v, Intrinsic
_)               = ((Namespace
Term, VName -> Name
baseName VName
v), [VName] -> VName -> QualName VName
forall vn. [vn] -> vn -> QualName vn
QualName [] VName
v)

topLevelNameMap :: NameMap
topLevelNameMap :: Map (Namespace, Name) (QualName VName)
topLevelNameMap = ((Namespace, Name) -> QualName VName -> Bool)
-> Map (Namespace, Name) (QualName VName)
-> Map (Namespace, Name) (QualName VName)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\(Namespace, Name)
k QualName VName
_ -> (Namespace, Name) -> Bool
atTopLevel (Namespace, Name)
k) Map (Namespace, Name) (QualName VName)
intrinsicsNameMap
  where atTopLevel :: (Namespace, Name) -> Bool
        atTopLevel :: (Namespace, Name) -> Bool
atTopLevel (Namespace
Type, Name
_) = Bool
True
        atTopLevel (Namespace
Term, Name
v) = Name
v Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` (Set Name
type_names Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Set Name
binop_names Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Set Name
unop_names Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Set Name
fun_names)
          where type_names :: Set Name
type_names = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (PrimType -> Name) -> [PrimType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
nameFromString (String -> Name) -> (PrimType -> String) -> PrimType -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimType -> String
forall a. Pretty a => a -> String
pretty) [PrimType]
anyPrimType
                binop_names :: Set Name
binop_names = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (BinOp -> Name) -> [BinOp] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
nameFromString (String -> Name) -> (BinOp -> String) -> BinOp -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinOp -> String
forall a. Pretty a => a -> String
pretty)
                              [BinOp
forall a. Bounded a => a
minBound..(BinOp
forall a. Bounded a => a
maxBound::BinOp)]
                unop_names :: Set Name
unop_names = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
nameFromString [String
"!"]
                fun_names :: Set Name
fun_names = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
nameFromString [String
"shape"]
        atTopLevel (Namespace, Name)
_         = Bool
False