Make use of lens-family to provide some utility lenses/traversals

hnix.cabal

@@ -104,6 +104,9 @@ library
     , http-client
     , http-client-tls
     , http-types
+    , lens-family
+    , lens-family-core
+    , lens-family-th
     , logict
     , megaparsec
     , monadlist

package.yaml

@@ -78,6 +78,9 @@ library:
     - http-client
     - http-client-tls
     - haskeline
+    - lens-family
+    - lens-family-core
+    - lens-family-th
     - logict
     - megaparsec
     - monadlist

src/Nix/Builtins.hs

@@ -533,7 +533,7 @@ seq_ a b = a >> b
 deepSeq :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
 deepSeq a b = do
     -- We evaluate 'a' only for its effects, so data cycles are ignored.
-    _ <- normalFormBy (forceEffects . coerce . baseThunk) 0 =<< a
+    _ <- normalFormBy (forceEffects . coerce . _baseThunk) 0 =<< a
 
     -- Then we evaluate the other argument to deepseq, thus this function
     -- should always produce a result (unlike applying 'deepseq' on infinitely

src/Nix/Exec.hs

@@ -97,7 +97,7 @@ nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
 nverr = evalError @(NValue m)
 
 currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
-currentPos = asks (view @e @SrcSpan hasLens)
+currentPos = asks (view hasLens)
 
 wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
 wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)

src/Nix/Expr/Types.hs

@@ -8,24 +8,29 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
 
 -- | The nix expression type and supporting types.
 module Nix.Expr.Types where
 
 import           Codec.Serialise (Serialise)
 import qualified Codec.Serialise as Ser
+import           Control.Applicative
 import           Control.DeepSeq
+import           Control.Monad
 import           Data.Aeson
 import           Data.Aeson.TH
 import           Data.Binary (Binary)
@@ -36,8 +41,10 @@ import           Data.Fix
 import           Data.Functor.Classes
 import           Data.Hashable
 import           Data.Hashable.Lifted
-import           Data.List.NonEmpty (NonEmpty)
+import           Data.List (inits, tails)
+import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromMaybe)
 import           Data.Monoid
 import           Data.Ord.Deriving
 import           Data.Text (Text, pack, unpack)
@@ -45,6 +52,9 @@ import           Data.Traversable
 import           GHC.Exts
 import           GHC.Generics
 import           Language.Haskell.TH.Syntax
+import           Lens.Family2
+import           Lens.Family2.Stock (_1)
+import           Lens.Family2.TH
 import           Nix.Atoms
 import           Nix.Parser.Library (SourcePos(..))
 import           Nix.Utils
@@ -389,6 +399,47 @@ instance FromJSON NBinaryOp
 instance FromJSON a => FromJSON (NExprF a)
 instance FromJSON NExpr
 
+$(makeTraversals ''NExprF)
+$(makeTraversals ''Binding)
+$(makeTraversals ''Params)
+$(makeTraversals ''Antiquoted)
+$(makeTraversals ''NString)
+$(makeTraversals ''NKeyName)
+$(makeTraversals ''NUnaryOp)
+$(makeTraversals ''NBinaryOp)
+
+-- $(makeLenses ''Fix)
+
+class NExprAnn ann g | g -> ann where
+    fromNExpr :: g r -> (NExprF r, ann)
+    toNExpr :: (NExprF r, ann) -> g r
+
+ekey :: NExprAnn ann g
+     => NonEmpty Text
+     -> Lens' (Fix g) (Maybe (Fix g))
+ekey keys f e@(Fix x) | (NSet xs, ann) <- fromNExpr x =
+    case go xs of
+        ((v, []):_) -> fromMaybe e <$> f (Just v)
+        ((v, r:rest):_) -> ekey (r :| rest) f v
+
+        _ -> f Nothing <&> \case
+            Nothing -> e
+            Just v  ->
+                let entry = NamedVar (NE.map (StaticKey ?? Nothing) keys) v
+                in Fix (toNExpr (NSet (entry : xs), ann))
+  where
+    go xs = do
+        let keys' = NE.toList keys
+        (ks, rest) <- zip (inits keys') (tails keys')
+        case ks of
+            [] -> empty
+            j:js -> do
+                NamedVar ns v <- xs
+                guard $ (j:js) == (NE.toList ns ^.. traverse._StaticKey._1)
+                return (v, rest)
+
+ekey _ f e = fromMaybe e <$> f Nothing
+
 stripPositionInfo :: NExpr -> NExpr
 stripPositionInfo = transport phi
   where

src/Nix/Normal.hs

@@ -45,8 +45,8 @@ normalFormBy k n v = do
                 traceM $ replicate n ' ' ++ "normalFormBy: List[" ++ show i ++ "]"
                 t `k` normalFormBy k (succ n)
         NVSet s p        ->
-            fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \key t -> do
-                traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show key ++ "}"
+            fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
+                traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show ky ++ "}"
                 t `k` normalFormBy k (succ n)
         NVClosure p f    -> return $ Fix $ NVClosureF p f
         NVPath fp        -> return $ Fix $ NVPathF fp

src/Nix/Pretty.hs

@@ -167,7 +167,7 @@ prettyOriginExpr = withoutParens . go
     go = exprFNixDoc . annotated . getCompose . fmap render
 
     render Nothing = simpleExpr $ text "_"
-    render (Just (NValue (reverse -> p:_) _)) = go (originExpr p)
+    render (Just (NValue (reverse -> p:_) _)) = go (_originExpr p)
     render (Just (NValue _ _)) = simpleExpr $ text "?"
         -- simpleExpr $ foldr ((<$>) . parens . indent 2 . withoutParens
         --                           . go . originExpr)
@@ -264,7 +264,7 @@ printNix = cata phi
 removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
 removeEffects = Fix . fmap dethunk
   where
-    dethunk (NThunk _ (Value v)) = removeEffects (baseValue v)
+    dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
     dethunk (NThunk _ _) = Fix $ NVStrF "<thunk>" mempty
 
 removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
@@ -282,18 +282,18 @@ prettyNValueProv = \case
     NValue ps v -> do
         v' <- prettyNValueF v
         pure $ v' </> indent 2 (parens (mconcat
-            (text "from: " : map (prettyOriginExpr . originExpr) ps)))
+            (text "from: " : map (prettyOriginExpr . _originExpr) ps)))
 
 prettyNThunk :: MonadVar m => NThunk m -> m Doc
 prettyNThunk = \case
     t@(NThunk ps _) -> do
         v' <- fmap prettyNValueNF (dethunk t)
         pure $ v' </> indent 2 (parens (mconcat
-            (text "thunk from: " : map (prettyOriginExpr . originExpr) ps)))
+            (text "thunk from: " : map (prettyOriginExpr . _originExpr) ps)))
 
 dethunk :: MonadVar m => NThunk m -> m (NValueNF m)
 dethunk = \case
-    NThunk _ (Value v) -> removeEffectsM (baseValue v)
+    NThunk _ (Value v) -> removeEffectsM (_baseValue v)
     NThunk _ (Thunk _ active ref) -> do
         nowActive <- atomicModifyVar active (True,)
         if nowActive
@@ -301,5 +301,5 @@ dethunk = \case
             else do
                 eres <- readVar ref
                 case eres of
-                    Computed v -> removeEffectsM (baseValue v)
+                    Computed v -> removeEffectsM (_baseValue v)
                     _ -> pure $ Fix $ NVStrF "<thunk>" mempty

src/Nix/Scope.hs

@@ -15,6 +15,7 @@ import           Control.Monad.Reader
 import qualified Data.HashMap.Lazy as M
 import           Data.Semigroup
 import           Data.Text (Text)
+import           Lens.Family2
 import           Nix.Utils
 
 newtype Scope a = Scope { getScope :: AttrSet a }

src/Nix/Utils.hs

@@ -15,13 +15,14 @@ import           Control.Monad.Fix
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Encoding as A
 import           Data.Fix
-import           Data.Functor.Identity
 import           Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as M
 import           Data.List (sortOn)
 import           Data.Monoid (Endo)
 import           Data.Text (Text)
 import qualified Data.Vector as V
+import           Lens.Family2 as X
+import           Lens.Family2.Stock (_1, _2)
 
 #if ENABLE_TRACING
 import           Debug.Trace as X
@@ -46,10 +47,6 @@ type AlgM f m a = f a -> m a
 -- | An "transform" here is a modification of a catamorphism.
 type Transform f a = (Fix f -> a) -> Fix f -> a
 
-infixr 0 &
-(&) :: a -> (a -> c) -> c
-(&) = flip ($)
-
 (<&>) :: Functor f => f a -> (a -> c) -> f c
 (<&>) = flip (<$>)
 
@@ -91,28 +88,17 @@ adiM :: (Traversable t, Monad m)
      => (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
 adiM f g = g ((f <=< traverse (adiM f g)) . unFix)
 
-type MonoLens a b = forall f. Functor f => (b -> f b) -> a -> f a
-
-view :: MonoLens a b -> a -> b
-view l = getConst . l Const
-
-set :: MonoLens a b -> b -> a -> a
-set l b = runIdentity . l (\_ -> Identity b)
-
-over :: MonoLens a b -> (b -> b) -> a -> a
-over l f = runIdentity . l (Identity . f)
-
 class Has a b where
-    hasLens :: MonoLens a b
+    hasLens :: Lens' a b
 
 instance Has a a where
     hasLens f = f
 
 instance Has (a, b) a where
-    hasLens f (x, y) = (, y) <$> f x
+    hasLens = _1
 
 instance Has (a, b) b where
-    hasLens f (x, y) = (x,) <$> f y
+    hasLens = _2
 
 toEncodingSorted :: A.Value -> A.Encoding
 toEncodingSorted = \case

src/Nix/Value.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -30,12 +31,17 @@ import           Control.Monad.Trans.Except
 import qualified Data.Aeson as A
 import           Data.Align
 import           Data.Fix
+import           Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as M
+import           Data.Hashable
 import           Data.Monoid (appEndo)
 import           Data.Text (Text)
 import           Data.These
 import           Data.Typeable (Typeable)
 import           GHC.Generics
+import           Lens.Family2
+import           Lens.Family2.Stock
+import           Lens.Family2.TH
 import           Nix.Atoms
 import           Nix.Expr.Types
 import           Nix.Expr.Types.Annotated
@@ -84,8 +90,8 @@ type NValueNF m = Fix (NValueF m)      -- normal form
 type ValueSet m = AttrSet (NThunk m)
 
 data Provenance m = Provenance
-    { lexicalScope :: Scopes m (NThunk m)
-    , originExpr   :: NExprLocF (Maybe (NValue m))
+    { _lexicalScope :: Scopes m (NThunk m)
+    , _originExpr   :: NExprLocF (Maybe (NValue m))
       -- ^ When calling the function x: x + 2 with argument x = 3, the
       --   'originExpr' for the resulting value will be 3 + 2, while the
       --   'contextExpr' will be @(x: x + 2) 3@, preserving not only the
@@ -93,13 +99,13 @@ data Provenance m = Provenance
     }
 
 data NThunk m = NThunk
-    { thunkProvenance :: [Provenance m]
-    , baseThunk       :: Thunk m (NValue m)
+    { _thunkProvenance :: [Provenance m]
+    , _baseThunk       :: Thunk m (NValue m)
     }
 
 data NValue m = NValue
-    { valueProvenance :: [Provenance m]
-    , baseValue       :: NValueF m (NThunk m)
+    { _valueProvenance :: [Provenance m]
+    , _baseValue       :: NValueF m (NThunk m)
     }
 
 addProvenance :: (NValue m -> Provenance m) -> NValue m -> NValue m
@@ -326,3 +332,20 @@ data ValueFrame m
     deriving (Show, Typeable)
 
 instance Typeable m => Exception (ValueFrame m)
+
+$(makeTraversals ''NValueF)
+$(makeLenses ''Provenance)
+$(makeLenses ''NThunk)
+$(makeLenses ''NValue)
+
+alterF :: (Eq k, Hashable k, Functor f)
+       => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
+alterF f k m = f (M.lookup k m) <&> \case
+    Nothing -> M.delete k m
+    Just v  -> M.insert k v m
+
+hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
+hashAt = flip alterF
+
+key :: Applicative f => VarName -> LensLike' f (NValue m) (Maybe (NThunk m))
+key k = baseValue._NVSetF._1.hashAt k