{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Nix.Scope where

import qualified Data.HashMap.Lazy             as M
import qualified Text.Show
import           Lens.Family2
import           Nix.Utils

newtype Scope a = Scope { Scope a -> AttrSet a
getScope :: AttrSet a }
  deriving (a -> Scope b -> Scope a
(a -> b) -> Scope a -> Scope b
(forall a b. (a -> b) -> Scope a -> Scope b)
-> (forall a b. a -> Scope b -> Scope a) -> Functor Scope
forall a b. a -> Scope b -> Scope a
forall a b. (a -> b) -> Scope a -> Scope b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Scope b -> Scope a
$c<$ :: forall a b. a -> Scope b -> Scope a
fmap :: (a -> b) -> Scope a -> Scope b
$cfmap :: forall a b. (a -> b) -> Scope a -> Scope b
Functor, a -> Scope a -> Bool
Scope m -> m
Scope a -> [a]
Scope a -> Bool
Scope a -> Int
Scope a -> a
Scope a -> a
Scope a -> a
Scope a -> a
(a -> m) -> Scope a -> m
(a -> m) -> Scope a -> m
(a -> b -> b) -> b -> Scope a -> b
(a -> b -> b) -> b -> Scope a -> b
(b -> a -> b) -> b -> Scope a -> b
(b -> a -> b) -> b -> Scope a -> b
(a -> a -> a) -> Scope a -> a
(a -> a -> a) -> Scope a -> a
(forall m. Monoid m => Scope m -> m)
-> (forall m a. Monoid m => (a -> m) -> Scope a -> m)
-> (forall m a. Monoid m => (a -> m) -> Scope a -> m)
-> (forall a b. (a -> b -> b) -> b -> Scope a -> b)
-> (forall a b. (a -> b -> b) -> b -> Scope a -> b)
-> (forall b a. (b -> a -> b) -> b -> Scope a -> b)
-> (forall b a. (b -> a -> b) -> b -> Scope a -> b)
-> (forall a. (a -> a -> a) -> Scope a -> a)
-> (forall a. (a -> a -> a) -> Scope a -> a)
-> (forall a. Scope a -> [a])
-> (forall a. Scope a -> Bool)
-> (forall a. Scope a -> Int)
-> (forall a. Eq a => a -> Scope a -> Bool)
-> (forall a. Ord a => Scope a -> a)
-> (forall a. Ord a => Scope a -> a)
-> (forall a. Num a => Scope a -> a)
-> (forall a. Num a => Scope a -> a)
-> Foldable Scope
forall a. Eq a => a -> Scope a -> Bool
forall a. Num a => Scope a -> a
forall a. Ord a => Scope a -> a
forall m. Monoid m => Scope m -> m
forall a. Scope a -> Bool
forall a. Scope a -> Int
forall a. Scope a -> [a]
forall a. (a -> a -> a) -> Scope a -> a
forall m a. Monoid m => (a -> m) -> Scope a -> m
forall b a. (b -> a -> b) -> b -> Scope a -> b
forall a b. (a -> b -> b) -> b -> Scope a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Scope a -> a
$cproduct :: forall a. Num a => Scope a -> a
sum :: Scope a -> a
$csum :: forall a. Num a => Scope a -> a
minimum :: Scope a -> a
$cminimum :: forall a. Ord a => Scope a -> a
maximum :: Scope a -> a
$cmaximum :: forall a. Ord a => Scope a -> a
elem :: a -> Scope a -> Bool
$celem :: forall a. Eq a => a -> Scope a -> Bool
length :: Scope a -> Int
$clength :: forall a. Scope a -> Int
null :: Scope a -> Bool
$cnull :: forall a. Scope a -> Bool
toList :: Scope a -> [a]
$ctoList :: forall a. Scope a -> [a]
foldl1 :: (a -> a -> a) -> Scope a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Scope a -> a
foldr1 :: (a -> a -> a) -> Scope a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Scope a -> a
foldl' :: (b -> a -> b) -> b -> Scope a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Scope a -> b
foldl :: (b -> a -> b) -> b -> Scope a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Scope a -> b
foldr' :: (a -> b -> b) -> b -> Scope a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Scope a -> b
foldr :: (a -> b -> b) -> b -> Scope a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Scope a -> b
foldMap' :: (a -> m) -> Scope a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Scope a -> m
foldMap :: (a -> m) -> Scope a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Scope a -> m
fold :: Scope m -> m
$cfold :: forall m. Monoid m => Scope m -> m
Foldable, Functor Scope
Foldable Scope
Functor Scope
-> Foldable Scope
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Scope a -> f (Scope b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Scope (f a) -> f (Scope a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Scope a -> m (Scope b))
-> (forall (m :: * -> *) a. Monad m => Scope (m a) -> m (Scope a))
-> Traversable Scope
(a -> f b) -> Scope a -> f (Scope b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Scope (m a) -> m (Scope a)
forall (f :: * -> *) a. Applicative f => Scope (f a) -> f (Scope a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Scope a -> m (Scope b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Scope a -> f (Scope b)
sequence :: Scope (m a) -> m (Scope a)
$csequence :: forall (m :: * -> *) a. Monad m => Scope (m a) -> m (Scope a)
mapM :: (a -> m b) -> Scope a -> m (Scope b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Scope a -> m (Scope b)
sequenceA :: Scope (f a) -> f (Scope a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Scope (f a) -> f (Scope a)
traverse :: (a -> f b) -> Scope a -> f (Scope b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Scope a -> f (Scope b)
$cp2Traversable :: Foldable Scope
$cp1Traversable :: Functor Scope
Traversable, Scope a -> Scope a -> Bool
(Scope a -> Scope a -> Bool)
-> (Scope a -> Scope a -> Bool) -> Eq (Scope a)
forall a. Eq a => Scope a -> Scope a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scope a -> Scope a -> Bool
$c/= :: forall a. Eq a => Scope a -> Scope a -> Bool
== :: Scope a -> Scope a -> Bool
$c== :: forall a. Eq a => Scope a -> Scope a -> Bool
Eq)

instance Show (Scope a) where
  show :: Scope a -> String
show (Scope AttrSet a
m) = [Text] -> String
forall b a. (Show a, IsString b) => a -> b
show ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ AttrSet a -> [Text]
forall k v. HashMap k v -> [k]
M.keys AttrSet a
m

newScope :: AttrSet a -> Scope a
newScope :: AttrSet a -> Scope a
newScope = AttrSet a -> Scope a
forall a. AttrSet a -> Scope a
Scope

scopeLookup :: Text -> [Scope a] -> Maybe a
scopeLookup :: Text -> [Scope a] -> Maybe a
scopeLookup Text
key = (Scope a -> Maybe a -> Maybe a) -> Maybe a -> [Scope a] -> Maybe a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scope a -> Maybe a -> Maybe a
forall a. Scope a -> Maybe a -> Maybe a
go Maybe a
forall a. Maybe a
Nothing
 where
  go
    :: Scope a
    -> Maybe a
    -> Maybe a
  go :: Scope a -> Maybe a -> Maybe a
go (Scope AttrSet a
m) Maybe a
rest = Text -> AttrSet a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
key AttrSet a
m Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
rest

data Scopes m a =
  Scopes
    { Scopes m a -> [Scope a]
lexicalScopes :: [Scope a]
    , Scopes m a -> [m (Scope a)]
dynamicScopes :: [m (Scope a)]
    }

instance Show (Scopes m a) where
  show :: Scopes m a -> String
show (Scopes [Scope a]
m [m (Scope a)]
a) =
    String
"Scopes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Scope a] -> String
forall b a. (Show a, IsString b) => a -> b
show [Scope a]
m String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([m (Scope a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [m (Scope a)]
a) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with-scopes"

instance Semigroup (Scopes m a) where
  Scopes [Scope a]
ls [m (Scope a)]
lw <> :: Scopes m a -> Scopes m a -> Scopes m a
<> Scopes [Scope a]
rs [m (Scope a)]
rw = [Scope a] -> [m (Scope a)] -> Scopes m a
forall (m :: * -> *) a. [Scope a] -> [m (Scope a)] -> Scopes m a
Scopes ([Scope a]
ls [Scope a] -> [Scope a] -> [Scope a]
forall a. Semigroup a => a -> a -> a
<> [Scope a]
rs) ([m (Scope a)]
lw [m (Scope a)] -> [m (Scope a)] -> [m (Scope a)]
forall a. Semigroup a => a -> a -> a
<> [m (Scope a)]
rw)

instance Monoid (Scopes m a) where
  mempty :: Scopes m a
mempty  = Scopes m a
forall (m :: * -> *) a. Scopes m a
emptyScopes
  mappend :: Scopes m a -> Scopes m a -> Scopes m a
mappend = Scopes m a -> Scopes m a -> Scopes m a
forall a. Semigroup a => a -> a -> a
(<>)

emptyScopes :: forall m a . Scopes m a
emptyScopes :: Scopes m a
emptyScopes = [Scope a] -> [m (Scope a)] -> Scopes m a
forall (m :: * -> *) a. [Scope a] -> [m (Scope a)] -> Scopes m a
Scopes [Scope a]
forall a. Monoid a => a
mempty [m (Scope a)]
forall a. Monoid a => a
mempty

class Scoped a m | m -> a where
  currentScopes :: m (Scopes m a)
  clearScopes   :: m r -> m r
  pushScopes    :: Scopes m a -> m r -> m r
  lookupVar     :: Text -> m (Maybe a)

currentScopesReader
  :: forall m a e
  . ( MonadReader e m
    , Has e (Scopes m a)
    )
  => m (Scopes m a)
currentScopesReader :: m (Scopes m a)
currentScopesReader = (e -> Scopes m a) -> m (Scopes m a)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((e -> Scopes m a) -> m (Scopes m a))
-> (e -> Scopes m a) -> m (Scopes m a)
forall a b. (a -> b) -> a -> b
$ FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
-> e -> Scopes m a
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
forall a b. Has a b => Lens' a b
hasLens

clearScopesReader
  :: forall m a e r
  . ( MonadReader e m
    , Has e (Scopes m a)
    )
  => m r
  -> m r
clearScopesReader :: m r -> m r
clearScopesReader = (e -> e) -> m r -> m r
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((e -> e) -> m r -> m r) -> (e -> e) -> m r -> m r
forall a b. (a -> b) -> a -> b
$ Setter e e (Scopes m a) (Scopes m a) -> Scopes m a -> e -> e
forall s t a b. Setter s t a b -> b -> s -> t
set forall a b. Has a b => Lens' a b
Setter e e (Scopes m a) (Scopes m a)
hasLens (Scopes m a -> e -> e) -> Scopes m a -> e -> e
forall a b. (a -> b) -> a -> b
$ Scopes m a
forall (m :: * -> *) a. Scopes m a
emptyScopes @m @a

pushScope
  :: Scoped a m
  => AttrSet a
  -> m r
  -> m r
pushScope :: AttrSet a -> m r -> m r
pushScope AttrSet a
s = Scopes m a -> m r -> m r
forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
pushScopes (Scopes m a -> m r -> m r) -> Scopes m a -> m r -> m r
forall a b. (a -> b) -> a -> b
$ [Scope a] -> [m (Scope a)] -> Scopes m a
forall (m :: * -> *) a. [Scope a] -> [m (Scope a)] -> Scopes m a
Scopes [AttrSet a -> Scope a
forall a. AttrSet a -> Scope a
Scope AttrSet a
s] [m (Scope a)]
forall a. Monoid a => a
mempty

pushWeakScope
  :: ( Functor m
     , Scoped a m
     )
  => m (AttrSet a)
  -> m r
  -> m r
pushWeakScope :: m (AttrSet a) -> m r -> m r
pushWeakScope m (AttrSet a)
s = Scopes m a -> m r -> m r
forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
pushScopes (Scopes m a -> m r -> m r) -> Scopes m a -> m r -> m r
forall a b. (a -> b) -> a -> b
$ [Scope a] -> [m (Scope a)] -> Scopes m a
forall (m :: * -> *) a. [Scope a] -> [m (Scope a)] -> Scopes m a
Scopes [Scope a]
forall a. Monoid a => a
mempty [AttrSet a -> Scope a
forall a. AttrSet a -> Scope a
Scope (AttrSet a -> Scope a) -> m (AttrSet a) -> m (Scope a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (AttrSet a)
s]

pushScopesReader
  :: ( MonadReader e m
     , Has e (Scopes m a)
     )
  => Scopes m a
  -> m r
  -> m r
pushScopesReader :: Scopes m a -> m r -> m r
pushScopesReader Scopes m a
s = (e -> e) -> m r -> m r
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((e -> e) -> m r -> m r) -> (e -> e) -> m r -> m r
forall a b. (a -> b) -> a -> b
$ Setter e e (Scopes m a) (Scopes m a)
-> (Scopes m a -> Scopes m a) -> e -> e
forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over forall a b. Has a b => Lens' a b
Setter e e (Scopes m a) (Scopes m a)
hasLens (Scopes m a
s Scopes m a -> Scopes m a -> Scopes m a
forall a. Semigroup a => a -> a -> a
<>)

lookupVarReader
  :: forall m a e
  . ( MonadReader e m
    , Has e (Scopes m a)
    )
  => Text
  -> m (Maybe a)
lookupVarReader :: Text -> m (Maybe a)
lookupVarReader Text
k =
  do
    Maybe a
mres <- (e -> Maybe a) -> m (Maybe a)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((e -> Maybe a) -> m (Maybe a)) -> (e -> Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> [Scope a] -> Maybe a
forall a. Text -> [Scope a] -> Maybe a
scopeLookup Text
k ([Scope a] -> Maybe a) -> (e -> [Scope a]) -> e -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Scopes m a -> [Scope a]
forall (m :: * -> *) a. Scopes m a -> [Scope a]
lexicalScopes @m (Scopes m a -> [Scope a]) -> (e -> Scopes m a) -> e -> [Scope a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
-> e -> Scopes m a
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
forall a b. Has a b => Lens' a b
hasLens

    m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (do
        [m (Scope a)]
ws <- (e -> [m (Scope a)]) -> m [m (Scope a)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((e -> [m (Scope a)]) -> m [m (Scope a)])
-> (e -> [m (Scope a)]) -> m [m (Scope a)]
forall a b. (a -> b) -> a -> b
$ Scopes m a -> [m (Scope a)]
forall (m :: * -> *) a. Scopes m a -> [m (Scope a)]
dynamicScopes (Scopes m a -> [m (Scope a)])
-> (e -> Scopes m a) -> e -> [m (Scope a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
-> e -> Scopes m a
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike (Scopes m a) e e (Scopes m a) (Scopes m a)
forall a b. Has a b => Lens' a b
hasLens

        (m (Scope a) -> m (Maybe a) -> m (Maybe a))
-> m (Maybe a) -> [m (Scope a)] -> m (Maybe a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          (\ m (Scope a)
x m (Maybe a)
rest ->
            do
              Maybe a
mres' <- Text -> HashMap Text a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
k (HashMap Text a -> Maybe a)
-> (Scope a -> HashMap Text a) -> Scope a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope a -> HashMap Text a
forall a. Scope a -> AttrSet a
getScope (Scope a -> Maybe a) -> m (Scope a) -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Scope a)
x

              m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                m (Maybe a)
rest
                (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
                Maybe a
mres'
          )
          (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)
          [m (Scope a)]
ws
      )
      (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      Maybe a
mres

withScopes
  :: Scoped a m
  => Scopes m a
  -> m r
  -> m r
withScopes :: Scopes m a -> m r -> m r
withScopes Scopes m a
scope = m r -> m r
forall a (m :: * -> *) r. Scoped a m => m r -> m r
clearScopes (m r -> m r) -> (m r -> m r) -> m r -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scopes m a -> m r -> m r
forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
pushScopes Scopes m a
scope