Merge #805: Children finding their parents

Author: Anton-Latukha

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