diff --git a/hnix.cabal b/hnix.cabal index 2b97534..29ccab1 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -439,6 +439,7 @@ library Nix.Atoms Nix.Builtins Nix.Cache + Nix.Cited Nix.Context Nix.Convert Nix.Effects diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs new file mode 100644 index 0000000..9660776 --- /dev/null +++ b/src/Nix/Cited.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Nix.Cited where + +import Control.Comonad +import Control.Comonad.Env +import Lens.Family2.TH + +import Data.Typeable (Typeable) +import GHC.Generics + +import Nix.Expr.Types.Annotated +import Nix.Scope + +data Provenance t v m = Provenance + { _lexicalScope :: Scopes m t + , _originExpr :: NExprLocF (Maybe v) + -- ^ 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 + -- result of the call, but what was called and with what arguments. + } + deriving (Generic, Typeable) + +data NCited t v m a = NCited + { _provenance :: [Provenance t v m] + , _cited :: a + } + deriving (Generic, Typeable, Functor, Foldable, Traversable) + +instance Applicative (NCited t v m) where + pure = NCited [] + -- jww (2019-03-11): ?? + NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) + +instance Comonad (NCited t v m) where + duplicate p = NCited (_provenance p) p + extract = _cited + +instance ComonadEnv [Provenance t v m] (NCited t v m) where + ask = _provenance + +$(makeLenses ''Provenance) +$(makeLenses ''NCited) diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index a322c1e..43da2e4 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -70,6 +70,9 @@ import qualified Type.Reflection as Reflection type VarName = Text +hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) +hashAt = flip alterF + -- unfortunate orphans #if MIN_VERSION_hashable(1, 2, 5) instance Hashable1 NonEmpty diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs index c74e96d..132e5a6 100644 --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -30,7 +30,7 @@ import Nix.Var newtype NormalLoop m = NormalLoop (NValue m) deriving Show -instance Typeable m => Exception (NormalLoop m) +instance (MonadDataContext m, Typeable m) => Exception (NormalLoop m) normalFormBy :: forall e m. (Framed e m, MonadVar m, Typeable m) diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs index a151558..c66be24 100644 --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -5,8 +5,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module Nix.Utils (module Nix.Utils, module X) where import Control.Arrow ((&&&)) @@ -15,6 +18,8 @@ import Control.Monad.Fix import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import Data.Fix +import Data.Functor.Compose +import Data.Hashable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as M import Data.List (sortOn) @@ -24,6 +29,7 @@ import qualified Data.Text as Text import qualified Data.Vector as V import Lens.Family2 as X import Lens.Family2.Stock (_1, _2) +import Lens.Family2.TH #if ENABLE_TRACING import Debug.Trace as X @@ -35,6 +41,9 @@ traceM :: Monad m => String -> m () traceM = const (return ()) #endif +$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix) +$(makeLensesBy (\n -> Just ("_" ++ n)) ''Compose) + type DList a = Endo [a] type AttrSet = HashMap Text @@ -124,3 +133,9 @@ uriAwareSplit = go where let ((suffix, _):path) = go (Text.drop 3 e2) in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path | otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2) + +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 diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index 458be0b..04c5459 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -30,7 +30,6 @@ module Nix.Value where import Control.Comonad -import Control.Comonad.Env import Control.Monad -- import Control.Monad.Catch import Control.Monad.Free @@ -40,9 +39,7 @@ import qualified Data.Aeson as A import Data.Align import Data.Fix import Data.Functor.Classes -import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as M -import Data.Hashable import Data.These import Data.Typeable (Typeable) import GHC.Generics @@ -53,39 +50,10 @@ import Nix.Atoms import Nix.Expr.Types import Nix.Expr.Types.Annotated -- import Nix.Frames -import Nix.Scope import Nix.String import Nix.Thunk import Nix.Utils -data Provenance t v m = Provenance - { _lexicalScope :: Scopes m t - , _originExpr :: NExprLocF (Maybe v) - -- ^ 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 - -- result of the call, but what was called and with what arguments. - } - deriving (Generic, Typeable) - -data NCited t v m a = NCited - { _provenance :: [Provenance t v m] - , _cited :: a - } - deriving (Generic, Typeable, Functor, Foldable, Traversable) - -instance Applicative (NCited t v m) where - pure = NCited [] - -- jww (2019-03-11): ?? - NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) - -instance Comonad (NCited t v m) where - duplicate p = NCited (_provenance p) p - extract = _cited - -instance ComonadEnv [Provenance t v m] (NCited t v m) where - ask = _provenance - -- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is -- completed. 's' is related to the type of errors that might occur during -- construction or use of a value. @@ -419,8 +387,18 @@ describeValue = \case TPath -> "a path" TBuiltin -> "a builtin function" --- instance Show (NValueF (NValue m) m (NThunk m)) where --- show = describeValue . valueType +instance MonadDataContext m => Show (NValue m) where + show = describeValue + . valueType + . getCompose + . extract + . getCompose + . unFix + . _nValue + +instance Show (NValueF (NValue m) m + (f (Fix (Compose g (Compose (NValueF (NValue m) m) f))))) where + show = describeValue . valueType instance Show (NValueF (NValueNF m) m r) where show = describeValue . valueType @@ -467,20 +445,7 @@ data ValueFrame m -- instance Typeable m => Exception (ValueFrame m) $(makeTraversals ''NValueF) -$(makeLenses ''Provenance) -$(makeLenses ''NCited) $(makeLenses ''NValue) -$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix) -$(makeLensesBy (\n -> Just ("_" ++ n)) ''Compose) - -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, MonadDataContext m) => VarName -> LensLike' f (NValue m) (Maybe (NThunk m))