Children finding their parents

ChangeLog.md

@@ -23,6 +23,39 @@
  * `principledMakeNixStringWithSingletonContext` -> `makeNixStringWithSingletonContext`.
  * `principledModifyNixContents` -> `modifyNixContents`.
 
+ * [(link)](https://github.com/haskell-nix/hnix/pull/805/files):
+ * Data type: `MonadFix1T t m`: `Nix.Standard` -> `Nix.Utils.Fix1`
+ * Children found their parents:
+ * `Binary NAtom`: `Nix.Expr.Types` -> `Nix.Atoms`
+ * `Eq1 (NValue' t f m a)`: `Nix.Value.Equal` -> `Nix.Value` - instance was TH, become regular derivable
+ * `Eq1 (NValueF p m)`: `Nix.Value.Equal` -> `Nix.Value`
+ * `FromJSON NAtom`: `Nix.Expr.Types` -> `Nix.Atoms`
+ * `ToJSON NAtom`: `Nix.Expr.Types` -> `Nix.Atoms`
+ * `HasCitations m v (NValue t f m)`: `Nix.Pretty` -> `Nix.Cited`
+ * `HasCitations m v (NValue' t f m a)`: `Nix.Pretty` -> `Nix.Cited`
+ * `Hashable1 Binding`: `Nix.Expr.Types` -> `Void` - please, report if it is needed
+ * `Hashable1 NExprF`: `Nix.Expr.Types` -> `Void` - please, report if it is needed
+ * `Hashable1 NonEmpty`: `Nix.Expr.Types` -> `Void` - please, report if it is needed
+ * `MonadAtomicRef (Fix1T t m)`: `Nix.Standard` -> `Nix.Utils.Fix1`
+ * `MonadEnv (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadEnv (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadExec (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadExec (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadFile (Fix1T t m)`: `Nix.Standard` -> `Nix.Render`
+ * `MonadHttp (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadHttp (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadInstantiate (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadInstantiate (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadIntrospect (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadIntrospect (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadPaths (Fix1 t)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadPaths (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadPutStr (Fix1 t)`: `Nix.Standard` -> `Nix.Effects`
+ * `MonadPutStr (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+ * `MonadRef (Fix1T t m)`: `Nix.Standard` -> `Nix.Utils.Fix1`
+ * `MonadStore (Fix1T t m)`: `Nix.Standard` -> `Nix.Efffects`
+
+
 * Additional:
  * [(link)](https://github.com/haskell-nix/hnix/commit/7e6cd97bf3288cb584241611fdb25bf85d7e0ba7) `cabal.project`: freed from the `cryptohash-sha512` override, Hackage trustees made a revision.
  * [(link)](https://github.com/haskell-nix/hnix/pull/824/commits/4422eb10959115f21045f39e302314a77df4b775) To be more approachable for user understanding, the thunk representation in outputs changed from `"<CYCLE>" -> "<expr>"`.

main/Repl.hs

@@ -100,7 +100,7 @@ main' iniVal = initState iniVal >>= \s -> flip evalStateT s
 
  rcFile = do
  f <- liftIO $ Data.Text.IO.readFile ".hnixrc" `catch` handleMissing
- forM_ (map (words . Data.Text.unpack) $ Data.Text.lines f) $ \case
+ forM_ (fmap (words . Data.Text.unpack) $ Data.Text.lines f) $ \case
  ((prefix:command) : xs) | prefix == commandPrefix -> do
  let arguments = unwords xs
  optMatcher command options arguments

src/Nix/Atoms.hs

@@ -11,12 +11,14 @@ import Codec.Serialise
 #endif
 import Control.DeepSeq
 import Data.Data
-import Data.Fixed (mod')
+import Data.Fixed ( mod' )
 import Data.Hashable
 import Data.Text ( Text
  , pack
  )
 import GHC.Generics
+import Data.Binary ( Binary )
+import Data.Aeson.Types ( FromJSON, ToJSON )
 
 -- | Atoms are values that evaluate to themselves. This means that
 -- they appear in both the parsed AST (in the form of literals) and
@@ -40,6 +42,10 @@ data NAtom
 instance Serialise NAtom
 #endif
 
+instance Binary NAtom
+instance ToJSON NAtom
+instance FromJSON NAtom
+
 -- | Translate an atom into its nix representation.
 atomText :: NAtom -> Text
 atomText (NURI t) = t

src/Nix/Cited.hs

@@ -18,6 +18,8 @@ import Lens.Family2.TH
 
 import Nix.Expr.Types.Annotated
 import Nix.Scope
+import Nix.Value ( NValue, NValue'(NValue) )
+import Control.Monad.Free ( Free(Pure, Free) )
 
 data Provenance m v = Provenance
  { _lexicalScope :: Scopes m v
@@ -60,3 +62,15 @@ instance HasCitations m v (NCited m v a) where
 class HasCitations1 m v f where
  citations1 :: f a -> [Provenance m v]
  addProvenance1 :: Provenance m v -> f a -> f a
+
+instance HasCitations1 m v f
+ => HasCitations m v (NValue' t f m a) where
+ citations (NValue f) = citations1 f
+ addProvenance x (NValue f) = NValue (addProvenance1 x f)
+
+instance (HasCitations1 m v f, HasCitations m v t)
+ => HasCitations m v (NValue t f m) where
+ citations (Pure t) = citations t
+ citations (Free v) = citations v
+ addProvenance x (Pure t) = Pure (addProvenance x t)
+ addProvenance x (Free v) = Free (addProvenance x v)

src/Nix/Effects.hs

@@ -9,6 +9,12 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 
 module Nix.Effects where
 
@@ -26,6 +32,7 @@ import qualified Data.Text.Encoding as T
 import Network.HTTP.Client hiding ( path, Proxy )
 import Network.HTTP.Client.TLS
 import Network.HTTP.Types
+import Nix.Utils.Fix1
 import Nix.Expr
 import Nix.Frames hiding ( Proxy )
 import Nix.Parser
@@ -40,7 +47,7 @@ import qualified System.Info
 import System.Process
 
 import qualified System.Nix.Hash as Store
-import qualified System.Nix.Store.Remote as Store
+import qualified System.Nix.Store.Remote as Store.Remote
 import qualified System.Nix.StorePath as Store
 
 -- | A path into the nix store
@@ -70,6 +77,10 @@ class (MonadFile m,
 
  traceEffect :: String -> m ()
 
+instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where
+ addToStore a b c d = lift $ addToStore a b c d
+ addTextToStore' a b c d = lift $ addTextToStore' a b c d
+
 class Monad m => MonadIntrospect m where
  recursiveSize :: a -> m Word
  default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word
@@ -219,11 +230,11 @@ instance MonadHttp IO where
 
 
 class Monad m => MonadPutStr m where
-  --TODO: Should this be used *only* when the Nix to be evaluated invokes a
-  --`trace` operation?
-  putStr :: String -> m ()
-  default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
-  putStr = lift . putStr
+ --TODO: Should this be used *only* when the Nix to be evaluated invokes a
+ --`trace` operation?
+ putStr :: String -> m ()
+ default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
+ putStr = lift . putStr
 
 putStrLn :: MonadPutStr m => String -> m ()
 putStrLn = putStr . (<> "\n")
@@ -243,20 +254,20 @@ type StorePathSet = HS.HashSet StorePath
 
 class Monad m => MonadStore m where
 
-  -- | Copy the contents of a local path to the store. The resulting store
-  -- path is returned. Note: This does not support yet support the expected
-  -- `filter` function that allows excluding some files.
-  addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
-  default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
-  addToStore a b c d = lift $ addToStore a b c d
+ -- | Copy the contents of a local path to the store. The resulting store
+ -- path is returned. Note: This does not support yet support the expected
+ -- `filter` function that allows excluding some files.
+ addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+ default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+ addToStore a b c d = lift $ addToStore a b c d
 
-  -- | Like addToStore, but the contents written to the output path is a
-  -- regular file containing the given string.
-  addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
-  default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
-  addTextToStore' a b c d = lift $ addTextToStore' a b c d
+ -- | Like addToStore, but the contents written to the output path is a
+ -- regular file containing the given string.
+ addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
+ default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
+ addTextToStore' a b c d = lift $ addTextToStore' a b c d
 
-parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a)
+parseStoreResult :: Monad m => String -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a)
 parseStoreResult name res = case res of
  (Left msg, logs) -> return $ Left $ ErrorCall $ "Failed to execute '" <> name <> "': " <> msg <> "\n" <> show logs
  (Right result, _) -> return $ Right result
@@ -267,13 +278,13 @@ instance MonadStore IO where
  Left err -> return $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err
  Right pathName -> do
  -- TODO: redesign the filter parameter
- res <- Store.runStore $ Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
+ res <- Store.Remote.runStore $ Store.Remote.addToStore @'Store.SHA256 pathName path recursive (const False) repair
  parseStoreResult "addToStore" res >>= \case
  Left err -> return $ Left err
  Right storePath -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath
 
  addTextToStore' name text references repair = do
- res <- Store.runStore $ Store.addTextToStore name text references repair
+ res <- Store.Remote.runStore $ Store.Remote.addTextToStore name text references repair
  parseStoreResult "addTextToStore" res >>= \case
  Left err -> return $ Left err
  Right path -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path
@@ -286,3 +297,21 @@ addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p
 
 toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
 toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False
+
+-- All of the following type classes defer to the underlying 'm'.
+
+deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t)
+deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t)
+deriving instance MonadEnv (t (Fix1 t)) => MonadEnv (Fix1 t)
+deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t)
+deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t)
+deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t)
+deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t)
+
+deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m)
+deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m)
+deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m)
+deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m)
+deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m)
+deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m)
+deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m)

src/Nix/Exec.hs

@@ -18,6 +18,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
+
 module Nix.Exec where
 
 import Prelude hiding ( putStr
@@ -153,6 +154,8 @@ currentPos = asks (view hasLens)
 wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
 wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
 
+-- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class.
+-- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`.
 instance MonadNix e t f m => MonadEval (NValue t f m) m where
  freeVariable var =
  nverr @e @t @f

src/Nix/Expr/Types.hs

@@ -27,16 +27,16 @@
 module Nix.Expr.Types where
 
 #ifdef MIN_VERSION_serialise
-import qualified Codec.Serialise ( Serialise(decode, encode) ) -- For instance implementation function disamburgation
+import qualified Codec.Serialise as Serialise
 import Codec.Serialise ( Serialise )
 #endif
 import Control.Applicative
 import Control.DeepSeq
 import Control.Monad
 import Data.Aeson
 import Data.Aeson.TH
+import qualified Data.Binary as Binary
 import Data.Binary ( Binary )
-import qualified Data.Binary as Bin
 import Data.Data
 import Data.Eq.Deriving
 import Data.Fix
@@ -65,17 +65,14 @@ import Nix.Utils
 import Text.Megaparsec.Pos
 import Text.Read.Deriving
 import Text.Show.Deriving
-import Type.Reflection ( eqTypeRep )
 import qualified Type.Reflection as Reflection
+import Type.Reflection ( eqTypeRep )
 
 type VarName = Text
 
 hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
 hashAt = flip alterF
 
--- unfortunate orphans
-instance Hashable1 NonEmpty
-
 -- | The main Nix expression type. As it is polimophic, has a functor,
 -- which allows to traverse expressions and map functions over them.
 -- The actual 'NExpr' type is a fixed point of this functor, defined
@@ -163,8 +160,6 @@ data NExprF r
  deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor,
  Foldable, Traversable, Show, NFData, Hashable)
 
-instance Hashable1 NExprF
-
 instance NFData1 NExprF
 
 #ifdef MIN_VERSION_serialise
@@ -213,8 +208,6 @@ data Binding r
  deriving (Generic, Generic1, Typeable, Data, Ord, Eq, Functor,
  Foldable, Traversable, Show, NFData, Hashable)
 
-instance Hashable1 Binding
-
 instance NFData1 Binding
 
 #ifdef MIN_VERSION_serialise
@@ -354,16 +347,16 @@ data NKeyName r
 instance Serialise r => Serialise (NKeyName r)
 
 instance Serialise Pos where
- encode x = Codec.Serialise.encode (unPos x)
- decode = mkPos <$> Codec.Serialise.decode
+ encode = Serialise.encode . unPos
+ decode = mkPos <$> Serialise.decode
 
 instance Serialise SourcePos where
- encode (SourcePos f l c) = Codec.Serialise.encode f <> Codec.Serialise.encode l <> Codec.Serialise.encode c
- decode = SourcePos <$> Codec.Serialise.decode <*> Codec.Serialise.decode <*> Codec.Serialise.decode
+ encode (SourcePos f l c) = Serialise.encode f <> Serialise.encode l <> Serialise.encode c
+ decode = SourcePos <$> Serialise.decode <*> Serialise.decode <*> Serialise.decode
 #endif
 
 instance Hashable Pos where
- hashWithSalt salt x = hashWithSalt salt (unPos x)
+ hashWithSalt salt = hashWithSalt salt . unPos
 
 instance Hashable SourcePos where
  hashWithSalt salt (SourcePos f l c) =
@@ -425,7 +418,7 @@ instance Traversable NKeyName where
  DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str
  DynamicKey (Antiquoted e ) -> DynamicKey . Antiquoted <$> f e
  DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline
- StaticKey key -> pure (StaticKey key)
+ StaticKey key -> pure $ StaticKey key
 
 -- | A selector (for example in a @let@ or an attribute set) is made up
 -- of strung-together key names.
@@ -525,12 +518,11 @@ instance (Binary v, Binary a) => Binary (Antiquoted v a)
 instance Binary a => Binary (NString a)
 instance Binary a => Binary (Binding a)
 instance Binary Pos where
- put x = Bin.put (unPos x)
- get = mkPos <$> Bin.get
+ put = Binary.put . unPos
+ get = mkPos <$> Binary.get
 instance Binary SourcePos
 instance Binary a => Binary (NKeyName a)
 instance Binary a => Binary (Params a)
-instance Binary NAtom
 instance Binary NUnaryOp
 instance Binary NBinaryOp
 instance Binary NRecordType
@@ -540,11 +532,10 @@ instance (ToJSON v, ToJSON a) => ToJSON (Antiquoted v a)
 instance ToJSON a => ToJSON (NString a)
 instance ToJSON a => ToJSON (Binding a)
 instance ToJSON Pos where
- toJSON x = toJSON (unPos x)
+ toJSON = toJSON . unPos
 instance ToJSON SourcePos
 instance ToJSON a => ToJSON (NKeyName a)
 instance ToJSON a => ToJSON (Params a)
-instance ToJSON NAtom
 instance ToJSON NUnaryOp
 instance ToJSON NBinaryOp
 instance ToJSON NRecordType
@@ -558,7 +549,6 @@ instance FromJSON Pos where
 instance FromJSON SourcePos
 instance FromJSON a => FromJSON (NKeyName a)
 instance FromJSON a => FromJSON (Params a)
-instance FromJSON NAtom
 instance FromJSON NUnaryOp
 instance FromJSON NBinaryOp
 instance FromJSON NRecordType
@@ -576,8 +566,8 @@ $(makeTraversals ''NBinaryOp)
 --x $(makeLenses ''Fix)
 
 class NExprAnn ann g | g -> ann where
-  fromNExpr :: g r -> (NExprF r, ann)
-  toNExpr :: (NExprF r, ann) -> g r
+ fromNExpr :: g r -> (NExprF r, ann)
+ toNExpr :: (NExprF r, ann) -> g r
 
 ekey
  :: NExprAnn ann g
@@ -609,7 +599,7 @@ ekey _ _ f e = fromMaybe e <$> f Nothing
 stripPositionInfo :: NExpr -> NExpr
 stripPositionInfo = transport phi
  where
- phi (NSet recur binds) = NSet recur (fmap go binds)
+ phi (NSet recur binds) = NSet recur $ fmap go binds
  phi (NLet binds body) = NLet (fmap go binds) body
  phi x = x