{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

{- | Check scoping rules and naming conventions for identifiers.

Here, we ensure that all identifiers that appear in the AST only appear after
they are previously declared or defined.

Identifiers can be segregated into two categories: data identifiers, which
produce expressions, and type identifiers, which produce types (more accurately,
type expressions). These inhabit separate namespaces and are distinguished by
the different contexts in which they are used.

Of each category, there are two kinds of identifiers: constructors and
variables. Constructors must begin with an upper case letter or a colon (@:@);
all other identifiers are variables (see 'isCons' and 'isVar'). For instance,
data constructors name the variants of an algebraic data type, while data
variables name values bound by a let-binding, a pattern-match, or a lambda.
Meanwhile, type constructors are points in the type system defined by the user,
while type variables are universally quantified in each type expression.

Consider the following example:

@@
type Bool =
  True
  False

type Either t u =
  Left t
  Right u

liftEither b x y: Bool -> a -> b -> Either a b =
  match b
    True  = Left x
    False = Right y
@@

Data variables are @switch@, @b@, @x@, and @y@; data constructors are @True@,
@False@, @Left@, and @Right@. Type variables are @t@, @u@, @a@, and @b@; type
constructors are @Bool@ and @Either@.

The grammar as it appears in the parser does not actually distinguish between
any of these kinds of identifiers, so it is the responsibility of this module to
check that, a data constructor does not appear where a data variable is
expected, e.g., @let F x = e@, or vice versa, e.g., @let f (x Y) = e@.
-}
module Front.Scope (scopeProgram) where

import Common.Compiler (
  Error (..),
  ErrorMsg,
  MonadError (..),
  MonadWriter,
  Pass (..),
  Warning (..),
  fromString,
  warn,
 )
import Common.Default (Default (..))
import Common.Identifiers (Identifiable (..), Identifier (..), isCons, isReserved, isVar)

import qualified Front.Ast as A
import Front.Identifiers (
  DataInfo (..),
  IdKind (..),
  TypInfo (..),
  builtinData,
  builtinTypes,
 )

import Control.Monad (forM_, unless, when)
import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)
import Data.List (group, sort)
import qualified Data.Map as M
import Data.Maybe (isJust, mapMaybe)


-- | Report 'Identifier' for error reporting.
showId :: Identifier -> ErrorMsg
showId :: Identifier -> ErrorMsg
showId Identifier
s = ErrorMsg
"'" ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> String -> ErrorMsg
forall a. IsString a => String -> a
fromString (Identifier -> String
forall i. Identifiable i => i -> String
ident Identifier
s) ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"'"


{- | Scoping environment, maintained during the scoping pass.

In type expressions that act as type annotations, type variables are implicitly
qualified at the top-level, so any type variable is always in scope. So, an
annotation like @id : a -> a@ is legal, and means @id : forall a. a -> a@.

However, in the context of type definitions, type variables must be quantified.
So something like @type T a = D a b@ is illegal because the type variable @b@
does not appear as a parameter of unary type constructor @T@.

To account for this discrepancy, the 'implicitScheme' field of the scoping
environment is used to keep track of this context.
-}
data ScopeCtx = ScopeCtx
  { -- | Map of in-scope data ids
    ScopeCtx -> Map Identifier DataInfo
dataMap :: M.Map Identifier DataInfo
  , -- | Map of in-scope type ids
    ScopeCtx -> Map Identifier TypInfo
typeMap :: M.Map Identifier TypInfo
  , -- | Allow implicit type vars
    ScopeCtx -> Bool
implicitScheme :: Bool
  }


-- | Scoping monad.
newtype ScopeFn a = ScopeFn (ReaderT ScopeCtx Pass a)
  deriving (a -> ScopeFn b -> ScopeFn a
(a -> b) -> ScopeFn a -> ScopeFn b
(forall a b. (a -> b) -> ScopeFn a -> ScopeFn b)
-> (forall a b. a -> ScopeFn b -> ScopeFn a) -> Functor ScopeFn
forall a b. a -> ScopeFn b -> ScopeFn a
forall a b. (a -> b) -> ScopeFn a -> ScopeFn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ScopeFn b -> ScopeFn a
$c<$ :: forall a b. a -> ScopeFn b -> ScopeFn a
fmap :: (a -> b) -> ScopeFn a -> ScopeFn b
$cfmap :: forall a b. (a -> b) -> ScopeFn a -> ScopeFn b
Functor) via (ReaderT ScopeCtx Pass)
  deriving (Functor ScopeFn
a -> ScopeFn a
Functor ScopeFn
-> (forall a. a -> ScopeFn a)
-> (forall a b. ScopeFn (a -> b) -> ScopeFn a -> ScopeFn b)
-> (forall a b c.
    (a -> b -> c) -> ScopeFn a -> ScopeFn b -> ScopeFn c)
-> (forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b)
-> (forall a b. ScopeFn a -> ScopeFn b -> ScopeFn a)
-> Applicative ScopeFn
ScopeFn a -> ScopeFn b -> ScopeFn b
ScopeFn a -> ScopeFn b -> ScopeFn a
ScopeFn (a -> b) -> ScopeFn a -> ScopeFn b
(a -> b -> c) -> ScopeFn a -> ScopeFn b -> ScopeFn c
forall a. a -> ScopeFn a
forall a b. ScopeFn a -> ScopeFn b -> ScopeFn a
forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b
forall a b. ScopeFn (a -> b) -> ScopeFn a -> ScopeFn b
forall a b c. (a -> b -> c) -> ScopeFn a -> ScopeFn b -> ScopeFn 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
<* :: ScopeFn a -> ScopeFn b -> ScopeFn a
$c<* :: forall a b. ScopeFn a -> ScopeFn b -> ScopeFn a
*> :: ScopeFn a -> ScopeFn b -> ScopeFn b
$c*> :: forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b
liftA2 :: (a -> b -> c) -> ScopeFn a -> ScopeFn b -> ScopeFn c
$cliftA2 :: forall a b c. (a -> b -> c) -> ScopeFn a -> ScopeFn b -> ScopeFn c
<*> :: ScopeFn (a -> b) -> ScopeFn a -> ScopeFn b
$c<*> :: forall a b. ScopeFn (a -> b) -> ScopeFn a -> ScopeFn b
pure :: a -> ScopeFn a
$cpure :: forall a. a -> ScopeFn a
$cp1Applicative :: Functor ScopeFn
Applicative) via (ReaderT ScopeCtx Pass)
  deriving (Applicative ScopeFn
a -> ScopeFn a
Applicative ScopeFn
-> (forall a b. ScopeFn a -> (a -> ScopeFn b) -> ScopeFn b)
-> (forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b)
-> (forall a. a -> ScopeFn a)
-> Monad ScopeFn
ScopeFn a -> (a -> ScopeFn b) -> ScopeFn b
ScopeFn a -> ScopeFn b -> ScopeFn b
forall a. a -> ScopeFn a
forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b
forall a b. ScopeFn a -> (a -> ScopeFn b) -> ScopeFn 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 -> ScopeFn a
$creturn :: forall a. a -> ScopeFn a
>> :: ScopeFn a -> ScopeFn b -> ScopeFn b
$c>> :: forall a b. ScopeFn a -> ScopeFn b -> ScopeFn b
>>= :: ScopeFn a -> (a -> ScopeFn b) -> ScopeFn b
$c>>= :: forall a b. ScopeFn a -> (a -> ScopeFn b) -> ScopeFn b
$cp1Monad :: Applicative ScopeFn
Monad) via (ReaderT ScopeCtx Pass)
  deriving (Monad ScopeFn
Monad ScopeFn
-> (forall a. String -> ScopeFn a) -> MonadFail ScopeFn
String -> ScopeFn a
forall a. String -> ScopeFn a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> ScopeFn a
$cfail :: forall a. String -> ScopeFn a
$cp1MonadFail :: Monad ScopeFn
MonadFail) via (ReaderT ScopeCtx Pass)
  deriving (MonadError Error) via (ReaderT ScopeCtx Pass)
  deriving (MonadWriter [Warning]) via (ReaderT ScopeCtx Pass)
  deriving (MonadReader ScopeCtx) via (ReaderT ScopeCtx Pass)


-- | Run a ScopeFn computation.
runScopeFn :: ScopeFn a -> Pass a
runScopeFn :: ScopeFn a -> Pass a
runScopeFn (ScopeFn ReaderT ScopeCtx Pass a
m) =
  ReaderT ScopeCtx Pass a -> ScopeCtx -> Pass a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
    ReaderT ScopeCtx Pass a
m
    ScopeCtx :: Map Identifier DataInfo
-> Map Identifier TypInfo -> Bool -> ScopeCtx
ScopeCtx
      { dataMap :: Map Identifier DataInfo
dataMap = Map Identifier DataInfo
builtinData
      , typeMap :: Map Identifier TypInfo
typeMap = Map Identifier TypInfo
builtinTypes
      , implicitScheme :: Bool
implicitScheme = Bool
True
      }


-- | Add a list of data identifiers to the scope.
withTypeScope :: [(Identifier, TypInfo)] -> ScopeFn a -> ScopeFn a
withTypeScope :: [(Identifier, TypInfo)] -> ScopeFn a -> ScopeFn a
withTypeScope [(Identifier, TypInfo)]
is =
  (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a)
-> (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall a b. (a -> b) -> a -> b
$ \ScopeCtx
ctx -> ScopeCtx
ctx{typeMap :: Map Identifier TypInfo
typeMap = ((Identifier, TypInfo)
 -> Map Identifier TypInfo -> Map Identifier TypInfo)
-> Map Identifier TypInfo
-> [(Identifier, TypInfo)]
-> Map Identifier TypInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Identifier
 -> TypInfo -> Map Identifier TypInfo -> Map Identifier TypInfo)
-> (Identifier, TypInfo)
-> Map Identifier TypInfo
-> Map Identifier TypInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Identifier
-> TypInfo -> Map Identifier TypInfo -> Map Identifier TypInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) (ScopeCtx -> Map Identifier TypInfo
typeMap ScopeCtx
ctx) [(Identifier, TypInfo)]
is}


-- | Add a list of data identifiers to the scope.
withDataScope :: [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope :: [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
is =
  (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a)
-> (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall a b. (a -> b) -> a -> b
$ \ScopeCtx
ctx -> ScopeCtx
ctx{dataMap :: Map Identifier DataInfo
dataMap = ((Identifier, DataInfo)
 -> Map Identifier DataInfo -> Map Identifier DataInfo)
-> Map Identifier DataInfo
-> [(Identifier, DataInfo)]
-> Map Identifier DataInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Identifier
 -> DataInfo -> Map Identifier DataInfo -> Map Identifier DataInfo)
-> (Identifier, DataInfo)
-> Map Identifier DataInfo
-> Map Identifier DataInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Identifier
-> DataInfo -> Map Identifier DataInfo -> Map Identifier DataInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) (ScopeCtx -> Map Identifier DataInfo
dataMap ScopeCtx
ctx) [(Identifier, DataInfo)]
is}


withExplicitScheme :: [Identifier] -> ScopeFn a -> ScopeFn a
withExplicitScheme :: [Identifier] -> ScopeFn a -> ScopeFn a
withExplicitScheme [Identifier]
is = (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a)
-> (ScopeCtx -> ScopeCtx) -> ScopeFn a -> ScopeFn a
forall a b. (a -> b) -> a -> b
$ \ScopeCtx
ctx ->
  ScopeCtx
ctx
    { typeMap :: Map Identifier TypInfo
typeMap =
        ((Identifier, TypInfo)
 -> Map Identifier TypInfo -> Map Identifier TypInfo)
-> Map Identifier TypInfo
-> [(Identifier, TypInfo)]
-> Map Identifier TypInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          ((Identifier
 -> TypInfo -> Map Identifier TypInfo -> Map Identifier TypInfo)
-> (Identifier, TypInfo)
-> Map Identifier TypInfo
-> Map Identifier TypInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Identifier
-> TypInfo -> Map Identifier TypInfo -> Map Identifier TypInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert)
          (ScopeCtx -> Map Identifier TypInfo
typeMap ScopeCtx
ctx)
          ([Identifier] -> [TypInfo] -> [(Identifier, TypInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
is ([TypInfo] -> [(Identifier, TypInfo)])
-> [TypInfo] -> [(Identifier, TypInfo)]
forall a b. (a -> b) -> a -> b
$ TypInfo -> [TypInfo]
forall a. a -> [a]
repeat TypInfo :: IdKind -> TypInfo
TypInfo{typKind :: IdKind
typKind = IdKind
User})
    , implicitScheme :: Bool
implicitScheme = Bool
False
    }


-- | Check that an 'Identifier' is not an empty string.
ensureNonempty :: Identifier -> ScopeFn ()
ensureNonempty :: Identifier -> ScopeFn ()
ensureNonempty Identifier
i =
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Identifier -> String
forall i. Identifiable i => i -> String
ident Identifier
i) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
UnexpectedError ErrorMsg
"Empty identifier"


-- | Check that a set of bindings does not define overlapping 'Identifier'.
ensureUnique :: [Identifier] -> ScopeFn ()
ensureUnique :: [Identifier] -> ScopeFn ()
ensureUnique [Identifier]
ids = do
  [[Identifier]] -> ([Identifier] -> ScopeFn ()) -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Identifier] -> [[Identifier]]
forall a. Eq a => [a] -> [[a]]
group ([Identifier] -> [[Identifier]]) -> [Identifier] -> [[Identifier]]
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort [Identifier]
ids) (([Identifier] -> ScopeFn ()) -> ScopeFn ())
-> ([Identifier] -> ScopeFn ()) -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ \case
    [] -> Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
UnexpectedError ErrorMsg
"unique should not be empty"
    [Identifier
_] -> () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Identifier
i : [Identifier]
_ -> Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
ScopeError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Defined more than once: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i


-- | Ensure that an identifier will not clash with compiler-generated ones
ensureNotReserved :: Identifier -> ScopeFn ()
ensureNotReserved :: Identifier -> ScopeFn ()
ensureNotReserved Identifier
i = do
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier -> Bool
forall a. Identifiable a => a -> Bool
isReserved Identifier
i) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
nameErr
 where
  nameErr :: Error
nameErr = ErrorMsg -> Error
NameError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ Identifier -> ErrorMsg
showId Identifier
i ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" may clash with internal sslang-generated identifiers"


-- | Check that a constructor 'Identifier' has the right naming convention.
ensureCons :: Identifier -> ScopeFn ()
ensureCons :: Identifier -> ScopeFn ()
ensureCons Identifier
i = do
  Identifier -> ScopeFn ()
ensureNonempty Identifier
i
  Identifier -> ScopeFn ()
ensureNotReserved Identifier
i
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
nameErr
 where
  nameErr :: Error
nameErr = ErrorMsg -> Error
NameError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ Identifier -> ErrorMsg
showId Identifier
i ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" should begin with upper case or begin and end with ':'"


-- | Check that a variable 'Identifier' has the right naming convention.
ensureVar :: Identifier -> ScopeFn ()
ensureVar :: Identifier -> ScopeFn ()
ensureVar Identifier
i = do
  Identifier -> ScopeFn ()
ensureNonempty Identifier
i
  Identifier -> ScopeFn ()
ensureNotReserved Identifier
i
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
nameErr
 where
  nameErr :: Error
nameErr = ErrorMsg -> Error
NameError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ Identifier -> ErrorMsg
showId Identifier
i ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" should begin with upper case or begin and end with ':'"


{- | Validate a declaration of a data 'Identifier'.

This includes binding to the left of the @=@ in a let-binding or pattern match,
and in the argument of lambdas. Does not include type definitions, where data
constructors are defined.
-}
dataDecl :: Identifier -> ScopeFn ()
dataDecl :: Identifier -> ScopeFn ()
dataDecl Identifier
i = do
  Maybe DataInfo
info <- (ScopeCtx -> Maybe DataInfo) -> ScopeFn (Maybe DataInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ScopeCtx -> Maybe DataInfo) -> ScopeFn (Maybe DataInfo))
-> (ScopeCtx -> Maybe DataInfo) -> ScopeFn (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Identifier -> Map Identifier DataInfo -> Maybe DataInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
i (Map Identifier DataInfo -> Maybe DataInfo)
-> (ScopeCtx -> Map Identifier DataInfo)
-> ScopeCtx
-> Maybe DataInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeCtx -> Map Identifier DataInfo
dataMap

  -- A data constructor cannot be defined inside of a pattern.
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i Bool -> Bool -> Bool
&& Bool -> Bool
not (Maybe DataInfo -> Bool
forall a. Maybe a -> Bool
inScope Maybe DataInfo
info)) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ do
    Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
ScopeError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Data constructor is out of scope: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i

  -- A data variable can usually be shadowed, but we want warn about it.
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i Bool -> Bool -> Bool
&& Maybe DataInfo -> Bool
forall a. Maybe a -> Bool
inScope Maybe DataInfo
info) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$
    if Maybe DataInfo -> Bool
canShadow Maybe DataInfo
info
      then Warning -> ScopeFn ()
forall (m :: * -> *). MonadWriter [Warning] m => Warning -> m ()
warn (Warning -> ScopeFn ()) -> Warning -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Warning
NameWarning (ErrorMsg -> Warning) -> ErrorMsg -> Warning
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"shadowing variable: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i
      else Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
NameError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Cannot bind identifier shadowing: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i
 where
  inScope :: Maybe a -> Bool
inScope = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust
  canShadow :: Maybe DataInfo -> Bool
canShadow = Bool -> (DataInfo -> Bool) -> Maybe DataInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((IdKind -> IdKind -> Bool
forall a. Eq a => a -> a -> Bool
== IdKind
User) (IdKind -> Bool) -> (DataInfo -> IdKind) -> DataInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataInfo -> IdKind
dataKind)


-- | Validate a reference to a data 'Identifier'.
dataRef :: Identifier -> ScopeFn ()
dataRef :: Identifier -> ScopeFn ()
dataRef Identifier
i = do
  let IO ()
_ = ErrorMsg -> IO ()
forall a. Show a => a -> IO ()
print (Identifier -> ErrorMsg
showId Identifier
i)
  let isDupDrop :: Bool
isDupDrop = Identifier -> String
forall i. Identifiable i => i -> String
ident Identifier
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"dup" Bool -> Bool -> Bool
|| Identifier -> String
forall i. Identifiable i => i -> String
ident Identifier
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"drop"
  Bool
inScope <- (ScopeCtx -> Bool) -> ScopeFn Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ScopeCtx -> Bool) -> ScopeFn Bool)
-> (ScopeCtx -> Bool) -> ScopeFn Bool
forall a b. (a -> b) -> a -> b
$ Identifier -> Map Identifier DataInfo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Identifier
i (Map Identifier DataInfo -> Bool)
-> (ScopeCtx -> Map Identifier DataInfo) -> ScopeCtx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeCtx -> Map Identifier DataInfo
dataMap
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
inScope Bool -> Bool -> Bool
|| Bool
isDupDrop) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$
    Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$
      ErrorMsg -> Error
ScopeError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$
        ErrorMsg
"Not in scope: "
          ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i


-- | Validate a reference to a type 'Identifier'.
typeRef :: Identifier -> ScopeFn ()
typeRef :: Identifier -> ScopeFn ()
typeRef Identifier
i = do
  Bool
inScope <- (ScopeCtx -> Bool) -> ScopeFn Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ScopeCtx -> Bool) -> ScopeFn Bool)
-> (ScopeCtx -> Bool) -> ScopeFn Bool
forall a b. (a -> b) -> a -> b
$ Identifier -> Map Identifier TypInfo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Identifier
i (Map Identifier TypInfo -> Bool)
-> (ScopeCtx -> Map Identifier TypInfo) -> ScopeCtx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeCtx -> Map Identifier TypInfo
typeMap
  Bool
allowImplicit <- (ScopeCtx -> Bool) -> ScopeFn Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ScopeCtx -> Bool
implicitScheme
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
inScope Bool -> Bool -> Bool
&& Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ do
    Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
ScopeError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Type constructor is out of scope: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i
  Bool -> ScopeFn () -> ScopeFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
inScope Bool -> Bool -> Bool
&& Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allowImplicit) (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ do
    Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
ScopeError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Type variable is not defined: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> Identifier -> ErrorMsg
showId Identifier
i


-- | Check the scoping of a 'A.Program'.
scopeProgram :: A.Program -> Pass ()
scopeProgram :: Program -> Pass ()
scopeProgram (A.Program [TopDef]
ds) = ScopeFn () -> Pass ()
forall a. ScopeFn a -> Pass a
runScopeFn (ScopeFn () -> Pass ()) -> ScopeFn () -> Pass ()
forall a b. (a -> b) -> a -> b
$ do
  [TypeDef] -> ScopeFn () -> ScopeFn ()
scopeTypeDefs [TypeDef]
tds (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ [ExternDecl] -> ScopeFn () -> ScopeFn ()
scopeExterns [ExternDecl]
eds (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ [Definition] -> ScopeFn () -> ScopeFn ()
scopeDefs [Definition]
dds (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  eds :: [ExternDecl]
eds = (TopDef -> Maybe ExternDecl) -> [TopDef] -> [ExternDecl]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TopDef -> Maybe ExternDecl
A.getTopExtern [TopDef]
ds
  tds :: [TypeDef]
tds = (TopDef -> Maybe TypeDef) -> [TopDef] -> [TypeDef]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TopDef -> Maybe TypeDef
A.getTopTypeDef [TopDef]
ds
  dds :: [Definition]
dds = (TopDef -> Maybe Definition) -> [TopDef] -> [Definition]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TopDef -> Maybe Definition
A.getTopDataDef [TopDef]
ds


-- | Check the scoping of a set of type definitions.
scopeTypeDefs :: [A.TypeDef] -> ScopeFn () -> ScopeFn ()
scopeTypeDefs :: [TypeDef] -> ScopeFn () -> ScopeFn ()
scopeTypeDefs [TypeDef]
tds ScopeFn ()
k = do
  -- Check and collect all type constructors, which are mutually recursive.
  [(Identifier, TypInfo)]
tcons <- (TypeDef -> ScopeFn (Identifier, TypInfo))
-> [TypeDef] -> ScopeFn [(Identifier, TypInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeDef -> ScopeFn (Identifier, TypInfo)
scopeTCons [TypeDef]
tds
  [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, TypInfo) -> Identifier)
-> [(Identifier, TypInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, TypInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, TypInfo)]
tcons
  [(Identifier, TypInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, TypInfo)] -> ScopeFn a -> ScopeFn a
withTypeScope [(Identifier, TypInfo)]
tcons (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ do
    -- Then, check and collect all data constructors.
    [(Identifier, DataInfo)]
dcons <- [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDef -> ScopeFn [(Identifier, DataInfo)])
-> [TypeDef] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeDef -> ScopeFn [(Identifier, DataInfo)]
scopeDCons [TypeDef]
tds
    [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
dcons
    -- Continuation k is checked with all type and data constructors in scope
    [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
dcons ScopeFn ()
k


-- | Check the scoping of a user-defined type constructor.
scopeTCons :: A.TypeDef -> ScopeFn (Identifier, TypInfo)
scopeTCons :: TypeDef -> ScopeFn (Identifier, TypInfo)
scopeTCons A.TypeDef{typeName :: TypeDef -> Identifier
A.typeName = Identifier
tn} = do
  Identifier -> ScopeFn ()
ensureCons Identifier
tn
  (Identifier, TypInfo) -> ScopeFn (Identifier, TypInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
tn, TypInfo :: IdKind -> TypInfo
TypInfo{typKind :: IdKind
typKind = IdKind
User})


-- | Check the scoping of the data constructors of a type definition.
scopeDCons :: A.TypeDef -> ScopeFn [(Identifier, DataInfo)]
scopeDCons :: TypeDef -> ScopeFn [(Identifier, DataInfo)]
scopeDCons A.TypeDef{typeVariants :: TypeDef -> [TypeVariant]
A.typeVariants = [TypeVariant]
tvs, typeParams :: TypeDef -> [Identifier]
A.typeParams = [Identifier]
tps} = do
  (Identifier -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Identifier -> ScopeFn ()
ensureVar [Identifier]
tps
  [Identifier] -> ScopeFn ()
ensureUnique [Identifier]
tps
  [Identifier]
-> ScopeFn [(Identifier, DataInfo)]
-> ScopeFn [(Identifier, DataInfo)]
forall a. [Identifier] -> ScopeFn a -> ScopeFn a
withExplicitScheme [Identifier]
tps (ScopeFn [(Identifier, DataInfo)]
 -> ScopeFn [(Identifier, DataInfo)])
-> ScopeFn [(Identifier, DataInfo)]
-> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$ do
    (TypeVariant -> ScopeFn (Identifier, DataInfo))
-> [TypeVariant] -> ScopeFn [(Identifier, DataInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeVariant -> ScopeFn (Identifier, DataInfo)
scopeDcon [TypeVariant]
tvs


-- | Check the scoping of the data constructor a single data variant.
scopeDcon :: A.TypeVariant -> ScopeFn (Identifier, DataInfo)
scopeDcon :: TypeVariant -> ScopeFn (Identifier, DataInfo)
scopeDcon (A.VariantUnnamed Identifier
dcon [Typ]
ts) = do
  Identifier -> ScopeFn ()
ensureCons Identifier
dcon
  (Typ -> ScopeFn ()) -> [Typ] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Typ -> ScopeFn ()
scopeType [Typ]
ts
  (Identifier, DataInfo) -> ScopeFn (Identifier, DataInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
dcon, DataInfo :: IdKind -> DataInfo
DataInfo{dataKind :: IdKind
dataKind = IdKind
User})


scopeExterns :: [A.ExternDecl] -> ScopeFn () -> ScopeFn ()
scopeExterns :: [ExternDecl] -> ScopeFn () -> ScopeFn ()
scopeExterns [ExternDecl]
ds ScopeFn ()
k = do
  (Typ -> ScopeFn ()) -> [Typ] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Typ -> ScopeFn ()
scopeType [Typ]
xTypes
  [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope ((Identifier -> (Identifier, DataInfo))
-> [Identifier] -> [(Identifier, DataInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (,DataInfo
forall a. Default a => a
def) [Identifier]
xIds) ScopeFn ()
k
 where
  ([Identifier]
xIds, [Typ]
xTypes) = [(Identifier, Typ)] -> ([Identifier], [Typ])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Identifier, Typ)] -> ([Identifier], [Typ]))
-> [(Identifier, Typ)] -> ([Identifier], [Typ])
forall a b. (a -> b) -> a -> b
$ (ExternDecl -> (Identifier, Typ))
-> [ExternDecl] -> [(Identifier, Typ)]
forall a b. (a -> b) -> [a] -> [b]
map (\(A.ExternDecl Identifier
i Typ
t) -> (Identifier
i, Typ
t)) [ExternDecl]
ds


-- | Check the scoping of a set of parallel (co-recursive) 'A.Definition'.
scopeDefs :: [A.Definition] -> ScopeFn () -> ScopeFn ()
scopeDefs :: [Definition] -> ScopeFn () -> ScopeFn ()
scopeDefs [Definition]
ds ScopeFn ()
k = do
  [(Identifier, DataInfo)]
corecs <- [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Definition -> ScopeFn [(Identifier, DataInfo)])
-> [Definition] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Definition -> ScopeFn [(Identifier, DataInfo)]
scopeCorec [Definition]
ds
  [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
corecs
  (Definition -> ScopeFn ()) -> [Definition] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(Identifier, DataInfo)] -> Definition -> ScopeFn ()
scopeDef [(Identifier, DataInfo)]
corecs) [Definition]
ds
  [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
corecs ScopeFn ()
k
 where
  scopeCorec :: A.Definition -> ScopeFn [(Identifier, DataInfo)]
  scopeCorec :: Definition -> ScopeFn [(Identifier, DataInfo)]
scopeCorec (A.DefFn Identifier
f [Pat]
_ps TypFn
t Expr
_e) = do
    TypFn -> ScopeFn ()
scopeTypeFn TypFn
t
    Identifier -> ScopeFn ()
ensureVar Identifier
f
    Identifier -> ScopeFn ()
dataDecl Identifier
f
    [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Identifier
f, DataInfo
forall a. Default a => a
def)]
  scopeCorec (A.DefPat Pat
p Expr
_) = do
    [(Identifier, DataInfo)]
ids <- Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat Pat
p
    -- Not strictly necessary here, but gives a more precise error message.
    [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
ids
    [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Identifier, DataInfo)]
ids
  scopeDef :: [(Identifier, DataInfo)] -> A.Definition -> ScopeFn ()
  scopeDef :: [(Identifier, DataInfo)] -> Definition -> ScopeFn ()
scopeDef [(Identifier, DataInfo)]
corecs (A.DefFn Identifier
_f [Pat]
ps TypFn
_t Expr
e) = do
    -- NOTE: corecs should already contain _f
    [(Identifier, DataInfo)]
ids <- ([(Identifier, DataInfo)]
corecs [(Identifier, DataInfo)]
-> [(Identifier, DataInfo)] -> [(Identifier, DataInfo)]
forall a. [a] -> [a] -> [a]
++) ([(Identifier, DataInfo)] -> [(Identifier, DataInfo)])
-> ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> [[(Identifier, DataInfo)]]
-> [(Identifier, DataInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ScopeFn [(Identifier, DataInfo)])
-> [Pat] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat [Pat]
ps
    [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
ids
    [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
ids (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeFn ()
scopeExpr Expr
e
  scopeDef [(Identifier, DataInfo)]
corecs (A.DefPat Pat
_p Expr
e) = do
    -- NOTE: corecs should already contain _p's identifiers
    [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
corecs (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeFn ()
scopeExpr Expr
e


-- | Check the scoping of an 'A.Expr'.
scopeExpr :: A.Expr -> ScopeFn ()
scopeExpr :: Expr -> ScopeFn ()
scopeExpr (A.Id Identifier
i) = Identifier -> ScopeFn ()
dataRef Identifier
i
scopeExpr (A.Match Expr
s [(Pat, Expr)]
as) = do
  Expr -> ScopeFn ()
scopeExpr Expr
s
  [(Pat, Expr)] -> ((Pat, Expr) -> ScopeFn ()) -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Pat, Expr)]
as (((Pat, Expr) -> ScopeFn ()) -> ScopeFn ())
-> ((Pat, Expr) -> ScopeFn ()) -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ \(Pat
p, Expr
b) -> do
    [(Identifier, DataInfo)]
ids <- Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat Pat
p
    [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
ids
    [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
ids (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeFn ()
scopeExpr Expr
b
scopeExpr (A.Lambda [Pat]
as Expr
b) = do
  [(Identifier, DataInfo)]
args <- [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ScopeFn [(Identifier, DataInfo)])
-> [Pat] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat [Pat]
as
  [Identifier] -> ScopeFn ()
ensureUnique ([Identifier] -> ScopeFn ()) -> [Identifier] -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ ((Identifier, DataInfo) -> Identifier)
-> [(Identifier, DataInfo)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, DataInfo) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, DataInfo)]
args
  [(Identifier, DataInfo)] -> ScopeFn () -> ScopeFn ()
forall a. [(Identifier, DataInfo)] -> ScopeFn a -> ScopeFn a
withDataScope [(Identifier, DataInfo)]
args (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeFn ()
scopeExpr Expr
b
scopeExpr (A.Let [Definition]
ds Expr
b) = [Definition] -> ScopeFn () -> ScopeFn ()
scopeDefs [Definition]
ds (ScopeFn () -> ScopeFn ()) -> ScopeFn () -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeFn ()
scopeExpr Expr
b
scopeExpr (A.Constraint Expr
e Typ
t) = Typ -> ScopeFn ()
scopeType Typ
t ScopeFn () -> ScopeFn () -> ScopeFn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> ScopeFn ()
scopeExpr Expr
e
scopeExpr (A.Apply Expr
f Expr
a) = Expr -> ScopeFn ()
scopeExpr Expr
f ScopeFn () -> ScopeFn () -> ScopeFn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> ScopeFn ()
scopeExpr Expr
a
scopeExpr (A.While Expr
c Expr
b) = Expr -> ScopeFn ()
scopeExpr Expr
c ScopeFn () -> ScopeFn () -> ScopeFn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> ScopeFn ()
scopeExpr Expr
b
scopeExpr (A.Loop Expr
b) = Expr -> ScopeFn ()
scopeExpr Expr
b
scopeExpr (A.Par [Expr]
es) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr]
es
scopeExpr (A.IfElse Expr
c Expr
i Expr
e) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr
c, Expr
i, Expr
e]
scopeExpr (A.After Expr
d Expr
l Expr
r) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr
d, Expr
l, Expr
r]
scopeExpr (A.Assign Expr
l Expr
r) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr
l, Expr
r]
scopeExpr (A.Wait [Expr]
es) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr]
es
scopeExpr (A.Seq Expr
e Expr
e') = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr
e, Expr
e']
scopeExpr (A.Lit Literal
_) = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
scopeExpr (A.ListExpr [Expr]
l) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr]
l
scopeExpr Expr
A.Break = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
scopeExpr (A.Tuple [Expr]
es) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr]
es
scopeExpr (A.OpRegion Expr
e OpRegion
o) =
  Error -> ScopeFn ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn ()) -> Error -> ScopeFn ()
forall a b. (a -> b) -> a -> b
$
    ErrorMsg -> Error
UnexpectedError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$
      ErrorMsg
"OpRegion should not be reachable: "
        ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> String -> ErrorMsg
forall a. IsString a => String -> a
fromString (Expr -> String
forall a. Show a => a -> String
show Expr
e)
        ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" "
        ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> String -> ErrorMsg
forall a. IsString a => String -> a
fromString (OpRegion -> String
forall a. Show a => a -> String
show OpRegion
o)
scopeExpr (A.CQuote String
_) = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
scopeExpr (A.CCall Identifier
_ [Expr]
es) = (Expr -> ScopeFn ()) -> [Expr] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr -> ScopeFn ()
scopeExpr [Expr]
es
scopeExpr (A.Last Expr
e) = Expr -> ScopeFn ()
scopeExpr Expr
e
scopeExpr Expr
A.Now = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
scopeExpr Expr
A.NoExpr = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


{- | Check 'A.Pat' and retrieve variable identifiers defined therein.

Not responsible for ensuring data identifiers are in scope, though it will call
'scopeType' to check type identifiers.
-}
scopePat :: A.Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat :: Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat (A.PatId Identifier
i) = do
  -- NOTE: here, i may be either a data constructor or a variable name.
  Identifier -> ScopeFn ()
dataDecl Identifier
i
  [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)])
-> [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$ [(Identifier
i, DataInfo
forall a. Default a => a
def) | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i]
scopePat (A.PatAs Identifier
i Pat
p) = do
  -- When we have v@p, v should always be a variable identifier.
  Identifier -> ScopeFn ()
ensureVar Identifier
i
  Identifier -> ScopeFn ()
dataDecl Identifier
i
  ([(Identifier
i, DataInfo
forall a. Default a => a
def) | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i] [(Identifier, DataInfo)]
-> [(Identifier, DataInfo)] -> [(Identifier, DataInfo)]
forall a. [a] -> [a] -> [a]
++) ([(Identifier, DataInfo)] -> [(Identifier, DataInfo)])
-> ScopeFn [(Identifier, DataInfo)]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat Pat
p
scopePat (A.PatTup [Pat]
pats)
  | [Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 =
    Error -> ScopeFn [(Identifier, DataInfo)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn [(Identifier, DataInfo)])
-> Error -> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$
      ErrorMsg -> Error
UnexpectedError ErrorMsg
"PatTup should have arity greater than 2"
  | Bool
otherwise = [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ScopeFn [(Identifier, DataInfo)])
-> [Pat] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat [Pat]
pats
scopePat (A.PatApp []) =
  Error -> ScopeFn [(Identifier, DataInfo)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn [(Identifier, DataInfo)])
-> Error -> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
UnexpectedError ErrorMsg
"PatApp should not be empty"
scopePat (A.PatApp [Pat
_]) =
  Error -> ScopeFn [(Identifier, DataInfo)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn [(Identifier, DataInfo)])
-> Error -> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
UnexpectedError ErrorMsg
"PatApp should not be singleton"
scopePat (A.PatApp pats :: [Pat]
pats@(A.PatId Identifier
i : [Pat]
_)) = do
  Identifier -> ScopeFn ()
ensureCons Identifier
i
  [[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Identifier, DataInfo)]] -> [(Identifier, DataInfo)])
-> ScopeFn [[(Identifier, DataInfo)]]
-> ScopeFn [(Identifier, DataInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ScopeFn [(Identifier, DataInfo)])
-> [Pat] -> ScopeFn [[(Identifier, DataInfo)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat [Pat]
pats
scopePat (A.PatApp [Pat]
_) = do
  -- We encountered something like @let f ((x y) z) = ...@
  Error -> ScopeFn [(Identifier, DataInfo)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ScopeFn [(Identifier, DataInfo)])
-> Error -> ScopeFn [(Identifier, DataInfo)]
forall a b. (a -> b) -> a -> b
$
    ErrorMsg -> Error
PatternError ErrorMsg
"Head of destructuring pattern must be a data constructor"
scopePat (A.PatAnn Typ
typ Pat
pat) = Typ -> ScopeFn ()
scopeType Typ
typ ScopeFn ()
-> ScopeFn [(Identifier, DataInfo)]
-> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pat -> ScopeFn [(Identifier, DataInfo)]
scopePat Pat
pat
scopePat (A.PatLit Literal
_) = [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
scopePat Pat
A.PatWildcard = [(Identifier, DataInfo)] -> ScopeFn [(Identifier, DataInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return []


-- | Check scoping for a 'A.TypFn' annotation.
scopeTypeFn :: A.TypFn -> ScopeFn ()
scopeTypeFn :: TypFn -> ScopeFn ()
scopeTypeFn (A.TypReturn Typ
typ) = Typ -> ScopeFn ()
scopeType Typ
typ
scopeTypeFn (A.TypProper Typ
typ) = Typ -> ScopeFn ()
scopeType Typ
typ
scopeTypeFn TypFn
A.TypNone = () -> ScopeFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Check scoping for a 'A.Typ' annotation.
scopeType :: A.Typ -> ScopeFn ()
scopeType :: Typ -> ScopeFn ()
scopeType (A.TCon Identifier
i) = Identifier -> ScopeFn ()
typeRef Identifier
i
scopeType (A.TApp Typ
f Typ
a) = (Typ -> ScopeFn ()) -> [Typ] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Typ -> ScopeFn ()
scopeType [Typ
f, Typ
a]
scopeType (A.TTuple [Typ]
ts) = (Typ -> ScopeFn ()) -> [Typ] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Typ -> ScopeFn ()
scopeType [Typ]
ts
scopeType (A.TArrow Typ
a Typ
r) = (Typ -> ScopeFn ()) -> [Typ] -> ScopeFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Typ -> ScopeFn ()
scopeType [Typ
a, Typ
r]