2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
|
|
{-# LANGUAGE DeriveFoldable #-}
|
|
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2018-04-11 20:53:30 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
|
|
|
|
module Nix.Scope where
|
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
import Control.Monad.Reader
|
|
|
|
import qualified Data.HashMap.Lazy as M
|
2018-04-11 20:53:30 +02:00
|
|
|
import Data.Semigroup
|
2018-04-07 21:02:50 +02:00
|
|
|
import Data.Text (Text)
|
2018-05-06 09:40:08 +02:00
|
|
|
import Lens.Family2
|
2018-04-07 21:02:50 +02:00
|
|
|
import Nix.Utils
|
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
newtype Scope a = Scope { getScope :: AttrSet a }
|
2018-04-07 21:02:50 +02:00
|
|
|
deriving (Functor, Foldable, Traversable)
|
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
instance Show (Scope a) where
|
2018-04-07 21:02:50 +02:00
|
|
|
show (Scope m) = show (M.keys m)
|
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
newScope :: AttrSet a -> Scope a
|
2018-04-07 21:02:50 +02:00
|
|
|
newScope = Scope
|
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
scopeLookup :: Text -> [Scope v] -> Maybe v
|
|
|
|
scopeLookup key = foldr go Nothing
|
|
|
|
where
|
|
|
|
go (Scope m) rest = M.lookup key m <|> rest
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
data Scopes m v = Scopes
|
|
|
|
{ lexicalScopes :: [Scope v]
|
|
|
|
, dynamicScopes :: [m (Scope v)]
|
|
|
|
}
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
instance Show (Scopes m v) where
|
|
|
|
show (Scopes m v) =
|
|
|
|
"Scopes: " ++ show m ++ ", and "
|
|
|
|
++ show (length v) ++ " with-scopes"
|
|
|
|
|
|
|
|
instance Semigroup (Scopes m v) where
|
|
|
|
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
|
|
|
|
|
|
|
|
instance Monoid (Scopes m v) where
|
|
|
|
mempty = emptyScopes
|
|
|
|
mappend = (<>)
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
type Scoped e v m = (MonadReader e m, Has e (Scopes m v))
|
|
|
|
|
|
|
|
emptyScopes :: Scopes m v
|
2018-04-11 20:53:30 +02:00
|
|
|
emptyScopes = Scopes [] []
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
currentScopes :: Scoped e v m => m (Scopes m v)
|
|
|
|
currentScopes = asks (view hasLens)
|
|
|
|
|
|
|
|
clearScopes :: forall v m e r. Scoped e v m => m r -> m r
|
2018-04-11 20:53:30 +02:00
|
|
|
clearScopes = local (set hasLens (emptyScopes @m @v))
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
pushScope :: forall v m e r. Scoped e v m => AttrSet v -> m r -> m r
|
2018-04-11 20:53:30 +02:00
|
|
|
pushScope s = pushScopes (Scopes [Scope s] [])
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-11 20:53:30 +02:00
|
|
|
pushWeakScope :: forall v m e r. Scoped e v m => m (AttrSet v) -> m r -> m r
|
|
|
|
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
|
2018-04-11 20:53:30 +02:00
|
|
|
pushScopes s = local (over hasLens (s <>))
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v)
|
2018-04-11 20:53:30 +02:00
|
|
|
lookupVar k = do
|
|
|
|
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
|
|
|
|
case mres of
|
|
|
|
Just sym -> return $ Just sym
|
|
|
|
Nothing -> do
|
|
|
|
ws <- asks (dynamicScopes . view hasLens)
|
2018-09-07 22:08:30 +02:00
|
|
|
foldr (\x rest -> do
|
|
|
|
mres' <- M.lookup k . getScope <$> x
|
|
|
|
case mres' of
|
|
|
|
Just sym -> return $ Just sym
|
|
|
|
Nothing -> rest)
|
2018-04-11 20:53:30 +02:00
|
|
|
(return Nothing) ws
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
withScopes :: forall v m e a. Scoped e v m => Scopes m v -> m a -> m a
|
|
|
|
withScopes scope = clearScopes @v . pushScopes scope
|