{-# LANGUAGE NondecreasingIndentation #-}
module Agda.Syntax.Scope.Monad where
import Prelude hiding (null)
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Except
import Control.Monad.State
import Data.Either ( partitionEithers )
import Data.Foldable (all, traverse_)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.HashMap.Strict as HMap
import qualified Data.HashSet as HSet
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable hiding (for)
import Agda.Interaction.Options
import Agda.Interaction.Options.Warnings
import Agda.Syntax.Common
import Agda.Syntax.Position
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Abstract.Name as A
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract (ScopeCopyInfo(..))
import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Fixity
import Agda.Syntax.Concrete.Definitions ( DeclarationWarning(..) ,DeclarationWarning'(..) )
import Agda.Syntax.Scope.Base as A
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.Builtin
( HasBuiltins, getBuiltinName'
, builtinProp, builtinSet, builtinStrictSet, builtinPropOmega, builtinSetOmega, builtinSSetOmega )
import Agda.TypeChecking.Monad.Debug
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Monad.Trace
import Agda.TypeChecking.Positivity.Occurrence (Occurrence)
import Agda.TypeChecking.Warnings ( warning, warning' )
import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, toList)
import Agda.Utils.List2 (List2(List2), toList)
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.List2 as List2
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Syntax.Common.Pretty
import Agda.Utils.Singleton
import Agda.Utils.Suffix as C
import Agda.Utils.Impossible
type ScopeM = TCM
printLocals :: Int -> String -> ScopeM ()
printLocals :: Int -> [Char] -> TCMT IO ()
printLocals Int
v [Char]
s = [Char] -> Int -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => [Char] -> Int -> m () -> m ()
verboseS [Char]
"scope.top" Int
v (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
locals <- TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
reportSLn "scope.top" v $ s ++ " " ++ prettyShow locals
scopeWarning' :: CallStack -> DeclarationWarning' -> ScopeM ()
scopeWarning' :: CallStack -> DeclarationWarning' -> TCMT IO ()
scopeWarning' CallStack
loc = CallStack -> Warning -> TCMT IO ()
forall (m :: * -> *).
MonadWarning m =>
CallStack -> Warning -> m ()
warning' CallStack
loc (Warning -> TCMT IO ())
-> (DeclarationWarning' -> Warning)
-> DeclarationWarning'
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationWarning -> Warning
NicifierIssue (DeclarationWarning -> Warning)
-> (DeclarationWarning' -> DeclarationWarning)
-> DeclarationWarning'
-> Warning
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> DeclarationWarning' -> DeclarationWarning
DeclarationWarning CallStack
loc
scopeWarning :: HasCallStack => DeclarationWarning' -> ScopeM ()
scopeWarning :: HasCallStack => DeclarationWarning' -> TCMT IO ()
scopeWarning = (CallStack -> DeclarationWarning' -> TCMT IO ())
-> DeclarationWarning' -> TCMT IO ()
forall b. HasCallStack => (CallStack -> b) -> b
withCallerCallStack CallStack -> DeclarationWarning' -> TCMT IO ()
scopeWarning'
isDatatypeModule :: ReadTCState m => A.ModuleName -> m (Maybe DataOrRecordModule)
isDatatypeModule :: forall (m :: * -> *).
ReadTCState m =>
ModuleName -> m (Maybe DataOrRecordModule)
isDatatypeModule ModuleName
m = do
Scope -> Maybe DataOrRecordModule
scopeDatatypeModule (Scope -> Maybe DataOrRecordModule)
-> (Map ModuleName Scope -> Scope)
-> Map ModuleName Scope
-> Maybe DataOrRecordModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> ModuleName -> Map ModuleName Scope -> Scope
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Scope
forall a. HasCallStack => a
__IMPOSSIBLE__ ModuleName
m (Map ModuleName Scope -> Maybe DataOrRecordModule)
-> m (Map ModuleName Scope) -> m (Maybe DataOrRecordModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' ScopeInfo (Map ModuleName Scope) -> m (Map ModuleName Scope)
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map ModuleName Scope)
scopeModules
getCurrentModule :: ReadTCState m => m A.ModuleName
getCurrentModule :: forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule = Range -> ModuleName -> ModuleName
forall a. SetRange a => Range -> a -> a
setRange Range
forall a. Range' a
noRange (ModuleName -> ModuleName) -> m ModuleName -> m ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' ScopeInfo ModuleName -> m ModuleName
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent
setCurrentModule :: MonadTCState m => A.ModuleName -> m ()
setCurrentModule :: forall (m :: * -> *). MonadTCState m => ModuleName -> m ()
setCurrentModule ModuleName
m = (ScopeInfo -> ScopeInfo) -> m ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope ((ScopeInfo -> ScopeInfo) -> m ())
-> (ScopeInfo -> ScopeInfo) -> m ()
forall a b. (a -> b) -> a -> b
$ Lens' ScopeInfo ModuleName -> LensSet ScopeInfo ModuleName
forall o i. Lens' o i -> LensSet o i
set (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent ModuleName
m
withCurrentModule :: (ReadTCState m, MonadTCState m) => A.ModuleName -> m a -> m a
withCurrentModule :: forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
new m a
action = do
old <- m ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
setCurrentModule new
x <- action
setCurrentModule old
return x
withCurrentModule' :: (MonadTrans t, Monad (t ScopeM)) => A.ModuleName -> t ScopeM a -> t ScopeM a
withCurrentModule' :: forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t (TCMT IO))) =>
ModuleName -> t (TCMT IO) a -> t (TCMT IO) a
withCurrentModule' ModuleName
new t (TCMT IO) a
action = do
old <- ScopeM ModuleName -> t (TCMT IO) ModuleName
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
lift $ setCurrentModule new
x <- action
lift $ setCurrentModule old
return x
getNamedScope :: A.ModuleName -> ScopeM Scope
getNamedScope :: ModuleName -> ScopeM Scope
getNamedScope ModuleName
m = do
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
case Map.lookup m (scope ^. scopeModules) of
Just Scope
s -> Scope -> ScopeM Scope
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Scope
s
Maybe Scope
Nothing -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"" Int
0 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR: In scope\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ScopeInfo -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ScopeInfo
scope [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nNO SUCH SCOPE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
ScopeM Scope
forall a. HasCallStack => a
__IMPOSSIBLE__
getCurrentScope :: ScopeM Scope
getCurrentScope :: ScopeM Scope
getCurrentScope = ModuleName -> ScopeM Scope
getNamedScope (ModuleName -> ScopeM Scope) -> ScopeM ModuleName -> ScopeM Scope
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
createModule :: Maybe DataOrRecordModule -> A.ModuleName -> ScopeM ()
createModule :: Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule Maybe DataOrRecordModule
b ModuleName
m = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.createModule" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"createModule " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
s <- ScopeM Scope
getCurrentScope
let parents = Scope -> ModuleName
scopeName Scope
s ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: Scope -> [ModuleName]
scopeParents Scope
s
sm = Scope
emptyScope { scopeName = m
, scopeParents = parents
, scopeDatatypeModule = b }
modifyScopes $ Map.insertWith mergeScope m sm
modifyScopes :: (Map A.ModuleName Scope -> Map A.ModuleName Scope) -> ScopeM ()
modifyScopes :: (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes = (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> ((Map ModuleName Scope -> Map ModuleName Scope)
-> ScopeInfo -> ScopeInfo)
-> (Map ModuleName Scope -> Map ModuleName Scope)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ScopeInfo (Map ModuleName Scope)
-> (Map ModuleName Scope -> Map ModuleName Scope)
-> ScopeInfo
-> ScopeInfo
forall o i. Lens' o i -> LensMap o i
over (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map ModuleName Scope)
scopeModules
modifyNamedScope :: A.ModuleName -> (Scope -> Scope) -> ScopeM ()
modifyNamedScope :: ModuleName -> (Scope -> Scope) -> TCMT IO ()
modifyNamedScope ModuleName
m Scope -> Scope
f = (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes ((Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ())
-> (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (Scope -> Scope)
-> ModuleName -> Map ModuleName Scope -> Map ModuleName Scope
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Scope -> Scope
f ModuleName
m
setNamedScope :: A.ModuleName -> Scope -> ScopeM ()
setNamedScope :: ModuleName -> Scope -> TCMT IO ()
setNamedScope ModuleName
m Scope
s = ModuleName -> (Scope -> Scope) -> TCMT IO ()
modifyNamedScope ModuleName
m ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> Scope -> Scope
forall a b. a -> b -> a
const Scope
s
modifyNamedScopeM :: A.ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a
modifyNamedScopeM :: forall a. ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a
modifyNamedScopeM ModuleName
m Scope -> ScopeM (a, Scope)
f = do
(a, s) <- Scope -> ScopeM (a, Scope)
f (Scope -> ScopeM (a, Scope)) -> ScopeM Scope -> ScopeM (a, Scope)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModuleName -> ScopeM Scope
getNamedScope ModuleName
m
setNamedScope m s
return a
modifyCurrentScope :: (Scope -> Scope) -> ScopeM ()
modifyCurrentScope :: (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope Scope -> Scope
f = ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule ScopeM ModuleName -> (ModuleName -> TCMT IO ()) -> TCMT IO ()
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ModuleName -> (Scope -> Scope) -> TCMT IO ()
`modifyNamedScope` Scope -> Scope
f)
modifyCurrentScopeM :: (Scope -> ScopeM (a, Scope)) -> ScopeM a
modifyCurrentScopeM :: forall a. (Scope -> ScopeM (a, Scope)) -> ScopeM a
modifyCurrentScopeM Scope -> ScopeM (a, Scope)
f = ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule ScopeM ModuleName -> (ModuleName -> TCMT IO a) -> TCMT IO a
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ModuleName -> (Scope -> ScopeM (a, Scope)) -> TCMT IO a
forall a. ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a
`modifyNamedScopeM` Scope -> ScopeM (a, Scope)
f)
modifyCurrentNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> ScopeM ()
modifyCurrentNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> TCMT IO ()
modifyCurrentNameSpace NameSpaceId
acc NameSpace -> NameSpace
f = (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope
updateScopeNameSpaces ((ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope)
-> (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$
NameSpaceId
-> (NameSpace -> NameSpace) -> ScopeNameSpaces -> ScopeNameSpaces
forall k v. Eq k => k -> (v -> v) -> AssocList k v -> AssocList k v
AssocList.updateAt NameSpaceId
acc NameSpace -> NameSpace
f
setContextPrecedence :: PrecedenceStack -> ScopeM ()
setContextPrecedence :: PrecedenceStack -> TCMT IO ()
setContextPrecedence = (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> (PrecedenceStack -> ScopeInfo -> ScopeInfo)
-> PrecedenceStack
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ScopeInfo PrecedenceStack
-> PrecedenceStack -> ScopeInfo -> ScopeInfo
forall o i. Lens' o i -> LensSet o i
set (PrecedenceStack -> f PrecedenceStack) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo PrecedenceStack
scopePrecedence
withContextPrecedence :: ReadTCState m => Precedence -> m a -> m a
withContextPrecedence :: forall (m :: * -> *) a. ReadTCState m => Precedence -> m a -> m a
withContextPrecedence Precedence
p =
Lens' TCState PrecedenceStack
-> (PrecedenceStack -> PrecedenceStack) -> m a -> m a
forall a b. Lens' TCState a -> (a -> a) -> m b -> m b
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' TCState a -> (a -> a) -> m b -> m b
locallyTCState ((ScopeInfo -> f ScopeInfo) -> TCState -> f TCState
Lens' TCState ScopeInfo
stScope ((ScopeInfo -> f ScopeInfo) -> TCState -> f TCState)
-> ((PrecedenceStack -> f PrecedenceStack)
-> ScopeInfo -> f ScopeInfo)
-> (PrecedenceStack -> f PrecedenceStack)
-> TCState
-> f TCState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrecedenceStack -> f PrecedenceStack) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo PrecedenceStack
scopePrecedence) ((PrecedenceStack -> PrecedenceStack) -> m a -> m a)
-> (PrecedenceStack -> PrecedenceStack) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Precedence -> PrecedenceStack -> PrecedenceStack
pushPrecedence Precedence
p
getLocalVars :: ReadTCState m => m LocalVars
getLocalVars :: forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars = Lens' ScopeInfo LocalVars -> m LocalVars
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (LocalVars -> f LocalVars) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo LocalVars
scopeLocals
modifyLocalVars :: (LocalVars -> LocalVars) -> ScopeM ()
modifyLocalVars :: (LocalVars -> LocalVars) -> TCMT IO ()
modifyLocalVars = (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> ((LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo)
-> (LocalVars -> LocalVars)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateScopeLocals
setLocalVars :: LocalVars -> ScopeM ()
setLocalVars :: LocalVars -> TCMT IO ()
setLocalVars LocalVars
vars = (LocalVars -> LocalVars) -> TCMT IO ()
modifyLocalVars ((LocalVars -> LocalVars) -> TCMT IO ())
-> (LocalVars -> LocalVars) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ LocalVars -> LocalVars -> LocalVars
forall a b. a -> b -> a
const LocalVars
vars
withLocalVars :: ScopeM a -> ScopeM a
withLocalVars :: forall a. ScopeM a -> ScopeM a
withLocalVars = TCMT IO LocalVars
-> (LocalVars -> TCMT IO ()) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars LocalVars -> TCMT IO ()
setLocalVars
outsideLocalVars :: Int -> ScopeM a -> ScopeM a
outsideLocalVars :: forall a. Int -> ScopeM a -> ScopeM a
outsideLocalVars Int
n ScopeM a
m = do
inner <- Int -> LocalVars -> LocalVars
forall a. Int -> [a] -> [a]
take Int
n (LocalVars -> LocalVars) -> TCMT IO LocalVars -> TCMT IO LocalVars
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
modifyLocalVars (drop n)
x <- m
modifyLocalVars (inner ++)
return x
withCheckNoShadowing :: ScopeM a -> ScopeM a
withCheckNoShadowing :: forall a. ScopeM a -> ScopeM a
withCheckNoShadowing = TCMT IO LocalVars
-> (LocalVars -> TCMT IO ()) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars ((LocalVars -> TCMT IO ()) -> TCMT IO a -> TCMT IO a)
-> (LocalVars -> TCMT IO ()) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ \ LocalVars
lvarsOld ->
LocalVars -> LocalVars -> TCMT IO ()
checkNoShadowing LocalVars
lvarsOld (LocalVars -> TCMT IO ()) -> TCMT IO LocalVars -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
checkNoShadowing :: LocalVars
-> LocalVars
-> ScopeM ()
checkNoShadowing :: LocalVars -> LocalVars -> TCMT IO ()
checkNoShadowing LocalVars
old LocalVars
new = do
opts <- TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
when (ShadowingInTelescope_ `Set.member`
(optWarningMode opts ^. warningSet)) $ do
let diff = Int -> LocalVars -> LocalVars
forall a. Int -> [a] -> [a]
dropEnd (LocalVars -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalVars
old) LocalVars
new
let newNames = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ LocalVars -> [Name]
forall k v. AssocList k v -> [k]
AssocList.keys LocalVars
diff
let nameOccs1 :: [(C.Name, List1 Range)]
nameOccs1 = Map Name (NonEmpty Range) -> [(Name, NonEmpty Range)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name (NonEmpty Range) -> [(Name, NonEmpty Range)])
-> Map Name (NonEmpty Range) -> [(Name, NonEmpty Range)]
forall a b. (a -> b) -> a -> b
$ (NonEmpty Range -> NonEmpty Range -> NonEmpty Range)
-> [(Name, NonEmpty Range)] -> Map Name (NonEmpty Range)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty Range -> NonEmpty Range -> NonEmpty Range
forall a. Semigroup a => a -> a -> a
(<>) ([(Name, NonEmpty Range)] -> Map Name (NonEmpty Range))
-> [(Name, NonEmpty Range)] -> Map Name (NonEmpty Range)
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, NonEmpty Range))
-> [Name] -> [(Name, NonEmpty Range)]
forall a b. (a -> b) -> [a] -> [b]
map Name -> (Name, NonEmpty Range)
pairWithRange [Name]
newNames
let nameOccs2 :: [(C.Name, List2 Range)]
nameOccs2 = ((Name, NonEmpty Range) -> Maybe (Name, List2 Range))
-> [(Name, NonEmpty Range)] -> [(Name, List2 Range)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((NonEmpty Range -> Maybe (List2 Range))
-> (Name, NonEmpty Range) -> Maybe (Name, List2 Range)
forall (t :: * -> *) (m :: * -> *) a b.
(Decoration t, Functor m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Functor m =>
(a -> m b) -> (Name, a) -> m (Name, b)
traverseF NonEmpty Range -> Maybe (List2 Range)
forall a. List1 a -> Maybe (List2 a)
List2.fromList1Maybe) [(Name, NonEmpty Range)]
nameOccs1
caseList nameOccs2 (return ()) $ \ (Name, List2 Range)
c [(Name, List2 Range)]
conflicts -> do
HasCallStack => DeclarationWarning' -> TCMT IO ()
DeclarationWarning' -> TCMT IO ()
scopeWarning (DeclarationWarning' -> TCMT IO ())
-> DeclarationWarning' -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ List1 (Name, List2 Range) -> DeclarationWarning'
ShadowingInTelescope (List1 (Name, List2 Range) -> DeclarationWarning')
-> List1 (Name, List2 Range) -> DeclarationWarning'
forall a b. (a -> b) -> a -> b
$ (Name, List2 Range)
c (Name, List2 Range)
-> [(Name, List2 Range)] -> List1 (Name, List2 Range)
forall a. a -> [a] -> NonEmpty a
:| [(Name, List2 Range)]
conflicts
where
pairWithRange :: C.Name -> (C.Name, List1 Range)
pairWithRange :: Name -> (Name, NonEmpty Range)
pairWithRange Name
n = (Name
n, Range -> NonEmpty Range
forall el coll. Singleton el coll => el -> coll
singleton (Range -> NonEmpty Range) -> Range -> NonEmpty Range
forall a b. (a -> b) -> a -> b
$ Name -> Range
forall a. HasRange a => a -> Range
getRange Name
n)
getVarsToBind :: ScopeM LocalVars
getVarsToBind :: TCMT IO LocalVars
getVarsToBind = Lens' ScopeInfo LocalVars -> TCMT IO LocalVars
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (LocalVars -> f LocalVars) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo LocalVars
scopeVarsToBind
addVarToBind :: C.Name -> LocalVar -> ScopeM ()
addVarToBind :: Name -> LocalVar -> TCMT IO ()
addVarToBind Name
x LocalVar
y = (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateVarsToBind ((LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo)
-> (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
forall a b. (a -> b) -> a -> b
$ Name -> LocalVar -> LocalVars -> LocalVars
forall k v. k -> v -> AssocList k v -> AssocList k v
AssocList.insert Name
x LocalVar
y
bindVarsToBind :: ScopeM ()
bindVarsToBind :: TCMT IO ()
bindVarsToBind = do
vars <- TCMT IO LocalVars
getVarsToBind
modifyLocalVars (vars ++)
printLocals 10 "bound variables:"
modifyScope_ $ setVarsToBind []
annotateDecls :: ReadTCState m => m [A.Declaration] -> m A.Declaration
annotateDecls :: forall (m :: * -> *).
ReadTCState m =>
m [Declaration] -> m Declaration
annotateDecls m [Declaration]
m = do
ds <- m [Declaration]
m
s <- getScope
return $ A.ScopedDecl s ds
annotateExpr :: ReadTCState m => m A.Expr -> m A.Expr
annotateExpr :: forall (m :: * -> *). ReadTCState m => m Expr -> m Expr
annotateExpr m Expr
m = do
e <- m Expr
m
s <- getScope
return $ A.ScopedExpr s e
freshAbstractName :: Fixity' -> C.Name -> ScopeM A.Name
freshAbstractName :: Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x = do
i <- TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
return $ A.Name
{ nameId = i
, nameConcrete = x
, nameCanonical = x
, nameBindingSite = getRange x
, nameFixity = fx
, nameIsRecordName = False
}
freshAbstractName_ :: C.Name -> ScopeM A.Name
freshAbstractName_ :: Name -> ScopeM Name
freshAbstractName_ = Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
noFixity'
freshAbstractQName :: Fixity' -> C.Name -> ScopeM A.QName
freshAbstractQName :: Fixity' -> Name -> ScopeM QName
freshAbstractQName Fixity'
fx Name
x = do
y <- Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x
m <- getCurrentModule
return $ A.qualify m y
freshAbstractQName' :: C.Name -> ScopeM A.QName
freshAbstractQName' :: Name -> ScopeM QName
freshAbstractQName' Name
x = do
fx <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
freshAbstractQName fx x
freshConcreteName :: Range -> Int -> String -> ScopeM C.Name
freshConcreteName :: Range -> Int -> [Char] -> ScopeM Name
freshConcreteName Range
r Int
i [Char]
s = do
let cname :: Name
cname = Range -> NameInScope -> NameParts -> Name
C.Name Range
r NameInScope
C.NotInScope (NameParts -> Name) -> NameParts -> Name
forall a b. (a -> b) -> a -> b
$ NamePart -> NameParts
forall el coll. Singleton el coll => el -> coll
singleton (NamePart -> NameParts) -> NamePart -> NameParts
forall a b. (a -> b) -> a -> b
$ [Char] -> NamePart
Id ([Char] -> NamePart) -> [Char] -> NamePart
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stringToRawName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
cname) ScopeM ResolvedName -> (ResolvedName -> ScopeM Name) -> ScopeM Name
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ResolvedName
UnknownName -> Name -> ScopeM Name
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
cname
ResolvedName
_ -> Range -> Int -> [Char] -> ScopeM Name
freshConcreteName Range
r (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char]
s
resolveName :: C.QName -> ScopeM ResolvedName
resolveName :: QName -> ScopeM ResolvedName
resolveName = KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
allKindsOfNames Maybe (Set Name)
forall a. Maybe a
Nothing
resolveName' ::
KindsOfNames -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName
resolveName' :: KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
kinds Maybe (Set Name)
names QName
x = ExceptT AmbiguousNameReason (TCMT IO) ResolvedName
-> TCMT IO (Either AmbiguousNameReason ResolvedName)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (KindsOfNames
-> Maybe (Set Name)
-> QName
-> ExceptT AmbiguousNameReason (TCMT IO) ResolvedName
forall (m :: * -> *).
(ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m) =>
KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName
tryResolveName KindsOfNames
kinds Maybe (Set Name)
names QName
x) TCMT IO (Either AmbiguousNameReason ResolvedName)
-> (Either AmbiguousNameReason ResolvedName -> ScopeM ResolvedName)
-> ScopeM ResolvedName
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left AmbiguousNameReason
reason -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
[Char] -> Int -> a -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportS [Char]
"scope.resolve" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
[Char]
"resolveName': ambiguous name" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:
(QName -> [Char]) -> [QName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Char]
forall a. Show a => a -> [Char]
show (Name -> [Char]) -> (QName -> Name) -> QName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName) (List2 QName -> [Item (List2 QName)]
forall l. IsList l => l -> [Item l]
toList (List2 QName -> [Item (List2 QName)])
-> List2 QName -> [Item (List2 QName)]
forall a b. (a -> b) -> a -> b
$ AmbiguousNameReason -> List2 QName
ambiguousNamesInReason AmbiguousNameReason
reason)
QName -> ScopeM ResolvedName -> ScopeM ResolvedName
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
x (ScopeM ResolvedName -> ScopeM ResolvedName)
-> ScopeM ResolvedName -> ScopeM ResolvedName
forall a b. (a -> b) -> a -> b
$ TypeError -> ScopeM ResolvedName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> ScopeM ResolvedName)
-> TypeError -> ScopeM ResolvedName
forall a b. (a -> b) -> a -> b
$ QName -> AmbiguousNameReason -> TypeError
AmbiguousName QName
x AmbiguousNameReason
reason
Right ResolvedName
x' -> ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
x'
tryResolveName
:: forall m. (ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m)
=> KindsOfNames
-> Maybe (Set A.Name)
-> C.QName
-> m ResolvedName
tryResolveName :: forall (m :: * -> *).
(ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m) =>
KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName
tryResolveName KindsOfNames
kinds Maybe (Set Name)
names QName
x = do
scope <- m ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
let vars = (Name -> QName) -> LocalVars -> AssocList QName LocalVar
forall k k' v. (k -> k') -> AssocList k v -> AssocList k' v
AssocList.mapKeysMonotonic Name -> QName
C.QName (LocalVars -> AssocList QName LocalVar)
-> LocalVars -> AssocList QName LocalVar
forall a b. (a -> b) -> a -> b
$ ScopeInfo
scope ScopeInfo -> Lens' ScopeInfo LocalVars -> LocalVars
forall o i. o -> Lens' o i -> i
^. (LocalVars -> f LocalVars) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo LocalVars
scopeLocals
case lookup x vars of
Just var :: LocalVar
var@(LocalVar Name
y BindingSource
b [AbstractName]
ys) ->
case [AbstractName] -> Maybe (NonEmpty AbstractName)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([AbstractName] -> Maybe (NonEmpty AbstractName))
-> [AbstractName] -> Maybe (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$ (AbstractName -> AbstractName) -> [AbstractName] -> [AbstractName]
forall a. (a -> AbstractName) -> [a] -> [a]
filterNames AbstractName -> AbstractName
forall a. a -> a
id [AbstractName]
ys of
Maybe (NonEmpty AbstractName)
Nothing -> ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ Name -> BindingSource -> ResolvedName
VarName Name
y{ nameConcrete = unqualify x } BindingSource
b
Just NonEmpty AbstractName
ys' -> AmbiguousNameReason -> m ResolvedName
forall a. AmbiguousNameReason -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AmbiguousNameReason -> m ResolvedName)
-> AmbiguousNameReason -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ LocalVar -> NonEmpty AbstractName -> AmbiguousNameReason
AmbiguousLocalVar LocalVar
var NonEmpty AbstractName
ys'
Maybe LocalVar
Nothing -> do
let filtKind :: [(AbstractName, Access)] -> [(AbstractName, Access)]
filtKind = ((AbstractName, Access) -> Bool)
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a. (a -> Bool) -> [a] -> [a]
filter (((AbstractName, Access) -> Bool)
-> [(AbstractName, Access)] -> [(AbstractName, Access)])
-> ((AbstractName, Access) -> Bool)
-> [(AbstractName, Access)]
-> [(AbstractName, Access)]
forall a b. (a -> b) -> a -> b
$ (KindOfName -> KindsOfNames -> Bool
`elemKindsOfNames` KindsOfNames
kinds) (KindOfName -> Bool)
-> ((AbstractName, Access) -> KindOfName)
-> (AbstractName, Access)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind (AbstractName -> KindOfName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst
possibleNames :: QName -> [(AbstractName, Access)]
possibleNames QName
z = [(AbstractName, Access)] -> [(AbstractName, Access)]
filtKind ([(AbstractName, Access)] -> [(AbstractName, Access)])
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a. (a -> AbstractName) -> [a] -> [a]
filterNames (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst ([(AbstractName, Access)] -> [(AbstractName, Access)])
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a b. (a -> b) -> a -> b
$ QName -> ScopeInfo -> [(AbstractName, Access)]
forall a. InScope a => QName -> ScopeInfo -> [(a, Access)]
scopeLookup' QName
z ScopeInfo
scope
canHaveSuffix <- m (QName -> Bool)
forall (m :: * -> *). HasBuiltins m => m (QName -> Bool)
canHaveSuffixTest
let (xsuffix, xbase) = (C.lensQNameName . nameSuffix) (,Nothing) x
possibleBaseNames = ((AbstractName, Access) -> Bool)
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a. (a -> Bool) -> [a] -> [a]
filter (QName -> Bool
canHaveSuffix (QName -> Bool)
-> ((AbstractName, Access) -> QName)
-> (AbstractName, Access)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName (AbstractName -> QName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) ([(AbstractName, Access)] -> [(AbstractName, Access)])
-> [(AbstractName, Access)] -> [(AbstractName, Access)]
forall a b. (a -> b) -> a -> b
$ QName -> [(AbstractName, Access)]
possibleNames QName
xbase
suffixedNames = (,) (Suffix
-> NonEmpty (AbstractName, Access)
-> (Suffix, NonEmpty (AbstractName, Access)))
-> Maybe Suffix
-> Maybe
(NonEmpty (AbstractName, Access)
-> (Suffix, NonEmpty (AbstractName, Access)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Suffix -> Maybe Suffix
fromConcreteSuffix Maybe Suffix
xsuffix Maybe
(NonEmpty (AbstractName, Access)
-> (Suffix, NonEmpty (AbstractName, Access)))
-> Maybe (NonEmpty (AbstractName, Access))
-> Maybe (Suffix, NonEmpty (AbstractName, Access))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(AbstractName, Access)] -> Maybe (NonEmpty (AbstractName, Access))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(AbstractName, Access)]
possibleBaseNames
case (nonEmpty $ possibleNames x) of
Just NonEmpty (AbstractName, Access)
ds | let ks :: NonEmpty (Maybe Induction)
ks = ((AbstractName, Access) -> Maybe Induction)
-> NonEmpty (AbstractName, Access) -> NonEmpty (Maybe Induction)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KindOfName -> Maybe Induction
isConName (KindOfName -> Maybe Induction)
-> ((AbstractName, Access) -> KindOfName)
-> (AbstractName, Access)
-> Maybe Induction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind (AbstractName -> KindOfName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds
, (Maybe Induction -> Bool) -> NonEmpty (Maybe Induction) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Induction -> Bool
forall a. Maybe a -> Bool
isJust NonEmpty (Maybe Induction)
ks
, Maybe (Suffix, NonEmpty (AbstractName, Access)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Suffix, NonEmpty (AbstractName, Access))
suffixedNames ->
ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ Set Induction -> NonEmpty AbstractName -> ResolvedName
ConstructorName ([Induction] -> Set Induction
forall a. Ord a => [a] -> Set a
Set.fromList ([Induction] -> Set Induction) -> [Induction] -> Set Induction
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe Induction) -> [Induction]
forall a. List1 (Maybe a) -> [a]
List1.catMaybes NonEmpty (Maybe Induction)
ks) (NonEmpty AbstractName -> ResolvedName)
-> NonEmpty AbstractName -> ResolvedName
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> NonEmpty (AbstractName, Access) -> NonEmpty AbstractName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AbstractName -> AbstractName
upd (AbstractName -> AbstractName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> AbstractName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds
Just NonEmpty (AbstractName, Access)
ds | ((AbstractName, Access) -> Bool)
-> NonEmpty (AbstractName, Access) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((KindOfName
FldName KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
==) (KindOfName -> Bool)
-> ((AbstractName, Access) -> KindOfName)
-> (AbstractName, Access)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind (AbstractName -> KindOfName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds , Maybe (Suffix, NonEmpty (AbstractName, Access)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Suffix, NonEmpty (AbstractName, Access))
suffixedNames ->
ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> ResolvedName
FieldName (NonEmpty AbstractName -> ResolvedName)
-> NonEmpty AbstractName -> ResolvedName
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> NonEmpty (AbstractName, Access) -> NonEmpty AbstractName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AbstractName -> AbstractName
upd (AbstractName -> AbstractName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> AbstractName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds
Just NonEmpty (AbstractName, Access)
ds | ((AbstractName, Access) -> Bool)
-> NonEmpty (AbstractName, Access) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((KindOfName
PatternSynName KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
==) (KindOfName -> Bool)
-> ((AbstractName, Access) -> KindOfName)
-> (AbstractName, Access)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind (AbstractName -> KindOfName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds , Maybe (Suffix, NonEmpty (AbstractName, Access)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Suffix, NonEmpty (AbstractName, Access))
suffixedNames ->
ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> ResolvedName
PatternSynResName (NonEmpty AbstractName -> ResolvedName)
-> NonEmpty AbstractName -> ResolvedName
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> NonEmpty (AbstractName, Access) -> NonEmpty AbstractName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AbstractName -> AbstractName
upd (AbstractName -> AbstractName)
-> ((AbstractName, Access) -> AbstractName)
-> (AbstractName, Access)
-> AbstractName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst) NonEmpty (AbstractName, Access)
ds
Just ((AbstractName
d, Access
a) :| [(AbstractName, Access)]
ds) -> case (Maybe (Suffix, NonEmpty (AbstractName, Access))
suffixedNames, [(AbstractName, Access)]
ds) of
(Maybe (Suffix, NonEmpty (AbstractName, Access))
Nothing, []) ->
ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ Access -> AbstractName -> Suffix -> ResolvedName
DefinedName Access
a (AbstractName -> AbstractName
upd AbstractName
d) Suffix
A.NoSuffix
(Maybe (Suffix, NonEmpty (AbstractName, Access))
Nothing, (AbstractName
d',Access
_) : [(AbstractName, Access)]
ds') ->
AmbiguousNameReason -> m ResolvedName
forall a. AmbiguousNameReason -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AmbiguousNameReason -> m ResolvedName)
-> AmbiguousNameReason -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ List2 AbstractName -> AmbiguousNameReason
AmbiguousDeclName (List2 AbstractName -> AmbiguousNameReason)
-> List2 AbstractName -> AmbiguousNameReason
forall a b. (a -> b) -> a -> b
$ AbstractName
-> AbstractName -> [AbstractName] -> List2 AbstractName
forall a. a -> a -> [a] -> List2 a
List2 AbstractName
d AbstractName
d' ([AbstractName] -> List2 AbstractName)
-> [AbstractName] -> List2 AbstractName
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> [(AbstractName, Access)] -> [AbstractName]
forall a b. (a -> b) -> [a] -> [b]
map (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst [(AbstractName, Access)]
ds'
(Just (Suffix
_, NonEmpty (AbstractName, Access)
ss), [(AbstractName, Access)]
_) ->
AmbiguousNameReason -> m ResolvedName
forall a. AmbiguousNameReason -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AmbiguousNameReason -> m ResolvedName)
-> AmbiguousNameReason -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ List2 AbstractName -> AmbiguousNameReason
AmbiguousDeclName (List2 AbstractName -> AmbiguousNameReason)
-> List2 AbstractName -> AmbiguousNameReason
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName
-> NonEmpty AbstractName -> List2 AbstractName
forall a. List1 a -> List1 a -> List2 a
List2.append (AbstractName
d AbstractName -> [AbstractName] -> NonEmpty AbstractName
forall a. a -> [a] -> NonEmpty a
:| ((AbstractName, Access) -> AbstractName)
-> [(AbstractName, Access)] -> [AbstractName]
forall a b. (a -> b) -> [a] -> [b]
map (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst [(AbstractName, Access)]
ds) (((AbstractName, Access) -> AbstractName)
-> NonEmpty (AbstractName, Access) -> NonEmpty AbstractName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst NonEmpty (AbstractName, Access)
ss)
Maybe (NonEmpty (AbstractName, Access))
Nothing -> case Maybe (Suffix, NonEmpty (AbstractName, Access))
suffixedNames of
Maybe (Suffix, NonEmpty (AbstractName, Access))
Nothing -> ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
UnknownName
Just (Suffix
suffix , (AbstractName
d, Access
a) :| []) -> ResolvedName -> m ResolvedName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> m ResolvedName) -> ResolvedName -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ Access -> AbstractName -> Suffix -> ResolvedName
DefinedName Access
a (AbstractName -> AbstractName
upd AbstractName
d) Suffix
suffix
Just (Suffix
suffix , (AbstractName
d1,Access
_) :| (AbstractName
d2,Access
_) : [(AbstractName, Access)]
sds) ->
AmbiguousNameReason -> m ResolvedName
forall a. AmbiguousNameReason -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AmbiguousNameReason -> m ResolvedName)
-> AmbiguousNameReason -> m ResolvedName
forall a b. (a -> b) -> a -> b
$ List2 AbstractName -> AmbiguousNameReason
AmbiguousDeclName (List2 AbstractName -> AmbiguousNameReason)
-> List2 AbstractName -> AmbiguousNameReason
forall a b. (a -> b) -> a -> b
$ AbstractName
-> AbstractName -> [AbstractName] -> List2 AbstractName
forall a. a -> a -> [a] -> List2 a
List2 AbstractName
d1 AbstractName
d2 ([AbstractName] -> List2 AbstractName)
-> [AbstractName] -> List2 AbstractName
forall a b. (a -> b) -> a -> b
$ ((AbstractName, Access) -> AbstractName)
-> [(AbstractName, Access)] -> [AbstractName]
forall a b. (a -> b) -> [a] -> [b]
map (AbstractName, Access) -> AbstractName
forall a b. (a, b) -> a
fst [(AbstractName, Access)]
sds
where
filterNames :: forall a. (a -> AbstractName) -> [a] -> [a]
filterNames :: forall a. (a -> AbstractName) -> [a] -> [a]
filterNames = case Maybe (Set Name)
names of
Maybe (Set Name)
Nothing -> \ a -> AbstractName
f -> [a] -> [a]
forall a. a -> a
id
Just Set Name
ns -> \ a -> AbstractName
f -> (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> Bool) -> [a] -> [a]) -> (a -> Bool) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
ns) (Name -> Bool) -> (a -> Name) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
A.qnameName (QName -> Name) -> (a -> QName) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName (AbstractName -> QName) -> (a -> AbstractName) -> a -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AbstractName
f
upd :: AbstractName -> AbstractName
upd AbstractName
d = AbstractName -> Name -> AbstractName
updateConcreteName AbstractName
d (Name -> AbstractName) -> Name -> AbstractName
forall a b. (a -> b) -> a -> b
$ QName -> Name
unqualify QName
x
updateConcreteName :: AbstractName -> C.Name -> AbstractName
updateConcreteName :: AbstractName -> Name -> AbstractName
updateConcreteName d :: AbstractName
d@(AbsName { anameName :: AbstractName -> QName
anameName = A.QName ModuleName
qm Name
qn }) Name
x =
AbstractName
d { anameName = A.QName (setRange (getRange x) qm) (qn { nameConcrete = x }) }
fromConcreteSuffix :: Maybe Suffix -> Maybe Suffix
fromConcreteSuffix = \case
Maybe Suffix
Nothing -> Maybe Suffix
forall a. Maybe a
Nothing
Just C.Prime{} -> Maybe Suffix
forall a. Maybe a
Nothing
Just (C.Index Integer
i) -> Suffix -> Maybe Suffix
forall a. a -> Maybe a
Just (Suffix -> Maybe Suffix) -> Suffix -> Maybe Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Suffix
A.Suffix Integer
i
Just (C.Subscript Integer
i) -> Suffix -> Maybe Suffix
forall a. a -> Maybe a
Just (Suffix -> Maybe Suffix) -> Suffix -> Maybe Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Suffix
A.Suffix Integer
i
canHaveSuffixTest :: HasBuiltins m => m (A.QName -> Bool)
canHaveSuffixTest :: forall (m :: * -> *). HasBuiltins m => m (QName -> Bool)
canHaveSuffixTest = do
builtinProp <- BuiltinId -> m (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinProp
builtinSet <- getBuiltinName' builtinSet
builtinSSet <- getBuiltinName' builtinStrictSet
builtinPropOmega <- getBuiltinName' builtinPropOmega
builtinSetOmega <- getBuiltinName' builtinSetOmega
builtinSSetOmega <- getBuiltinName' builtinSSetOmega
return $ \QName
x -> QName -> Maybe QName
forall a. a -> Maybe a
Just QName
x Maybe QName -> [Maybe QName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe QName
builtinProp, Maybe QName
builtinSet, Maybe QName
builtinSSet, Maybe QName
builtinPropOmega, Maybe QName
builtinSetOmega, Maybe QName
builtinSSetOmega]
resolveModule :: C.QName -> ScopeM AbstractModule
resolveModule :: QName -> ScopeM AbstractModule
resolveModule QName
x = do
ms <- QName -> ScopeInfo -> [AbstractModule]
forall a. InScope a => QName -> ScopeInfo -> [a]
scopeLookup QName
x (ScopeInfo -> [AbstractModule])
-> TCMT IO ScopeInfo -> TCMT IO [AbstractModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
caseMaybe (nonEmpty ms) (typeError $ NoSuchModule x) $ \ case
AbsModule ModuleName
m WhyInScope
why :| [] -> AbstractModule -> ScopeM AbstractModule
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractModule -> ScopeM AbstractModule)
-> AbstractModule -> ScopeM AbstractModule
forall a b. (a -> b) -> a -> b
$ ModuleName -> WhyInScope -> AbstractModule
AbsModule (ModuleName
m ModuleName -> QName -> ModuleName
forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` QName
x) WhyInScope
why
NonEmpty AbstractModule
ms -> TypeError -> ScopeM AbstractModule
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> ScopeM AbstractModule)
-> TypeError -> ScopeM AbstractModule
forall a b. (a -> b) -> a -> b
$ QName -> List1 ModuleName -> TypeError
AmbiguousModule QName
x ((AbstractModule -> ModuleName)
-> NonEmpty AbstractModule -> List1 ModuleName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractModule -> ModuleName
amodName NonEmpty AbstractModule
ms)
getConcreteFixity :: C.Name -> ScopeM Fixity'
getConcreteFixity :: Name -> ScopeM Fixity'
getConcreteFixity Name
x = Fixity' -> Name -> Map Name Fixity' -> Fixity'
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Fixity'
noFixity' Name
x (Map Name Fixity' -> Fixity')
-> TCMT IO (Map Name Fixity') -> ScopeM Fixity'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' ScopeInfo (Map Name Fixity') -> TCMT IO (Map Name Fixity')
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (Map Name Fixity' -> f (Map Name Fixity'))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map Name Fixity')
scopeFixities
getConcretePolarity :: C.Name -> ScopeM (Maybe [Occurrence])
getConcretePolarity :: Name -> ScopeM (Maybe [Occurrence])
getConcretePolarity Name
x = Name -> Map Name [Occurrence] -> Maybe [Occurrence]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (Map Name [Occurrence] -> Maybe [Occurrence])
-> TCMT IO (Map Name [Occurrence]) -> ScopeM (Maybe [Occurrence])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' ScopeInfo (Map Name [Occurrence])
-> TCMT IO (Map Name [Occurrence])
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (Map Name [Occurrence] -> f (Map Name [Occurrence]))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map Name [Occurrence])
scopePolarities
instance MonadFixityError ScopeM where
throwMultipleFixityDecls :: forall a. [(Name, [Fixity'])] -> ScopeM a
throwMultipleFixityDecls [(Name, [Fixity'])]
xs = case [(Name, [Fixity'])]
xs of
(Name
x, [Fixity']
_) : [(Name, [Fixity'])]
_ -> Range -> ScopeM a -> ScopeM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ TypeError -> ScopeM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> ScopeM a) -> TypeError -> ScopeM a
forall a b. (a -> b) -> a -> b
$ [(Name, [Fixity'])] -> TypeError
MultipleFixityDecls [(Name, [Fixity'])]
xs
[] -> ScopeM a
forall a. HasCallStack => a
__IMPOSSIBLE__
throwMultiplePolarityPragmas :: forall a. [Name] -> ScopeM a
throwMultiplePolarityPragmas [Name]
xs = case [Name]
xs of
Name
x : [Name]
_ -> Range -> ScopeM a -> ScopeM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ TypeError -> ScopeM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> ScopeM a) -> TypeError -> ScopeM a
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
MultiplePolarityPragmas [Name]
xs
[] -> ScopeM a
forall a. HasCallStack => a
__IMPOSSIBLE__
warnUnknownNamesInFixityDecl :: HasCallStack => [Name] -> TCMT IO ()
warnUnknownNamesInFixityDecl = HasCallStack => DeclarationWarning' -> TCMT IO ()
DeclarationWarning' -> TCMT IO ()
scopeWarning (DeclarationWarning' -> TCMT IO ())
-> ([Name] -> DeclarationWarning') -> [Name] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> DeclarationWarning'
UnknownNamesInFixityDecl
warnUnknownNamesInPolarityPragmas :: HasCallStack => [Name] -> TCMT IO ()
warnUnknownNamesInPolarityPragmas = HasCallStack => DeclarationWarning' -> TCMT IO ()
DeclarationWarning' -> TCMT IO ()
scopeWarning (DeclarationWarning' -> TCMT IO ())
-> ([Name] -> DeclarationWarning') -> [Name] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> DeclarationWarning'
UnknownNamesInPolarityPragmas
warnUnknownFixityInMixfixDecl :: HasCallStack => [Name] -> TCMT IO ()
warnUnknownFixityInMixfixDecl = HasCallStack => DeclarationWarning' -> TCMT IO ()
DeclarationWarning' -> TCMT IO ()
scopeWarning (DeclarationWarning' -> TCMT IO ())
-> ([Name] -> DeclarationWarning') -> [Name] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> DeclarationWarning'
UnknownFixityInMixfixDecl
warnPolarityPragmasButNotPostulates :: HasCallStack => [Name] -> TCMT IO ()
warnPolarityPragmasButNotPostulates = HasCallStack => DeclarationWarning' -> TCMT IO ()
DeclarationWarning' -> TCMT IO ()
scopeWarning (DeclarationWarning' -> TCMT IO ())
-> ([Name] -> DeclarationWarning') -> [Name] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> DeclarationWarning'
PolarityPragmasButNotPostulates
computeFixitiesAndPolarities :: DoWarn -> [C.Declaration] -> ScopeM a -> ScopeM a
computeFixitiesAndPolarities :: forall a. DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
computeFixitiesAndPolarities DoWarn
warn [Declaration]
ds ScopeM a
cont = do
fp <- DoWarn
-> [Declaration]
-> TCMT IO (Map Name Fixity', Map Name [Occurrence])
forall (m :: * -> *).
MonadFixityError m =>
DoWarn
-> [Declaration] -> m (Map Name Fixity', Map Name [Occurrence])
fixitiesAndPolarities DoWarn
warn [Declaration]
ds
locallyScope scopeFixitiesAndPolarities (const fp) cont
getNotation
:: C.QName
-> Set A.Name
-> ScopeM NewNotation
getNotation :: QName -> Set Name -> ScopeM NewNotation
getNotation QName
x Set Name
ns = do
r <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
allKindsOfNames (Set Name -> Maybe (Set Name)
forall a. a -> Maybe a
Just Set Name
ns) QName
x
case r of
VarName Name
y BindingSource
_ -> NewNotation -> ScopeM NewNotation
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NewNotation -> ScopeM NewNotation)
-> NewNotation -> ScopeM NewNotation
forall a b. (a -> b) -> a -> b
$ QName -> Name -> NewNotation
namesToNotation QName
x Name
y
DefinedName Access
_ AbstractName
d Suffix
_ -> NewNotation -> ScopeM NewNotation
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NewNotation -> ScopeM NewNotation)
-> NewNotation -> ScopeM NewNotation
forall a b. (a -> b) -> a -> b
$ AbstractName -> NewNotation
notation AbstractName
d
FieldName NonEmpty AbstractName
ds -> NewNotation -> ScopeM NewNotation
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NewNotation -> ScopeM NewNotation)
-> NewNotation -> ScopeM NewNotation
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> NewNotation
oneNotation NonEmpty AbstractName
ds
ConstructorName Set Induction
_ NonEmpty AbstractName
ds-> NewNotation -> ScopeM NewNotation
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NewNotation -> ScopeM NewNotation)
-> NewNotation -> ScopeM NewNotation
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> NewNotation
oneNotation NonEmpty AbstractName
ds
PatternSynResName NonEmpty AbstractName
n -> NewNotation -> ScopeM NewNotation
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NewNotation -> ScopeM NewNotation)
-> NewNotation -> ScopeM NewNotation
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> NewNotation
oneNotation NonEmpty AbstractName
n
ResolvedName
UnknownName -> ScopeM NewNotation
forall a. HasCallStack => a
__IMPOSSIBLE__
where
notation :: AbstractName -> NewNotation
notation = QName -> Name -> NewNotation
namesToNotation QName
x (Name -> NewNotation)
-> (AbstractName -> Name) -> AbstractName -> NewNotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName (QName -> Name) -> (AbstractName -> QName) -> AbstractName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName
oneNotation :: NonEmpty AbstractName -> NewNotation
oneNotation = NonEmpty NewNotation -> NewNotation
forall a. NonEmpty a -> a
List1.head (NonEmpty NewNotation -> NewNotation)
-> (NonEmpty AbstractName -> NonEmpty NewNotation)
-> NonEmpty AbstractName
-> NewNotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty NewNotation -> NonEmpty NewNotation
mergeNotations (NonEmpty NewNotation -> NonEmpty NewNotation)
-> (NonEmpty AbstractName -> NonEmpty NewNotation)
-> NonEmpty AbstractName
-> NonEmpty NewNotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName -> NewNotation)
-> NonEmpty AbstractName -> NonEmpty NewNotation
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> NewNotation
notation
bindVariable
:: A.BindingSource
-> C.Name
-> A.Name
-> ScopeM ()
bindVariable :: BindingSource -> Name -> Name -> TCMT IO ()
bindVariable BindingSource
b Name
x Name
y = (LocalVars -> LocalVars) -> TCMT IO ()
modifyLocalVars ((LocalVars -> LocalVars) -> TCMT IO ())
-> (LocalVars -> LocalVars) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> LocalVar -> LocalVars -> LocalVars
forall k v. k -> v -> AssocList k v -> AssocList k v
AssocList.insert Name
x (LocalVar -> LocalVars -> LocalVars)
-> LocalVar -> LocalVars -> LocalVars
forall a b. (a -> b) -> a -> b
$ Name -> BindingSource -> [AbstractName] -> LocalVar
LocalVar Name
y BindingSource
b []
unbindVariable :: C.Name -> ScopeM a -> ScopeM a
unbindVariable :: forall a. Name -> ScopeM a -> ScopeM a
unbindVariable Name
x = TCMT IO LocalVars
-> (LocalVars -> TCMT IO ()) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ (TCMT IO LocalVars
forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars TCMT IO LocalVars -> TCMT IO () -> TCMT IO LocalVars
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (LocalVars -> LocalVars) -> TCMT IO ()
modifyLocalVars (Name -> LocalVars -> LocalVars
forall k v. Eq k => k -> AssocList k v -> AssocList k v
AssocList.delete Name
x)) ((LocalVars -> LocalVars) -> TCMT IO ()
modifyLocalVars ((LocalVars -> LocalVars) -> TCMT IO ())
-> (LocalVars -> LocalVars -> LocalVars) -> LocalVars -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalVars -> LocalVars -> LocalVars
forall a b. a -> b -> a
const)
bindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()
bindName :: Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
acc KindOfName
kind Name
x QName
y = Access -> KindOfName -> NameMetadata -> Name -> QName -> TCMT IO ()
bindName' Access
acc KindOfName
kind NameMetadata
NoMetadata Name
x QName
y
bindName' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM ()
bindName' :: Access -> KindOfName -> NameMetadata -> Name -> QName -> TCMT IO ()
bindName' Access
acc KindOfName
kind NameMetadata
meta Name
x QName
y = TCMT IO (Maybe TypeError)
-> (TypeError -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (Access
-> KindOfName
-> NameMetadata
-> Name
-> QName
-> TCMT IO (Maybe TypeError)
bindName'' Access
acc KindOfName
kind NameMetadata
meta Name
x QName
y) TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError
bindName'' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM (Maybe TypeError)
bindName'' :: Access
-> KindOfName
-> NameMetadata
-> Name
-> QName
-> TCMT IO (Maybe TypeError)
bindName'' Access
acc KindOfName
kind NameMetadata
meta Name
x QName
y = do
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
x) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes ((Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ())
-> (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope)
-> (Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> Scope -> Scope
removeNameFromScope NameSpaceId
PrivateNS Name
x
r <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x)
let y' :: Either TypeError AbstractName
y' = case ResolvedName
r of
ResolvedName
_ | Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
x -> Either TypeError AbstractName
success
DefinedName Access
_ AbstractName
d Suffix
_ -> QName -> Either TypeError AbstractName
clash (QName -> Either TypeError AbstractName)
-> QName -> Either TypeError AbstractName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
VarName Name
z BindingSource
_ -> QName -> Either TypeError AbstractName
clash (QName -> Either TypeError AbstractName)
-> QName -> Either TypeError AbstractName
forall a b. (a -> b) -> a -> b
$ Name -> QName
A.qualify_ Name
z
FieldName NonEmpty AbstractName
ds -> (KindOfName -> Bool)
-> NonEmpty AbstractName -> Either TypeError AbstractName
ambiguous (KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
FldName) NonEmpty AbstractName
ds
ConstructorName Set Induction
i NonEmpty AbstractName
ds-> (KindOfName -> Bool)
-> NonEmpty AbstractName -> Either TypeError AbstractName
ambiguous (Maybe Induction -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Induction -> Bool)
-> (KindOfName -> Maybe Induction) -> KindOfName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindOfName -> Maybe Induction
isConName) NonEmpty AbstractName
ds
PatternSynResName NonEmpty AbstractName
n -> (KindOfName -> Bool)
-> NonEmpty AbstractName -> Either TypeError AbstractName
ambiguous (KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
PatternSynName) NonEmpty AbstractName
n
ResolvedName
UnknownName -> Either TypeError AbstractName
success
let ns = if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
x then NameSpaceId
PrivateNS else Access -> NameSpaceId
localNameSpace Access
acc
traverse_ (modifyCurrentScope . addNameToScope ns x) y'
pure $ either Just (const Nothing) y'
where
success :: Either TypeError AbstractName
success = AbstractName -> Either TypeError AbstractName
forall a b. b -> Either a b
Right (AbstractName -> Either TypeError AbstractName)
-> AbstractName -> Either TypeError AbstractName
forall a b. (a -> b) -> a -> b
$ QName -> KindOfName -> WhyInScope -> NameMetadata -> AbstractName
AbsName QName
y KindOfName
kind WhyInScope
Defined NameMetadata
meta
clash :: QName -> Either TypeError AbstractName
clash QName
n = TypeError -> Either TypeError AbstractName
forall a b. a -> Either a b
Left (TypeError -> Either TypeError AbstractName)
-> TypeError -> Either TypeError AbstractName
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) QName
n Maybe NiceDeclaration
forall a. Maybe a
Nothing
ambiguous :: (KindOfName -> Bool)
-> NonEmpty AbstractName -> Either TypeError AbstractName
ambiguous KindOfName -> Bool
f NonEmpty AbstractName
ds =
if KindOfName -> Bool
f KindOfName
kind Bool -> Bool -> Bool
&& (AbstractName -> Bool) -> NonEmpty AbstractName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (KindOfName -> Bool
f (KindOfName -> Bool)
-> (AbstractName -> KindOfName) -> AbstractName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind) NonEmpty AbstractName
ds
then Either TypeError AbstractName
success else QName -> Either TypeError AbstractName
clash (QName -> Either TypeError AbstractName)
-> QName -> Either TypeError AbstractName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
ds)
rebindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()
rebindName :: Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
acc KindOfName
kind Name
x QName
y = do
if KindOfName
kind KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
ConName
then (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
NameSpaceId
-> (NamesInScope -> NamesInScope)
-> (ModulesInScope -> ModulesInScope)
-> (InScopeSet -> InScopeSet)
-> Scope
-> Scope
mapScopeNS (Access -> NameSpaceId
localNameSpace Access
acc)
((NonEmpty AbstractName -> Maybe (NonEmpty AbstractName))
-> Name -> NamesInScope -> NamesInScope
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update ([AbstractName] -> Maybe (NonEmpty AbstractName)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([AbstractName] -> Maybe (NonEmpty AbstractName))
-> (NonEmpty AbstractName -> [AbstractName])
-> NonEmpty AbstractName
-> Maybe (NonEmpty AbstractName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractName -> Bool) -> NonEmpty AbstractName -> [AbstractName]
forall a. (a -> Bool) -> NonEmpty a -> [a]
List1.filter ((KindOfName
ConName KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
==) (KindOfName -> Bool)
-> (AbstractName -> KindOfName) -> AbstractName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind)) Name
x)
ModulesInScope -> ModulesInScope
forall a. a -> a
id
InScopeSet -> InScopeSet
forall a. a -> a
id
else (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> Scope -> Scope
removeNameFromScope (Access -> NameSpaceId
localNameSpace Access
acc) Name
x
Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
acc KindOfName
kind Name
x QName
y
bindModule :: Access -> C.Name -> A.ModuleName -> ScopeM ()
bindModule :: Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
acc Name
x ModuleName
m = (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
NameSpaceId -> Name -> AbstractModule -> Scope -> Scope
addModuleToScope (Access -> NameSpaceId
localNameSpace Access
acc) Name
x (ModuleName -> WhyInScope -> AbstractModule
AbsModule ModuleName
m WhyInScope
Defined)
bindQModule :: Access -> C.QName -> A.ModuleName -> ScopeM ()
bindQModule :: Access -> QName -> ModuleName -> TCMT IO ()
bindQModule Access
acc QName
q ModuleName
m = (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Scope
s ->
Scope
s { scopeImports = Map.insert q m (scopeImports s) }
stripNoNames :: ScopeM ()
stripNoNames :: TCMT IO ()
stripNoNames = (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes ((Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ())
-> (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope)
-> (Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall a b. (a -> b) -> a -> b
$ (NamesInScope -> NamesInScope)
-> (ModulesInScope -> ModulesInScope)
-> (InScopeSet -> InScopeSet)
-> Scope
-> Scope
mapScope_ NamesInScope -> NamesInScope
forall {a}. Map Name a -> Map Name a
stripN ModulesInScope -> ModulesInScope
forall {a}. Map Name a -> Map Name a
stripN InScopeSet -> InScopeSet
forall a. a -> a
id
where
stripN :: Map Name a -> Map Name a
stripN = (Name -> a -> Bool) -> Map Name a -> Map Name a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey ((Name -> a -> Bool) -> Map Name a -> Map Name a)
-> (Name -> a -> Bool) -> Map Name a -> Map Name a
forall a b. (a -> b) -> a -> b
$ Bool -> a -> Bool
forall a b. a -> b -> a
const (Bool -> a -> Bool) -> (Name -> Bool) -> Name -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName
type WSM = StateT ScopeMemo ScopeM
data ScopeMemo = ScopeMemo
{ ScopeMemo -> Ren QName
memoNames :: A.Ren A.QName
, ScopeMemo -> Map ModuleName (ModuleName, Bool)
memoModules :: Map ModuleName (ModuleName, Bool)
}
memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo
memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo
memoToScopeInfo (ScopeMemo Ren QName
names Map ModuleName (ModuleName, Bool)
mods) =
ScopeCopyInfo { renNames :: Ren QName
renNames = Ren QName
names
, renModules :: Ren ModuleName
renModules = ((ModuleName, Bool) -> List1 ModuleName)
-> Map ModuleName (ModuleName, Bool) -> Ren ModuleName
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (ModuleName -> List1 ModuleName
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName -> List1 ModuleName)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> List1 ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) Map ModuleName (ModuleName, Bool)
mods }
copyName :: A.QName -> A.QName -> ScopeM ()
copyName :: QName -> QName -> TCMT IO ()
copyName QName
from QName
to = do
from <- QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe QName
from (Maybe QName -> QName)
-> (HashMap QName QName -> Maybe QName)
-> HashMap QName QName
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> HashMap QName QName -> Maybe QName
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup QName
from (HashMap QName QName -> QName)
-> TCMT IO (HashMap QName QName) -> ScopeM QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCState (HashMap QName QName)
-> TCMT IO (HashMap QName QName)
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (HashMap QName QName -> f (HashMap QName QName))
-> TCState -> f TCState
Lens' TCState (HashMap QName QName)
stCopiedNames
modifyTCLens stCopiedNames $ HMap.insert to from
let
k Maybe (HashSet QName)
Nothing = HashSet QName -> Maybe (HashSet QName)
forall a. a -> Maybe a
Just (QName -> HashSet QName
forall a. Hashable a => a -> HashSet a
HSet.singleton QName
to)
k (Just HashSet QName
s) = HashSet QName -> Maybe (HashSet QName)
forall a. a -> Maybe a
Just (QName -> HashSet QName -> HashSet QName
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HSet.insert QName
to HashSet QName
s)
modifyTCLens stNameCopies $ HMap.alter k from
copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)
copyScope :: QName -> ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)
copyScope QName
oldc ModuleName
new0 Scope
s = ((WhyInScope -> WhyInScope) -> Scope -> Scope
inScopeBecause (QName -> WhyInScope -> WhyInScope
Applied QName
oldc) (Scope -> Scope)
-> (ScopeMemo -> ScopeCopyInfo)
-> (Scope, ScopeMemo)
-> (Scope, ScopeCopyInfo)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ScopeMemo -> ScopeCopyInfo
memoToScopeInfo) ((Scope, ScopeMemo) -> (Scope, ScopeCopyInfo))
-> TCMT IO (Scope, ScopeMemo) -> ScopeM (Scope, ScopeCopyInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ScopeMemo (TCMT IO) Scope
-> ScopeMemo -> TCMT IO (Scope, ScopeMemo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ModuleName -> Scope -> StateT ScopeMemo (TCMT IO) Scope
copy ModuleName
new0 Scope
s) (Ren QName -> Map ModuleName (ModuleName, Bool) -> ScopeMemo
ScopeMemo Ren QName
forall a. Monoid a => a
mempty Map ModuleName (ModuleName, Bool)
forall a. Monoid a => a
mempty)
where
copy :: A.ModuleName -> Scope -> WSM Scope
copy :: ModuleName -> Scope -> StateT ScopeMemo (TCMT IO) Scope
copy ModuleName
new Scope
s = do
TCMT IO () -> StateT ScopeMemo (TCMT IO) ()
forall (m :: * -> *) a. Monad m => m a -> StateT ScopeMemo m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO () -> StateT ScopeMemo (TCMT IO) ())
-> TCMT IO () -> StateT ScopeMemo (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.copy" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Copying scope " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
old [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
new
TCMT IO () -> StateT ScopeMemo (TCMT IO) ()
forall (m :: * -> *) a. Monad m => m a -> StateT ScopeMemo m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO () -> StateT ScopeMemo (TCMT IO) ())
-> TCMT IO () -> StateT ScopeMemo (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.copy" Int
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Scope
s
s0 <- ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope
forall (m :: * -> *) a. Monad m => m a -> StateT ScopeMemo m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope)
-> ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope
forall a b. (a -> b) -> a -> b
$ ModuleName -> ScopeM Scope
getNamedScope ModuleName
new
s' <- recomputeInScopeSets <$> mapScopeM_ copyD copyM return (setNameSpace PrivateNS emptyNameSpace s)
return $ s' { scopeName = scopeName s0
, scopeParents = scopeParents s0
}
where
rnew :: Range
rnew = ModuleName -> Range
forall a. HasRange a => a -> Range
getRange ModuleName
new
new' :: ModuleName
new' = ModuleName -> ModuleName
forall a. KillRange a => KillRangeT a
killRange ModuleName
new
newL :: [Name]
newL = ModuleName -> [Name]
A.mnameToList ModuleName
new'
old :: ModuleName
old = Scope -> ModuleName
scopeName Scope
s
copyD :: NamesInScope -> WSM NamesInScope
copyD :: NamesInScope -> StateT ScopeMemo (TCMT IO) NamesInScope
copyD = (NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName))
-> NamesInScope -> StateT ScopeMemo (TCMT IO) NamesInScope
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Name a -> f (Map Name b)
traverse ((NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName))
-> NamesInScope -> StateT ScopeMemo (TCMT IO) NamesInScope)
-> (NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName))
-> NamesInScope
-> StateT ScopeMemo (TCMT IO) NamesInScope
forall a b. (a -> b) -> a -> b
$ (AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName)
-> NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName)
-> NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName))
-> (AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName)
-> NonEmpty AbstractName
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$ (QName -> WSM QName)
-> AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName
onName QName -> WSM QName
renName
copyM :: ModulesInScope -> WSM ModulesInScope
copyM :: ModulesInScope -> StateT ScopeMemo (TCMT IO) ModulesInScope
copyM = (NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule))
-> ModulesInScope -> StateT ScopeMemo (TCMT IO) ModulesInScope
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Name a -> f (Map Name b)
traverse ((NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule))
-> ModulesInScope -> StateT ScopeMemo (TCMT IO) ModulesInScope)
-> (NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule))
-> ModulesInScope
-> StateT ScopeMemo (TCMT IO) ModulesInScope
forall a b. (a -> b) -> a -> b
$ (AbstractModule -> StateT ScopeMemo (TCMT IO) AbstractModule)
-> NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((AbstractModule -> StateT ScopeMemo (TCMT IO) AbstractModule)
-> NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule))
-> (AbstractModule -> StateT ScopeMemo (TCMT IO) AbstractModule)
-> NonEmpty AbstractModule
-> StateT ScopeMemo (TCMT IO) (NonEmpty AbstractModule)
forall a b. (a -> b) -> a -> b
$ (ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName)
-> AbstractModule -> StateT ScopeMemo (TCMT IO) AbstractModule
Lens' AbstractModule ModuleName
lensAmodName ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
renMod
onName :: (A.QName -> WSM A.QName) -> AbstractName -> WSM AbstractName
onName :: (QName -> WSM QName)
-> AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName
onName QName -> WSM QName
f AbstractName
d =
case AbstractName -> KindOfName
anameKind AbstractName
d of
KindOfName
PatternSynName -> AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName
forall a. a -> StateT ScopeMemo (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return AbstractName
d
KindOfName
_ -> (QName -> WSM QName)
-> AbstractName -> StateT ScopeMemo (TCMT IO) AbstractName
Lens' AbstractName QName
lensAnameName QName -> WSM QName
f AbstractName
d
addName :: QName -> QName -> m ()
addName QName
x QName
y = (ScopeMemo -> ScopeMemo) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ScopeMemo -> ScopeMemo) -> m ())
-> (ScopeMemo -> ScopeMemo) -> m ()
forall a b. (a -> b) -> a -> b
$ \ ScopeMemo
i -> ScopeMemo
i { memoNames = Map.insertWith (<>) x (pure y) (memoNames i) }
addMod :: ModuleName -> ModuleName -> Bool -> m ()
addMod ModuleName
x ModuleName
y Bool
rec = (ScopeMemo -> ScopeMemo) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ScopeMemo -> ScopeMemo) -> m ())
-> (ScopeMemo -> ScopeMemo) -> m ()
forall a b. (a -> b) -> a -> b
$ \ ScopeMemo
i -> ScopeMemo
i { memoModules = Map.insert x (y, rec) (memoModules i) }
findName :: QName -> m (Maybe (List1 QName))
findName QName
x = (ScopeMemo -> Maybe (List1 QName)) -> m (Maybe (List1 QName))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (QName -> Ren QName -> Maybe (List1 QName)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
x (Ren QName -> Maybe (List1 QName))
-> (ScopeMemo -> Ren QName) -> ScopeMemo -> Maybe (List1 QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeMemo -> Ren QName
memoNames)
findMod :: ModuleName -> m (Maybe (ModuleName, Bool))
findMod ModuleName
x = (ScopeMemo -> Maybe (ModuleName, Bool))
-> m (Maybe (ModuleName, Bool))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ModuleName
-> Map ModuleName (ModuleName, Bool) -> Maybe (ModuleName, Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
x (Map ModuleName (ModuleName, Bool) -> Maybe (ModuleName, Bool))
-> (ScopeMemo -> Map ModuleName (ModuleName, Bool))
-> ScopeMemo
-> Maybe (ModuleName, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopeMemo -> Map ModuleName (ModuleName, Bool)
memoModules)
refresh :: A.Name -> WSM A.Name
refresh :: Name -> WSM Name
refresh Name
x = do
i <- TCMT IO NameId -> StateT ScopeMemo (TCMT IO) NameId
forall (m :: * -> *) a. Monad m => m a -> StateT ScopeMemo m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
return $ x { A.nameId = i }
renName :: A.QName -> WSM A.QName
renName :: QName -> WSM QName
renName QName
x = do
m <- if QName
x QName -> ModuleName -> Bool
`isInModule` ModuleName
old
then ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
forall a. a -> StateT ScopeMemo (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
new'
else Bool -> ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
renMod' Bool
False (QName -> ModuleName
qnameModule QName
x)
y <- setRange rnew . A.qualify m <$> refresh (qnameName x)
lift $ reportSLn "scope.copy" 50 $ " Copying " ++ prettyShow x ++ " to " ++ prettyShow y
addName x y
lift (copyName x y)
return y
renMod :: A.ModuleName -> WSM A.ModuleName
renMod :: ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
renMod = Bool -> ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
renMod' Bool
True
renMod' :: Bool -> ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
renMod' Bool
rec ModuleName
x = do
z <- ModuleName -> StateT ScopeMemo (TCMT IO) (Maybe (ModuleName, Bool))
forall {m :: * -> *}.
MonadState ScopeMemo m =>
ModuleName -> m (Maybe (ModuleName, Bool))
findMod ModuleName
x
case z of
Just (ModuleName
y, Bool
False) | Bool
rec -> ModuleName
y ModuleName
-> StateT ScopeMemo (TCMT IO) ()
-> StateT ScopeMemo (TCMT IO) ModuleName
forall a b.
a -> StateT ScopeMemo (TCMT IO) b -> StateT ScopeMemo (TCMT IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ModuleName -> ModuleName -> StateT ScopeMemo (TCMT IO) ()
copyRec ModuleName
x ModuleName
y
Just (ModuleName
y, Bool
_) -> ModuleName -> StateT ScopeMemo (TCMT IO) ModuleName
forall a. a -> StateT ScopeMemo (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
y
Maybe (ModuleName, Bool)
Nothing -> do
let newM :: [Name]
newM = if ModuleName
x ModuleName -> ModuleName -> Bool
`isLtChildModuleOf` ModuleName
old then [Name]
newL else ModuleName -> [Name]
mnameToList ModuleName
new0
y <- do
y <- Name -> WSM Name
refresh (Name -> WSM Name) -> Name -> WSM Name
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Name
forall a. a -> [a] -> a
lastWithDefault Name
forall a. HasCallStack => a
__IMPOSSIBLE__ ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Name]
A.mnameToList ModuleName
x
return $ A.mnameFromList $ newM ++ [y]
if (x == y) then return x else do
lift $ reportSLn "scope.copy" 50 $ " Copying module " ++ prettyShow x ++ " to " ++ prettyShow y
addMod x y rec
lift $ createModule Nothing y
when rec $ copyRec x y
return y
where
copyRec :: ModuleName -> ModuleName -> StateT ScopeMemo (TCMT IO) ()
copyRec ModuleName
x ModuleName
y = do
s0 <- ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope
forall (m :: * -> *) a. Monad m => m a -> StateT ScopeMemo m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope)
-> ScopeM Scope -> StateT ScopeMemo (TCMT IO) Scope
forall a b. (a -> b) -> a -> b
$ ModuleName -> ScopeM Scope
getNamedScope ModuleName
x
s <- withCurrentModule' y $ copy y s0
lift $ modifyNamedScope y (const s)
checkNoFixityInRenamingModule :: [C.Renaming] -> ScopeM ()
checkNoFixityInRenamingModule :: [Renaming] -> TCMT IO ()
checkNoFixityInRenamingModule [Renaming]
ren = do
Maybe (NonEmpty Range)
-> (NonEmpty Range -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust ([Range] -> Maybe (NonEmpty Range)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Range] -> Maybe (NonEmpty Range))
-> [Range] -> Maybe (NonEmpty Range)
forall a b. (a -> b) -> a -> b
$ (Renaming -> Maybe Range) -> [Renaming] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Renaming -> Maybe Range
rangeOfUselessInfix [Renaming]
ren) ((NonEmpty Range -> TCMT IO ()) -> TCMT IO ())
-> (NonEmpty Range -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ NonEmpty Range
rs -> do
NonEmpty Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NonEmpty Range
rs (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty Range -> Warning
FixityInRenamingModule NonEmpty Range
rs
where
rangeOfUselessInfix :: C.Renaming -> Maybe Range
rangeOfUselessInfix :: Renaming -> Maybe Range
rangeOfUselessInfix = \case
Renaming ImportedModule{} ImportedName
_ Maybe Fixity
mfx Range
_ -> Fixity -> Range
forall a. HasRange a => a -> Range
getRange (Fixity -> Range) -> Maybe Fixity -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Fixity
mfx
Renaming
_ -> Maybe Range
forall a. Maybe a
Nothing
verifyImportDirective :: [C.ImportedName] -> C.HidingDirective -> C.RenamingDirective -> ScopeM ()
verifyImportDirective :: [ImportedName] -> [ImportedName] -> [Renaming] -> TCMT IO ()
verifyImportDirective [ImportedName]
usn [ImportedName]
hdn [Renaming]
ren =
case (NonEmpty ImportedName -> Bool)
-> [NonEmpty ImportedName] -> [NonEmpty ImportedName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (NonEmpty ImportedName -> Bool) -> NonEmpty ImportedName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ImportedName] -> Bool
forall a. Null a => a -> Bool
null ([ImportedName] -> Bool)
-> (NonEmpty ImportedName -> [ImportedName])
-> NonEmpty ImportedName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ImportedName -> [ImportedName]
forall a. NonEmpty a -> [a]
List1.tail)
([NonEmpty ImportedName] -> [NonEmpty ImportedName])
-> [NonEmpty ImportedName] -> [NonEmpty ImportedName]
forall a b. (a -> b) -> a -> b
$ [ImportedName] -> [NonEmpty ImportedName]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
List1.group
([ImportedName] -> [NonEmpty ImportedName])
-> [ImportedName] -> [NonEmpty ImportedName]
forall a b. (a -> b) -> a -> b
$ [ImportedName] -> [ImportedName]
forall a. Ord a => [a] -> [a]
List.sort [ImportedName]
xs
of
[] -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[NonEmpty ImportedName]
yss -> [NonEmpty ImportedName] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [NonEmpty ImportedName]
yss (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
[Char]
"Repeated name" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in import directive: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
List.intersperse [Char]
", " ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (NonEmpty ImportedName -> [Char])
-> [NonEmpty ImportedName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ImportedName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (ImportedName -> [Char])
-> (NonEmpty ImportedName -> ImportedName)
-> NonEmpty ImportedName
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ImportedName -> ImportedName
forall a. NonEmpty a -> a
List1.head) [NonEmpty ImportedName]
yss)
where
s :: [Char]
s = case [NonEmpty ImportedName]
yss of
[NonEmpty ImportedName
_] -> [Char]
""
[NonEmpty ImportedName]
_ -> [Char]
"s"
where
xs :: [ImportedName]
xs = [ImportedName]
usn [ImportedName] -> [ImportedName] -> [ImportedName]
forall a. [a] -> [a] -> [a]
++ [ImportedName]
hdn [ImportedName] -> [ImportedName] -> [ImportedName]
forall a. [a] -> [a] -> [a]
++ (Renaming -> ImportedName) -> [Renaming] -> [ImportedName]
forall a b. (a -> b) -> [a] -> [b]
map Renaming -> ImportedName
forall n m. Renaming' n m -> ImportedName' n m
renFrom [Renaming]
ren
applyImportDirectiveM
:: C.QName
-> C.ImportDirective
-> Scope
-> ScopeM (A.ImportDirective, Scope)
applyImportDirectiveM :: QName
-> ImportDirective -> Scope -> ScopeM (ImportDirective, Scope)
applyImportDirectiveM QName
m (ImportDirective Range
rng Using' Name Name
usn' [ImportedName]
hdn' [Renaming]
ren' Maybe KwRange
public) Scope
scope0 = do
[Renaming] -> TCMT IO ()
checkNoFixityInRenamingModule [Renaming]
ren'
usingList <- Using' Name Name -> ScopeM [ImportedName]
discardDuplicatesInUsing Using' Name Name
usn'
verifyImportDirective usingList hdn' ren'
let (missingExports, namesA) = checkExist $ usingList ++ hdn' ++ map renFrom ren'
unless (null missingExports) $ setCurrentRange rng $ do
reportSLn "scope.import.apply" 20 $ "non existing names: " ++ prettyShow missingExports
warning $ ModuleDoesntExport m (Map.keys namesInScope) (Map.keys modulesInScope) missingExports
let notMissing = Bool -> Bool
not (Bool -> Bool) -> (ImportedName -> Bool) -> ImportedName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ImportedName]
missingExports [ImportedName] -> ImportedName -> Bool
forall a. Ord a => [a] -> a -> Bool
`hasElem`)
let usn = (ImportedName -> Bool) -> [ImportedName] -> [ImportedName]
forall a. (a -> Bool) -> [a] -> [a]
filter ImportedName -> Bool
notMissing [ImportedName]
usingList
let hdn = (ImportedName -> Bool) -> [ImportedName] -> [ImportedName]
forall a. (a -> Bool) -> [a] -> [a]
filter ImportedName -> Bool
notMissing [ImportedName]
hdn'
let ren = (Renaming -> Bool) -> [Renaming] -> [Renaming]
forall a. (a -> Bool) -> [a] -> [a]
filter (ImportedName -> Bool
notMissing (ImportedName -> Bool)
-> (Renaming -> ImportedName) -> Renaming -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renaming -> ImportedName
forall n m. Renaming' n m -> ImportedName' n m
renFrom) [Renaming]
ren'
let dir = Range
-> Using' Name Name
-> [ImportedName]
-> [Renaming]
-> Maybe KwRange
-> ImportDirective
forall n m.
Range
-> Using' n m
-> HidingDirective' n m
-> RenamingDirective' n m
-> Maybe KwRange
-> ImportDirective' n m
ImportDirective Range
rng (([ImportedName] -> [ImportedName])
-> Using' Name Name -> Using' Name Name
forall n1 m1 n2 m2.
([ImportedName' n1 m1] -> [ImportedName' n2 m2])
-> Using' n1 m1 -> Using' n2 m2
mapUsing ([ImportedName] -> [ImportedName] -> [ImportedName]
forall a b. a -> b -> a
const [ImportedName]
usn) Using' Name Name
usn') [ImportedName]
hdn [Renaming]
ren Maybe KwRange
public
let names = (Renaming -> ImportedName) -> [Renaming] -> [ImportedName]
forall a b. (a -> b) -> [a] -> [b]
map Renaming -> ImportedName
forall n m. Renaming' n m -> ImportedName' n m
renFrom [Renaming]
ren [ImportedName] -> [ImportedName] -> [ImportedName]
forall a. [a] -> [a] -> [a]
++ [ImportedName]
hdn [ImportedName] -> [ImportedName] -> [ImportedName]
forall a. [a] -> [a] -> [a]
++ [ImportedName]
usn
let definedNames = (Renaming -> ImportedName) -> [Renaming] -> [ImportedName]
forall a b. (a -> b) -> [a] -> [b]
map Renaming -> ImportedName
forall n m. Renaming' n m -> ImportedName' n m
renTo [Renaming]
ren
let targetNames = [ImportedName]
usn [ImportedName] -> [ImportedName] -> [ImportedName]
forall a. [a] -> [a] -> [a]
++ [ImportedName]
definedNames
let inNames = ([ImportedName]
names [ImportedName] -> ImportedName -> Bool
forall a. Ord a => [a] -> a -> Bool
`hasElem`)
let extra Name
x = ImportedName -> Bool
inNames (Name -> ImportedName
forall n m. n -> ImportedName' n m
ImportedName Name
x)
Bool -> Bool -> Bool
&& ImportedName -> Bool
notMissing (Name -> ImportedName
forall n m. m -> ImportedName' n m
ImportedModule Name
x)
Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (ImportedName -> Bool) -> ImportedName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportedName -> Bool
inNames (ImportedName -> Bool) -> ImportedName -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> ImportedName
forall n m. m -> ImportedName' n m
ImportedModule Name
x)
dir' <- sanityCheck (not . inNames) $ addExtraModules extra dir
unlessNull (allDuplicates targetNames) $ \ [ImportedName]
dup ->
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> [ImportedName] -> TypeError
DuplicateImports QName
m [ImportedName]
dup
let (scope', (nameClashes, moduleClashes)) = applyImportDirective_ dir' scope
unless (null nameClashes) $
warning $ ClashesViaRenaming NameNotModule $ Set.toList nameClashes
unless (null moduleClashes) $
warning $ ClashesViaRenaming ModuleNotName $ Set.toList moduleClashes
let namesInScope' = (Scope -> NamesInScope
forall a. InScope a => Scope -> ThingsInScope a
allNamesInScope Scope
scope' :: ThingsInScope AbstractName)
let modulesInScope' = (Scope -> ModulesInScope
forall a. InScope a => Scope -> ThingsInScope a
allNamesInScope Scope
scope' :: ThingsInScope AbstractModule)
let look k
x = NonEmpty c -> c
forall a. NonEmpty a -> a
List1.head (NonEmpty c -> c)
-> (Map k (NonEmpty c) -> NonEmpty c) -> Map k (NonEmpty c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty c -> k -> Map k (NonEmpty c) -> NonEmpty c
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault NonEmpty c
forall a. HasCallStack => a
__IMPOSSIBLE__ k
x
let definedA = [ImportedName]
-> (ImportedName -> ImportedName' (Name, QName) (Name, ModuleName))
-> [ImportedName' (Name, QName) (Name, ModuleName)]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [ImportedName]
definedNames ((ImportedName -> ImportedName' (Name, QName) (Name, ModuleName))
-> [ImportedName' (Name, QName) (Name, ModuleName)])
-> (ImportedName -> ImportedName' (Name, QName) (Name, ModuleName))
-> [ImportedName' (Name, QName) (Name, ModuleName)]
forall a b. (a -> b) -> a -> b
$ \case
ImportedName Name
x -> (Name, QName) -> ImportedName' (Name, QName) (Name, ModuleName)
forall n m. n -> ImportedName' n m
ImportedName ((Name, QName) -> ImportedName' (Name, QName) (Name, ModuleName))
-> (AbstractName -> (Name, QName))
-> AbstractName
-> ImportedName' (Name, QName) (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x,) (QName -> (Name, QName))
-> (AbstractName -> QName) -> AbstractName -> (Name, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> QName -> QName
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (QName -> QName)
-> (AbstractName -> QName) -> AbstractName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName (AbstractName -> ImportedName' (Name, QName) (Name, ModuleName))
-> AbstractName -> ImportedName' (Name, QName) (Name, ModuleName)
forall a b. (a -> b) -> a -> b
$ Name -> NamesInScope -> AbstractName
forall {k} {c}. Ord k => k -> Map k (NonEmpty c) -> c
look Name
x NamesInScope
namesInScope'
ImportedModule Name
x -> (Name, ModuleName)
-> ImportedName' (Name, QName) (Name, ModuleName)
forall n m. m -> ImportedName' n m
ImportedModule ((Name, ModuleName)
-> ImportedName' (Name, QName) (Name, ModuleName))
-> (AbstractModule -> (Name, ModuleName))
-> AbstractModule
-> ImportedName' (Name, QName) (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x,) (ModuleName -> (Name, ModuleName))
-> (AbstractModule -> ModuleName)
-> AbstractModule
-> (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> ModuleName -> ModuleName
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (ModuleName -> ModuleName)
-> (AbstractModule -> ModuleName) -> AbstractModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName (AbstractModule -> ImportedName' (Name, QName) (Name, ModuleName))
-> AbstractModule -> ImportedName' (Name, QName) (Name, ModuleName)
forall a b. (a -> b) -> a -> b
$ Name -> ModulesInScope -> AbstractModule
forall {k} {c}. Ord k => k -> Map k (NonEmpty c) -> c
look Name
x ModulesInScope
modulesInScope'
let adir = [ImportedName' (Name, QName) (Name, ModuleName)]
-> [ImportedName' (Name, QName) (Name, ModuleName)]
-> ImportDirective
-> ImportDirective
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
[ImportedName' (n1, n2) (m1, m2)]
-> [ImportedName' (n1, n2) (m1, m2)]
-> ImportDirective' n1 m1
-> ImportDirective' n2 m2
mapImportDir [ImportedName' (Name, QName) (Name, ModuleName)]
namesA [ImportedName' (Name, QName) (Name, ModuleName)]
definedA ImportDirective
dir
return (adir, scope')
where
scope :: Scope
scope = Scope -> Scope
restrictPrivate Scope
scope0
discardDuplicatesInUsing :: C.Using -> ScopeM [C.ImportedName]
discardDuplicatesInUsing :: Using' Name Name -> ScopeM [ImportedName]
discardDuplicatesInUsing = \case
Using' Name Name
UseEverything -> [ImportedName] -> ScopeM [ImportedName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Using [ImportedName]
xs -> do
let ([ImportedName]
ys, [ImportedName]
dups) = (ImportedName -> ImportedName)
-> [ImportedName] -> ([ImportedName], [ImportedName])
forall b a. Ord b => (a -> b) -> [a] -> ([a], [a])
nubAndDuplicatesOn ImportedName -> ImportedName
forall a. a -> a
id [ImportedName]
xs
[ImportedName]
-> (NonEmpty ImportedName -> TCMT IO ()) -> TCMT IO ()
forall m a. Null m => [a] -> (List1 a -> m) -> m
List1.unlessNull [ImportedName]
dups ((NonEmpty ImportedName -> TCMT IO ()) -> TCMT IO ())
-> (NonEmpty ImportedName -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ())
-> (NonEmpty ImportedName -> Warning)
-> NonEmpty ImportedName
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ImportedName -> Warning
DuplicateUsing
[ImportedName] -> ScopeM [ImportedName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ImportedName]
ys
sanityCheck :: (ImportedName' Name m -> Bool)
-> ImportDirective -> m ImportDirective
sanityCheck ImportedName' Name m -> Bool
notMentioned = \case
dir :: ImportDirective
dir@(ImportDirective{ using :: forall n m. ImportDirective' n m -> Using' n m
using = Using{}, hiding :: forall n m. ImportDirective' n m -> HidingDirective' n m
hiding = [ImportedName]
ys }) -> do
let useless :: ImportedName -> Bool
useless = \case
ImportedName{} -> Bool
True
ImportedModule Name
y -> ImportedName' Name m -> Bool
notMentioned (Name -> ImportedName' Name m
forall n m. n -> ImportedName' n m
ImportedName Name
y)
[ImportedName] -> ([ImportedName] -> m ()) -> m ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull ((ImportedName -> Bool) -> [ImportedName] -> [ImportedName]
forall a. (a -> Bool) -> [a] -> [a]
filter ImportedName -> Bool
useless [ImportedName]
ys) (([ImportedName] -> m ()) -> m ())
-> ([ImportedName] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Warning -> m ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> m ())
-> ([ImportedName] -> Warning) -> [ImportedName] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ImportedName] -> Warning
UselessHiding
ImportDirective -> m ImportDirective
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
dir{ hiding = [] }
ImportDirective
dir -> ImportDirective -> m ImportDirective
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
dir
addExtraModules :: (C.Name -> Bool) -> C.ImportDirective -> C.ImportDirective
addExtraModules :: (Name -> Bool) -> ImportDirective -> ImportDirective
addExtraModules Name -> Bool
extra ImportDirective
dir =
ImportDirective
dir{ using = mapUsing (concatMap addExtra) $ using dir
, hiding = concatMap addExtra $ hiding dir
, impRenaming = concatMap extraRenaming $ impRenaming dir
}
where
addExtra :: ImportedName -> [ImportedName]
addExtra f :: ImportedName
f@(ImportedName Name
y) | Name -> Bool
extra Name
y = [ImportedName
f, Name -> ImportedName
forall n m. m -> ImportedName' n m
ImportedModule Name
y]
addExtra ImportedName
m = [ImportedName
m]
extraRenaming :: Renaming -> [Renaming]
extraRenaming = \case
r :: Renaming
r@(Renaming (ImportedName Name
y) (ImportedName Name
z) Maybe Fixity
_fixity Range
rng) | Name -> Bool
extra Name
y ->
[ Renaming
r , ImportedName -> ImportedName -> Maybe Fixity -> Range -> Renaming
forall n m.
ImportedName' n m
-> ImportedName' n m -> Maybe Fixity -> Range -> Renaming' n m
Renaming (Name -> ImportedName
forall n m. m -> ImportedName' n m
ImportedModule Name
y) (Name -> ImportedName
forall n m. m -> ImportedName' n m
ImportedModule Name
z) Maybe Fixity
forall a. Maybe a
Nothing Range
rng ]
Renaming
r -> [Renaming
r]
namesInScope :: NamesInScope
namesInScope = (Scope -> NamesInScope
forall a. InScope a => Scope -> ThingsInScope a
allNamesInScope Scope
scope :: ThingsInScope AbstractName)
modulesInScope :: ModulesInScope
modulesInScope = (Scope -> ModulesInScope
forall a. InScope a => Scope -> ThingsInScope a
allNamesInScope Scope
scope :: ThingsInScope AbstractModule)
concreteNamesInScope :: [Name]
concreteNamesInScope = (NamesInScope -> [Name]
forall k a. Map k a -> [k]
Map.keys NamesInScope
namesInScope [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ModulesInScope -> [Name]
forall k a. Map k a -> [k]
Map.keys ModulesInScope
modulesInScope :: [C.Name])
checkExist :: [ImportedName] -> ([ImportedName], [ImportedName' (C.Name, A.QName) (C.Name, A.ModuleName)])
checkExist :: [ImportedName]
-> ([ImportedName],
[ImportedName' (Name, QName) (Name, ModuleName)])
checkExist [ImportedName]
xs = [Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))]
-> ([ImportedName],
[ImportedName' (Name, QName) (Name, ModuleName)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))]
-> ([ImportedName],
[ImportedName' (Name, QName) (Name, ModuleName)]))
-> [Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))]
-> ([ImportedName],
[ImportedName' (Name, QName) (Name, ModuleName)])
forall a b. (a -> b) -> a -> b
$ [ImportedName]
-> (ImportedName
-> Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName)))
-> [Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [ImportedName]
xs ((ImportedName
-> Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName)))
-> [Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))])
-> (ImportedName
-> Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName)))
-> [Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))]
forall a b. (a -> b) -> a -> b
$ \ ImportedName
name -> case ImportedName
name of
ImportedName Name
x -> (Name, QName) -> ImportedName' (Name, QName) (Name, ModuleName)
forall n m. n -> ImportedName' n m
ImportedName ((Name, QName) -> ImportedName' (Name, QName) (Name, ModuleName))
-> (AbstractName -> (Name, QName))
-> AbstractName
-> ImportedName' (Name, QName) (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x,) (QName -> (Name, QName))
-> (AbstractName -> QName) -> AbstractName -> (Name, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> QName -> QName
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (QName -> QName)
-> (AbstractName -> QName) -> AbstractName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName (AbstractName -> ImportedName' (Name, QName) (Name, ModuleName))
-> Either ImportedName AbstractName
-> Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportedName
-> Name -> NamesInScope -> Either ImportedName AbstractName
forall a err b.
Ord a =>
err -> a -> Map a (List1 b) -> Either err b
resolve ImportedName
name Name
x NamesInScope
namesInScope
ImportedModule Name
x -> (Name, ModuleName)
-> ImportedName' (Name, QName) (Name, ModuleName)
forall n m. m -> ImportedName' n m
ImportedModule ((Name, ModuleName)
-> ImportedName' (Name, QName) (Name, ModuleName))
-> (AbstractModule -> (Name, ModuleName))
-> AbstractModule
-> ImportedName' (Name, QName) (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x,) (ModuleName -> (Name, ModuleName))
-> (AbstractModule -> ModuleName)
-> AbstractModule
-> (Name, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> ModuleName -> ModuleName
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) (ModuleName -> ModuleName)
-> (AbstractModule -> ModuleName) -> AbstractModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName (AbstractModule -> ImportedName' (Name, QName) (Name, ModuleName))
-> Either ImportedName AbstractModule
-> Either
ImportedName (ImportedName' (Name, QName) (Name, ModuleName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportedName
-> Name -> ModulesInScope -> Either ImportedName AbstractModule
forall a err b.
Ord a =>
err -> a -> Map a (List1 b) -> Either err b
resolve ImportedName
name Name
x ModulesInScope
modulesInScope
where
resolve :: Ord a => err -> a -> Map a (List1 b) -> Either err b
resolve :: forall a err b.
Ord a =>
err -> a -> Map a (List1 b) -> Either err b
resolve err
err a
x Map a (List1 b)
m = Either err b
-> (List1 b -> Either err b) -> Maybe (List1 b) -> Either err b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (err -> Either err b
forall a b. a -> Either a b
Left err
err) (b -> Either err b
forall a b. b -> Either a b
Right (b -> Either err b) -> (List1 b -> b) -> List1 b -> Either err b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 b -> b
forall a. NonEmpty a -> a
List1.head) (Maybe (List1 b) -> Either err b)
-> Maybe (List1 b) -> Either err b
forall a b. (a -> b) -> a -> b
$ a -> Map a (List1 b) -> Maybe (List1 b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a (List1 b)
m
mapImportDir
:: (Ord n1, Ord m1)
=> [ImportedName' (n1,n2) (m1,m2)]
-> [ImportedName' (n1,n2) (m1,m2)]
-> ImportDirective' n1 m1
-> ImportDirective' n2 m2
mapImportDir :: forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
[ImportedName' (n1, n2) (m1, m2)]
-> [ImportedName' (n1, n2) (m1, m2)]
-> ImportDirective' n1 m1
-> ImportDirective' n2 m2
mapImportDir [ImportedName' (n1, n2) (m1, m2)]
src0 [ImportedName' (n1, n2) (m1, m2)]
tgt0 (ImportDirective Range
r Using' n1 m1
u HidingDirective' n1 m1
h RenamingDirective' n1 m1
ren Maybe KwRange
open) =
Range
-> Using' n2 m2
-> HidingDirective' n2 m2
-> RenamingDirective' n2 m2
-> Maybe KwRange
-> ImportDirective' n2 m2
forall n m.
Range
-> Using' n m
-> HidingDirective' n m
-> RenamingDirective' n m
-> Maybe KwRange
-> ImportDirective' n m
ImportDirective Range
r
((HidingDirective' n1 m1 -> HidingDirective' n2 m2)
-> Using' n1 m1 -> Using' n2 m2
forall n1 m1 n2 m2.
([ImportedName' n1 m1] -> [ImportedName' n2 m2])
-> Using' n1 m1 -> Using' n2 m2
mapUsing ((ImportedName' n1 m1 -> ImportedName' n2 m2)
-> HidingDirective' n1 m1 -> HidingDirective' n2 m2
forall a b. (a -> b) -> [a] -> [b]
map (ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
lookupImportedName ImportedNameMap n1 n2 m1 m2
src)) Using' n1 m1
u)
((ImportedName' n1 m1 -> ImportedName' n2 m2)
-> HidingDirective' n1 m1 -> HidingDirective' n2 m2
forall a b. (a -> b) -> [a] -> [b]
map (ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
lookupImportedName ImportedNameMap n1 n2 m1 m2
src) HidingDirective' n1 m1
h)
((Renaming' n1 m1 -> Renaming' n2 m2)
-> RenamingDirective' n1 m1 -> RenamingDirective' n2 m2
forall a b. (a -> b) -> [a] -> [b]
map (ImportedNameMap n1 n2 m1 m2
-> ImportedNameMap n1 n2 m1 m2
-> Renaming' n1 m1
-> Renaming' n2 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedNameMap n1 n2 m1 m2
-> Renaming' n1 m1
-> Renaming' n2 m2
mapRenaming ImportedNameMap n1 n2 m1 m2
src ImportedNameMap n1 n2 m1 m2
tgt) RenamingDirective' n1 m1
ren)
Maybe KwRange
open
where
src :: ImportedNameMap n1 n2 m1 m2
src = [ImportedName' (n1, n2) (m1, m2)] -> ImportedNameMap n1 n2 m1 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
[ImportedName' (n1, n2) (m1, m2)] -> ImportedNameMap n1 n2 m1 m2
importedNameMapFromList [ImportedName' (n1, n2) (m1, m2)]
src0
tgt :: ImportedNameMap n1 n2 m1 m2
tgt = [ImportedName' (n1, n2) (m1, m2)] -> ImportedNameMap n1 n2 m1 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
[ImportedName' (n1, n2) (m1, m2)] -> ImportedNameMap n1 n2 m1 m2
importedNameMapFromList [ImportedName' (n1, n2) (m1, m2)]
tgt0
data ImportedNameMap n1 n2 m1 m2 = ImportedNameMap
{ forall n1 n2 m1 m2. ImportedNameMap n1 n2 m1 m2 -> Map n1 n2
inameMap :: Map n1 n2
, forall n1 n2 m1 m2. ImportedNameMap n1 n2 m1 m2 -> Map m1 m2
imoduleMap :: Map m1 m2
}
importedNameMapFromList
:: (Ord n1, Ord m1)
=> [ImportedName' (n1,n2) (m1,m2)]
-> ImportedNameMap n1 n2 m1 m2
importedNameMapFromList :: forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
[ImportedName' (n1, n2) (m1, m2)] -> ImportedNameMap n1 n2 m1 m2
importedNameMapFromList = (ImportedName' (n1, n2) (m1, m2)
-> ImportedNameMap n1 n2 m1 m2 -> ImportedNameMap n1 n2 m1 m2)
-> ImportedNameMap n1 n2 m1 m2
-> [ImportedName' (n1, n2) (m1, m2)]
-> ImportedNameMap n1 n2 m1 m2
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ImportedNameMap n1 n2 m1 m2
-> ImportedName' (n1, n2) (m1, m2) -> ImportedNameMap n1 n2 m1 m2)
-> ImportedName' (n1, n2) (m1, m2)
-> ImportedNameMap n1 n2 m1 m2
-> ImportedNameMap n1 n2 m1 m2
forall a b c. (a -> b -> c) -> b -> a -> c
flip ImportedNameMap n1 n2 m1 m2
-> ImportedName' (n1, n2) (m1, m2) -> ImportedNameMap n1 n2 m1 m2
forall {n1} {m1} {n2} {m2}.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' (n1, n2) (m1, m2) -> ImportedNameMap n1 n2 m1 m2
add) (ImportedNameMap n1 n2 m1 m2
-> [ImportedName' (n1, n2) (m1, m2)]
-> ImportedNameMap n1 n2 m1 m2)
-> ImportedNameMap n1 n2 m1 m2
-> [ImportedName' (n1, n2) (m1, m2)]
-> ImportedNameMap n1 n2 m1 m2
forall a b. (a -> b) -> a -> b
$ Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
forall n1 n2 m1 m2.
Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
ImportedNameMap Map n1 n2
forall k a. Map k a
Map.empty Map m1 m2
forall k a. Map k a
Map.empty
where
add :: ImportedNameMap n1 n2 m1 m2
-> ImportedName' (n1, n2) (m1, m2) -> ImportedNameMap n1 n2 m1 m2
add (ImportedNameMap Map n1 n2
nm Map m1 m2
mm) = \case
ImportedName (n1
x,n2
y) -> Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
forall n1 n2 m1 m2.
Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
ImportedNameMap (n1 -> n2 -> Map n1 n2 -> Map n1 n2
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n1
x n2
y Map n1 n2
nm) Map m1 m2
mm
ImportedModule (m1
x,m2
y) -> Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
forall n1 n2 m1 m2.
Map n1 n2 -> Map m1 m2 -> ImportedNameMap n1 n2 m1 m2
ImportedNameMap Map n1 n2
nm (m1 -> m2 -> Map m1 m2 -> Map m1 m2
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert m1
x m2
y Map m1 m2
mm)
lookupImportedName
:: (Ord n1, Ord m1)
=> ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1
-> ImportedName' n2 m2
lookupImportedName :: forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
lookupImportedName (ImportedNameMap Map n1 n2
nm Map m1 m2
mm) = \case
ImportedName n1
x -> n2 -> ImportedName' n2 m2
forall n m. n -> ImportedName' n m
ImportedName (n2 -> ImportedName' n2 m2) -> n2 -> ImportedName' n2 m2
forall a b. (a -> b) -> a -> b
$ n2 -> n1 -> Map n1 n2 -> n2
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault n2
forall a. HasCallStack => a
__IMPOSSIBLE__ n1
x Map n1 n2
nm
ImportedModule m1
x -> m2 -> ImportedName' n2 m2
forall n m. m -> ImportedName' n m
ImportedModule (m2 -> ImportedName' n2 m2) -> m2 -> ImportedName' n2 m2
forall a b. (a -> b) -> a -> b
$ m2 -> m1 -> Map m1 m2 -> m2
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault m2
forall a. HasCallStack => a
__IMPOSSIBLE__ m1
x Map m1 m2
mm
mapRenaming
:: (Ord n1, Ord m1)
=> ImportedNameMap n1 n2 m1 m2
-> ImportedNameMap n1 n2 m1 m2
-> Renaming' n1 m1
-> Renaming' n2 m2
mapRenaming :: forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedNameMap n1 n2 m1 m2
-> Renaming' n1 m1
-> Renaming' n2 m2
mapRenaming ImportedNameMap n1 n2 m1 m2
src ImportedNameMap n1 n2 m1 m2
tgt (Renaming ImportedName' n1 m1
from ImportedName' n1 m1
to Maybe Fixity
fixity Range
r) =
ImportedName' n2 m2
-> ImportedName' n2 m2 -> Maybe Fixity -> Range -> Renaming' n2 m2
forall n m.
ImportedName' n m
-> ImportedName' n m -> Maybe Fixity -> Range -> Renaming' n m
Renaming (ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
lookupImportedName ImportedNameMap n1 n2 m1 m2
src ImportedName' n1 m1
from) (ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
forall n1 m1 n2 m2.
(Ord n1, Ord m1) =>
ImportedNameMap n1 n2 m1 m2
-> ImportedName' n1 m1 -> ImportedName' n2 m2
lookupImportedName ImportedNameMap n1 n2 m1 m2
tgt ImportedName' n1 m1
to) Maybe Fixity
fixity Range
r
data OpenKind = LetOpenModule | TopOpenModule
noGeneralizedVarsIfLetOpen :: OpenKind -> Scope -> Scope
noGeneralizedVarsIfLetOpen :: OpenKind -> Scope -> Scope
noGeneralizedVarsIfLetOpen OpenKind
TopOpenModule = Scope -> Scope
forall a. a -> a
id
noGeneralizedVarsIfLetOpen OpenKind
LetOpenModule = Scope -> Scope
disallowGeneralizedVars
openModule_ :: OpenKind -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective
openModule_ :: OpenKind -> QName -> ImportDirective -> ScopeM ImportDirective
openModule_ OpenKind
kind QName
cm ImportDirective
dir = OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM ImportDirective
openModule OpenKind
kind Maybe ModuleName
forall a. Maybe a
Nothing QName
cm ImportDirective
dir
openModule :: OpenKind -> Maybe A.ModuleName -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective
openModule :: OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM ImportDirective
openModule OpenKind
kind Maybe ModuleName
mam QName
cm ImportDirective
dir = do
current <- ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
m <- caseMaybe mam (amodName <$> resolveModule cm) return
let acc | Maybe KwRange
Nothing <- ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dir = NameSpaceId
PrivateNS
| ModuleName
m ModuleName -> ModuleName -> Bool
`isLtChildModuleOf` ModuleName
current = NameSpaceId
PublicNS
| Bool
otherwise = NameSpaceId
ImportedNS
(adir, s') <- applyImportDirectiveM cm dir . inScopeBecause (Opened cm) .
noGeneralizedVarsIfLetOpen kind =<< getNamedScope m
let s = NameSpaceId -> Scope -> Scope
setScopeAccess NameSpaceId
acc Scope
s'
let ns = NameSpaceId -> Scope -> NameSpace
scopeNameSpace NameSpaceId
acc Scope
s
modifyCurrentScope (`mergeScope` s)
checkForClashes
verboseS "scope.locals" 10 $ do
locals <- mapMaybe (\ (Name
c,LocalVar
x) -> Name
c Name -> Maybe Name -> Maybe Name
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LocalVar -> Maybe Name
notShadowedLocal LocalVar
x) <$> getLocalVars
let newdefs = NamesInScope -> [Name]
forall k a. Map k a -> [k]
Map.keys (NamesInScope -> [Name]) -> NamesInScope -> [Name]
forall a b. (a -> b) -> a -> b
$ NameSpace -> NamesInScope
nsNames NameSpace
ns
shadowed = [Name]
locals [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`List.intersect` [Name]
newdefs
reportSLn "scope.locals" 10 $ "opening module shadows the following locals vars: " ++ prettyShow shadowed
modifyLocalVars $ AssocList.mapWithKey $ \ Name
c LocalVar
x ->
case Name -> NamesInScope -> Maybe (NonEmpty AbstractName)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
c (NamesInScope -> Maybe (NonEmpty AbstractName))
-> NamesInScope -> Maybe (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$ NameSpace -> NamesInScope
nsNames NameSpace
ns of
Maybe (NonEmpty AbstractName)
Nothing -> LocalVar
x
Just NonEmpty AbstractName
ys -> NonEmpty AbstractName -> LocalVar -> LocalVar
shadowLocal NonEmpty AbstractName
ys LocalVar
x
return adir
where
checkForClashes :: TCMT IO ()
checkForClashes = Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe KwRange -> Bool
forall a. Maybe a -> Bool
isJust (Maybe KwRange -> Bool) -> Maybe KwRange -> Bool
forall a b. (a -> b) -> a -> b
$ ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dir) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
exported <- Scope -> NameSpace
allThingsInScope (Scope -> NameSpace) -> (Scope -> Scope) -> Scope -> NameSpace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> Scope
restrictPrivate (Scope -> NameSpace) -> ScopeM Scope -> TCMT IO NameSpace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleName -> ScopeM Scope
getNamedScope (ModuleName -> ScopeM Scope) -> ScopeM ModuleName -> ScopeM Scope
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule)
let defClashes = ((Name, NonEmpty AbstractName) -> Bool)
-> [(Name, NonEmpty AbstractName)]
-> [(Name, NonEmpty AbstractName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (Name
_c, NonEmpty AbstractName
as) -> NonEmpty AbstractName -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty AbstractName
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) ([(Name, NonEmpty AbstractName)]
-> [(Name, NonEmpty AbstractName)])
-> [(Name, NonEmpty AbstractName)]
-> [(Name, NonEmpty AbstractName)]
forall a b. (a -> b) -> a -> b
$ NamesInScope -> [(Name, NonEmpty AbstractName)]
forall k a. Map k a -> [(k, a)]
Map.toList (NamesInScope -> [(Name, NonEmpty AbstractName)])
-> NamesInScope -> [(Name, NonEmpty AbstractName)]
forall a b. (a -> b) -> a -> b
$ NameSpace -> NamesInScope
nsNames NameSpace
exported
modClashes = ((Name, NonEmpty AbstractModule) -> Bool)
-> [(Name, NonEmpty AbstractModule)]
-> [(Name, NonEmpty AbstractModule)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (Name
_c, NonEmpty AbstractModule
as) -> NonEmpty AbstractModule -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty AbstractModule
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) ([(Name, NonEmpty AbstractModule)]
-> [(Name, NonEmpty AbstractModule)])
-> [(Name, NonEmpty AbstractModule)]
-> [(Name, NonEmpty AbstractModule)]
forall a b. (a -> b) -> a -> b
$ ModulesInScope -> [(Name, NonEmpty AbstractModule)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModulesInScope -> [(Name, NonEmpty AbstractModule)])
-> ModulesInScope -> [(Name, NonEmpty AbstractModule)]
forall a b. (a -> b) -> a -> b
$ NameSpace -> ModulesInScope
nsModules NameSpace
exported
defClash (a
_, t AbstractName
qs) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ (KindOfName -> Bool) -> t KindOfName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Induction -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Induction -> Bool)
-> (KindOfName -> Maybe Induction) -> KindOfName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindOfName -> Maybe Induction
isConName) t KindOfName
ks
, (KindOfName -> Bool) -> t KindOfName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
FldName) t KindOfName
ks
, (KindOfName -> Bool) -> t KindOfName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
PatternSynName) t KindOfName
ks
]
where ks :: t KindOfName
ks = (AbstractName -> KindOfName) -> t AbstractName -> t KindOfName
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> KindOfName
anameKind t AbstractName
qs
unlessNull (filter defClash defClashes) $
\ ((Name
x, AbstractName
q :| [AbstractName]
_) : [(Name, NonEmpty AbstractName)]
_) -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
q) Maybe NiceDeclaration
forall a. Maybe a
Nothing
unlessNull modClashes $ \ ((Name
_, NonEmpty AbstractModule
ms) : [(Name, NonEmpty AbstractModule)]
_) -> do
Maybe (AbstractModule, AbstractModule)
-> TCMT IO ()
-> ((AbstractModule, AbstractModule) -> TCMT IO ())
-> TCMT IO ()
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (NonEmpty AbstractModule -> Maybe (AbstractModule, AbstractModule)
forall a. List1 a -> Maybe (a, a)
List1.last2 NonEmpty AbstractModule
ms) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__ (((AbstractModule, AbstractModule) -> TCMT IO ()) -> TCMT IO ())
-> ((AbstractModule, AbstractModule) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ (AbstractModule
m0, AbstractModule
m1) -> do
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> TypeError
ClashingModule (AbstractModule -> ModuleName
amodName AbstractModule
m0) (AbstractModule -> ModuleName
amodName AbstractModule
m1)