diff --git a/ChangeLog.md b/ChangeLog.md index 0a53072cd..6a2aae6cb 100644 --- a/ChangeLog.md +++ b/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 `"" -> ""`. diff --git a/main/Repl.hs b/main/Repl.hs index 03abff344..a35946d33 100644 --- a/main/Repl.hs +++ b/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 diff --git a/src/Nix/Atoms.hs b/src/Nix/Atoms.hs index 24f9091e5..6174727c2 100644 --- a/src/Nix/Atoms.hs +++ b/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 diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs index f993c5f53..90855df83 100644 --- a/src/Nix/Cited.hs +++ b/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) diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs index 24533a955..b44d914b3 100644 --- a/src/Nix/Effects.hs +++ b/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) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 5b18e8fd8..f3417347f 100644 --- a/src/Nix/Exec.hs +++ b/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 diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index cb295bcab..ab4ecdfa1 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -27,7 +27,7 @@ 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 @@ -35,8 +35,8 @@ 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 diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs index a52e1152e..8aed021a6 100644 --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -10,6 +10,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Fresh where import Control.Applicative @@ -50,14 +51,16 @@ instance MonadTrans (FreshIdT i) where instance MonadBase b m => MonadBase b (FreshIdT i m) where liftBase = FreshIdT . liftBase -instance ( MonadVar m - , Eq i - , Ord i - , Show i - , Enum i - , Typeable i - ) - => MonadThunkId (FreshIdT i m) where +instance + ( MonadVar m + , Eq i + , Ord i + , Show i + , Enum i + , Typeable i + ) + => MonadThunkId (FreshIdT i m) + where type ThunkId (FreshIdT i m) = i freshId = FreshIdT $ do v <- ask @@ -69,6 +72,7 @@ runFreshIdT i m = runReaderT (unFreshIdT m) i -- Orphan instance needed by Infer.hs and Lint.hs -- Since there's no forking, it's automatically atomic. +-- NOTE: MonadAtomicRef (ST s) can be upstreamed to `ref-tf` instance MonadAtomicRef (ST s) where atomicModifyRef r f = do v <- readRef r diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs index a6c48e999..e60aa0f34 100644 --- a/src/Nix/Fresh/Basic.hs +++ b/src/Nix/Fresh/Basic.hs @@ -7,6 +7,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Fresh.Basic where #if !MIN_VERSION_base(4,13,0) @@ -20,6 +21,7 @@ import Nix.Value type StdIdT = FreshIdT Int +-- NOTE: These would be removed by: https://github.com/haskell-nix/hnix/pull/804 instance (MonadFail m, MonadFile m) => MonadFile (StdIdT m) instance MonadIntrospect m => MonadIntrospect (StdIdT m) instance MonadStore m => MonadStore (StdIdT m) @@ -45,6 +47,6 @@ instance (MonadEffects t f m, MonadDataContext f m) pathToDefaultNix = lift . pathToDefaultNix @t @f @m derivationStrict v = do i <- FreshIdT ask - p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v) + p <- lift $ derivationStrict @t @f @m $ unliftNValue (runFreshIdT i) v return $ liftNValue (runFreshIdT i) p traceEffect = lift . traceEffect @t @f @m diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index 42fc9e5fa..2b1c28499 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Pretty where @@ -184,18 +184,6 @@ prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . foldFix exprFNixDoc -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) - prettyOriginExpr :: forall t f m ann . HasCitations1 m (NValue t f m) f diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index 024ba46f7..ed289aece 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -17,7 +17,7 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-orphans #-} + -- | This module provides a "reducing" expression evaluator, which reduces -- away pure, non self-referential aspects of an expression tree, yielding a diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs index 0ba390eb1..e059a5e7f 100644 --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -23,6 +24,8 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Void +import Nix.Utils.Fix1 ( Fix1T + , MonadFix1T ) import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S @@ -70,6 +73,9 @@ instance MonadFile IO where doesDirectoryExist = S.doesDirectoryExist getSymbolicLinkStatus = S.getSymbolicLinkStatus + +instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) + posAndMsg :: SourcePos -> Doc a -> ParseError s Void posAndMsg (SourcePos _ lineNo _) msg = FancyError (unPos lineNo) diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs index ac601d6c6..18fc06cac 100644 --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -1,21 +1,20 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Standard where import Control.Applicative @@ -53,42 +52,6 @@ import Nix.Value import Nix.Value.Monad import Nix.Var --- 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) - -type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) - -instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where - type Ref (Fix1T t m) = Ref m - newRef = lift . newRef - readRef = lift . readRef - writeRef r = lift . writeRef r - -instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where - atomicModifyRef r = lift . atomicModifyRef r - -instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t 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 - ---------------------------------------------------------------------------------- newtype StdCited m a = StdCited { _stdCited :: Cited (StdThunk m) (StdCited m) m a } diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs index 66d526fba..5e25b17b1 100644 --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where diff --git a/src/Nix/Utils/Fix1.hs b/src/Nix/Utils/Fix1.hs index 9ef62d3ce..2595fefb6 100644 --- a/src/Nix/Utils/Fix1.hs +++ b/src/Nix/Utils/Fix1.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,6 +19,10 @@ import Control.Monad.Fail import Control.Monad ( MonadPlus ) import Control.Monad.Fix ( MonadFix ) import Control.Monad.IO.Class ( MonadIO ) +import Control.Monad.Trans.Class ( MonadTrans + , lift ) +import Control.Monad.Ref ( MonadAtomicRef(..) + , MonadRef(..) ) import Control.Monad.Catch ( MonadCatch , MonadMask , MonadThrow ) @@ -57,6 +64,19 @@ deriving instance MonadMask (t (Fix1T t m) m) => MonadMask (Fix1T t m) deriving instance MonadReader e (t (Fix1T t m) m) => MonadReader e (Fix1T t m) deriving instance MonadState s (t (Fix1T t m) m) => MonadState s (Fix1T t m) + +type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) + +instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where + type Ref (Fix1T t m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + + +instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where + atomicModifyRef r = lift . atomicModifyRef r + {- newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a } diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index e5b1c1e22..591526431 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -28,7 +28,8 @@ import Control.Monad.Trans.Class ( MonadTrans, lift ) import qualified Data.Aeson as A import Data.Functor.Classes ( Show1 , liftShowsPrec - , showsUnaryWith ) + , showsUnaryWith + , Eq1(liftEq) ) import Data.HashMap.Lazy ( HashMap ) import Data.Text ( Text ) import Data.Typeable ( Typeable ) @@ -100,6 +101,14 @@ instance Show r => Show (NValueF p m r) where showsCon1 con a d = showParen (d > 10) $ showString (con <> " ") . showsPrec 11 a +instance Eq1 (NValueF p m) where + liftEq _ (NVConstantF x) (NVConstantF y) = x == y + liftEq _ (NVStrF x) (NVStrF y) = x == y + liftEq eq (NVListF x) (NVListF y) = liftEq eq x y + liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y + liftEq _ (NVPathF x ) (NVPathF y ) = x == y + liftEq _ _ _ = False + lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r lmapNValueF f = \case NVConstantF a -> NVConstantF a @@ -171,7 +180,7 @@ type MonadDataContext f (m :: * -> *) -- | At the time of constructor, the expected arguments to closures are values -- that may contain thunks. The type of such thunks are fixed at that time. newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) } - deriving (Generic, Typeable, Functor, Foldable) + deriving (Generic, Typeable, Functor, Foldable, Eq1) instance (Comonad f, Show a) => Show (NValue' t f m a) where show (NValue (extract -> v)) = show v diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs index 509c0317a..6a54c1feb 100644 --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -20,7 +20,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} module Nix.Value.Equal where @@ -31,8 +30,6 @@ import Control.Monad.Free import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Data.Align -import Data.Eq.Deriving -import Data.Functor.Classes import Data.Functor.Identity import qualified Data.HashMap.Lazy as M import Data.These @@ -114,8 +111,8 @@ valueFEq -> NValueF p m a -> Bool valueFEq attrsEq eq x y = runIdentity $ valueFEqM - (\x' y' -> Identity (attrsEq x' y')) - (\x' y' -> Identity (eq x' y')) + (\x' y' -> Identity $ attrsEq x' y') + (\x' y' -> Identity $ eq x' y') x y @@ -144,7 +141,7 @@ compareAttrSets -> AttrSet t -> Bool compareAttrSets f eq lm rm = runIdentity - $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm + $ compareAttrSetsM (Identity . f) (\x y -> Identity (eq x y)) lm rm valueEqM :: forall t f m @@ -175,13 +172,3 @@ thunkEqM lt rt = force lt $ \lv -> force rt $ \rv -> (NVList _ , NVList _ ) -> unsafePtrEq (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq _ -> valueEqM lv rv - -instance Eq1 (NValueF p m) where - liftEq _ (NVConstantF x) (NVConstantF y) = x == y - liftEq _ (NVStrF x) (NVStrF y) = x == y - liftEq eq (NVListF x) (NVListF y) = liftEq eq x y - liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y - liftEq _ (NVPathF x ) (NVPathF y ) = x == y - liftEq _ _ _ = False - -$(deriveEq1 ''NValue') diff --git a/src/Nix/Var.hs b/src/Nix/Var.hs index cae8cac92..f4e67e116 100644 --- a/src/Nix/Var.hs +++ b/src/Nix/Var.hs @@ -5,6 +5,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module Nix.Var where import Control.Monad.Ref @@ -15,6 +16,7 @@ import Data.STRef import Type.Reflection ((:~:)(Refl)) import Unsafe.Coerce +import Data.Bool ( bool ) type Var m = Ref m @@ -37,7 +39,15 @@ atomicModifyVar = atomicModifyRef --TODO: Upstream GEq instances instance GEq IORef where - a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing + a `geq` b = + bool + Nothing + (pure $ unsafeCoerce Refl) + (a == unsafeCoerce b ) instance GEq (STRef s) where - a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing + a `geq` b = + bool + Nothing + (pure $ unsafeCoerce Refl ) + (a == unsafeCoerce b) diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs index 8cb7c1b48..2e99ca36e 100644 --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} + module EvalTests (tests, genEvalCompareTests) where diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs index e132fe613..c479eeb99 100644 --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -158,7 +158,7 @@ assertEval _opts files = do Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time) - (fixup (map Text.unpack (Text.splitOn " " flags'))) + (fixup (fmap Text.unpack (Text.splitOn " " flags'))) of Opts.Failure err -> errorWithoutStackTrace @@ -171,7 +171,7 @@ assertEval _opts files = do _ -> assertFailure $ "Unknown test type " ++ show files where name = - "data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files) + "data/nix/tests/lang/" ++ the (fmap (takeFileName . dropExtensions) files) fixup ("--arg" : x : y : rest) = "--arg" : (x ++ "=" ++ y) : fixup rest fixup ("--argstr" : x : y : rest) = "--argstr" : (x ++ "=" ++ y) : fixup rest diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs index a3e55687b..8df480f6c 100644 --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} + module ParserTests (tests) where @@ -122,7 +122,7 @@ case_inherit_selector = do case_int_list = assertParseText "[1 2 3]" $ Fix $ NList [ mkInt i | i <- [1,2,3] ] -case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (map (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4])) +case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (fmap (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4])) case_mixed_list = do assertParseText "[{a = 3;}.a (if true then null else false) null false 4 [] c.d or null]" $ Fix $ NList diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs index 4e175ab9d..3426bfe04 100644 --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} + module PrettyParseTests where import Data.Algorithm.Diff @@ -147,8 +148,8 @@ normalize = foldFix $ \case NConstant (NFloat n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n))))) - NSet recur binds -> Fix (NSet recur (map normBinding binds)) - NLet binds r -> Fix (NLet (map normBinding binds) r) + NSet recur binds -> Fix (NSet recur (fmap normBinding binds)) + NLet binds r -> Fix (NLet (fmap normBinding binds) r) NAbs params r -> Fix (NAbs (normParams params) r) @@ -156,7 +157,7 @@ normalize = foldFix $ \case where normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos - normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos + normBinding (Inherit mr names pos) = Inherit mr (fmap normKey names) pos normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted) normKey (StaticKey name ) = StaticKey name @@ -219,7 +220,7 @@ prop_prettyparse p = do normalise = unlines . fmap (reverse . dropWhile isSpace . reverse) . lines ldiff :: String -> String -> [Diff [String]] - ldiff s1 s2 = getDiff (map (: []) (lines s1)) (map (: []) (lines s2)) + ldiff s1 s2 = getDiff (fmap (: []) (lines s1)) (fmap (: []) (lines s2)) tests :: TestLimit -> TestTree tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do