hnix 0.13.1 → 0.14.0
raw patch · 54 files changed
+1706/−1449 lines, 54 filesdep +cryptonitedep ~hashabledep ~hnix-store-coredep ~hnix-store-remotePVP ok
version bump matches the API change (PVP)
Dependencies added: cryptonite
Dependency ranges changed: hashable, hnix-store-core, hnix-store-remote
API changes (from Hackage documentation)
- Nix.Cited.Basic: [getCited] :: Cited t f m a -> NCited m (NValue t f m) a
- Nix.Convert: [getDeeper] :: Deeper a -> a
- Nix.Effects: pathExists :: MonadFile m => FilePath -> m Bool
- Nix.Expr.Types: instance (Data.Aeson.Types.FromJSON.FromJSON v, Data.Aeson.Types.FromJSON.FromJSON a) => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Antiquoted v a)
- Nix.Expr.Types: instance (Data.Aeson.Types.ToJSON.ToJSON v, Data.Aeson.Types.ToJSON.ToJSON a) => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Antiquoted v a)
- Nix.Expr.Types: instance (Data.Binary.Class.Binary v, Data.Binary.Class.Binary a) => Data.Binary.Class.Binary (Nix.Expr.Types.Antiquoted v a)
- Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Binding a)
- Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NExprF a)
- Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NKeyName a)
- Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NString a)
- Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON a => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Params a)
- Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Binding a)
- Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NExprF a)
- Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NKeyName a)
- Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NString a)
- Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON a => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Params a)
- Nix.Expr.Types: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Nix.Expr.Types.Binding a)
- Nix.Expr.Types: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Nix.Expr.Types.NExprF a)
- Nix.Expr.Types: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Nix.Expr.Types.NKeyName a)
- Nix.Expr.Types: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Nix.Expr.Types.NString a)
- Nix.Expr.Types: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Nix.Expr.Types.Params a)
- Nix.Expr.Types: instance Language.Haskell.TH.Syntax.Lift (Data.Fix.Fix Nix.Expr.Types.NExprF)
- Nix.Expr.Types.Annotated: instance Codec.Serialise.Class.Serialise r => Codec.Serialise.Class.Serialise (Data.Functor.Compose.Compose (Nix.Expr.Types.Annotated.Ann Nix.Expr.Types.Annotated.SrcSpan) Nix.Expr.Types.NExprF r)
- Nix.Fresh: instance (Nix.Var.MonadVar m, GHC.Classes.Eq i, GHC.Classes.Ord i, GHC.Show.Show i, GHC.Enum.Enum i, Data.Typeable.Internal.Typeable i) => Nix.Thunk.MonadThunkId (Nix.Fresh.FreshIdT i m)
- Nix.Normal: opaque :: Applicative f => NValue t f m
- Nix.Thunk: queryM :: MonadThunk t m a => m a -> t -> m a
- Nix.Thunk: queryMF :: MonadThunkF t m a => (a -> m r) -> m r -> t -> m r
- Nix.Type.Env: [types] :: Env -> Map Name [Scheme]
- Nix.Var: atomicModifyVar :: MonadAtomicRef m => Ref m a -> (a -> (a, b)) -> m b
- Nix.Var: eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
- Nix.Var: newVar :: MonadRef m => a -> m (Ref m a)
- Nix.Var: readVar :: MonadRef m => Ref m a -> m a
- Nix.Var: type MonadVar m = MonadAtomicRef m
- Nix.Var: type Var m = Ref m
- Nix.Var: writeVar :: MonadRef m => Ref m a -> a -> m ()
+ Nix.Cited.Basic: cite :: Functor m => [Provenance m (NValue t f m)] -> m a -> m (Cited t f m a)
+ Nix.Cited.Basic: pattern CitedP :: [Provenance m (NValue t f m)] -> a -> Cited t f m a
+ Nix.Convert: type CoerceDeeperToNValue t f m = Deeper (NValue t f m) -> NValue t f m
+ Nix.Convert: type CoerceDeeperToNValue' t f m = Deeper (NValue' t f m (NValue t f m)) -> NValue' t f m (NValue t f m)
+ Nix.Eval: addMetaInfo :: forall v m e a. (Framed e m, Scoped v m, Has e SrcSpan, Typeable m, Typeable v) => TransformF NExprLoc (m a)
+ Nix.Eval: evalContent :: MonadNixEval v m => AnnF ann NExprF (m v) -> m v
+ Nix.Expr.Types: instance (Data.Aeson.Types.FromJSON.FromJSON r, Data.Aeson.Types.FromJSON.FromJSON v) => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Antiquoted v r)
+ Nix.Expr.Types: instance (Data.Aeson.Types.ToJSON.ToJSON r, Data.Aeson.Types.ToJSON.ToJSON v) => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Antiquoted v r)
+ Nix.Expr.Types: instance (Data.Binary.Class.Binary v, Data.Binary.Class.Binary r) => Data.Binary.Class.Binary (Nix.Expr.Types.Antiquoted v r)
+ Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON r => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Binding r)
+ Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON r => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NExprF r)
+ Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON r => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NKeyName r)
+ Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON r => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.NString r)
+ Nix.Expr.Types: instance Data.Aeson.Types.FromJSON.FromJSON r => Data.Aeson.Types.FromJSON.FromJSON (Nix.Expr.Types.Params r)
+ Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON r => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Binding r)
+ Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON r => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NExprF r)
+ Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON r => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NKeyName r)
+ Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON r => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.NString r)
+ Nix.Expr.Types: instance Data.Aeson.Types.ToJSON.ToJSON r => Data.Aeson.Types.ToJSON.ToJSON (Nix.Expr.Types.Params r)
+ Nix.Expr.Types: instance Data.Binary.Class.Binary r => Data.Binary.Class.Binary (Nix.Expr.Types.Binding r)
+ Nix.Expr.Types: instance Data.Binary.Class.Binary r => Data.Binary.Class.Binary (Nix.Expr.Types.NExprF r)
+ Nix.Expr.Types: instance Data.Binary.Class.Binary r => Data.Binary.Class.Binary (Nix.Expr.Types.NKeyName r)
+ Nix.Expr.Types: instance Data.Binary.Class.Binary r => Data.Binary.Class.Binary (Nix.Expr.Types.NString r)
+ Nix.Expr.Types: instance Data.Binary.Class.Binary r => Data.Binary.Class.Binary (Nix.Expr.Types.Params r)
+ Nix.Expr.Types: instance Language.Haskell.TH.Syntax.Lift Nix.Expr.Types.NExpr
+ Nix.Expr.Types.Annotated: instance Codec.Serialise.Class.Serialise r => Codec.Serialise.Class.Serialise (Nix.Expr.Types.Annotated.NExprLocF r)
+ Nix.Expr.Types.Annotated: pattern AnnFP :: ann -> f a -> Compose (Ann ann) f a
+ Nix.Fresh: instance (Control.Monad.Ref.MonadAtomicRef m, GHC.Classes.Eq i, GHC.Classes.Ord i, GHC.Show.Show i, GHC.Enum.Enum i, Data.Typeable.Internal.Typeable i) => Nix.Thunk.MonadThunkId (Nix.Fresh.FreshIdT i m)
+ Nix.Normal: bindComputedThunkOrStub :: (Applicative f, MonadThunk t m (NValue t f m)) => (NValue t f m -> m a) -> t -> m a
+ Nix.Normal: opaqueVal :: Applicative f => NValue t f m
+ Nix.Normal: thunkStubVal :: Applicative f => NValue t f m
+ Nix.Thunk: query :: MonadThunk t m a => m a -> t -> m a
+ Nix.Thunk: queryF :: MonadThunkF t m a => (a -> m r) -> m r -> t -> m r
+ Nix.Thunk: thunkStubText :: Text
+ Nix.Thunk.Basic: deferred :: (v -> b) -> (m v -> b) -> Deferred m v -> b
+ Nix.Type.Assumption: instance GHC.Base.Monoid Nix.Type.Assumption.Assumption
+ Nix.Type.Assumption: instance GHC.Base.Semigroup Nix.Type.Assumption.Assumption
+ Nix.Type.Assumption: instance Relude.Container.One.One Nix.Type.Assumption.Assumption
+ Nix.Type.Env: instance Relude.Container.One.One Nix.Type.Env.Env
+ Nix.Utils: type TransformF f a = (f -> a) -> f -> a
+ Nix.Value: iterNValueByDiscardWith :: MonadDataContext f m => r -> (NValue' t f m r -> r) -> Free (NValue' t f m) t -> r
+ Nix.Value: nvStrWithoutContext :: Applicative f => Text -> NValue t f m
- Nix.Effects.Derivation: defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, HashMap Text Text) m) => NValue t f m -> m (NValue t f m)
+ Nix.Effects.Derivation: defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, AttrSet Text) m) => NValue t f m -> m (NValue t f m)
- Nix.Eval: addStackFrames :: forall v e m a. (Scoped v m, Framed e m, Typeable v, Typeable m) => Transform NExprLocF (m a)
+ Nix.Eval: addStackFrames :: forall v e m a. (Scoped v m, Framed e m, Typeable v, Typeable m) => TransformF NExprLoc (m a)
- Nix.Exec: addTracing :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
+ Nix.Exec: addTracing :: (MonadNix e t f m, Has e Options, Alternative n, MonadReader Int n, MonadFail n) => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
- Nix.Expr.Types: Antiquoted :: !r -> Antiquoted (v :: *) (r :: *)
+ Nix.Expr.Types: Antiquoted :: !r -> Antiquoted (v :: Type) (r :: Type)
- Nix.Expr.Types: EscapedNewline :: Antiquoted (v :: *) (r :: *)
+ Nix.Expr.Types: EscapedNewline :: Antiquoted (v :: Type) (r :: Type)
- Nix.Expr.Types: Plain :: !v -> Antiquoted (v :: *) (r :: *)
+ Nix.Expr.Types: Plain :: !v -> Antiquoted (v :: Type) (r :: Type)
- Nix.Expr.Types: data Antiquoted (v :: *) (r :: *)
+ Nix.Expr.Types: data Antiquoted (v :: Type) (r :: Type)
- Nix.Expr.Types.Annotated: pattern AnnE :: forall ann (g :: * -> *). ann -> g (Fix (Compose (Ann ann) g)) -> Fix (Compose (Ann ann) g)
+ Nix.Expr.Types.Annotated: pattern AnnE :: forall ann (f :: Type -> Type). ann -> f (Fix (AnnF ann f)) -> Fix (AnnF ann f)
- Nix.Fresh: FreshIdT :: ReaderT (Var m i) m a -> FreshIdT i m a
+ Nix.Fresh: FreshIdT :: ReaderT (Ref m i) m a -> FreshIdT i m a
- Nix.Fresh: [unFreshIdT] :: FreshIdT i m a -> ReaderT (Var m i) m a
+ Nix.Fresh: [unFreshIdT] :: FreshIdT i m a -> ReaderT (Ref m i) m a
- Nix.Fresh: runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a
+ Nix.Fresh: runFreshIdT :: Functor m => Ref m i -> FreshIdT i m a -> m a
- Nix.Lint: TBuiltin :: Text -> (Symbolic m -> m r) -> NTypeF (m :: * -> *) r
+ Nix.Lint: TBuiltin :: Text -> (Symbolic m -> m r) -> NTypeF (m :: Type -> Type) r
- Nix.Lint: TClosure :: Params () -> NTypeF (m :: * -> *) r
+ Nix.Lint: TClosure :: Params () -> NTypeF (m :: Type -> Type) r
- Nix.Lint: TConstant :: [TAtom] -> NTypeF (m :: * -> *) r
+ Nix.Lint: TConstant :: [TAtom] -> NTypeF (m :: Type -> Type) r
- Nix.Lint: TList :: r -> NTypeF (m :: * -> *) r
+ Nix.Lint: TList :: r -> NTypeF (m :: Type -> Type) r
- Nix.Lint: TPath :: NTypeF (m :: * -> *) r
+ Nix.Lint: TPath :: NTypeF (m :: Type -> Type) r
- Nix.Lint: TSet :: Maybe (HashMap Text r) -> NTypeF (m :: * -> *) r
+ Nix.Lint: TSet :: Maybe (HashMap Text r) -> NTypeF (m :: Type -> Type) r
- Nix.Lint: TStr :: NTypeF (m :: * -> *) r
+ Nix.Lint: TStr :: NTypeF (m :: Type -> Type) r
- Nix.Lint: data NTypeF (m :: * -> *) r
+ Nix.Lint: data NTypeF (m :: Type -> Type) r
- Nix.Lint: everyPossible :: MonadVar m => m (Symbolic m)
+ Nix.Lint: everyPossible :: MonadAtomicRef m => m (Symbolic m)
- Nix.Lint: mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m)
+ Nix.Lint: mkSymbolic :: MonadAtomicRef m => [NTypeF m (Symbolic m)] -> m (Symbolic m)
- Nix.Lint: packSymbolic :: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
+ Nix.Lint: packSymbolic :: MonadAtomicRef m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
- Nix.Lint: type MonadLint e m = (Scoped (Symbolic m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId m)
+ Nix.Lint: type MonadLint e m = (Scoped (Symbolic m) m, Framed e m, MonadAtomicRef m, MonadCatch m, MonadThunkId m)
- Nix.Lint: type SThunk (m :: * -> *) = NThunkF m (Symbolic m)
+ Nix.Lint: type SThunk (m :: Type -> Type) = NThunkF m (Symbolic m)
- Nix.Lint: type SValue (m :: * -> *) = Var m (NSymbolicF (NTypeF m (Symbolic m)))
+ Nix.Lint: type SValue (m :: Type -> Type) = Ref m (NSymbolicF (NTypeF m (Symbolic m)))
- Nix.Lint: unpackSymbolic :: (MonadVar m, MonadThunkId m, MonadCatch m) => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
+ Nix.Lint: unpackSymbolic :: (MonadAtomicRef m, MonadThunkId m, MonadCatch m) => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
- Nix.Render.Frame: framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame -> Maybe SourcePos
+ Nix.Render.Frame: framePos :: forall v (m :: Type -> Type). (Typeable m, Typeable v) => NixFrame -> Maybe SourcePos
- Nix.Standard: StdThunk :: StdCited m (NThunkF m (StdValue m)) -> StdThunk (m :: * -> *)
+ Nix.Standard: StdThunk :: StdCited m (NThunkF m (StdValue m)) -> StdThunk (m :: Type -> Type)
- Nix.Standard: [_stdThunk] :: StdThunk (m :: * -> *) -> StdCited m (NThunkF m (StdValue m))
+ Nix.Standard: [_stdThunk] :: StdThunk (m :: Type -> Type) -> StdCited m (NThunkF m (StdValue m))
- Nix.Standard: newtype StdThunk (m :: * -> *)
+ Nix.Standard: newtype StdThunk (m :: Type -> Type)
- Nix.String: NixLikeContext :: HashMap Text NixLikeContextValue -> NixLikeContext
+ Nix.String: NixLikeContext :: AttrSet NixLikeContextValue -> NixLikeContext
- Nix.String: [getNixLikeContext] :: NixLikeContext -> HashMap Text NixLikeContextValue
+ Nix.String: [getNixLikeContext] :: NixLikeContext -> AttrSet NixLikeContextValue
- Nix.Thunk: type family ThunkId m :: *;
+ Nix.Thunk: type family ThunkId m :: Type;
- Nix.Thunk.Basic: type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
+ Nix.Thunk.Basic: type MonadBasicThunk m = (MonadThunkId m, MonadAtomicRef m)
- Nix.Utils: adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
+ Nix.Utils: adi :: Functor f => Transform f a -> Alg f a -> Fix f -> a
- Nix.Utils: adiM :: (Traversable t, Monad m) => (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
+ Nix.Utils: adiM :: (Traversable t, Monad m) => Transform t (m a) -> AlgM t m a -> Fix t -> m a
- Nix.Utils: type Transform f a = (Fix f -> a) -> Fix f -> a
+ Nix.Utils: type Transform f a = TransformF (Fix f) a
- Nix.Utils.Fix1: Fix1 :: t (Fix1 t) a -> Fix1 (t :: (k -> *) -> k -> *) (a :: k)
+ Nix.Utils.Fix1: Fix1 :: t (Fix1 t) a -> Fix1 (t :: (k -> Type) -> k -> Type) (a :: k)
- Nix.Utils.Fix1: Fix1T :: t (Fix1T t m) m a -> Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k)
+ Nix.Utils.Fix1: Fix1T :: t (Fix1T t m) m a -> Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k)
- Nix.Utils.Fix1: [unFix1T] :: Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k) -> t (Fix1T t m) m a
+ Nix.Utils.Fix1: [unFix1T] :: Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k) -> t (Fix1T t m) m a
- Nix.Utils.Fix1: [unFix1] :: Fix1 (t :: (k -> *) -> k -> *) (a :: k) -> t (Fix1 t) a
+ Nix.Utils.Fix1: [unFix1] :: Fix1 (t :: (k -> Type) -> k -> Type) (a :: k) -> t (Fix1 t) a
- Nix.Utils.Fix1: newtype Fix1 (t :: (k -> *) -> k -> *) (a :: k)
+ Nix.Utils.Fix1: newtype Fix1 (t :: (k -> Type) -> k -> Type) (a :: k)
- Nix.Utils.Fix1: newtype Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k)
+ Nix.Utils.Fix1: newtype Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k)
- Nix.Value: iterNValue :: forall t f m r. MonadDataContext f m => (t -> (NValue t f m -> r) -> r) -> (NValue' t f m r -> r) -> NValue t f m -> r
+ Nix.Value: iterNValue :: forall t f m r. MonadDataContext f m => ((Free (NValue' t f m) t -> r) -> t -> r) -> (NValue' t f m r -> r) -> Free (NValue' t f m) t -> r
- Nix.Value: iterNValueM :: (MonadDataContext f m, Monad n) => (forall x. n x -> m x) -> (t -> (NValue t f m -> n r) -> n r) -> (NValue' t f m (n r) -> n r) -> NValue t f m -> n r
+ Nix.Value: iterNValueM :: (MonadDataContext f m, Monad n) => (forall x. n x -> m x) -> ((NValue t f m -> n r) -> t -> n r) -> (NValue' t f m (n r) -> n r) -> NValue t f m -> n r
- Nix.Value: nvSet :: Applicative f => HashMap Text SourcePos -> HashMap Text (NValue t f m) -> NValue t f m
+ Nix.Value: nvSet :: Applicative f => AttrSet SourcePos -> AttrSet (NValue t f m) -> NValue t f m
- Nix.Value: nvSet' :: Applicative f => HashMap Text SourcePos -> HashMap Text r -> NValue' t f m r
+ Nix.Value: nvSet' :: Applicative f => AttrSet SourcePos -> AttrSet r -> NValue' t f m r
- Nix.Value: type MonadDataContext f (m :: * -> *) = (Comonad f, Applicative f, Traversable f, Monad m)
+ Nix.Value: type MonadDataContext f (m :: Type -> Type) = (Comonad f, Applicative f, Traversable f, Monad m)
Files
- ChangeLog.md +62/−1
- hnix.cabal +99/−16
- main/Main.hs +94/−92
- main/Repl.hs +2/−6
- src/Nix.hs +29/−40
- src/Nix/Atoms.hs +0/−6
- src/Nix/Builtins.hs +195/−141
- src/Nix/Cache.hs +0/−10
- src/Nix/Cited.hs +3/−7
- src/Nix/Cited/Basic.hs +89/−57
- src/Nix/Context.hs +2/−6
- src/Nix/Convert.hs +36/−40
- src/Nix/Effects.hs +14/−28
- src/Nix/Effects/Basic.hs +0/−5
- src/Nix/Effects/Derivation.hs +54/−39
- src/Nix/Eval.hs +113/−61
- src/Nix/Exec.hs +78/−85
- src/Nix/Expr/Shorthands.hs +55/−35
- src/Nix/Expr/Strings.hs +0/−1
- src/Nix/Expr/Types.hs +263/−258
- src/Nix/Expr/Types/Annotated.hs +42/−43
- src/Nix/Frames.hs +2/−4
- src/Nix/Fresh.hs +6/−10
- src/Nix/Fresh/Basic.hs +1/−4
- src/Nix/Json.hs +0/−2
- src/Nix/Lint.hs +25/−31
- src/Nix/Normal.hs +27/−14
- src/Nix/Options.hs +2/−0
- src/Nix/Parser.hs +4/−9
- src/Nix/Pretty.hs +12/−14
- src/Nix/Reduce.hs +37/−43
- src/Nix/Render.hs +28/−17
- src/Nix/Render/Frame.hs +2/−11
- src/Nix/Scope.hs +1/−6
- src/Nix/Standard.hs +25/−29
- src/Nix/String.hs +8/−14
- src/Nix/String/Coerce.hs +5/−7
- src/Nix/TH.hs +18/−24
- src/Nix/Thunk.hs +14/−7
- src/Nix/Thunk/Basic.hs +63/−64
- src/Nix/Type/Assumption.hs +15/−1
- src/Nix/Type/Env.hs +24/−14
- src/Nix/Type/Infer.hs +68/−60
- src/Nix/Utils.hs +35/−14
- src/Nix/Utils/Fix1.hs +5/−8
- src/Nix/Value.hs +31/−19
- src/Nix/Value/Equal.hs +0/−3
- src/Nix/Value/Monad.hs +2/−1
- src/Nix/Var.hs +15/−31
- src/Nix/XML.hs +1/−3
- tests/EvalTests.hs +0/−1
- tests/Main.hs +0/−2
- tests/PrettyParseTests.hs +0/−3
- tests/TestCommon.hs +0/−2
ChangeLog.md view
@@ -1,6 +1,66 @@ # ChangeLog +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.13.1...0.14.0#files_bucket) WIP++* GHC 9.0 support.++* HNix switched to pre-0.9 style of log (aka "no log"). We temporarily stopped producing log, choosing effectiveness over writing about it.++* All changes seem trivial (from the inside). There is no changes in `Nix.Expr.Shorthands` module. Would there be difficulties in migration - please write to us - we would tackle & solve it togather.++A partial log:++* Breaking:++ * `Nix.Effects`:+ * rm `pathExits` in favour of `doesPathExist` (in `Nix.Render`: `class MonadFile`: `doesPathExist`)++ * `Nix.Var`: was found being superflous ([report](https://github.com/haskell-nix/hnix/issues/946)), so reduced. use `Control.Monad.Ref` instead.++ * `Nix.Normal`+ * rename `opaque(,->Val)`, indicate that it is a literal.+ + * `Nix.Thunk`:+ * `class MonadThunkId m => MonadThunk{,F} t m a`:+ * rename `query(M->){,F}`++* Additional:++ * `Nix.Utils`:+ * added type `TransformF`++ * `Nix.Eval`:+ * added fun:+ * `evalContent`+ * `addMetaInfo`+ + * `Nix.Types.Assumption`:+ * added instances:+ * `Assumption`: `{Semigroup,Monoid,One}`++ * `Nix.Type.Env`:+ * added instances:+ * `Env`: `{Semigroup,Monoid,One}`+ + * `Nix`:+ * changed argument order:+ * `nixEval`:+ + ```haskell+ -- was:+ => Maybe FilePath -> Transform g (m a) -> Alg g (m a) -> Fix g -> m a+ -- became:+ => Transform g (m a) -> Alg g (m a) -> Maybe FilePath -> Fix g -> m a+ ```+ + * `Nix.Normal`+ * add `thunkVal` literal & use it where appropriate `{deThunk, removeEffects}`+ + * `Nix.Thunk.Basic`:+ * export `deferred`++ ### [(diff)](https://github.com/haskell-nix/hnix/compare/0.13.0.1...0.13.1#files_bucket) 0.13.1 (2021-05-22) * [(link)](https://github.com/haskell-nix/hnix/pull/936/files) `Nix.Parser`: `annotateLocation`: Fix source location preservation. * [(link)](https://github.com/haskell-nix/hnix/pull/934/files) Require Cabal dependency `relude` `>= 1.0`: since imports & Cabal file got cleaned-up & that clean-up depends on `relude` reimports introduced in aforementioned version.@@ -135,8 +195,9 @@ $ Hashable1 NonEmpty:: Nix.Expr.Types -> Void -- please use upstreamed instance -- | Was upstreamed, released in `ref-tf >= 0.5`.- MonadAtomicRef (Fix1T t m) :: Nix.Standard -> Void+ MonadAtomicRef (ST s) :: Nix.Standard -> Void + MonadAtomicRef (Fix1T t m) :: Nix.Standard -> Nix.Utils.Fix1 MonadRef (Fix1T t m) :: Nix.Standard -> Nix.Utils.Fix1 MonadEnv (Fix1T t m) :: Nix.Standard -> Nix.Effects MonadExec (Fix1T t m) :: Nix.Standard -> Nix.Effects
hnix.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix-version: 0.13.1+version: 0.14.0 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix@@ -400,7 +400,9 @@ base hiding (Prelude) , relude (Relude as Prelude) , relude- ghc-options: -Wall -fprint-potential-instances+ ghc-options:+ -Wall+ -fprint-potential-instances build-depends: aeson >= 1.4.2 && < 1.6 , array >= 0.4 && < 0.6@@ -408,6 +410,7 @@ , base16-bytestring >= 0.1.1 && < 1.1 , binary >= 0.8.5 && < 0.9 , bytestring >= 0.10.8 && < 0.12+ , cryptonite , comonad >= 5.0.4 && < 5.1 , containers >= 0.5.11.0 && < 0.7 , data-fix >= 0.3.0 && < 0.4@@ -420,8 +423,8 @@ , gitrev >= 1.1.0 && < 1.4 , hashable >= 1.2.5 && < 1.4 , hashing >= 0.1.0 && < 0.2- , hnix-store-core >= 0.4.0 && < 0.5- , hnix-store-remote >= 0.4.0 && < 0.5+ , hnix-store-core >= 0.5.0 && < 0.6+ , hnix-store-remote >= 0.5.0 && < 0.6 , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.2 && < 0.13@@ -443,7 +446,7 @@ , regex-tdfa >= 1.2.3 && < 1.4 , relude >= 1.0.0 && < 1.1.0 , scientific >= 0.3.6 && < 0.4- , semialign >= 1 && < 1.3+ , semialign >= 1.2 && < 1.3 , serialise >= 0.2.1 && < 0.3 , some >= 1.0.1 && < 1.1 , split >= 0.2.3 && < 0.3@@ -465,11 +468,30 @@ , vector >= 0.12.0 && < 0.13 , xml >= 1.3.14 && < 1.4 default-extensions:- OverloadedStrings+ OverloadedStrings+ , DeriveGeneric+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveLift+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , TypeApplications+ , TypeSynonymInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , TupleSections+ , LambdaCase+ , BangPatterns if flag(optimize) default-extensions: ApplicativeDo- ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2+ ghc-options:+ -O2+ -fexpose-all-unfoldings+ -fspecialise-aggressively -- if !flag(profiling) -- build-depends: -- ghc-datasize@@ -484,7 +506,8 @@ Paths_hnix autogen-modules: Paths_hnix- ghc-options: -Wall+ ghc-options:+ -Wall build-depends: aeson , base@@ -511,11 +534,30 @@ , relude (Relude as Prelude) , relude default-extensions:- OverloadedStrings+ OverloadedStrings+ , DeriveGeneric+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveLift+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , TypeApplications+ , TypeSynonymInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , TupleSections+ , LambdaCase+ , BangPatterns if flag(optimize) default-extensions: ApplicativeDo- ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2+ ghc-options:+ -O2+ -fexpose-all-unfoldings+ -fspecialise-aggressively if impl(ghc < 8.10) -- GHC < 8.10 comes with haskeline < 0.8, which we don't support. -- To simplify CI, we just disable the component.@@ -539,7 +581,9 @@ , relude hs-source-dirs: tests- ghc-options: -Wall -threaded+ ghc-options:+ -Wall+ -threaded build-depends: Diff , Glob@@ -568,11 +612,30 @@ , time , unix default-extensions:- OverloadedStrings+ OverloadedStrings+ , DeriveGeneric+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveLift+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , TypeApplications+ , TypeSynonymInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , TupleSections+ , LambdaCase+ , BangPatterns if flag(optimize) default-extensions: ApplicativeDo- ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2+ ghc-options:+ -O2+ -fexpose-all-unfoldings+ -fspecialise-aggressively default-language: Haskell2010 benchmark hnix-benchmarks@@ -586,7 +649,8 @@ base hiding (Prelude) , relude (Relude as Prelude) , relude- ghc-options: -Wall+ ghc-options:+ -Wall build-depends: base , criterion@@ -600,9 +664,28 @@ , template-haskell , time default-extensions:- OverloadedStrings+ OverloadedStrings+ , DeriveGeneric+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveLift+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , TypeApplications+ , TypeSynonymInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , TupleSections+ , LambdaCase+ , BangPatterns if flag(optimize) default-extensions: ApplicativeDo- ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2+ ghc-options:+ -O2+ -fexpose-all-unfoldings+ -fspecialise-aggressively default-language: Haskell2010
main/Main.hs view
@@ -1,22 +1,20 @@ {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} -module Main where+module Main ( main ) where import Nix.Utils import Control.Comonad ( extract ) import qualified Control.DeepSeq as Deep import qualified Control.Exception as Exc import GHC.Err ( errorWithoutStackTrace )+import Control.Monad.Free+import Control.Monad.Ref ( MonadRef(readRef) ) import Control.Monad.Catch import System.IO ( hPutStrLn, getContents )-import Control.Monad.Free import qualified Data.HashMap.Lazy as M import qualified Data.Map as Map import Data.Maybe ( fromJust )@@ -31,9 +29,9 @@ import Nix.Options.Parser import Nix.Standard import Nix.Thunk.Basic-import qualified Nix.Type.Env as Env+import Nix.Type.Env ( Env(..) )+import Nix.Type.Type ( Scheme ) import qualified Nix.Type.Infer as HM-import Nix.Var import Nix.Value.Monad import Options.Applicative hiding ( ParserResult(..) ) import Prettyprinter hiding ( list )@@ -47,74 +45,76 @@ main = do time <- getCurrentTime- opts <- execParser (nixOptionsInfo time)+ opts <- execParser $ nixOptionsInfo time - runWithBasicEffectsIO opts $ execContentsFilesOrRepl opts+ main' opts +main' :: Options -> IO ()+main' (opts@Options{..}) = runWithBasicEffectsIO opts execContentsFilesOrRepl where- execContentsFilesOrRepl opts =- maybe- (maybe- (maybe- (list- (withNixContext mempty Repl.main) -- run REPL- (\case- ["-"] -> handleResult opts mempty . parseNixTextLoc =<< liftIO Text.getContents- _paths -> traverse_ (processFile opts) _paths- )- (filePaths opts)- )- (\ x ->- -- We can start use Text as in the base case, requires changing FilePath -> Text- traverse_ (processFile opts) . String.lines =<< liftIO- (case x of- "-" -> getContents -- get user input- _path -> readFile _path- )- )- (fromFile opts)- )- (handleResult opts mempty . parseNixTextLoc)- (expression opts)- )- (\ path ->- do+ execContentsFilesOrRepl =+ firstJust+ -- The `--read` option: load expression from a serialized file.+ [ readFrom <&> \path -> do let file = addExtension (dropExtension path) "nixc"- process opts (pure file) =<< liftIO (readCache path)- )- (readFrom opts)+ process (Just file) =<< liftIO (readCache path) - processFile opts path =- do- eres <- parseNixFileLoc path- handleResult opts (pure path) eres+ -- The `--expr` option: read expression from the argument string+ , expression <&> processText - handleResult opts mpath =+ -- The `--file` argument: read expressions from the files listed in the argument file+ , fromFile <&> \x ->+ -- We can start use Text as in the base case, requires changing FilePath -> Text+ traverse_ processFile . String.lines =<< liftIO+ (case x of+ "-" -> getContents+ fp -> readFile fp+ )+ ]+ `orElse`+ -- The base case: read expressions from the files listed on the command line+ case filePaths of+ -- With no files, fall back to running the REPL+ [] -> withNixContext mempty Repl.main+ ["-"] -> processText =<< liftIO Text.getContents+ _paths -> traverse_ processFile _paths++ firstJust :: [Maybe a] -> Maybe a+ firstJust = asum++ orElse :: Maybe a -> a -> a+ orElse = flip fromMaybe++ processText text = handleResult Nothing $ parseNixTextLoc text++ processFile path = handleResult (Just path) =<< parseNixFileLoc path++ handleResult mpath = either (\ err -> bool errorWithoutStackTrace (liftIO . hPutStrLn stderr)- (ignoreErrors opts)+ ignoreErrors $ "Parse failed: " <> show err ) (\ expr -> do- when (check opts) $+ when check $ do expr' <- liftIO (reduceExpr mpath expr) either (\ err -> errorWithoutStackTrace $ "Type error: " <> PS.ppShow err) (\ ty -> liftIO $ putStrLn $ "Type of expression: " <> PS.ppShow- (fromJust $ Map.lookup "it" $ Env.types ty)+ (fromJust $ Map.lookup "it" (coerce ty :: Map Text [Scheme])) )- (HM.inferTop Env.empty [("it", stripAnnotation expr')])+ (HM.inferTop mempty [("it", stripAnnotation expr')]) -- liftIO $ putStrLn $ runST $ -- runLintM opts . renderSymbolic =<< lint opts expr - catch (process opts mpath expr) $+ catch (process mpath expr) $ \case NixException frames -> errorWithoutStackTrace . show =<<@@ -123,7 +123,7 @@ @(StdThunk (StandardT (StdIdT IO))) frames - when (repl opts) $+ when repl $ withNixContext mempty $ bool Repl.main@@ -131,40 +131,42 @@ val <- Nix.nixEvalExprLoc mpath expr Repl.main' $ pure val )- (evaluate opts)+ evaluate ) - process opts mpath expr- | evaluate opts =+ process mpath expr+ | evaluate = if- | tracing opts -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr- | Just path <- reduce opts -> evaluateExpression mpath (reduction path) printer expr- | not ( null (arg opts)- && null (argstr opts)- ) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr- | otherwise -> processResult printer =<< Nix.nixEvalExprLoc mpath expr- | xml opts = fail "Rendering expression trees to XML is not yet implemented"- | json opts = fail "Rendering expression trees to JSON is not implemented"- | verbose opts >= DebugInfo = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr- | cache opts- , Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr- | parseOnly opts = void $ liftIO $ Exc.evaluate $ Deep.force expr- | otherwise =+ | tracing -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr+ | Just path <- reduce -> evaluateExpression mpath (reduction path) printer expr+ | not (null arg && null argstr) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr+ | otherwise -> processResult printer =<< Nix.nixEvalExprLoc mpath expr+ | xml = fail "Rendering expression trees to XML is not yet implemented"+ | json = fail "Rendering expression trees to JSON is not implemented"+ | verbose >= DebugInfo = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr+ | cache , Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr+ | parseOnly = void $ liftIO $ Exc.evaluate $ Deep.force expr+ | otherwise = liftIO $ renderIO stdout . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) . prettyNix- . stripAnnotation $- expr+ . stripAnnotation+ $ expr where printer- | finder opts = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO))))- | xml opts = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm- | json opts = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString- | strict opts = liftIO . print . prettyNValue <=< normalForm- | values opts = liftIO . print . prettyNValueProv <=< removeEffects- | otherwise = liftIO . print . prettyNValue <=< removeEffects+ | finder = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO))))+ | xml = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm+ -- 2021-05-27: NOTE: With naive fix of the #941+ -- This is overall a naive printer implementation, as options should interact/respect one another.+ -- A nice question: "Should respect one another to what degree?": Go full combinator way, for which+ -- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI),+ -- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys.+ | json = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString <=< normalForm+ | strict = liftIO . print . prettyNValue <=< normalForm+ | values = liftIO . print . prettyNValueProv <=< removeEffects+ | otherwise = liftIO . print . prettyNValue <=< removeEffects where findAttrs :: AttrSet (StdValue (StandardT (StdIdT IO)))@@ -176,6 +178,7 @@ xs <- traverse (\ (k, nv) ->+ (k, ) <$> free (\ (StdThunk (extract -> Thunk _ _ ref)) -> do@@ -183,19 +186,21 @@ path = prefix <> k (_, descend) = filterEntry path k - val <- readVar @(StandardT (StdIdT IO)) ref- case val of- Computed _ -> pure (k, Nothing)- _ ->- bool- (pure (k, Nothing))- ((k, ) <$> forceEntry path nv)- descend+ val <- readRef @(StandardT (StdIdT IO)) ref+ bool+ (pure Nothing)+ (forceEntry path nv)+ (descend &&+ deferred+ (const False)+ (const True)+ val+ ) )- (\ v -> pure (k, pure (Free v)))+ (pure . pure . Free) nv )- (sortWith fst (M.toList s))+ (sortWith fst $ M.toList s) traverse_ (\ (k, mv) -> do@@ -260,7 +265,7 @@ Nix.withNixContext mp (Nix.reducingEvalExpr- (Eval.eval . annotated . getCompose)+ Eval.evalContent mp x )@@ -275,9 +280,6 @@ do liftIO $ do- putStrLn $ "Wrote winnowed expression tree to " <> path- writeFile path $ show $ prettyNix (stripAnnotation expr')- either- throwM- pure- eres+ putStrLn $ "Wrote sifted expression tree to " <> path+ writeFile path $ show $ prettyNix $ stripAnnotation expr'+ either throwM pure eres
main/Repl.hs view
@@ -7,12 +7,8 @@ directory for more details. -} -{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} module Repl ( main@@ -212,7 +208,7 @@ -- import qualified Nix.Type.Env as Env -- import Nix.Type.Infer --- -- let tyctx' = inferTop Env.empty [("repl", stripAnnotation expr)]+ -- let tyctx' = inferTop mempty [("repl", stripAnnotation expr)] -- liftIO $ print tyctx' mVal <- lift $ lift $ try $ pushScope (replCtx st) (evalExprLoc expr)@@ -229,7 +225,7 @@ -- If the result value is a set, update our context with it case val of- NVSet xs _ -> put st { replCtx = Data.HashMap.Lazy.union xs (replCtx st) }+ NVSet xs _ -> put st { replCtx = xs <> replCtx st } _ -> pass pure $ pure val
src/Nix.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -57,12 +55,12 @@ -- transformations, allowing them to be easily composed. nixEval :: (MonadNix e t f m, Has e Options, Functor g)- => Maybe FilePath- -> Transform g (m a)+ => Transform g (m a) -> Alg g (m a)+ -> Maybe FilePath -> Fix g -> m a-nixEval mpath xform alg = withNixContext mpath . adi alg xform+nixEval transform alg mpath = withNixContext mpath . adi transform alg -- | Evaluate a nix expression in the default context nixEvalExpr@@ -70,7 +68,7 @@ => Maybe FilePath -> NExpr -> m (NValue t f m)-nixEvalExpr mpath = nixEval mpath id Eval.eval+nixEvalExpr = nixEval id Eval.eval -- | Evaluate a nix expression in the default context nixEvalExprLoc@@ -79,11 +77,10 @@ => Maybe FilePath -> NExprLoc -> m (NValue t f m)-nixEvalExprLoc mpath =+nixEvalExprLoc = nixEval- mpath- (Eval.addStackFrames . Eval.addSourcePositions)- (Eval.eval . annotated . getCompose)+ Eval.addMetaInfo+ Eval.evalContent -- | Evaluate a nix expression with tracing in the default context. Note that -- this function doesn't do any tracing itself, but 'evalExprLoc' will be@@ -110,8 +107,8 @@ args <- (traverse . traverse) eval'- $ (second parseArg <$> arg opts) <>- (second mkStr <$> argstr opts)+ $ (second parseArg <$> arg opts)+ <> (second mkStr <$> argstr opts) f <- evaluator mpath expr f' <- demand f val <-@@ -128,7 +125,7 @@ eval' = normalForm <=< nixEvalExpr mpath - argmap args = nvSet mempty (M.fromList args)+ argmap args = nvSet mempty $ M.fromList args processResult :: forall e t f m a@@ -137,34 +134,26 @@ -> NValue t f m -> m a processResult h val = do- opts :: Options <- asks (view hasLens)+ opts :: Options <- asks $ view hasLens maybe (h val)- (\ (Text.splitOn "." -> keys) -> go keys val)+ (\ (Text.splitOn "." -> keys) -> processKeys keys val) (attr opts) where- go :: [Text.Text] -> NValue t f m -> m a- go [] v = h v- go ((Text.decimal -> Right (n,"")) : ks) v =- (\case- NVList xs ->- list- h- go- ks- (xs !! n)- _ -> errorWithoutStackTrace $ "Expected a list for selector '" <> show n <> "', but got: " <> show v- ) =<< demand v- go (k : ks) v =- (\case- NVSet xs _ ->- maybe- (errorWithoutStackTrace $ toString $ "Set does not contain key '" <> k <> "'")- (list- h- go- ks- )- (M.lookup k xs)- _ -> errorWithoutStackTrace $ toString $ "Expected a set for selector '" <> k <> "', but got: " <> show v- ) =<< demand v+ processKeys :: [Text] -> NValue t f m -> m a+ processKeys kys v =+ list+ (h v)+ (\ (k : ks) ->+ do+ v' <- demand v+ case (k, v') of+ (Text.decimal -> Right (n,""), NVList xs) -> processKeys ks $ xs !! n+ (_, NVSet xs _) ->+ maybe+ (errorWithoutStackTrace $ toString $ "Set does not contain key '" <> k <> "'")+ (processKeys ks)+ (M.lookup k xs)+ (_, _) -> errorWithoutStackTrace $ toString $ "Expected a set or list for selector '" <> k <> "', but got: " <> show v+ )+ kys
src/Nix/Atoms.hs view
@@ -1,13 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} module Nix.Atoms where -#ifdef MIN_VERSION_serialise import Codec.Serialise ( Serialise )-#endif import Data.Data ( Data) import Data.Fixed ( mod' )@@ -50,9 +46,7 @@ , Hashable ) -#ifdef MIN_VERSION_serialise instance Serialise NAtom-#endif instance Binary NAtom instance ToJSON NAtom
src/Nix/Builtins.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PackageImports #-}@@ -13,10 +10,9 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -29,17 +25,16 @@ import Prelude hiding ( traceM )-import Relude.Unsafe as Unsafe import Nix.Utils import Control.Comonad ( Comonad ) import Control.Monad ( foldM ) import Control.Monad.Catch ( MonadCatch(catch) ) import Control.Monad.ListM ( sortByM )-import Crypto.Hash-import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Hash.SHA1 as SHA1-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.Hash.SHA512 as SHA512+import "hashing" Crypto.Hash+import qualified "hashing" Crypto.Hash.MD5 as MD5+import qualified "hashing" Crypto.Hash.SHA1 as SHA1+import qualified "hashing" Crypto.Hash.SHA256 as SHA256+import qualified "hashing" Crypto.Hash.SHA512 as SHA512 import qualified Data.Aeson as A import Data.Align ( alignWith ) import Data.Array@@ -87,7 +82,11 @@ , isDirectory , isSymbolicLink )-import Text.Regex.TDFA+import Text.Regex.TDFA ( Regex+ , makeRegex+ , matchOnceText+ , matchAllText+ ) -- This is a big module. There is recursive reuse:@@ -127,7 +126,7 @@ ) => ToBuiltin t f m (a -> b) where toBuiltin name f =- pure $ nvBuiltin name (toBuiltin name . f <=< fromValue . Deeper)+ pure $ nvBuiltin name $ toBuiltin name . f <=< fromValue . Deeper -- *** @WValue@ closure wrapper to have @Ord@ @@ -160,10 +159,10 @@ -- ** Helpers -nVNull+nvNull :: MonadNix e t f m => NValue t f m-nVNull = nvConstant NNull+nvNull = nvConstant NNull mkNVBool :: MonadNix e t f m@@ -225,8 +224,8 @@ data VersionComponent = VersionComponentPre -- ^ The string "pre"- | VersionComponentString Text -- ^ A string other than "pre"- | VersionComponentNumber Integer -- ^ A number+ | VersionComponentString !Text -- ^ A string other than "pre"+ | VersionComponentNumber !Integer -- ^ A number deriving (Show, Read, Eq, Ord) versionComponentToString :: VersionComponent -> Text@@ -319,19 +318,12 @@ caps = nvList (f <$> captures) f (a, (s, _)) = bool- nVNull+ nvNull (thunkStr a) (s >= 0) thunkStr :: Applicative f => ByteString -> NValue t f m-thunkStr s = nvStr $ makeNixStringWithoutContext $ decodeUtf8 s--elemAt :: [a] -> Int -> Maybe a-elemAt ls i =- list- Nothing- (pure . Unsafe.head)- (drop i ls)+thunkStr s = nvStrWithoutContext $ decodeUtf8 s hasKind :: forall a e t f m@@ -437,7 +429,7 @@ <> rest ) where- mkNvStr = nvStr . makeNixStringWithoutContext . toText+ mkNvStr = nvStrWithoutContext . toText toStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) toStringNix = toValue <=< coerceToString callFunc DontCopyToStore CoerceAny@@ -485,7 +477,7 @@ case (x, y) of (NVStr ns, NVSet _ apos) -> maybe- (pure nVNull)+ (pure nvNull) toValue (M.lookup (stringIgnoreContext ns) apos) _xy -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPosNix: " <> show _xy@@ -587,19 +579,19 @@ where go b a = (`callFunc` a) =<< callFunc f b -headNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m)+headNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) headNix =- list+ maybe (throwError $ ErrorCall "builtins.head: empty list")- (pure . Unsafe.head)- <=< fromValue+ (pure)+ . viaNonEmpty head <=< fromValue @[NValue t f m] -tailNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m)+tailNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) tailNix =- list+ maybe (throwError $ ErrorCall "builtins.tail: empty list")- (pure . nvList . Unsafe.tail)- <=< fromValue+ (pure . nvList)+ . viaNonEmpty tail <=< fromValue @[NValue t f m] splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) splitVersionNix v =@@ -607,7 +599,7 @@ version <- fromStringNoContext =<< fromValue v pure $ nvList $- nvStr . makeNixStringWithoutContext . versionComponentToString <$>+ nvStrWithoutContext . versionComponentToString <$> splitVersion version compareVersionsNix@@ -652,7 +644,7 @@ ] where- mkNVStr = nvStr . makeNixStringWithoutContext+ mkNVStr = nvStrWithoutContext matchNix :: forall e t f m@@ -678,24 +670,19 @@ (toValue $ makeNixStringWithoutContext t) (not $ Text.null t) - maybe- (pure nVNull)- (\case- ("", sarr, "") ->- do- let s = fst <$> elems sarr- nvList <$>- traverse- mkMatch- (bool- id -- (length <= 1) allowed & passes-through here the full string- Unsafe.tail- (length s > 1)- s- )- _ -> (pure nVNull)- )- (matchOnceText re s)+ case matchOnceText re s of+ Just ("", sarr, "") ->+ do+ let submatches = fst <$> elems sarr+ nvList <$>+ traverse+ mkMatch+ (case submatches of+ [] -> []+ [a] -> [a]+ _:xs -> xs -- return only the matched groups, drop the full string+ )+ _ -> pure nvNull splitNix :: forall e t f m@@ -735,7 +722,7 @@ attrNamesNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) attrNamesNix =- (fmap getDeeper . toValue . fmap makeNixStringWithoutContext . sort . M.keys)+ (fmap (coerce :: CoerceDeeperToNValue t f m) . toValue . fmap makeNixStringWithoutContext . sort . M.keys) <=< fromValue @(AttrSet (NValue t f m)) attrValuesNix@@ -779,7 +766,7 @@ applyFunToKeyVal (key, val) = do- runFunForKey <- callFunc f $ nvStr $ makeNixStringWithoutContext key+ runFunForKey <- callFunc f $ nvStrWithoutContext key callFunc runFunForKey val newVals <-@@ -933,7 +920,7 @@ maybe (throwError $ ErrorCall $ "builtins.elem: Index " <> show n' <> " too large for list of length " <> show (length xs')) pure- (elemAt xs' n')+ (xs' !!? n') genListNix :: forall e t f m@@ -964,7 +951,7 @@ ss <- fromValue @[NValue t f m] =<< demand startSet op <- demand operator - toValue @[NValue t f m] =<< snd <$> go op S.empty ss+ toValue @[NValue t f m] =<< snd <$> go op mempty ss where go :: NValue t f m@@ -1026,7 +1013,7 @@ maybePrefixMatch where- -- When prefix matched something - returns (match, replacement, reminder)+ -- When prefix matched something - returns (match, replacement, remainder) maybePrefixMatch :: Maybe (Text, NixString, Text) maybePrefixMatch = formMatchReplaceTailInfo <$> find ((`Text.isPrefixOf` input) . fst) fromKeysToValsMap where@@ -1076,7 +1063,7 @@ bugPassOneChar input output = maybe (finish updatedCtx output) -- The base case - there is no chars left to process -> finish- (\(c, i) -> go updatedCtx i (output <> Builder.singleton c)) -- If there are chars - pass one char & continue+ (\(c, i) -> go updatedCtx i $ output <> Builder.singleton c) -- If there are chars - pass one char & continue (Text.uncons input) -- chip first char toValue $ go (getContext string) (stringIgnoreContext string) mempty@@ -1118,7 +1105,7 @@ NVClosure p _ -> toValue @(AttrSet (NValue t f m)) $ mkNVBool <$> case p of- Param name -> M.singleton name False+ Param name -> one (name, False) ParamSet s _ _ -> isJust <$> M.fromList s _v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show _v @@ -1132,9 +1119,9 @@ name' <- fromStringNoContext =<< fromValue name s' <- fromValue s mres <-- toFile_- (toString name')- (toString $ stringIgnoreContext s')+ (toFile_ `on` toString)+ name'+ (stringIgnoreContext s') let t = toText $ unStorePath mres@@ -1151,8 +1138,8 @@ path <- demand nvpath toValue =<< case path of- NVPath p -> pathExists p- NVStr ns -> pathExists (toString $ stringIgnoreContext ns)+ NVPath p -> doesPathExist p+ NVStr ns -> doesPathExist $ toString $ stringIgnoreContext ns _v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show _v isAttrsNix@@ -1207,10 +1194,58 @@ throwError . ErrorCall . toString $ stringIgnoreContext ns +-- | Implementation of Nix @import@ clause.+--+-- Because Nix @import@s work strictly+-- (import gets fully evaluated befor bringing it into the scope it was called from)+-- - that property raises a requirement for execution phase of the interpreter go into evaluation phase+-- & then also go into parsing phase on the imports.+-- So it is not possible (more precise - not practical) to do a full parse Nix code phase fully & then go into evaluation phase.+-- As it is not possible to "import them lazily", as import is strict & it is not possible to establish+-- what imports whould be needed up until where it would be determined & they import strictly+-- importNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)-importNix = scopedImportNix (nvSet mempty mempty)+importNix = scopedImportNix $ nvSet mempty mempty +-- | @scopedImport scope path@+-- An undocumented secret powerful function.+--+-- At the same time it is strongly forbidden to be used, as prolonged use of it would bring devastating consequences.+-- As it is essentially allows rewriting(redefinition) paradigm.+--+-- Allows to import the environment into the scope of a file expression that gets imported.+-- It is as if the contents at @path@ were given to @import@ wrapped as: @with scope; path@+-- meaning:+--+-- > -- Nix pseudocode:+-- > import (with scope; path)+--+-- For example, it allows to use itself as:+-- > bar = scopedImport pkgs ./bar.nix;+-- > -- & declare @./bar.nix@ without a header, so as:+-- > stdenv.mkDerivation { ... buildInputs = [ libfoo ]; }+--+-- But that breaks the evaluation/execution sharing of the @import@s.+--+-- Function also allows to redefine or extend the builtins.+--+-- For instance, to trace all calls to function ‘map’:+--+-- > let+-- > overrides = {+-- > map = f: xs: builtins.trace "call of map!" (map f xs);+--+-- > # Propagate override by calls to import&scopedImport.+-- > import = fn: scopedImport overrides fn;+-- > scopedImport = attrs: fn: scopedImport (overrides // attrs) fn;+--+-- > # Update ‘builtins’.+-- > builtins = builtins // overrides;+-- > };+-- > in scopedImport overrides ./bla.nix+--+-- In the related matter the function can be added and passed around as builtin. scopedImportNix :: forall e t f m . MonadNix e t f m@@ -1266,9 +1301,7 @@ (do isGreaterThan <- (`callFunc` a) =<< callFunc f b fromValue isGreaterThan <&>- bool- EQ- GT+ bool EQ GT ) (pure LT) =<< fromValue isLessThan@@ -1284,42 +1317,50 @@ vb <- demand tb let- badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, " <> "got " <> show va <> " and " <> show vb+ badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, got '" <> show va <> "' and '" <> show vb <> "'." mkNVBool <$> case (va, vb) of (NVConstant ca, NVConstant cb) -> case (ca, cb) of- (NInt a, NInt b ) -> pure $ a < b- (NFloat a, NInt b ) -> pure $ a < fromInteger b+ (NInt a, NInt b) -> pure $ a < b (NInt a, NFloat b) -> pure $ fromInteger a < b+ (NFloat a, NInt b) -> pure $ a < fromInteger b (NFloat a, NFloat b) -> pure $ a < b _ -> badType (NVStr a, NVStr b) -> pure $ stringIgnoreContext a < stringIgnoreContext b _ -> badType -concatListsNix- :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)-concatListsNix =+-- | Helper function, generalization of @concat@ operations.+concatWith+ :: forall e t f m+ . MonadNix e t f m+ => (NValue t f m -> m (NValue t f m))+ -> NValue t f m+ -> m (NValue t f m)+concatWith f = toValue . concat <=< traverse- (fromValue @[NValue t f m] <=< demand)+ (fromValue @[NValue t f m] <=< f) <=< fromValue @[NValue t f m] +-- | Nix function of Haskell:+-- > concat :: [[a]] -> [a]+--+-- Concatenate a list of lists into a single list.+concatListsNix+ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)+concatListsNix = concatWith demand++-- | Nix function of Haskell:+-- > concatMap :: Foldable t => (a -> [b]) -> t a -> [b] concatMapNix :: forall e t f m . MonadNix e t f m => NValue t f m -> NValue t f m -> m (NValue t f m)-concatMapNix f =- toValue . concat <=<- traverse- applyFunc- <=< fromValue @[NValue t f m]- where- applyFunc :: NValue t f m -> m [NValue t f m]- applyFunc = fromValue <=< callFunc f+concatMapNix f = concatWith (callFunc f) listToAttrsNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)@@ -1365,7 +1406,7 @@ where -- This intermidiary `a` is only needed because of the type application mkHash :: (Show a, HashAlgorithm a) => Text -> a- mkHash s = hash (encodeUtf8 s)+ mkHash s = hash $ encodeUtf8 s placeHolderNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m)@@ -1373,11 +1414,10 @@ do t <- fromStringNoContext =<< fromValue p h <-- runPrim- (hashStringNix- (makeNixStringWithoutContext "sha256" )- (makeNixStringWithoutContext ("nix-output:" <> t))- )+ runPrim $+ (hashStringNix `on` makeNixStringWithoutContext)+ "sha256"+ ("nix-output:" <> t) toValue $ makeNixStringWithoutContext $ Text.cons '/'@@ -1415,7 +1455,7 @@ case (aset, filePath) of (NVList x, NVStr ns) -> do- mres <- findPath @t @f @m x (toString (stringIgnoreContext ns))+ mres <- findPath @t @f @m x $ toString $ stringIgnoreContext ns pure $ nvPath mres @@ -1449,7 +1489,7 @@ detectFileTypes items - getDeeper <$> toValue (M.fromList itemsWithTypes)+ (coerce :: CoerceDeeperToNValue t f m) <$> toValue (M.fromList itemsWithTypes) fromJSONNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)@@ -1468,7 +1508,7 @@ jsonToNValue = \case A.Object m -> nvSet mempty <$> traverse jsonToNValue m A.Array l -> nvList <$> traverse jsonToNValue (V.toList l)- A.String s -> pure $ nvStr $ makeNixStringWithoutContext s+ A.String s -> pure $ nvStrWithoutContext s A.Number n -> pure $ nvConstant $@@ -1477,7 +1517,7 @@ NInt (floatingOrInteger n) A.Bool b -> pure $ mkNVBool b- A.Null -> pure nVNull+ A.Null -> pure nvNull toJSONNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) toJSONNix = (fmap nvStr . nvalueToJSONNixString) <=< demand@@ -1511,14 +1551,15 @@ tryEvalNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)-tryEvalNix e = catch (onSuccess <$> demand e) (pure . onError)+tryEvalNix e = (`catch` (pure . onError))+ (onSuccess <$> demand e) where onSuccess v = nvSet mempty $ M.fromList [ ("success", mkNVBool True)- , ("value", v)+ , ("value" , v ) ] onError :: SomeException -> NValue t f m@@ -1526,9 +1567,9 @@ nvSet mempty $ M.fromList- $ ($ mkNVBool False) <$>- [ ("success",)- , ("value" ,)+ $ (, mkNVBool False) <$>+ [ "success"+ , "value" ] traceNix@@ -1560,7 +1601,7 @@ -- 2018-11-19: NOTE: Still need to do something with the context here -- See prim_exec in nix/src/libexpr/primops.cc -- Requires the implementation of EvalState::realiseContext- exec (stringIgnoreContext <$> xs)+ exec $ stringIgnoreContext <$> xs fetchurlNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)@@ -1607,7 +1648,10 @@ makeSide = nvList . fmap snd toValue @(AttrSet (NValue t f m))- $ M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]+ $ M.fromList+ [ ("right", makeSide right)+ , ("wrong", makeSide wrong)+ ] currentSystemNix :: MonadNix e t f m => m (NValue t f m) currentSystemNix =@@ -1615,13 +1659,13 @@ os <- getCurrentSystemOS arch <- getCurrentSystemArch - pure $ nvStr $ makeNixStringWithoutContext (arch <> "-" <> os)+ pure $ nvStrWithoutContext $ arch <> "-" <> os currentTimeNix :: MonadNix e t f m => m (NValue t f m) currentTimeNix = do- opts :: Options <- asks (view hasLens)- toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts)+ opts :: Options <- asks $ view hasLens+ toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds $ currentTime opts derivationStrictNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) derivationStrictNix = derivationStrict@@ -1637,7 +1681,7 @@ case v' of (NVStr ns) -> do let context = getNixLikeContext $ toNixLikeContext $ getContext ns- valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context+ valued :: AttrSet (NValue t f m) <- sequenceA $ toValue <$> context pure $ nvSet mempty valued x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x @@ -1672,17 +1716,11 @@ -- TODO: Fail for unexpected keys. let- getPaths =- maybe- (pure False)- (fromValue <=< demand)- (M.lookup "path" attrs)-- getAllOutputs =+ getK k = maybe (pure False) (fromValue <=< demand)- (M.lookup "allOutputs" attrs)+ (M.lookup k attrs) getOutputs = maybe@@ -1697,8 +1735,8 @@ ) (M.lookup "outputs" attrs) - path <- getPaths- allOutputs <- getAllOutputs+ path <- getK "path"+ allOutputs <- getK "allOutputs" NixLikeContextValue path allOutputs <$> getOutputs @@ -1797,7 +1835,7 @@ , add2 Normal "match" matchNix , add2 Normal "mul" mulNix , add0 Normal "nixPath" nixPathNix- , add0 Normal "null" (pure nVNull)+ , add0 Normal "null" (pure nvNull) , add Normal "parseDrvName" parseDrvNameNix , add2 Normal "partition" partitionNix --, add Normal "path" path@@ -1812,7 +1850,7 @@ , add2 Normal "sort" sortNix , add2 Normal "split" splitNix , add Normal "splitVersion" splitVersionNix- , add0 Normal "storeDir" (pure $ nvStr $ makeNixStringWithoutContext "/nix/store")+ , add0 Normal "storeDir" (pure $ nvStrWithoutContext "/nix/store") --, add Normal "storePath" storePath , add' Normal "stringLength" (arity1 $ Text.length . stringIgnoreContext) , add' Normal "sub" (arity2 ((-) @Integer))@@ -1849,12 +1887,23 @@ mkThunk :: Text -> m (NValue t f m) -> m (NValue t f m) mkThunk n = defer . withFrame Info (ErrorCall $ "While calling builtin " <> toString n <> "\n") + hAdd+ :: ( Text+ -> fun+ -> m (NValue t f m)+ )+ -> BuiltinType+ -> Text+ -> fun+ -> m (Builtin (NValue t f m))+ hAdd f t n v = mkBuiltin t n $ f n v+ add0 :: BuiltinType -> Text -> m (NValue t f m) -> m (Builtin (NValue t f m))- add0 t n v = mkBuiltin t n v+ add0 = hAdd (\ _ x -> x) add :: BuiltinType@@ -1863,7 +1912,7 @@ -> m (NValue t f m) ) -> m (Builtin (NValue t f m))- add t n v = mkBuiltin t n (builtin n v)+ add = hAdd builtin add2 :: BuiltinType@@ -1873,7 +1922,7 @@ -> m (NValue t f m) ) -> m (Builtin (NValue t f m))- add2 t n v = mkBuiltin t n (builtin2 n v)+ add2 = hAdd builtin2 add3 :: BuiltinType@@ -1884,7 +1933,7 @@ -> m (NValue t f m) ) -> m (Builtin (NValue t f m))- add3 t n v = mkBuiltin t n (builtin3 n v)+ add3 = hAdd builtin3 add' :: ToBuiltin t f m a@@ -1892,12 +1941,12 @@ -> Text -> a -> m (Builtin (NValue t f m))- add' t n v = mkBuiltin t n (toBuiltin n v)+ add' = hAdd toBuiltin -- * Exported --- | Evaluate a nix expression in the default context+-- | Evaluate expression in the default context. withNixContext :: forall e t f m r . (MonadNix e t f m, Has e Options)@@ -1909,18 +1958,23 @@ base <- builtins opts :: Options <- asks $ view hasLens let- i = nvList $ nvStr . makeNixStringWithoutContext . toText <$> include opts+ i = nvList $ nvStrWithoutContext . toText <$> include opts - pushScope (M.singleton "__includes" i) $ pushScopes base $- maybe- action- (\ path ->- do- traceM $ "Setting __cur_file = " <> show path- let ref = nvPath path- pushScope (M.singleton "__cur_file" ref) action- )- mpath+ pushScope+ (one ("__includes", i))+ (pushScopes+ base $+ maybe+ id+ (\ path act ->+ do+ traceM $ "Setting __cur_file = " <> show path+ let ref = nvPath path+ pushScope (one ("__cur_file", ref)) act+ )+ mpath+ action+ ) builtins :: ( MonadNix e t f m@@ -1936,9 +1990,9 @@ buildMap = fmap (M.fromList . fmap mapping) builtinsList topLevelBuiltins = mapping <<$>> fullBuiltinsList - fullBuiltinsList = go <<$>> builtinsList+ fullBuiltinsList = nameBuiltins <<$>> builtinsList where- go b@(Builtin TopLevel _) = b- go (Builtin Normal (name, builtin)) =- Builtin TopLevel ("__" <> name, builtin)+ nameBuiltins b@(Builtin TopLevel _) = b+ nameBuiltins (Builtin Normal nB) =+ Builtin TopLevel $ first ("__" <>) nB
src/Nix/Cache.hs view
@@ -15,9 +15,7 @@ import qualified Data.Compact as C import qualified Data.Compact.Serialize as C #endif-#ifdef MIN_VERSION_serialise import qualified Codec.Serialise as S-#endif readCache :: FilePath -> IO NExprLoc readCache path = do@@ -28,25 +26,17 @@ (\ expr -> pure $ C.getCompact expr) eres #else-#ifdef MIN_VERSION_serialise eres <- S.deserialiseOrFail <$> BS.readFile path either (\ err -> fail $ "Error reading cache file: " <> show err) pure eres-#else- fail "readCache not implemented for this platform" #endif-#endif writeCache :: FilePath -> NExprLoc -> IO () writeCache path expr = #ifdef USE_COMPACT C.writeCompact path =<< C.compact expr #else-#ifdef MIN_VERSION_serialise BS.writeFile path (S.serialise expr)-#else- fail "writeCache not implemented for this platform"-#endif #endif
src/Nix/Cited.hs view
@@ -1,9 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}@@ -30,7 +25,8 @@ } deriving (Generic, Typeable, Show) -data NCited m v a = NCited+data NCited m v a =+ NCited { _provenance :: [Provenance m v] , _cited :: a }@@ -38,7 +34,7 @@ instance Applicative (NCited m v) where pure = NCited mempty- NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)+ (<*>) (NCited xs f) (NCited ys x) = NCited (xs <> ys) (f x) instance Comonad (NCited m v) where duplicate p = NCited (_provenance p) p
src/Nix/Cited/Basic.hs view
@@ -1,14 +1,8 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE PatternSynonyms #-} module Nix.Cited.Basic where @@ -18,6 +12,7 @@ import Control.Monad.Catch hiding ( catchJust ) import Nix.Cited import Nix.Eval as Eval+ ( EvalFrame(EvaluatingExpr,ForcingExpr) ) import Nix.Exec import Nix.Expr import Nix.Frames@@ -26,7 +21,10 @@ import Nix.Utils import Nix.Value -newtype Cited t f m a = Cited { getCited :: NCited m (NValue t f m) a }++-- * data type @Cited@++newtype Cited t f m a = Cited (NCited m (NValue t f m) a) deriving ( Generic , Typeable@@ -38,89 +36,123 @@ , ComonadEnv [Provenance m (NValue t f m)] ) -instance HasCitations1 m (NValue t f m) (Cited t f m) where++-- ** Helpers++-- | @Cited@ pattern.+-- > pattern CitedP m a = Cited (NCited m a)+pattern CitedP+ :: [Provenance m (NValue t f m)]+ -> a+ -> Cited t f m a+pattern CitedP m a = Cited (NCited m a)+{-# complete CitedP #-}++-- | Take:+-- 1. Provenence info.+-- 2. Value (like thunk)+-- -> Produce cited value (thunk)+cite+ :: Functor m+ => [Provenance m (NValue t f m)]+ -> m a+ -> m (Cited t f m a)+cite v = fmap (Cited . NCited v)+++-- ** instances++instance+ HasCitations1 m (NValue t f m) (Cited t f m)+ where+ citations1 (Cited c) = citations c addProvenance1 x (Cited c) = Cited $ addProvenance x c -instance ( Has e Options- , Framed e m- , MonadThunk t m v- , Typeable m- , Typeable f- , Typeable u- , MonadCatch m- )+instance+ ( Has e Options+ , Framed e m+ , MonadThunk t m v+ , Typeable m+ , Typeable f+ , Typeable u+ , MonadCatch m+ ) => MonadThunk (Cited u f m t) m v where thunk :: m v -> m (Cited u f m t)- thunk mv = do- opts :: Options <- asks (view hasLens)+ thunk mv =+ do+ opts :: Options <- asks $ view hasLens - bool- (Cited . NCited mempty <$> thunk mv)- (do- frames :: Frames <- asks (view hasLens)+ bool+ (cite mempty)+ (\ t ->+ do+ frames :: Frames <- asks $ view hasLens - -- Gather the current evaluation context at the time of thunk- -- creation, and record it along with the thunk.- let- go (fromException -> Just (EvaluatingExpr scope (AnnE s e))) =- let e' = Compose (Ann s (Nothing <$ e)) in- [Provenance scope e']- go _ = mempty- ps = concatMap (go . frame) frames+ -- Gather the current evaluation context at the time of thunk+ -- creation, and record it along with the thunk.+ let+ go (fromException -> Just (EvaluatingExpr scope (AnnE s e))) =+ let e' = AnnFP s (Nothing <$ e) in+ [Provenance scope e']+ go _ = mempty+ ps = concatMap (go . frame) frames - Cited . NCited ps <$> thunk mv- )- (thunks opts)+ cite ps t+ )+ (thunks opts)+ (thunk mv) thunkId :: Cited u f m t -> ThunkId m- thunkId (Cited (NCited _ t)) = thunkId @_ @m t+ thunkId (CitedP _ t) = thunkId @_ @m t - queryM :: m v -> Cited u f m t -> m v- queryM m (Cited (NCited _ t)) = queryM m t+ query :: m v -> Cited u f m t -> m v+ query m (CitedP _ t) = query m t -- | The ThunkLoop exception is thrown as an exception with MonadThrow, -- which does not capture the current stack frame information to provide -- it in a NixException, so we catch and re-throw it here using -- 'throwError' from Frames.hs. force :: Cited u f m t -> m v- force (Cited (NCited ps t)) = handleDisplayProvenance ps $ force t+ force (CitedP ps t) = handleDisplayProvenance ps $ force t forceEff :: Cited u f m t -> m v- forceEff (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceEff t+ forceEff (CitedP ps t) = handleDisplayProvenance ps $ forceEff t further :: Cited u f m t -> m (Cited u f m t)- further (Cited (NCited ps t)) = Cited . NCited ps <$> further t+ further (CitedP ps t) = cite ps $ further t --- * Kleisli functor HOFs+-- ** Kleisli functor HOFs -- Please, do not use MonadThunkF for MonadThunk, later uses more straight-forward specialized line of functions.-instance ( Has e Options- , Framed e m- , MonadThunkF t m v- , Typeable m- , Typeable f- , Typeable u- , MonadCatch m- )+instance+ ( Has e Options+ , Framed e m+ , MonadThunkF t m v+ , Typeable m+ , Typeable f+ , Typeable u+ , MonadCatch m+ ) => MonadThunkF (Cited u f m t) m v where - queryMF :: (v -> m r) -> m r -> Cited u f m t -> m r- queryMF k m (Cited (NCited _ t)) = queryMF k m t+ queryF :: (v -> m r) -> m r -> Cited u f m t -> m r+ queryF k m (CitedP _ t) = queryF k m t forceF :: (v -> m r) -> Cited u f m t -> m r- forceF k (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceF k t+ forceF k (CitedP ps t) = handleDisplayProvenance ps $ forceF k t forceEffF :: (v -> m r) -> Cited u f m t -> m r- forceEffF k (Cited (NCited ps t)) = handleDisplayProvenance ps $ forceEffF k t+ forceEffF k (CitedP ps t) = handleDisplayProvenance ps $ forceEffF k t furtherF :: (m v -> m v) -> Cited u f m t -> m (Cited u f m t)- furtherF k (Cited (NCited ps t)) = Cited . NCited ps <$> furtherF k t+ furtherF k (CitedP ps t) = cite ps $ furtherF k t --- ** Utils+-- * Representation handleDisplayProvenance :: (MonadCatch m@@ -150,6 +182,6 @@ displayProvenance = list id- (\ (Provenance scope e@(Compose (Ann s _)) : _) ->- withFrame Info (ForcingExpr scope (wrapExprLoc s e))+ (\ (Provenance scope e@(AnnFP s _) : _) ->+ withFrame Info $ ForcingExpr scope $ wrapExprLoc s e )
src/Nix/Context.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Nix.Context where import Nix.Options ( Options )-import Nix.Scope ( Scopes- , emptyScopes )+import Nix.Scope ( Scopes ) import Nix.Frames ( Frames ) import Nix.Expr.Types.Annotated ( SrcSpan , nullSpan@@ -33,4 +29,4 @@ hasLens f a = (\x -> a { options = x }) <$> f (options a) newContext :: Options -> Context m t-newContext = Context emptyScopes nullSpan mempty+newContext = Context mempty nullSpan mempty
src/Nix/Convert.hs view
@@ -1,14 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -34,12 +27,15 @@ import Nix.String import Nix.Value import Nix.Value.Monad-import Nix.Thunk+import Nix.Thunk ( MonadThunk(force) ) import Nix.Utils -newtype Deeper a = Deeper { getDeeper :: a }+newtype Deeper a = Deeper a deriving (Typeable, Functor, Foldable, Traversable) +type CoerceDeeperToNValue t f m = Deeper (NValue t f m) -> NValue t f m+type CoerceDeeperToNValue' t f m = Deeper (NValue' t f m (NValue t f m)) -> NValue' t f m (NValue t f m)+ {- IMPORTANT NOTE@@ -90,7 +86,7 @@ do v' <- fromValueMay v maybe- (throwError $ Expectation @t @f @m t (Free $ getDeeper v))+ (throwError $ Expectation @t @f @m t $ Free $ (coerce :: CoerceDeeperToNValue' t f m) v) pure v' @@ -161,7 +157,7 @@ fromValueMay = pure . \case- NVConstant' (NInt b) -> pure (fromInteger b)+ NVConstant' (NInt b) -> pure $ fromInteger b _ -> Nothing fromValue = fromMayToValue TInt@@ -184,7 +180,7 @@ pure . \case NVConstant' (NFloat b) -> pure b- NVConstant' (NInt i) -> pure (fromInteger i)+ NVConstant' (NInt i) -> pure $ fromInteger i _ -> Nothing fromValue = fromMayToValue TFloat@@ -209,18 +205,18 @@ (M.lookup "outPath" s) _ -> stub - fromValue = fromMayToValue (TString NoContext)+ fromValue = fromMayToValue $ TString NoContext instance Convertible e t f m => FromValue ByteString m (NValue' t f m (NValue t f m)) where fromValueMay =- pure.+ pure . \case NVStr' ns -> encodeUtf8 <$> getStringNoContext ns _ -> mempty - fromValue = fromMayToValue (TString NoContext)+ fromValue = fromMayToValue $ TString NoContext newtype Path = Path { getPath :: FilePath }@@ -248,7 +244,7 @@ => FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where fromValueMay =- pure.+ pure . \case NVList' l -> pure l _ -> mempty@@ -320,24 +316,24 @@ , FromValue a m (NValue' t f m (NValue t f m)) ) => FromValue a m (Deeper (NValue' t f m (NValue t f m))) where- fromValueMay = fromValueMay . getDeeper- fromValue = fromValue . getDeeper+ fromValueMay = fromValueMay . (coerce :: CoerceDeeperToNValue' t f m)+ fromValue = fromValue . (coerce :: CoerceDeeperToNValue' t f m) -- * ToValue class ToValue a m v where- toValue :: a -> m v+ toValue :: a -> m v instance (Convertible e t f m, ToValue a m (NValue' t f m (NValue t f m))) => ToValue a m (NValue t f m) where- toValue = fmap Free . toValue+ toValue v = Free <$> toValue v instance ( Convertible e t f m , ToValue a m (Deeper (NValue' t f m (NValue t f m))) ) => ToValue a m (Deeper (NValue t f m)) where- toValue = fmap (fmap Free) . toValue+ toValue v = Free <<$>> toValue v instance Convertible e t f m => ToValue () m (NValue' t f m (NValue t f m)) where@@ -379,9 +375,9 @@ ) => ToValue SourcePos m (NValue' t f m (NValue t f m)) where toValue (SourcePos f l c) = do- f' <- toValue (makeNixStringWithoutContext (toText f))- l' <- toValue (unPos l)- c' <- toValue (unPos c)+ f' <- toValue $ makeNixStringWithoutContext $ toText f+ l' <- toValue $ unPos l+ c' <- toValue $ unPos c let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')] pure $ nvSet' mempty pos @@ -392,7 +388,7 @@ instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where- toValue = fmap (Deeper . nvList') . traverse toValue+ toValue l = Deeper . nvList' <$> traverse toValue l instance Convertible e t f m => ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where@@ -401,8 +397,7 @@ instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where toValue s =- liftA2- (\ v s -> Deeper $ nvSet' s v)+ liftA2 (\ v s -> Deeper $ nvSet' s v) (traverse toValue s) stub @@ -414,21 +409,22 @@ instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m (NValue t f m))) where- toValue (s, p) = (\ v s -> Deeper $ nvSet' s v) <$> traverse toValue s <*> pure p+ toValue (s, p) =+ liftA2 (\ v s -> Deeper $ nvSet' s v)+ (traverse toValue s)+ (pure p) instance Convertible e t f m => ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where toValue nlcv = do- path <-- bool- (pure Nothing)- (pure <$> toValue True)- (nlcvPath nlcv)- allOutputs <-- bool- (pure Nothing)- (pure <$> toValue True)- (nlcvAllOutputs nlcv)+ let+ g f =+ bool+ (pure Nothing)+ (pure <$> toValue True)+ (f nlcv)+ path <- g nlcvPath+ allOutputs <- g nlcvAllOutputs outputs <- do let outputs = makeNixStringWithoutContext <$> nlcvOutputs nlcv@@ -439,9 +435,9 @@ (fmap pure . toValue) ts pure $ nvSet' mempty $ M.fromList $ catMaybes- [ ("path",) <$> path+ [ ("path" ,) <$> path , ("allOutputs",) <$> allOutputs- , ("outputs",) <$> outputs+ , ("outputs" ,) <$> outputs ] instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where
src/Nix/Effects.hs view
@@ -1,16 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ {-# OPTIONS_GHC -Wno-orphans #-} @@ -29,6 +24,7 @@ import Network.HTTP.Client hiding ( path, Proxy ) import Network.HTTP.Client.TLS import Network.HTTP.Types+import qualified "cryptonite" Crypto.Hash as Hash import Nix.Utils.Fix1 import Nix.Expr import Nix.Frames hiding ( Proxy )@@ -42,7 +38,6 @@ import qualified System.Info import System.Process -import qualified System.Nix.Hash as Store import qualified System.Nix.Store.Remote as Store.Remote import qualified System.Nix.StorePath as Store @@ -111,13 +106,9 @@ instance MonadIntrospect IO where recursiveSize = #ifdef MIN_VERSION_ghc_datasize-#if MIN_VERSION_ghc_datasize(0,2,0) recursiveSize #else- \_ -> pure 0-#endif-#else- \_ -> pure 0+ \_ -> pure 0 #endif deriving@@ -150,16 +141,18 @@ [] -> pure $ Left $ ErrorCall "exec: missing program" (prog : args) -> do (exitCode, out, _) <- liftIO $ readProcessWithExitCode (toString prog) (toString <$> args) ""- let t = Text.strip (toText out)- let emsg = "program[" <> prog <> "] args=" <> show args+ let+ t = Text.strip $ toText out+ emsg = "program[" <> prog <> "] args=" <> show args case exitCode of ExitSuccess ->+ pure $ if Text.null t- then pure $ Left $ ErrorCall $ toString $ "exec has no output :" <> emsg+ then Left $ ErrorCall $ toString $ "exec has no output :" <> emsg else either- (\ err -> pure $ Left $ ErrorCall $ toString $ "Error parsing output of exec: " <> show err <> " " <> emsg)- (pure . pure)+ (\ err -> Left $ ErrorCall $ toString $ "Error parsing output of exec: " <> show err <> " " <> emsg)+ pure (parseNixTextLoc t) err -> pure $ Left $ ErrorCall $ toString $ "exec failed: " <> show err <> " " <> emsg @@ -206,7 +199,7 @@ either (\ e -> Left $ ErrorCall $ "Error parsing output of nix-instantiate: " <> show e) pure- (parseNixTextLoc (toText out))+ (parseNixTextLoc $ toText out) status -> Left $ ErrorCall $ "nix-instantiate failed: " <> show status <> ": " <> err deriving@@ -312,7 +305,7 @@ else newManager defaultManagerSettings -- print req response <- httpLbs (req { method = "GET" }) manager- let status = statusCode (responseStatus response)+ let status = statusCode $ responseStatus response pure $ Left $ ErrorCall $ if status /= 200 then "fail, got " <> show status <> " when fetching url:" <> urlstr@@ -410,7 +403,7 @@ (\ pathName -> do -- TODO: redesign the filter parameter- res <- Store.Remote.runStore $ Store.Remote.addToStore @'Store.SHA256 pathName path recursive (const False) repair+ res <- Store.Remote.runStore $ Store.Remote.addToStore @Hash.SHA256 pathName path recursive (const False) repair either Left -- err (pure . StorePath . decodeUtf8 . Store.storePathToRawFilePath) -- store path@@ -453,11 +446,4 @@ =<< addToStore (toText $ takeFileName p) p True False toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath-toFile_ p contents = addTextToStore (toText p) (toText contents) HS.empty False----- * misc---- Please, get rid of pathExists in favour of @doesPathExist@-pathExists :: MonadFile m => FilePath -> m Bool-pathExists = doesPathExist+toFile_ p contents = addTextToStore (toText p) (toText contents) mempty False
src/Nix/Effects/Basic.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Nix.Effects.Basic where@@ -34,9 +31,7 @@ import Nix.Value.Monad #ifdef MIN_VERSION_ghc_datasize-#if MIN_VERSION_ghc_datasize(0,2,0) import GHC.DataSize-#endif #endif defaultMakeAbsolutePath :: MonadNix e t f m => FilePath -> m FilePath
src/Nix/Effects/Derivation.hs view
@@ -1,12 +1,8 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-+{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ module Nix.Effects.Derivation ( defaultDerivationStrict ) where @@ -15,13 +11,18 @@ , isAlphaNum ) import qualified Data.HashMap.Lazy as M-import qualified Data.HashMap.Strict as MS+import qualified Data.HashMap.Strict as MS ( insert ) import qualified Data.HashSet as S import Data.Foldable ( foldl ) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as Text +import Text.Megaparsec+import Text.Megaparsec.Char++import qualified "cryptonite" Crypto.Hash as Hash -- 2021-07-05: Attrocity of Haskell hashing situation, in HNix we ended-up with 2 hash package dependencies @{hashing, cryptonite}@+ import Nix.Atoms import Nix.Convert import Nix.Effects@@ -39,9 +40,6 @@ import qualified System.Nix.ReadonlyStore as Store import qualified System.Nix.Hash as Store import qualified System.Nix.StorePath as Store--import Text.Megaparsec-import Text.Megaparsec.Char import Prelude hiding (readFile) @@ -75,27 +73,27 @@ writeDerivation :: (Framed e m, MonadStore m) => Derivation -> m Store.StorePath writeDerivation drv@Derivation{inputs, name} = do let (inputSrcs, inputDrvs) = inputs- references <- fmap Set.fromList $ traverse parsePath $ Set.toList $ Set.union inputSrcs $ Set.fromList $ Map.keys inputDrvs+ references <- Set.fromList <$> traverse parsePath (Set.toList $ inputSrcs <> Set.fromList (Map.keys inputDrvs)) path <- addTextToStore (Text.append name ".drv") (unparseDrv drv) (S.fromList $ Set.toList references) False parsePath $ toText $ unStorePath path -- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash. -- this avoids propagating changes to their .drv when the output hash stays the same.-hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256)+hashDerivationModulo :: (MonadNix e t f m, MonadState (b, AttrSet Text) m) => Derivation -> m (Hash.Digest Hash.SHA256) hashDerivationModulo Derivation- { mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType))+ { mFixed = Just (Store.SomeDigest (digest :: Hash.Digest hashType)) , outputs , hashMode } = case Map.toList outputs of [("out", path)] -> pure $- Store.hash @'Store.SHA256 $+ Hash.hash @ByteString @Hash.SHA256 $ encodeUtf8 $ "fixed:out" <> (if hashMode == Recursive then ":r" else "") <> ":" <> (Store.algoName @hashType)- <> ":" <> Store.encodeInBase Store.Base16 digest+ <> ":" <> Store.encodeDigestWith Store.Base16 digest <> ":" <> path _outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " <> show _outputsList hashDerivationModulo@@ -113,14 +111,14 @@ maybe (do drv' <- readDerivation $ toString path- hash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv'+ hash <- Store.encodeDigestWith Store.Base16 <$> hashDerivationModulo drv' pure (hash, outs) ) (\ hash -> pure (hash, outs))- (MS.lookup path cache)+ (M.lookup path cache) ) (Map.toList inputDrvs)- pure $ Store.hash @'Store.SHA256 $ encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)})+ pure $ Hash.hash @ByteString @Hash.SHA256 $ encodeUtf8 $ unparseDrv $ drv {inputs = (inputSrcs, inputsModulo)} unparseDrv :: Derivation -> Text unparseDrv Derivation{..} =@@ -150,8 +148,8 @@ parens $ (s <$>) $ ([outputName, outputPath] <>) $ maybe [mempty, mempty]- (\ (Store.SomeDigest (digest :: Store.Digest hashType)) ->- [prefix <> Store.algoName @hashType, Store.encodeInBase Store.Base16 digest]+ (\ (Store.SomeDigest (digest :: Hash.Digest hashType)) ->+ [prefix <> Store.algoName @hashType, Store.encodeDigestWith Store.Base16 digest] ) mFixed parens :: [Text] -> Text@@ -168,7 +166,7 @@ escape '\n' = "\\n" escape '\r' = "\\r" escape '\t' = "\\t"- escape c = Text.singleton c+ escape c = one c readDerivation :: (Framed e m, MonadFile m) => FilePath -> m Derivation readDerivation path = do@@ -216,10 +214,12 @@ ) regular = noneOf ['\\', '"'] + wrap o c p =+ string o *> sepBy p (string ",") <* string c+ parens :: Parsec () Text a -> Parsec () Text [a]- parens p =- (string "(") *> sepBy p (string ",") <* (string ")")- serializeList p = (string "[") *> sepBy p (string ",") <* (string "]")+ parens p = wrap "(" ")" p+ serializeList p = wrap "[" "]" p parseFixed :: [(Text, Text, Text, Text)] -> (Maybe Store.SomeNamedDigest, HashMode) parseFixed fullOutputs = case fullOutputs of@@ -238,44 +238,59 @@ _ -> (Nothing, Flat) -defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m)+defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, AttrSet Text) m) => NValue t f m -> m (NValue t f m) defaultDerivationStrict val = do s <- fromValue @(AttrSet (NValue t f m)) val (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s drvName <- makeStorePathName $ name drv- let inputs = toStorePaths ctx+ let+ inputs = toStorePaths ctx+ ifNotJsonModEnv f =+ bool f id (useJson drv)+ (env drv) -- Compute the output paths, and add them to the environment if needed. -- Also add the inputs, just computed from the strings contexts. drv' <- case mFixed drv of Just (Store.SomeDigest digest) -> do- let out = pathToText $ Store.makeFixedOutputPath "/nix/store" (hashMode drv == Recursive) digest drvName- let env' = if useJson drv then env drv else Map.insert "out" out (env drv)- pure $ drv { inputs, env = env', outputs = Map.singleton "out" out }+ let+ out = pathToText $ Store.makeFixedOutputPath "/nix/store" (hashMode drv == Recursive) digest drvName+ env' = ifNotJsonModEnv $ Map.insert "out" out+ pure $ drv { inputs, env = env', outputs = one ("out", out) } Nothing -> do hash <- hashDerivationModulo $ drv { inputs --, outputs = Map.map (const "") (outputs drv) -- not needed, this is already the case- , env = if useJson drv then env drv- else foldl' (\m k -> Map.insert k "" m) (env drv) (Map.keys $ outputs drv)+ , env =+ ifNotJsonModEnv+ (\ baseEnv ->+ foldl'+ (\m k -> Map.insert k "" m)+ baseEnv+ (Map.keys $ outputs drv)+ ) }- outputs' <- sequence $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) (outputs drv)+ outputs' <- sequence $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) $ outputs drv pure $ drv { inputs , outputs = outputs'- , env = if useJson drv then env drv else Map.union outputs' (env drv)+ , env = ifNotJsonModEnv $ (outputs' <>) } drvPath <- pathToText <$> writeDerivation drv' -- Memoize here, as it may be our last chance in case of readonly stores.- drvHash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv'+ drvHash <- Store.encodeDigestWith Store.Base16 <$> hashDerivationModulo drv' modify $ second $ MS.insert drvPath drvHash - let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath $ DerivationOutput out)) (outputs drv')- drvPathWithContext = makeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)- attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext+ let+ outputsWithContext =+ Map.mapWithKey+ (\out path -> makeNixStringWithSingletonContext path $ StringContext drvPath $ DerivationOutput out)+ (outputs drv')+ drvPathWithContext = makeNixStringWithSingletonContext drvPath $ StringContext drvPath AllOutputs+ attrSet = nvStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) -- TODO: Add location information for all the entries. -- here --v pure $ nvSet mempty attrSet@@ -285,7 +300,7 @@ pathToText = decodeUtf8 . Store.storePathToRawFilePath makeOutputPath o h n = do- name <- makeStorePathName (Store.unStorePathName n <> if o == "out" then "" else "-" <> o)+ name <- makeStorePathName $ Store.unStorePathName n <> if o == "out" then "" else "-" <> o pure $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> encodeUtf8 o) h name toStorePaths ctx = foldl (flip addToInputs) (mempty, mempty) ctx@@ -350,7 +365,7 @@ jsonString :: NixString <- lift $ nvalueToJSONNixString $ nvSet mempty $ deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs rawString :: Text <- extractNixString jsonString- pure $ Map.singleton "__json" rawString+ pure $ one ("__json", rawString) else traverse (extractNixString <=< lift . coerceToString callFunc CopyToStore CoerceAny) $ Map.fromList $ M.toList $ deleteKeys [ "args", "__ignoreNulls" ] attrs@@ -378,7 +393,7 @@ getAttrOr' n d f = case M.lookup n drvAttrs of Nothing -> lift d Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" <> show n <> "'") $- fromValue' v >>= f+ f =<< fromValue' v getAttrOr n d f = getAttrOr' n (pure d) f
src/Nix/Eval.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} @@ -111,11 +106,11 @@ eval (NSym var ) = do- mres <- lookupVar var+ mVal <- lookupVar var maybe (freeVariable var) (evaledSym var <=< demand)- mres+ mVal eval (NConstant x ) = evalConstant x eval (NStr str ) = evalString str@@ -125,31 +120,47 @@ eval (NBinary NApp fun arg) = do+ f <- fun scope <- currentScopes :: m (Scopes m v)- (`evalApp` withScopes scope arg) =<< fun+ evalApp f $ withScopes scope arg -eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg+eval (NBinary op larg rarg) =+ do+ lav <- larg+ evalBinary op lav rarg -eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id- where go (s, ks) = fromMaybe (attrMissing ks (pure s)) alt+eval (NSelect aset attr alt ) =+ do+ let useAltOrReportMissing (s, ks) = fromMaybe (attrMissing ks $ pure s) alt -eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight+ eAttr <- evalSelect aset attr+ either useAltOrReportMissing id eAttr +eval (NHasAttr aset attr) =+ do+ eAttr <- evalSelect aset attr+ toValue $ isRight eAttr+ eval (NList l ) = do scope <- currentScopes- toValue =<< traverse (defer @v @m . withScopes @v scope) l+ lst <- traverse (defer @v @m . withScopes @v scope) l+ toValue lst eval (NSet NNonRecursive binds) =- toValue =<< evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds)+ do+ attrSet <- evalBinds False $ desugarBinds (eval . NSet NNonRecursive) binds+ toValue attrSet eval (NSet NRecursive binds) =- toValue =<< evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds)+ do+ attrSet <- evalBinds True $ desugarBinds (eval . NSet NNonRecursive) binds+ toValue attrSet eval (NLet binds body ) = do- (x, _) <- evalBinds True binds- pushScope x body+ (attrSet, _) <- evalBinds True binds+ pushScope attrSet body eval (NIf cond t f ) = do@@ -169,25 +180,38 @@ -- defer here so the present scope is restored when the parameters and body -- are forced during application. scope <- currentScopes :: m (Scopes m v)- evalAbs params $ \arg k -> withScopes scope $ do- args <- buildArgument params arg- pushScope args $ k (withScopes scope . inform <$> args) body+ let+ withScope = withScopes scope+ withScopeInform = withScope . inform + evalAbs+ params+ (\arg k ->+ withScope $+ do+ args <- buildArgument params arg+ pushScope+ args $+ k+ (withScopeInform <$> args)+ body+ )+ eval (NSynHole name) = synHole name -- | If you know that the 'scope' action will result in an 'AttrSet v', then -- this implementation may be used as an implementation for 'evalWith'. evalWithAttrSet :: forall v m . MonadNixEval v m => m v -> m v -> m v evalWithAttrSet aset body = do+ scope <- currentScopes :: m (Scopes m v) -- The scope is deliberately wrapped in a thunk here, since it is demanded -- each time a name is looked up within the weak scope, and we want to be -- sure the action it evaluates is to force a thunk, so its value is only -- computed once.- scope <- currentScopes :: m (Scopes m v)- s <- defer $ withScopes scope aset- let s' = fst <$> (fromValue @(AttrSet v, AttrSet SourcePos) =<< demand s)+ deferredAset <- defer $ withScopes scope aset+ let attrSet = fst <$> (fromValue @(AttrSet v, AttrSet SourcePos) =<< demand deferredAset) - pushWeakScope s' body+ pushWeakScope attrSet body attrSetAlter :: forall v m@@ -236,12 +260,18 @@ collect (NamedVar (StaticKey x :| y : ys) val p) = do m <- get- put $ M.insert x ?? m $- maybe- (p, [NamedVar (y :| ys) val p])- (\ (q, v) -> (q, NamedVar (y :| ys) val q : v))- (M.lookup x m)+ put $+ M.insert+ x+ (maybe+ (p, [bindValAt p])+ (\ (q, v) -> (q, bindValAt q : v))+ (M.lookup x m)+ )+ m pure $ Left x+ where+ bindValAt pos = NamedVar (y :| ys) val pos collect x = pure $ pure x go@@ -250,10 +280,10 @@ go = either (\ x -> do- maybeValue <- gets (M.lookup x)+ maybeValue <- gets $ M.lookup x maybe (error $ "No binding " <> show x)- (\ (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p)+ (\ (p, v) -> pure $ NamedVar (StaticKey x :| mempty) (embed v) p) maybeValue ) pure@@ -287,12 +317,12 @@ pure (res, p) where+ insert (m, p) (path, pos, value) = attrSetAlter path pos m p value+ mkThunk = defer . withScopes scope encapsulate f attrs = mkThunk $ pushScope attrs f - insert (m, p) (path, pos, value) = attrSetAlter path pos m p value- applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = do@@ -301,7 +331,7 @@ pure $ (\ (k, v) -> ( [k]- , fromMaybe pos (M.lookup k p')+ , fromMaybe pos $ M.lookup k p' , demand v ) ) <$> M.toList o'@@ -316,25 +346,23 @@ where processAttrSetKeys :: NAttrPath (m v) -> m ([Text], SourcePos, m v)- processAttrSetKeys =- \case- h :| t ->- maybe- -- Empty attrset - return a stub.- (pure ( mempty, nullPos, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)) )- (\ k ->- list- -- No more keys in the attrset - return the result- (pure ( [k], pos, finalValue ) )- -- There are unprocessed keys in attrset - recurse appending the results- (\ (x : xs) ->- do- (restOfPath, _, v) <- processAttrSetKeys (x :| xs)- pure ( k : restOfPath, pos, v )- )- t+ processAttrSetKeys (h :| t) =+ maybe+ -- Empty attrset - return a stub.+ (pure ( mempty, nullPos, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)) )+ (\ k ->+ list+ -- No more keys in the attrset - return the result+ (pure ( [k], pos, finalValue ) )+ -- There are unprocessed keys in attrset - recurse appending the results+ (\ (x : xs) ->+ do+ (restOfPath, _, v) <- processAttrSetKeys (x :| xs)+ pure ( k : restOfPath, pos, v ) )- =<< evalSetterKeyName h+ t+ )+ =<< evalSetterKeyName h applyBindToAdt scope (Inherit ms names pos) = catMaybes <$>@@ -353,7 +381,7 @@ ([key] , pos , maybe- (attrMissing (key :| []) Nothing)+ (attrMissing (key :| mempty) Nothing) demand =<< maybe (withScopes scope $ lookupVar key)@@ -370,7 +398,7 @@ moveOverridesLast = uncurry (<>) . partition (\case- NamedVar (StaticKey "__overrides" :| []) _ _pos -> False+ NamedVar (StaticKey "__overrides" :| []) _ _ -> False _ -> True ) @@ -399,7 +427,7 @@ do list (pure . pure)- (\ (y : ys) -> ((extract ?? (y :| ys)) =<<))+ (\ (y : ys) -> ((`extract` (y :| ys)) =<<)) ks $ demand t | otherwise -> Left . (, path) <$> toValue (s, p)@@ -456,8 +484,9 @@ buildArgument params arg = do scope <- currentScopes :: m (Scopes m v)+ let argThunk = defer $ withScopes scope arg case params of- Param name -> M.singleton name <$> defer (withScopes scope arg)+ Param name -> M.singleton name <$> argThunk ParamSet s isVariadic m -> do (args, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< arg@@ -465,7 +494,7 @@ inject = maybe id- (\ n -> M.insert n $ const $ defer $ withScopes scope arg)+ (\ n -> M.insert n $ const argThunk) -- why insert into const? m loebM (inject $@@ -493,15 +522,24 @@ | otherwise -> pure $ const $ evalError @v $ ErrorCall $ "Unexpected parameter: " <> show k These x _ -> pure $ const $ pure x +-- | Add source positions to @NExprLoc@.+--+-- Takes @NExprLoc@, by itself takes source position informatoin, does transformation,+-- returns @NExprLoc@ with source positions.+--+-- Actually:+--+-- > => (NExprLoc -> m a)+-- > -> NExprLoc -> m a addSourcePositions :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)-addSourcePositions f v@(AnnE ann _) =+addSourcePositions f (v@(AnnE ann _) :: NExprLoc) = local (set hasLens ann) $ f v addStackFrames :: forall v e m a . (Scoped v m, Framed e m, Typeable v, Typeable m)- => Transform NExprLocF (m a)+ => TransformF NExprLoc (m a) addStackFrames f v = do scopes <- currentScopes :: m (Scopes m v)@@ -515,8 +553,22 @@ framedEvalExprLoc :: forall e v m- . (MonadNixEval v m, Framed e m, Has e SrcSpan, Typeable m, Typeable v)+ . (MonadNixEval v m, Framed e m, Has e SrcSpan, Typeable m, Typeable v) => NExprLoc -> m v framedEvalExprLoc =- adi (eval . annotated . getCompose) $ addStackFrames @v . addSourcePositions+ adi addMetaInfo evalContent++-- | Add source postionss & frame context system.+addMetaInfo+ :: forall v m e a+ . (Framed e m, Scoped v m, Has e SrcSpan, Typeable m, Typeable v)+ => TransformF NExprLoc (m a)+addMetaInfo = addStackFrames @v . addSourcePositions++-- | Takes annotated expression. Strip from annotation. Evaluate.+evalContent+ :: MonadNixEval v m+ => AnnF ann NExprF (m v)+ -> m v+evalContent = eval . stripAnn
src/Nix/Exec.hs view
@@ -1,14 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -48,15 +43,11 @@ import Nix.Value.Equal import Nix.Value.Monad import Prettyprinter-#ifdef MIN_VERSION_pretty_show import qualified Text.Show.Pretty as PS-#endif #ifdef MIN_VERSION_ghc_datasize-#if MIN_VERSION_ghc_datasize(0,2,0) import GHC.DataSize #endif-#endif type MonadCited t f m = ( HasCitations m (NValue t f m) t@@ -69,28 +60,28 @@ => Provenance m (NValue t f m) -> NAtom -> NValue t f m-nvConstantP p x = addProvenance p (nvConstant x)+nvConstantP p x = addProvenance p $ nvConstant x nvStrP :: MonadCited t f m => Provenance m (NValue t f m) -> NixString -> NValue t f m-nvStrP p ns = addProvenance p (nvStr ns)+nvStrP p ns = addProvenance p $ nvStr ns nvPathP :: MonadCited t f m => Provenance m (NValue t f m) -> FilePath -> NValue t f m-nvPathP p x = addProvenance p (nvPath x)+nvPathP p x = addProvenance p $ nvPath x nvListP :: MonadCited t f m => Provenance m (NValue t f m) -> [NValue t f m] -> NValue t f m-nvListP p l = addProvenance p (nvList l)+nvListP p l = addProvenance p $ nvList l nvSetP :: MonadCited t f m@@ -98,7 +89,7 @@ -> AttrSet SourcePos -> AttrSet (NValue t f m) -> NValue t f m-nvSetP p x s = addProvenance p (nvSet x s)+nvSetP p x s = addProvenance p $ nvSet x s nvClosureP :: MonadCited t f m@@ -106,7 +97,7 @@ -> Params () -> (NValue t f m -> m (NValue t f m)) -> NValue t f m-nvClosureP p x f = addProvenance p (nvClosure x f)+nvClosureP p x f = addProvenance p $ nvClosure x f nvBuiltinP :: MonadCited t f m@@ -114,17 +105,17 @@ -> Text -> (NValue t f m -> m (NValue t f m)) -> NValue t f m-nvBuiltinP p name f = addProvenance p (nvBuiltin name f)+nvBuiltinP p name f = addProvenance p $ nvBuiltin name f -type MonadCitedThunks t f m- = ( MonadThunk t m (NValue t f m)+type MonadCitedThunks t f m =+ ( MonadThunk t m (NValue t f m) , MonadDataErrorContext t f m , HasCitations m (NValue t f m) t , HasCitations1 m (NValue t f m) f ) -type MonadNix e t f m- = ( Has e SrcSpan+type MonadNix e t f m =+ ( Has e SrcSpan , Has e Options , Scoped (NValue t f m) m , Framed e m@@ -146,10 +137,10 @@ nverr = evalError @(NValue t f m) currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan-currentPos = asks (view hasLens)+currentPos = asks $ view hasLens wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc-wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)+wrapExprLoc span x = Fix $ Fix (NSym_ span "<?>") <$ x {-# inline wrapExprLoc #-} -- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class.@@ -177,13 +168,13 @@ ) ms where- attr = Text.intercalate "." (NE.toList ks)+ attr = Text.intercalate "." $ NE.toList ks evalCurPos = do scope <- currentScopes span@(SrcSpan delta _) <- currentPos addProvenance @_ @_ @(NValue t f m)- (Provenance scope (NSym_ span "__curPos")) <$>+ (Provenance scope $ NSym_ span "__curPos") <$> toValue delta evaledSym name val = do@@ -191,13 +182,13 @@ span <- currentPos pure $ addProvenance @_ @_ @(NValue t f m)- (Provenance scope (NSym_ span name))+ (Provenance scope $ NSym_ span name) val evalConstant c = do scope <- currentScopes span <- currentPos- pure $ nvConstantP (Provenance scope (NConstant_ span c)) c+ pure $ nvConstantP (Provenance scope $ NConstant_ span c) c evalString = maybe@@ -210,7 +201,7 @@ nvStrP (Provenance scope- (NStr_ span (DoubleQuoted [Plain (stringIgnoreContext ns)]))+ (NStr_ span $ DoubleQuoted [Plain $ stringIgnoreContext ns]) ) ns )@@ -219,13 +210,13 @@ evalLiteralPath p = do scope <- currentScopes span <- currentPos- nvPathP (Provenance scope (NLiteralPath_ span p)) <$>+ nvPathP (Provenance scope $ NLiteralPath_ span p) <$> makeAbsolutePath @t @f @m p evalEnvPath p = do scope <- currentScopes span <- currentPos- nvPathP (Provenance scope (NEnvPath_ span p)) <$>+ nvPathP (Provenance scope $ NEnvPath_ span p) <$> findEnvPath @t @f @m p evalUnary op arg = do@@ -241,8 +232,8 @@ evalWith c b = do scope <- currentScopes span <- currentPos- (\b -> addProvenance (Provenance scope (NWith_ span Nothing (pure b))) b)- <$> evalWithAttrSet c b+ let f = join $ addProvenance . Provenance scope . NWith_ span Nothing . pure+ f <$> evalWithAttrSet c b evalIf c t f = do scope <- currentScopes@@ -250,11 +241,14 @@ b <- fromValue c let- fun x y = addProvenance (Provenance scope (NIf_ span (pure c) x y))+ fun x y z = addProvenance (Provenance scope $ NIf_ span (pure c) x y) z+ -- Note: join acts as \ f x -> f x x+ false = join (fun Nothing . pure) <$> f+ true = join (flip fun Nothing . pure) <$> t bool- ( (\ f' -> fun Nothing (pure f') f') <$> f )- ( (\ t' -> fun (pure t') Nothing t') <$> t )+ false+ true b evalAssert c body =@@ -265,17 +259,15 @@ (nverr $ Assertion span c) (do scope <- currentScopes- (\b ->- addProvenance (Provenance scope (NAssert_ span (pure c) (pure b))) b- ) <$>- body+ let f = join (addProvenance . Provenance scope . NAssert_ span (pure c) . pure)+ f <$> body ) b evalApp f x = do scope <- currentScopes span <- currentPos- addProvenance (Provenance scope (NBinary_ span NApp (pure f) Nothing)) <$>+ addProvenance (Provenance scope $ NBinary_ span NApp (pure f) Nothing) <$> (callFunc f =<< defer x) evalAbs p k = do@@ -283,7 +275,7 @@ span <- currentPos pure $ nvClosureP- (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))+ (Provenance scope $ NAbs_ span (Nothing <$ p) Nothing) (void p) (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) @@ -298,7 +290,7 @@ -> m (NValue t f m) callFunc fun arg = do- frames :: Frames <- asks (view hasLens)+ frames :: Frames <- asks $ view hasLens when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" fun' <- demand fun@@ -307,10 +299,10 @@ NVBuiltin name f -> do span <- currentPos- withFrame Info ((Calling @m @(NValue t f m)) name span) (f arg)+ withFrame Info ((Calling @m @(NValue t f m)) name span) $ f arg -- Is this cool? (NVSet m _) | Just f <- M.lookup "__functor" m ->- ((`callFunc` arg) <=< (`callFunc` fun')) =<< demand f- x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x+ (`callFunc` arg) =<< (`callFunc` fun') =<< demand f+ _x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show _x execUnaryOp :: (Framed e m, MonadCited t f m, Show t)@@ -323,15 +315,15 @@ case arg of NVConstant c -> case (op, c) of- (NNeg, NInt i ) -> unaryOp $ NInt (-i)- (NNeg, NFloat f) -> unaryOp $ NFloat (-f)- (NNot, NBool b ) -> unaryOp $ NBool (not b)- _ ->- throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show op- x ->- throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show x+ (NNeg, NInt i) -> unaryOp $ NInt ( - i)+ (NNeg, NFloat f) -> unaryOp $ NFloat ( - f)+ (NNot, NBool b) -> unaryOp $ NBool (not b)+ _seq ->+ throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show _seq+ _x ->+ throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show _x where- unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (pure arg)))+ unaryOp = pure . nvConstantP (Provenance scope $ NUnary_ span op $ pure arg) execBinaryOp :: forall e t f m@@ -342,7 +334,6 @@ -> NValue t f m -> m (NValue t f m) -> m (NValue t f m)- execBinaryOp scope span op lval rarg = case op of NEq -> helperEq id@@ -376,7 +367,7 @@ ) =<< fromValue lval - boolOp rval = toBoolOp (pure rval)+ boolOp rval = toBoolOp $ pure rval bypass = toBoolOp Nothing @@ -384,7 +375,7 @@ toBoolOp r b = pure $ nvConstantP- (Provenance scope (NBinary_ span op (pure lval) r))+ (Provenance scope $ NBinary_ span op (pure lval) r) (NBool b) execBinaryOpForced@@ -412,7 +403,7 @@ NUpdate -> case (lval, rval) of- (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp `M.union` lp) (rs `M.union` ls)+ (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp <> lp) (rs <> ls) (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov lp ls (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rp rs _ -> unsupportedTypes@@ -452,7 +443,7 @@ where prov :: Provenance m (NValue t f m)- prov = Provenance scope (NBinary_ span op (pure lval) (pure rval))+ prov = Provenance scope $ NBinary_ span op (pure lval) (pure rval) toBool = pure . nvConstantP prov . NBool compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m)@@ -488,7 +479,10 @@ -- This function is here, rather than in 'Nix.String', because of the need to -- use 'throwError'.-fromStringNoContext :: Framed e m => NixString -> m Text+fromStringNoContext+ :: Framed e m+ => NixString+ -> m Text fromStringNoContext ns = maybe (throwError $ ErrorCall $ "expected string with no context, but got " <> show ns)@@ -496,52 +490,51 @@ (getStringNoContext ns) addTracing- :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n)+ ::( MonadNix e t f m+ , Has e Options+ , Alternative n+ , MonadReader Int n+ , MonadFail n+ ) => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a)) addTracing k v = do depth <- ask- guard (depth < 2000)+ guard $ depth < 2000 local succ $ do- v'@(Compose (Ann span x)) <- sequence v+ v'@(AnnFP span x) <- sequence v pure $ do- opts :: Options <- asks (view hasLens)+ opts :: Options <- asks $ view hasLens let rendered = if verbose opts >= Chatty then pretty $-#ifdef MIN_VERSION_pretty_show- PS.ppShow (void x)-#else- show (void x)-#endif- else prettyNix (Fix (Fix (NSym "?") <$ x))+ PS.ppShow $ void x+ else prettyNix $ Fix $ Fix (NSym "?") <$ x msg x = pretty ("eval: " <> replicate depth ' ') <> x- loc <- renderLocation span (msg rendered <> " ...\n")+ loc <- renderLocation span $ msg rendered <> " ...\n" putStr $ show loc res <- k v' print $ msg rendered <> " ...done" pure res evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m)-evalExprLoc expr = do- opts :: Options <- asks (view hasLens)-- bool- (adi- phi- (addStackFrames @(NValue t f m) . addSourcePositions)- )- (join . (`runReaderT` (0 :: Int)) .- adi- (addTracing phi)- (raise (addStackFrames @(NValue t f m) . addSourcePositions))- )- (tracing opts)- expr+evalExprLoc expr =+ do+ opts :: Options <- asks $ view hasLens+ let+ pTracedAdi =+ bool+ Eval.framedEvalExprLoc+ (join . (`runReaderT` (0 :: Int)) .+ adi+ (raise Eval.addMetaInfo)+ (addTracing Eval.evalContent)+ )+ (tracing opts)+ pTracedAdi expr where- phi = Eval.eval . annotated . getCompose raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x exec :: (MonadNix e t f m, MonadInstantiate m) => [Text] -> m (NValue t f m)
src/Nix/Expr/Shorthands.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} -- | A bunch of shorthands for making nix expressions. --@@ -132,8 +131,8 @@ mkDots (Fix (NSelect e keys' x)) keys = -- Special case: if the expression in the first argument is already -- a dotted expression, just extend it.- Fix (NSelect e (keys' <> fmap (StaticKey ?? Nothing) keys) x)-mkDots e keys = Fix $ NSelect e (fmap (StaticKey ?? Nothing) keys) Nothing+ Fix (NSelect e (keys' <> fmap (`StaticKey` Nothing) keys) x)+mkDots e keys = Fix $ NSelect e (fmap (`StaticKey` Nothing) keys) Nothing -} -- | An `inherit` clause without an expression to pull from.@@ -144,11 +143,11 @@ inheritFrom :: e -> [NKeyName e] -> SourcePos -> Binding e inheritFrom expr = Inherit (pure expr) --- | Shorthand for producing a binding of a name to an expression.+-- | Shorthand for producing a binding of a name to an expression: @= bindTo :: Text -> NExpr -> Binding NExpr bindTo name x = NamedVar (mkSelector name) x nullPos --- | Infix version of bindTo.+-- | Infix version of @bindTo@: @=@ ($=) :: Text -> NExpr -> Binding NExpr ($=) = bindTo @@ -165,13 +164,12 @@ -- | Applies a transformation to the body of a nix function. modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr-modifyFunctionBody f (Fix e) = case e of- NAbs params body -> Fix $ NAbs params (f body)- _ -> error "Not a function"+modifyFunctionBody f (Fix (NAbs params body)) = Fix $ NAbs params $ f body+modifyFunctionBody _ _ = error "Not a function" -- | A let statement with multiple assignments. letsE :: [(Text, NExpr)] -> NExpr -> NExpr-letsE pairs = Fix . NLet (fmap (uncurry bindTo) pairs)+letsE pairs = Fix . NLet (uncurry bindTo <$> pairs) -- | Wrapper for a single-variable @let@. letE :: Text -> NExpr -> NExpr -> NExpr@@ -179,11 +177,11 @@ -- | Make an attribute set (non-recursive). attrsE :: [(Text, NExpr)] -> NExpr-attrsE pairs = Fix $ NSet NNonRecursive (fmap (uncurry bindTo) pairs)+attrsE pairs = Fix $ NSet NNonRecursive $ uncurry bindTo <$> pairs -- | Make an attribute set (recursive). recAttrsE :: [(Text, NExpr)] -> NExpr-recAttrsE pairs = Fix $ NSet NRecursive (fmap (uncurry bindTo) pairs)+recAttrsE pairs = Fix $ NSet NRecursive $ uncurry bindTo <$> pairs -- | Logical negation. mkNot :: NExpr -> NExpr@@ -194,38 +192,60 @@ -- (!.) = mkDot -- infixl 8 !. +-- * Nix binary operators++-- | Nix binary operator builder. mkBinop :: NBinaryOp -> NExpr -> NExpr -> NExpr-mkBinop op e1 e2 = Fix (NBinary op e1 e2)+mkBinop op e1 e2 = Fix $ NBinary op e1 e2 --- | Various nix binary operators-($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++)+(@@), ($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++) :: NExpr -> NExpr -> NExpr-e1 $== e2 = mkBinop NEq e1 e2-e1 $!= e2 = mkBinop NNEq e1 e2-e1 $< e2 = mkBinop NLt e1 e2-e1 $<= e2 = mkBinop NLte e1 e2-e1 $> e2 = mkBinop NGt e1 e2-e1 $>= e2 = mkBinop NGte e1 e2-e1 $&& e2 = mkBinop NAnd e1 e2-e1 $|| e2 = mkBinop NOr e1 e2-e1 $-> e2 = mkBinop NImpl e1 e2-e1 $// e2 = mkBinop NUpdate e1 e2-e1 $+ e2 = mkBinop NPlus e1 e2-e1 $- e2 = mkBinop NMinus e1 e2-e1 $* e2 = mkBinop NMult e1 e2-e1 $/ e2 = mkBinop NDiv e1 e2-e1 $++ e2 = mkBinop NConcat e1 e2---- | Function application expression.-(@@) :: NExpr -> NExpr -> NExpr-f @@ arg = mkBinop NApp f arg+-- | Function application (@' '@ in @f x@)+(@@) = mkBinop NApp infixl 1 @@+-- | Equality: @==@+($==) = mkBinop NEq+-- | Inequality: @!=@+($!=) = mkBinop NNEq+-- | Less than: @<@+($<) = mkBinop NLt+-- | Less than OR equal: @<=@+($<=) = mkBinop NLte+-- | Greater than: @>@+($>) = mkBinop NGt+-- | Greater than OR equal: @>=@+($>=) = mkBinop NGte+-- | AND: @&&@+($&&) = mkBinop NAnd+-- | OR: @||@+($||) = mkBinop NOr+-- | Logical implication: @->@+($->) = mkBinop NImpl+-- | Extend/override the left attr set, with the right one: @//@+($//) = mkBinop NUpdate+-- | Addition: @+@+($+) = mkBinop NPlus+-- | Subtraction: @-@+($-) = mkBinop NMinus+-- | Multiplication: @*@+($*) = mkBinop NMult+-- | Division: @/@+($/) = mkBinop NDiv+-- | List concatenation: @++@+($++) = mkBinop NConcat --- | Lambda shorthand.++-- | Lambda function.+-- > x ==> x+--Haskell:+-- > \\ x -> x+--Nix:+-- > x: x (==>) :: Params NExpr -> NExpr -> NExpr (==>) = mkFunction infixr 1 ==> +-- | Dot-reference into an attribute set: @attrSet.k@ (@.) :: NExpr -> Text -> NExpr-obj @. name = Fix (NSelect obj (StaticKey name :| mempty) Nothing)+(@.) obj name = Fix $ NSelect obj (StaticKey name :| mempty) Nothing infixl 2 @.
src/Nix/Expr/Strings.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} -- | Functions for manipulating nix strings. module Nix.Expr.Strings where
src/Nix/Expr/Types.hs view
@@ -1,20 +1,10 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}@@ -23,42 +13,96 @@ -- -- For a brief introduction of the Nix expression language, see -- <https://nixos.org/nix/manual/#ch-expression-language>.+--+-- This module is a beginning of a deep embedding (term) of a Nix language into Haskell.+-- Shallow/deep embedding brief:+-- <https://web.archive.org/web/20201112031804/https://alessandrovermeulen.me/2013/07/13/the-difference-between-shallow-and-deep-embedding/>+--+-- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations module Nix.Expr.Types where -#ifdef MIN_VERSION_serialise import qualified Codec.Serialise as Serialise import Codec.Serialise ( Serialise )-#endif import Control.DeepSeq import Data.Aeson import Data.Aeson.TH import qualified Data.Binary as Binary import Data.Binary ( Binary ) import Data.Data-import Data.Eq.Deriving import Data.Fix import Data.Functor.Classes import Data.Hashable.Lifted import qualified Data.List.NonEmpty as NE-import Data.Ord.Deriving import qualified Text.Show import Data.Traversable import GHC.Generics import qualified Language.Haskell.TH.Syntax as TH import Lens.Family2 import Lens.Family2.TH-import Nix.Atoms-import Nix.Utils-import Text.Megaparsec.Pos-import Text.Read.Deriving+import Text.Megaparsec.Pos ( SourcePos(SourcePos)+ , Pos+ , mkPos+ , unPos+ ) import Text.Show.Deriving+import Text.Read.Deriving+import Data.Eq.Deriving+import Data.Ord.Deriving import qualified Type.Reflection as Reflection import Type.Reflection ( eqTypeRep )+import Nix.Atoms+import Nix.Utils #if !MIN_VERSION_text(1,2,4) -- NOTE: Remove package @th-lift-instances@ removing this import Instances.TH.Lift () -- importing Lift Text fo GHC 8.6 #endif ++-- * Utilitary: orphan instances++-- Placed here because TH inference depends on declaration sequence.++-- Upstreaming so far was not pursued.++instance Serialise Pos where+ encode = Serialise.encode . unPos+ decode = mkPos <$> Serialise.decode++instance Serialise SourcePos where+ encode (SourcePos f l c) =+ Serialise.encode f <>+ Serialise.encode l <>+ Serialise.encode c+ decode =+ liftA3 SourcePos+ Serialise.decode+ Serialise.decode+ Serialise.decode++instance Hashable Pos where+ hashWithSalt salt = hashWithSalt salt . unPos++instance Hashable SourcePos where+ hashWithSalt salt (SourcePos f l c) =+ salt+ `hashWithSalt` f+ `hashWithSalt` l+ `hashWithSalt` c++instance Binary Pos where+ put = Binary.put . unPos+ get = mkPos <$> Binary.get+instance Binary SourcePos++instance ToJSON Pos where+ toJSON = toJSON . unPos+instance ToJSON SourcePos++instance FromJSON Pos where+ parseJSON = fmap mkPos . parseJSON+instance FromJSON SourcePos++ -- * Components of Nix expressions -- NExpr is a composition of@@ -69,37 +113,13 @@ type VarName = Text --- ** @Binding@ --- | A single line of the bindings section of a let expression or of a set.-data Binding r- = NamedVar !(NAttrPath r) !r !SourcePos- -- ^ An explicit naming.- --- -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z SourcePos{} ~ x.y = z;- | Inherit !(Maybe r) ![NKeyName r] !SourcePos- -- ^ Using a name already in scope, such as @inherit x;@ which is shorthand- -- for @x = x;@ or @inherit (x) y;@ which means @y = x.y;@. The- -- @unsafeGetAttrPos@ for every name so inherited is the position of the- -- first name, whether that be the first argument to this constructor, or- -- the first member of the list in the second argument.- --- -- > Inherit Nothing [StaticKey "x"] SourcePos{} ~ inherit x;- -- > Inherit (pure x) mempty SourcePos{} ~ inherit (x);- deriving (Generic, Generic1, Typeable, Data, Ord, Eq, Functor,- Foldable, Traversable, Show, NFData, Hashable)--instance NFData1 Binding--instance Hashable1 Binding--#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (Binding r)-#endif-- -- ** @Params@ +-- This uses an association list because nix XML serialization preserves the+-- order of the param set.+type ParamSet r = [(VarName, Maybe r)]+ -- | @Params@ represents all the ways the formal parameters to a -- function can be represented. data Params r@@ -117,32 +137,30 @@ -- > ParamSet [("x",Nothing)] False Nothing ~ { x } -- > ParamSet [("x",pure y)] True (pure "s") ~ s@{ x ? y, ... } deriving- (Ord, Eq, Generic, Generic1, Typeable, Data, NFData, Hashable, Show,- Functor, Foldable, Traversable)--instance Hashable1 Params--instance NFData1 Params--#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (Params r)-#endif+ ( Eq, Ord, Generic, Generic1+ , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1+ , Functor, Foldable, Traversable+ , Show, Hashable, Hashable1+ ) instance IsString (Params r) where fromString = Param . fromString --- *** @ParamSet@+$(deriveShow1 ''Params)+$(deriveRead1 ''Params)+$(deriveEq1 ''Params)+$(deriveOrd1 ''Params) --- This uses an association list because nix XML serialization preserves the--- order of the param set.-type ParamSet r = [(VarName, Maybe r)]+-- *** Lens traversals +$(makeTraversals ''Params) + -- ** @Antiquoted@ -- | 'Antiquoted' represents an expression that is either -- antiquoted (surrounded by ${...}) or plain (not antiquoted).-data Antiquoted (v :: *) (r :: *)+data Antiquoted (v :: Type) (r :: Type) = Plain !v | EscapedNewline -- ^ 'EscapedNewline' corresponds to the special newline form@@ -153,23 +171,35 @@ -- -- > ''''\n'' ≡ "\n" | Antiquoted !r- deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, Foldable,- Traversable, Show, Read, NFData, Hashable)--instance Hashable v => Hashable1 (Antiquoted v)+ deriving+ ( Eq, Ord, Generic, Generic1+ , Typeable, Data, NFData, NFData1, Serialise, Binary+ , ToJSON, ToJSON1, FromJSON, FromJSON1+ , Functor, Foldable, Traversable+ , Show, Read, Hashable, Hashable1+ ) instance Hashable2 Antiquoted where liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int) liftHashWithSalt2 _ hb salt (Antiquoted b) = hb (salt `hashWithSalt` (2 :: Int)) b -instance NFData v => NFData1 (Antiquoted v)+$(deriveShow1 ''Antiquoted)+$(deriveShow2 ''Antiquoted)+$(deriveRead1 ''Antiquoted)+$(deriveRead2 ''Antiquoted)+$(deriveEq1 ''Antiquoted)+$(deriveEq2 ''Antiquoted)+$(deriveOrd1 ''Antiquoted)+$(deriveOrd2 ''Antiquoted)+$(deriveJSON2 defaultOptions ''Antiquoted) -#ifdef MIN_VERSION_serialise-instance (Serialise v, Serialise r) => Serialise (Antiquoted v r)-#endif +-- *** Lens traversals +$(makeTraversals ''Antiquoted)++ -- ** @NString@ -- | An 'NString' is a list of things that are either a plain string@@ -193,23 +223,28 @@ -- > Indented 0 [Plain "x\n ",Antiquoted y] ~ '' -- > x -- > ${y}''- deriving (Eq, Ord, Generic, Generic1, Typeable, Data, Functor, Foldable,- Traversable, Show, Read, NFData, Hashable)--instance Hashable1 NString--instance NFData1 NString--#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (NString r)-#endif+ deriving+ ( Eq, Ord, Generic, Generic1+ , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1+ , Functor, Foldable, Traversable+ , Show, Read, Hashable, Hashable1+ ) -- | For the the 'IsString' instance, we use a plain doublequoted string. instance IsString (NString r) where fromString "" = DoubleQuoted mempty fromString string = DoubleQuoted [Plain $ toText string] +$(deriveShow1 ''NString)+$(deriveRead1 ''NString)+$(deriveEq1 ''NString)+$(deriveOrd1 ''NString) +-- *** Lens traversals++$(makeTraversals ''NString)++ -- ** @NKeyName@ -- | A 'KeyName' is something that can appear on the left side of an@@ -240,26 +275,11 @@ | StaticKey !VarName -- ^ -- > StaticKey "x" ~ x- deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData, Hashable)--#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (NKeyName r)--instance Serialise Pos where- encode = Serialise.encode . unPos- decode = mkPos <$> Serialise.decode--instance Serialise SourcePos where- 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 = hashWithSalt salt . unPos--instance Hashable SourcePos where- hashWithSalt salt (SourcePos f l c) =- salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c+ deriving+ ( Eq, Ord, Generic+ , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON+ , Show, Read, Hashable+ ) instance NFData1 NKeyName where liftRnf _ (StaticKey !_ ) = ()@@ -319,7 +339,11 @@ DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline StaticKey key -> pure $ StaticKey key +-- *** Lens traversals +$(makeTraversals ''NKeyName)++ -- ** @NAttrPath@ -- | A selector (for example in a @let@ or an attribute set) is made up@@ -328,20 +352,84 @@ -- > StaticKey "x" :| [DynamicKey (Antiquoted y)] ~ x.${y} type NAttrPath r = NonEmpty (NKeyName r) --- ** @NUnaryOp +-- ** @Binding@++#if !MIN_VERSION_hashable(1,3,1)+-- Required by Hashable Binding deriving. There was none of this Hashable instance before mentioned version, remove this in year >2022+instance Hashable1 NonEmpty+#endif++-- | A single line of the bindings section of a let expression or of a set.+data Binding r+ = NamedVar !(NAttrPath r) !r !SourcePos+ -- ^ An explicit naming.+ --+ -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z SourcePos{} ~ x.y = z;+ | Inherit !(Maybe r) ![NKeyName r] !SourcePos+ -- ^ Inheriting an attribute (binding) into the attribute set from the other scope (attribute set). No denoted scope means to inherit from the closest outside scope.+ --+ -- +---------------------------------------------------------------+--------------------+-----------------------++ -- | Hask | Nix | pseudocode |+ -- +===============================================================+====================+=======================++ -- | @Inherit Nothing [StaticKey "a"] SourcePos{}@ | @inherit a;@ | @a = outside.a;@ |+ -- +---------------------------------------------------------------+--------------------+-----------------------++ -- | @Inherit (pure x) [StaticKey "a"] SourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ |+ -- +---------------------------------------------------------------+--------------------+-----------------------++ -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] SourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ |+ -- | | | @b = x.b;@ |+ -- +---------------------------------------------------------------+--------------------+-----------------------++ --+ -- (2021-07-07 use details):+ -- Inherits the position of the first name through @unsafeGetAttrPos@. The position of the scope inherited from else - the position of the first member of the binds list.+ deriving+ ( Eq, Ord, Generic, Generic1+ , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON+ , Functor, Foldable, Traversable+ , Show, Hashable, Hashable1+ )++$(deriveShow1 ''Binding)+$(deriveEq1 ''Binding)+$(deriveOrd1 ''Binding)+--x $(deriveJSON1 defaultOptions ''Binding)++-- *** Lens traversals++$(makeTraversals ''Binding)+++-- ** @NRecordType@++-- | 'NRecordType' distinguishes between recursive and non-recursive attribute+-- sets.+data NRecordType+ = NNonRecursive -- ^ > { ... }+ | NRecursive -- ^ > rec { ... }+ deriving+ ( Eq, Ord, Enum, Bounded, Generic+ , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON+ , Show, Read, Hashable+ )+++-- ** @NUnaryOp@+ -- | There are two unary operations: logical not and integer negation. data NUnaryOp = NNeg -- ^ @-@ | NNot -- ^ @!@- deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,- NFData, Hashable)+ deriving+ ( Eq, Ord, Enum, Bounded, Generic+ , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON+ , Show, Read, Hashable+ ) -#ifdef MIN_VERSION_serialise-instance Serialise NUnaryOp-#endif+-- *** Lens traversals +$(makeTraversals ''NUnaryOp) + -- ** @NBinaryOp@ -- | Binary operators expressible in the nix language.@@ -355,7 +443,7 @@ | NAnd -- ^ Logical and (@&&@) | NOr -- ^ Logical or (@||@) | NImpl -- ^ Logical implication (@->@)- | NUpdate -- ^ Joining two attribute sets (@//@)+ | NUpdate -- ^ Get the left attr set, extend it with the right one & override equal keys (@//@) | NPlus -- ^ Addition (@+@) | NMinus -- ^ Subtraction (@-@) | NMult -- ^ Multiplication (@*@)@@ -364,29 +452,18 @@ | NApp -- ^ Apply a function to an argument. -- -- > NBinary NApp f x ~ f x- deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,- NFData, Hashable)+ deriving+ ( Eq, Ord, Enum, Bounded, Generic+ , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON+ , Show, Read, Hashable+ ) -#ifdef MIN_VERSION_serialise-instance Serialise NBinaryOp-#endif+-- *** Lens traversals +$(makeTraversals ''NBinaryOp) --- ** @NRecordType@ --- | 'NRecordType' distinguishes between recursive and non-recursive attribute--- sets.-data NRecordType- = NNonRecursive -- ^ > { ... }- | NRecursive -- ^ > rec { ... }- deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,- NFData, Hashable)--#ifdef MIN_VERSION_serialise-instance Serialise NRecordType-#endif---- * @NExprF@ - Nix expressions, base functor+-- ** @NExprF@ - Nix expressions, base functor -- | The main Nix expression type. As it is polimophic, has a functor, -- which allows to traverse expressions and map functions over them.@@ -474,26 +551,45 @@ -- See <https://github.com/haskell-nix/hnix/issues/197> for context. -- -- > NSynHole "x" ~ ^x- deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor,- Foldable, Traversable, Show, NFData, Hashable)+ deriving+ ( Eq, Ord, Generic, Generic1+ , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON+ , Functor, Foldable, Traversable+ , Show, Hashable, Hashable1+ ) -instance NFData1 NExprF -#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (NExprF r)-#endif+$(deriveShow1 ''NExprF)+$(deriveEq1 ''NExprF)+$(deriveOrd1 ''NExprF)+--x $(deriveJSON1 defaultOptions ''NExprF) +-- *** Lens traversals++$(makeTraversals ''NExprF)+++-- *** @NExpr@++-- | The monomorphic expression type is a fixed point of the polymorphic one.+type NExpr = Fix NExprF+ -- | We make an `IsString` for expressions, where the string is interpreted -- as an identifier. This is the most common use-case... instance IsString NExpr where fromString = Fix . NSym . fromString -instance TH.Lift (Fix NExprF) where+instance Serialise NExpr++instance TH.Lift NExpr where lift = TH.dataToExpQ (\b -> do- -- Binding on constructor ensures type match and gives type inference to TH+ -- Binding on constructor ensures type match and gives type inference to TH.+ -- Reflection is the ability of a process to examine, introspect, and modify its own structure and behavior.+ -- Reflection is a key strategy in metaprogramming.+ -- <https://en.wikipedia.org/wiki/Reflective_programming> HRefl <- eqTypeRep (Reflection.typeRep @Text)@@ -501,28 +597,47 @@ pure [| $(TH.lift b) |] ) #if MIN_VERSION_template_haskell(2,17,0)- liftTyped = unsafeCodeCoerce . lift+ liftTyped = TH.liftTyped #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = TH.unsafeTExpCoerce . TH.lift #endif -#if !MIN_VERSION_hashable(1,3,1)--- there was none before, remove this in year >2022-instance Hashable1 NonEmpty++-- ** Methods++#if __GLASGOW_HASKELL__ >= 900+hashAt+ :: Functor f+ => VarName+ -> (Maybe v -> f (Maybe v))+ -> AttrSet v+ -> f (AttrSet v)+#else+hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) #endif+hashAt = flip alterF -instance Hashable1 NExprF+-- | Get the name out of the parameter (there might be none).+paramName :: Params r -> Maybe VarName+paramName (Param n ) = pure n+paramName (ParamSet _ _ n) = n +stripPositionInfo :: NExpr -> NExpr+stripPositionInfo = transport phi+ where+ transport f (Fix x) = Fix $ transport f <$> f x --- *** @NExpr@+ phi (NSet recur binds) = NSet recur $ go <$> binds+ phi (NLet binds body) = NLet (go <$> binds) body+ phi x = x --- | The monomorphic expression type is a fixed point of the polymorphic one.-type NExpr = Fix NExprF+ go (NamedVar path r _pos) = NamedVar path r nullPos+ go (Inherit ms names _pos) = Inherit ms names nullPos -#ifdef MIN_VERSION_serialise-instance Serialise NExpr-#endif+nullPos :: SourcePos+nullPos = on (SourcePos "<string>") mkPos 1 1 +-- * Dead code -- ** @class NExprAnn@ @@ -530,103 +645,7 @@ fromNExpr :: g r -> (NExprF r, ann) toNExpr :: (NExprF r, ann) -> g r ---- ** Additional instances--$(deriveEq1 ''NExprF)-$(deriveEq1 ''NString)-$(deriveEq1 ''Binding)-$(deriveEq1 ''Params)-$(deriveEq1 ''Antiquoted)-$(deriveEq2 ''Antiquoted)--$(deriveOrd1 ''NExprF)-$(deriveOrd1 ''NString)-$(deriveOrd1 ''Binding)-$(deriveOrd1 ''Params)-$(deriveOrd1 ''Antiquoted)-$(deriveOrd2 ''Antiquoted)--$(deriveRead1 ''NString)-$(deriveRead1 ''Params)-$(deriveRead1 ''Antiquoted)-$(deriveRead2 ''Antiquoted)--$(deriveShow1 ''NExprF)-$(deriveShow1 ''NString)-$(deriveShow1 ''Params)-$(deriveShow1 ''Binding)-$(deriveShow1 ''Antiquoted)-$(deriveShow2 ''Antiquoted)----x $(deriveJSON1 defaultOptions ''NExprF)-$(deriveJSON1 defaultOptions ''NString)-$(deriveJSON1 defaultOptions ''Params)---x $(deriveJSON1 defaultOptions ''Binding)-$(deriveJSON1 defaultOptions ''Antiquoted)-$(deriveJSON2 defaultOptions ''Antiquoted)--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 = Binary.put . unPos- get = mkPos <$> Binary.get-instance Binary SourcePos-instance Binary a => Binary (NKeyName a)-instance Binary a => Binary (Params a)-instance Binary NUnaryOp-instance Binary NBinaryOp-instance Binary NRecordType-instance Binary a => Binary (NExprF a)--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 = toJSON . unPos-instance ToJSON SourcePos-instance ToJSON a => ToJSON (NKeyName a)-instance ToJSON a => ToJSON (Params a)-instance ToJSON NUnaryOp-instance ToJSON NBinaryOp-instance ToJSON NRecordType-instance ToJSON a => ToJSON (NExprF a)--instance (FromJSON v, FromJSON a) => FromJSON (Antiquoted v a)-instance FromJSON a => FromJSON (NString a)-instance FromJSON a => FromJSON (Binding a)-instance FromJSON Pos where- parseJSON = fmap mkPos . parseJSON-instance FromJSON SourcePos-instance FromJSON a => FromJSON (NKeyName a)-instance FromJSON a => FromJSON (Params a)-instance FromJSON NUnaryOp-instance FromJSON NBinaryOp-instance FromJSON NRecordType-instance FromJSON a => FromJSON (NExprF a)--$(makeTraversals ''NExprF)-$(makeTraversals ''Binding)-$(makeTraversals ''Params)-$(makeTraversals ''Antiquoted)-$(makeTraversals ''NString)-$(makeTraversals ''NKeyName)-$(makeTraversals ''NUnaryOp)-$(makeTraversals ''NBinaryOp)----x $(makeLenses ''Fix)----- ** Methods--hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)-hashAt = flip alterF---- | Get the name out of the parameter (there might be none).-paramName :: Params r -> Maybe VarName-paramName (Param n ) = pure n-paramName (ParamSet _ _ n) = n+-- ** Other ekey :: NExprAnn ann g@@ -642,8 +661,9 @@ maybe e (\ v ->- let entry = NamedVar (NE.map StaticKey keys) v pos in- Fix (toNExpr (NSet NNonRecursive (entry : xs), ann)))+ let entry = NamedVar (StaticKey <$> keys) v pos in+ Fix $ toNExpr ( NSet NNonRecursive $ [entry] <> xs, ann )+ ) <$> f Nothing where@@ -662,18 +682,3 @@ ks ekey _ _ f e = fromMaybe e <$> f Nothing--stripPositionInfo :: NExpr -> NExpr-stripPositionInfo = transport phi- where- transport f (Fix x) = Fix $ transport f <$> f x-- phi (NSet recur binds) = NSet recur $ go <$> binds- phi (NLet binds body) = NLet (go <$> binds) body- phi x = x-- go (NamedVar path r _pos) = NamedVar path r nullPos- go (Inherit ms names _pos) = Inherit ms names nullPos--nullPos :: SourcePos-nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)
src/Nix/Expr/Types/Annotated.hs view
@@ -1,11 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}@@ -21,9 +16,7 @@ ) where -#ifdef MIN_VERSION_serialise import Codec.Serialise-#endif import Control.DeepSeq import Data.Aeson ( ToJSON(..) , FromJSON(..)@@ -59,15 +52,16 @@ -- ** Instances instance Semigroup SrcSpan where- s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2)+ s1 <> s2 =+ SrcSpan+ ((min `on` spanBegin) s1 s2)+ ((max `on` spanEnd ) s1 s2) instance Binary SrcSpan instance ToJSON SrcSpan instance FromJSON SrcSpan -#ifdef MIN_VERSION_serialise instance Serialise SrcSpan-#endif -- * data type @Ann@ @@ -84,15 +78,23 @@ type AnnF ann f = Compose (Ann ann) f +-- | Pattern: @(Compose (Ann _ _))@.+pattern AnnFP+ :: ann+ -> f a+ -> Compose (Ann ann) f a+pattern AnnFP ann f = Compose (Ann ann f)+{-# complete AnnFP #-}+ -- | Pattern: @Fix (Compose (Ann _ _))@. -- Fix composes units of (annotations & the annotated) into one object. -- Giving annotated expression. pattern AnnE- :: forall ann (g :: * -> *)+ :: forall ann (f :: Type -> Type) . ann- -> g (Fix (Compose (Ann ann) g))- -> Fix (Compose (Ann ann) g)-pattern AnnE ann a = Fix (Compose (Ann ann a))+ -> f (Fix (AnnF ann f))+ -> Fix (AnnF ann f)+pattern AnnE ann a = Fix (AnnFP ann a) {-# complete AnnE #-} annToAnnF :: Ann ann (f (Fix (AnnF ann f))) -> Fix (AnnF ann f)@@ -117,35 +119,32 @@ $(deriveJSON1 defaultOptions ''Ann) $(deriveJSON2 defaultOptions ''Ann) -#ifdef MIN_VERSION_serialise instance (Serialise ann, Serialise a) => Serialise (Ann ann a)-#endif -#ifdef MIN_VERSION_serialise-instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where- encode (Compose (Ann ann a)) = encode ann <> encode a- decode = (Compose .) . Ann <$> decode <*> decode-#endif- -- ** @NExprLoc{,F}@ - annotated Nix expression type NExprLocF = AnnF SrcSpan NExprF +instance Serialise r => Serialise (NExprLocF r) where+ encode (AnnFP ann a) = encode ann <> encode a+ decode =+ liftA2 AnnFP+ decode+ decode+ instance Binary r => Binary (NExprLocF r) -- | Annotated Nix expression (each subexpression direct to its source location). type NExprLoc = Fix NExprLocF -#ifdef MIN_VERSION_serialise instance Serialise NExprLoc-#endif instance Binary NExprLoc -- * Other stripAnnotation :: Functor f => Fix (AnnF ann f) -> Fix f-stripAnnotation = unfoldFix (annotated . getCompose . unFix)+stripAnnotation = unfoldFix (stripAnn . unFix) stripAnn :: AnnF ann f r -> f r stripAnn = annotated . getCompose@@ -186,7 +185,7 @@ deltaInfo (SourcePos fp l c) = (toText fp, unPos l, unPos c) nNull :: NExprLoc-nNull = Fix $ Compose $ Ann nullSpan $ NConstant NNull+nNull = AnnE nullSpan $ NConstant NNull {-# inline nNull #-} nullSpan :: SrcSpan@@ -196,53 +195,53 @@ -- | Pattern systems for matching on NExprLocF constructions. pattern NConstant_ :: SrcSpan -> NAtom -> NExprLocF r-pattern NConstant_ ann x = Compose (Ann ann (NConstant x))+pattern NConstant_ ann x = AnnFP ann (NConstant x) pattern NStr_ :: SrcSpan -> NString r -> NExprLocF r-pattern NStr_ ann x = Compose (Ann ann (NStr x))+pattern NStr_ ann x = AnnFP ann (NStr x) pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r-pattern NSym_ ann x = Compose (Ann ann (NSym x))+pattern NSym_ ann x = AnnFP ann (NSym x) pattern NList_ :: SrcSpan -> [r] -> NExprLocF r-pattern NList_ ann x = Compose (Ann ann (NList x))+pattern NList_ ann x = AnnFP ann (NList x) pattern NSet_ :: SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r-pattern NSet_ ann recur x = Compose (Ann ann (NSet recur x))+pattern NSet_ ann recur x = AnnFP ann (NSet recur x) pattern NLiteralPath_ :: SrcSpan -> FilePath -> NExprLocF r-pattern NLiteralPath_ ann x = Compose (Ann ann (NLiteralPath x))+pattern NLiteralPath_ ann x = AnnFP ann (NLiteralPath x) pattern NEnvPath_ :: SrcSpan -> FilePath -> NExprLocF r-pattern NEnvPath_ ann x = Compose (Ann ann (NEnvPath x))+pattern NEnvPath_ ann x = AnnFP ann (NEnvPath x) pattern NUnary_ :: SrcSpan -> NUnaryOp -> r -> NExprLocF r-pattern NUnary_ ann op x = Compose (Ann ann (NUnary op x))+pattern NUnary_ ann op x = AnnFP ann (NUnary op x) pattern NBinary_ :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r-pattern NBinary_ ann op x y = Compose (Ann ann (NBinary op x y))+pattern NBinary_ ann op x y = AnnFP ann (NBinary op x y) pattern NSelect_ :: SrcSpan -> r -> NAttrPath r -> Maybe r -> NExprLocF r-pattern NSelect_ ann x p v = Compose (Ann ann (NSelect x p v))+pattern NSelect_ ann x p v = AnnFP ann (NSelect x p v) pattern NHasAttr_ :: SrcSpan -> r -> NAttrPath r -> NExprLocF r-pattern NHasAttr_ ann x p = Compose (Ann ann (NHasAttr x p))+pattern NHasAttr_ ann x p = AnnFP ann (NHasAttr x p) pattern NAbs_ :: SrcSpan -> Params r-> r -> NExprLocF r-pattern NAbs_ ann x b = Compose (Ann ann (NAbs x b))+pattern NAbs_ ann x b = AnnFP ann (NAbs x b) pattern NLet_ :: SrcSpan -> [Binding r] -> r -> NExprLocF r-pattern NLet_ ann x b = Compose (Ann ann (NLet x b))+pattern NLet_ ann x b = AnnFP ann (NLet x b) pattern NIf_ :: SrcSpan -> r -> r -> r -> NExprLocF r-pattern NIf_ ann c t e = Compose (Ann ann (NIf c t e))+pattern NIf_ ann c t e = AnnFP ann (NIf c t e) pattern NWith_ :: SrcSpan -> r -> r -> NExprLocF r-pattern NWith_ ann x y = Compose (Ann ann (NWith x y))+pattern NWith_ ann x y = AnnFP ann (NWith x y) pattern NAssert_ :: SrcSpan -> r -> r -> NExprLocF r-pattern NAssert_ ann x y = Compose (Ann ann (NAssert x y))+pattern NAssert_ ann x y = AnnFP ann (NAssert x y) pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r-pattern NSynHole_ ann x = Compose (Ann ann (NSynHole x))+pattern NSynHole_ ann x = AnnFP ann (NSynHole x) {-# complete NConstant_, NStr_, NSym_, NList_, NSet_, NLiteralPath_, NEnvPath_, NUnary_, NBinary_, NSelect_, NHasAttr_, NAbs_, NLet_, NIf_, NWith_, NAssert_, NSynHole_ #-}
src/Nix/Frames.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Definitions of Frames. Frames are messages that gather and ship themself with a context related to the message. For example - the message about some exception would also gather, keep and bring with it the tracing information.@@ -54,11 +52,11 @@ withFrame :: forall s e m a . (Framed e m, Exception s) => NixLevel -> s -> m a -> m a-withFrame level f = local (over hasLens (NixFrame level (toException f) :))+withFrame level f = local $ over hasLens (NixFrame level (toException f) :) throwError :: forall s e m a . (Framed e m, Exception s, MonadThrow m) => s -> m a throwError err = do context <- asks (view hasLens) traceM "Throwing fail..."- throwM $ NixException (NixFrame Error (toException err) : context)+ throwM $ NixException $ NixFrame Error (toException err) : context
src/Nix/Fresh.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,14 +15,13 @@ ) import Control.Monad.Except ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..)- , MonadRef()+ , MonadRef(Ref) ) -import Nix.Var import Nix.Thunk --newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a }+-- 2021-06-02: NOTE: Remove singleton newtype accessor in favour of free coerce+newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Ref m i) m a } deriving ( Functor , Applicative@@ -49,7 +45,7 @@ liftBase = FreshIdT . liftBase instance- ( MonadVar m+ ( MonadAtomicRef m , Eq i , Ord i , Show i@@ -61,7 +57,7 @@ type ThunkId (FreshIdT i m) = i freshId = FreshIdT $ do v <- ask- atomicModifyVar v (\i -> (succ i, i))+ atomicModifyRef v (\i -> (succ i, i)) -runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a+runFreshIdT :: Functor m => Ref m i -> FreshIdT i m a -> m a runFreshIdT i m = runReaderT (unFreshIdT m) i
src/Nix/Fresh/Basic.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -36,7 +33,7 @@ findEnvPath = lift . findEnvPath @t @f @m findPath vs path = do i <- FreshIdT ask- let vs' = fmap (unliftNValue (runFreshIdT i)) vs+ let vs' = unliftNValue (runFreshIdT i) <$> vs lift $ findPath @t @f @m vs' path importPath path = do i <- FreshIdT ask
src/Nix/Json.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} module Nix.Json where
src/Nix/Lint.hs view
@@ -1,18 +1,11 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -Wno-missing-methods #-}@@ -47,7 +40,6 @@ import Nix.Scope import Nix.Thunk import Nix.Thunk.Basic-import Nix.Var import Nix.Value.Monad data TAtom@@ -57,7 +49,7 @@ | TNull deriving (Show, Eq, Ord) -data NTypeF (m :: * -> *) r+data NTypeF (m :: Type -> Type) r = TConstant [TAtom] | TStr | TList r@@ -93,9 +85,9 @@ | NMany [r] deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -type SThunk (m :: * -> *) = NThunkF m (Symbolic m)+type SThunk (m :: Type -> Type) = NThunkF m (Symbolic m) -type SValue (m :: * -> *) = Var m (NSymbolicF (NTypeF m (Symbolic m)))+type SValue (m :: Type -> Type) = Ref m (NSymbolicF (NTypeF m (Symbolic m))) data Symbolic m = SV { getSV :: SValue m } | ST { getST :: SThunk m } @@ -103,32 +95,32 @@ show _ = "<symbolic>" everyPossible- :: MonadVar m+ :: MonadAtomicRef m => m (Symbolic m) everyPossible = packSymbolic NAny mkSymbolic- :: MonadVar m+ :: MonadAtomicRef m => [NTypeF m (Symbolic m)] -> m (Symbolic m) mkSymbolic xs = packSymbolic (NMany xs) packSymbolic- :: MonadVar m+ :: MonadAtomicRef m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)-packSymbolic = fmap SV . newVar+packSymbolic = fmap SV . newRef unpackSymbolic- :: (MonadVar m, MonadThunkId m, MonadCatch m)+ :: (MonadAtomicRef m, MonadThunkId m, MonadCatch m) => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))-unpackSymbolic = readVar . getSV <=< demand+unpackSymbolic = readRef . getSV <=< demand type MonadLint e m = ( Scoped (Symbolic m) m , Framed e m- , MonadVar m+ , MonadAtomicRef m , MonadCatch m , MonadThunkId m )@@ -236,7 +228,7 @@ <$> go xs ys -} --- | unify raises an fail if the result is would be 'NMany mempty'.+-- | Result @== NMany []@ -> @unify@ fails. unify :: forall e m . MonadLint e m@@ -245,22 +237,23 @@ -> Symbolic m -> m (Symbolic m) unify context (SV x) (SV y) = do- x' <- readVar x- y' <- readVar y+ x' <- readRef x+ y' <- readRef y case (x', y') of (NAny, _) -> do- writeVar x y'+ writeRef x y' pure $ SV y (_, NAny) -> do- writeVar y x'+ writeRef y x' pure $ SV x (NMany xs, NMany ys) -> do m <- merge context xs ys bool (do- writeVar x (NMany m)- writeVar y (NMany m)- packSymbolic (NMany m))+ writeRef x (NMany m)+ writeRef y (NMany m)+ packSymbolic (NMany m)+ ) (do -- x' <- renderSymbolic (Symbolic x) -- y' <- renderSymbolic (Symbolic y)@@ -414,8 +407,9 @@ NUpdate -> [TSet mempty] NConcat -> [TList y]-+#if __GLASGOW_HASKELL__ < 900 _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope+#endif where check lsym rsym xs = do@@ -475,13 +469,13 @@ runLintM :: Options -> Lint s a -> ST s a runLintM opts action = do- i <- newVar (1 :: Int)+ i <- newRef (1 :: Int) runFreshIdT i $ (`runReaderT` newContext opts) $ runLint action symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m))-symbolicBaseEnv = pure emptyScopes+symbolicBaseEnv = pure mempty lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s)) lint opts expr =@@ -492,8 +486,8 @@ pushScopes basis (adi- (Eval.eval . annotated . getCompose) Eval.addSourcePositions+ Eval.evalContent expr )
src/Nix/Normal.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} @@ -21,7 +19,6 @@ ) import Nix.Cited import Nix.Frames-import Nix.String import Nix.Thunk import Nix.Value @@ -40,7 +37,7 @@ ) => NValue t f m -> m (NValue t f m)-normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v+normalizeValue v = run $ iterNValueM run (flip go) (fmap Free . sequenceNValue' run) v where start = 0 :: Int table = mempty@@ -60,7 +57,9 @@ (do i <- ask when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels"- lifted (lifted $ \f -> f =<< force t) $ local succ . k+ (lifted . lifted)+ (=<< force t)+ (local succ . k) ) (pure $ pure t) b@@ -84,7 +83,7 @@ => (forall r . t -> (NValue t f m -> m r) -> m r) -> NValue t f m -> m (NValue t f m)-normalizeValueF f = run . iterNValueM run go (fmap Free . sequenceNValue' run)+normalizeValueF f = run . iterNValueM run (flip go) (fmap Free . sequenceNValue' run) where start = 0 :: Int table = mempty@@ -142,6 +141,9 @@ -> m () normalForm_ t = void $ normalizeValue t +opaqueVal :: Applicative f => NValue t f m+opaqueVal = nvStrWithoutContext "<cycle>"+ -- | Detect cycles & stub them. stubCycles :: forall t f m@@ -153,7 +155,7 @@ -> NValue t f m stubCycles = iterNValue- (\t _ ->+ (\_ t -> Free $ NValue' $ foldr@@ -163,8 +165,23 @@ ) Free where- Free (NValue' cyc) = opaque+ Free (NValue' cyc) = opaqueVal +thunkStubVal :: Applicative f => NValue t f m+thunkStubVal = nvStrWithoutContext thunkStubText++-- | Check if thunk @t@ is computed,+-- then bind it into first arg.+-- else bind the thunk stub val.+bindComputedThunkOrStub+ :: ( Applicative f+ , MonadThunk t m (NValue t f m)+ )+ => (NValue t f m -> m a)+ -> t+ -> m a+bindComputedThunkOrStub = (<=< query (pure thunkStubVal))+ removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValue t f m@@ -172,15 +189,11 @@ removeEffects = iterNValueM id- -- 2021-02-25: NOTE: Please, unflip this up the stack- (\ t f -> f =<< queryM (pure opaque) t)+ bindComputedThunkOrStub (fmap Free . sequenceNValue' id) -opaque :: Applicative f => NValue t f m-opaque = nvStr $ makeNixStringWithoutContext "<cycle>"- dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => t -> m (NValue t f m)-dethunk = removeEffects <=< queryM (pure opaque)+dethunk = bindComputedThunkOrStub removeEffects
src/Nix/Options.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE StrictData #-}+ -- | Definitions & defaults for the CLI options module Nix.Options where
src/Nix/Parser.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -66,9 +63,7 @@ import Data.Fix ( Fix(..) ) import qualified Data.HashSet as HashSet import qualified Data.Map as Map-import Data.Text ( cons- , singleton- )+import Data.Text ( cons ) import Nix.Expr hiding ( ($>) ) import Nix.Expr.Strings ( escapeCodes , stripIndent@@ -339,7 +334,7 @@ <?> "double quoted string" doubleQ = void $ char '"'- doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)+ doubleEscape = Plain . one <$> (char '\\' *> escapeCode) indented :: Parser (NString NExprLoc) indented =@@ -363,13 +358,13 @@ pure $ bool EscapedNewline- (Plain $ singleton c)+ (Plain $ one c) (c /= '\n') stringChar end escStart esc = Antiquoted <$> (antiStart *> nixToplevelForm <* char '}')- <+> Plain . singleton <$>+ <+> Plain . one <$> char '$' <+> esc <+> Plain . toText <$> some plainChar where
src/Nix/Pretty.hs view
@@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -58,7 +53,7 @@ -- behaves as if its root operator had a precedence higher than all -- other operators (including function application). simpleExpr :: Doc ann -> NixDoc ann-simpleExpr = mkNixDoc (OperatorInfo minBound NAssocNone "simple expr")+simpleExpr = mkNixDoc $ OperatorInfo minBound NAssocNone "simple expr" pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True }@@ -89,7 +84,7 @@ bool (\ a -> "(" <> a <> ")") id- (precedence (rootOp sub) < precedence op+ ( precedence (rootOp sub) < precedence op || (precedence (rootOp sub) == precedence op && associativity (rootOp sub) == associativity op && associativity op /= NAssocNone)@@ -165,7 +160,7 @@ prettyBind (NamedVar n v _p) = prettySelector n <> " = " <> withoutParens v <> ";" prettyBind (Inherit s ns _p) =- "inherit " <> scope <> align (fillSep (fmap prettyKeyName ns)) <> ";"+ "inherit " <> scope <> align (fillSep $ prettyKeyName <$> ns) <> ";" where scope = maybe@@ -200,7 +195,7 @@ -> Doc ann prettyOriginExpr = withoutParens . go where- go = exprFNixDoc . annotated . getCompose . fmap render+ go = exprFNixDoc . stripAnn . fmap render render :: Maybe (NValue t f m) -> NixDoc ann render Nothing = simpleExpr "_"@@ -240,8 +235,11 @@ ] where opInfo = getBinaryOperator op- f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }- | otherwise = opInfo+ f x =+ bool+ opInfo+ (opInfo { associativity = NAssocNone })+ (associativity opInfo /= x) NUnary op r1 -> mkNixDoc opInfo@@ -312,7 +310,7 @@ valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr-valueToExpr = iterNValue (\_ _ -> thk) (Fix . phi)+valueToExpr = iterNValueByDiscardWith thk (Fix . phi) where thk = Fix . NSym $ "<expr>" @@ -377,9 +375,9 @@ -- | This function is used only by the testing code. printNix :: forall t f m . MonadDataContext f m => NValue t f m -> String-printNix = iterNValue (\_ _ -> thk) phi+printNix = iterNValueByDiscardWith thk phi where- thk = "<thunk>"+ thk = toString thunkStubText phi :: NValue' t f m String -> String phi (NVConstant' a ) = toString $ atomText a
src/Nix/Reduce.hs view
@@ -1,15 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -38,8 +32,12 @@ , foldFix , foldFixM )-import qualified Data.HashMap.Lazy as M-import qualified Data.HashMap.Strict as MS+import qualified Data.HashMap.Internal as HM+ ( lookup+ , insert+ , singleton+ , fromList+ ) import qualified Data.List.NonEmpty as NE import qualified Text.Show import Nix.Atoms@@ -64,7 +62,7 @@ ) ( StateT ( HashMap FilePath NExprLoc- , MS.HashMap Text Text+ , HashMap Text Text ) m )@@ -74,7 +72,7 @@ ( Functor, Applicative, Alternative , Monad, MonadPlus, MonadFix, MonadIO, MonadFail , MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc)- , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text)+ , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) ) staticImport@@ -98,7 +96,7 @@ maybe (go path') pure- (M.lookup path' imports)+ (HM.lookup path' imports) where go path = do liftIO $ putStrLn $ "Importing file " <> path@@ -116,12 +114,12 @@ (Fix (NLiteralPath_ pann path)) pos x' = Fix $ NLet_ span [cur] x- modify $ first $ M.insert path x'+ modify $ first $ HM.insert path x' local- (const (pure path, emptyScopes @m @NExprLoc)) $+ (const (pure path, mempty)) $ do x'' <- foldFix reduce x'- modify $ first $ M.insert path x''+ modify $ first $ HM.insert path x'' pure x'' ) eres@@ -134,8 +132,8 @@ reduceExpr :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc reduceExpr mpath expr =- (`evalStateT` (mempty, MS.empty))- . (`runReaderT` (mpath, emptyScopes))+ (`evalStateT` (mempty, mempty))+ . (`runReaderT` (mpath, mempty)) . runReducer $ foldFix reduce expr @@ -145,7 +143,7 @@ , Scoped NExprLoc m , MonadFail m , MonadReader (Maybe FilePath, Scopes m NExprLoc) m- , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) m+ , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m ) => NExprLocF (m NExprLoc) -> m NExprLoc@@ -183,7 +181,7 @@ do x <- arg pushScope- (M.singleton name x)+ (HM.singleton name x) (foldFix reduce body) f -> Fix . NBinary_ bann NApp f <$> arg@@ -257,7 +255,7 @@ -- Encountering a 'with' construction eliminates any hope of inlining -- definitions. reduce (NWith_ ann scope body) =- clearScopes @NExprLoc $ Fix <$> (NWith_ ann <$> scope <*> body)+ clearScopes @NExprLoc $ Fix <$> liftA2 (NWith_ ann) scope body -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope.@@ -265,16 +263,16 @@ do binds' <- traverse sequence binds body' <-- (`pushScope` body) . M.fromList . catMaybes =<<+ (`pushScope` body) . HM.fromList . catMaybes =<< traverse (\case NamedVar (StaticKey name :| []) def _pos -> let defcase = \case- d@(Fix NAbs_{} ) -> pure (name, d)+ d@(Fix NAbs_ {}) -> pure (name, d) d@(Fix NConstant_{}) -> pure (name, d)- d@(Fix NStr_{} ) -> pure (name, d)+ d@(Fix NStr_ {}) -> pure (name, d) _ -> Nothing in defcase <$> def@@ -285,14 +283,14 @@ -- let names = gatherNames body' -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case- -- NamedVar (StaticKey name _ :| mempty) _ ->+ -- NamedVar (StaticKey name _ :| []) _ -> -- name `S.member` names -- _ -> True pure $ Fix $ NLet_ ann binds' body' -- where -- go m [] = pure m -- go m (x:xs) = case x of- -- NamedVar (StaticKey name _ :| mempty) def -> do+ -- NamedVar (StaticKey name _ :| []) def -> do -- v <- pushScope m def -- go (M.insert name v m) xs -- _ -> go m xs@@ -320,9 +318,9 @@ let args = case params' of- Param name -> M.singleton name $ Fix $ NSym_ ann name+ Param name -> HM.singleton name $ Fix $ NSym_ ann name ParamSet pset _ _ ->- M.fromList $ (\(k, _) -> (k, Fix $ NSym_ ann k)) <$> pset+ HM.fromList $ (\(k, _) -> (k, Fix $ NSym_ ann k)) <$> pset Fix . NAbs_ ann params' <$> pushScope args body reduce v = Fix <$> sequence v@@ -357,7 +355,7 @@ prune = \case NStr str -> pure $ NStr $ pruneString str NHasAttr (Just aset) attr ->- pure $ NHasAttr aset $ NE.map pruneKeyName attr+ pure $ NHasAttr aset $ pruneKeyName <$> attr NAbs params (Just body) -> pure $ NAbs (pruneParams params) body NList l -> pure $ NList $@@ -381,7 +379,7 @@ (mapMaybe pruneBinding binds) NSelect (Just aset) attr alt ->- pure $ NSelect aset (NE.map pruneKeyName attr) (join alt)+ pure $ NSelect aset (pruneKeyName <$> attr) $ join alt -- These are the only short-circuiting binary operators NBinary NAnd (Just (AnnE _ larg)) _ -> pure larg@@ -401,11 +399,9 @@ -- If the scope of a with was never referenced, it's not needed NWith Nothing (Just (AnnE _ body)) -> pure body - NAssert Nothing _ ->- fail "How can an assert be used, but its condition not?"-+ NAssert Nothing _ -> fail "How can an assert be used, but its condition not?" NAssert _ (Just (AnnE _ body)) -> pure body- NAssert (Just cond) _ -> pure $ NAssert cond nNull+ NAssert (Just cond) _ -> pure $ NAssert cond nNull NIf Nothing _ _ -> fail "How can an if be used, but its condition not?" @@ -415,9 +411,8 @@ x -> sequence x pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc- pruneString (DoubleQuoted xs) =- DoubleQuoted (mapMaybe pruneAntiquotedText xs)- pruneString (Indented n xs) = Indented n (mapMaybe pruneAntiquotedText xs)+ pruneString (DoubleQuoted xs) = DoubleQuoted $ mapMaybe pruneAntiquotedText xs+ pruneString (Indented n xs) = Indented n $ mapMaybe pruneAntiquotedText xs pruneAntiquotedText :: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)@@ -453,13 +448,11 @@ (fromMaybe nNull) pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)- pruneBinding (NamedVar _ Nothing _) = Nothing- pruneBinding (NamedVar xs (Just x) pos) =- pure $ NamedVar (NE.map pruneKeyName xs) x pos- pruneBinding (Inherit _ [] _) = Nothing- pruneBinding (Inherit (join -> Nothing) _ _) = Nothing- pruneBinding (Inherit (join -> m) xs pos) =- pure $ Inherit m (pruneKeyName <$> xs) pos+ pruneBinding (NamedVar _ Nothing _ ) = Nothing+ pruneBinding (NamedVar xs (Just x) pos) = pure $ NamedVar (pruneKeyName <$> xs) x pos+ pruneBinding (Inherit _ [] _ ) = Nothing+ pruneBinding (Inherit (join -> Nothing) _ _ ) = Nothing+ pruneBinding (Inherit (join -> m) xs pos) = pure $ Inherit m (pruneKeyName <$> xs) pos reducingEvalExpr :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)@@ -470,7 +463,8 @@ reducingEvalExpr eval mpath expr = do expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)- eres <- catch (pure <$> foldFix (addEvalFlags eval) expr') $ pure . Left+ eres <- (`catch` pure . Left) $+ pure <$> foldFix (addEvalFlags eval) expr' opts :: Options <- asks $ view hasLens expr'' <- pruneTree opts expr' pure (fromMaybe nNull expr'', eres)
src/Nix/Render.hs view
@@ -2,22 +2,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-} module Nix.Render where import Prelude hiding ( readFile ) --- Please reduce Unsafe-import Relude.Unsafe ( read ) import qualified Data.ByteString as BS import qualified Data.Set as Set-import Data.List ( maximum ) import Nix.Utils.Fix1 ( Fix1T , MonadFix1T ) import Nix.Expr.Types.Annotated@@ -103,8 +100,8 @@ :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a) sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg = do- let beg' = max 1 $ min begLine $ begLine - 3- end' = max endLine $ endLine + 3+ let beg' = max 1 $ begLine - 3+ end' = endLine + 3 ls <- fmap pretty . take (end' - beg')@@ -113,14 +110,28 @@ . decodeUtf8 <$> readFile path let- nums = zipWith (curry (show . fst)) [beg' ..] ls- longest = maximum $ length <$> nums- nums' = (\n -> replicate (longest - length n) ' ' <> n) <$> nums- pad n | read n == begLine = "==> " <> n- | otherwise = " " <> n- ls' =- zipWith- (\ a b -> a <> space <> b)- (pretty . pad <$> nums')- (("| " <>) <$> ls)- pure $ vsep $ ls' <> [msg]+ longest = length $ show @String (beg' + (length ls) - 1)+ pad n =+ let+ ns = show n+ nsp = replicate (longest - length ns) ' ' <> ns+ in+ if+ | n == begLine && n == endLine -> "==> " <> nsp <> " | "+ | n >= begLine && n <= endLine -> " > " <> nsp <> " | "+ | otherwise -> " " <> nsp <> " | "+ composeLine n l =+ [pretty (pad n) <> l]+ ++ [ pretty+ $ replicate (length (pad n) - 3) ' '+ <> "| "+ <> replicate (_begCol - 1) ' '+ <> replicate (_endCol - _begCol) '^'+ | begLine == endLine && n == endLine ]+ -- XXX: Consider inserting the message here when it is small enough.+ -- ATM some messages are so huge that they take prevalence over the source listing.+ -- ++ [ indent (length $ pad n) msg | n == endLine ]++ ls' = concat $ zipWith composeLine [beg' ..] ls++ pure $ vsep $ ls' ++ [ indent (length $ pad begLine) msg ]
src/Nix/Render/Frame.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -29,9 +26,7 @@ import Prettyprinter hiding ( list ) import qualified Text.Show as Text import Text.Megaparsec.Pos ( sourcePosPretty)-#ifdef MIN_VERSION_pretty_show import qualified Text.Show.Pretty as PS-#endif renderFrames :: forall v t f e m ann@@ -66,7 +61,7 @@ (framePos @v @m f) framePos- :: forall v (m :: * -> *)+ :: forall v (m :: Type -> Type) . (Typeable m, Typeable v) => NixFrame -> Maybe SourcePos@@ -156,11 +151,7 @@ opts :: Options <- asks (view hasLens) let rendered | verbose opts >= DebugInfo =-#ifdef MIN_VERSION_pretty_show pretty (PS.ppShow (stripAnnotation e))-#else- pretty (show (stripAnnotation e))-#endif | verbose opts >= Chatty = prettyNix (stripAnnotation e) | otherwise = prettyNix (Fix (Fix (NSym "<?>") <$ x)) pure $@@ -209,7 +200,7 @@ -> NValue t f m -> m (Doc ann) renderValue _level _longLabel _shortLabel v = do- opts :: Options <- asks (view hasLens)+ opts :: Options <- asks $ view hasLens bool prettyNValue prettyNValueProv
src/Nix/Scope.hs view
@@ -1,12 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} module Nix.Scope where @@ -47,8 +43,7 @@ Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw) instance Monoid (Scopes m a) where- mempty = emptyScopes- mappend = (<>)+ mempty = emptyScopes emptyScopes :: forall m a . Scopes m a emptyScopes = Scopes mempty mempty
src/Nix/Standard.hs view
@@ -1,21 +1,15 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-orphans #-} module Nix.Standard where -import Control.Applicative+import Prelude hiding ( force ) import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch ( MonadThrow@@ -27,8 +21,9 @@ #endif import Control.Monad.Free ( Free(Pure, Free) ) import Control.Monad.Reader ( MonadFix )-import Control.Monad.Ref ( MonadAtomicRef )-import qualified Data.HashMap.Strict+import Control.Monad.Ref ( MonadRef(newRef)+ , MonadAtomicRef+ ) import qualified Text.Show import Nix.Cited import Nix.Cited.Basic@@ -48,12 +43,11 @@ import Nix.Utils.Fix1 ( Fix1T(Fix1T) ) import Nix.Value import Nix.Value.Monad-import Nix.Var-import Prelude hiding (force) -newtype StdCited m a = StdCited- { _stdCited :: Cited (StdThunk m) (StdCited m) m a }+newtype StdCited m a =+ StdCited+ { _stdCited :: Cited (StdThunk m) (StdCited m) m a } deriving ( Generic , Typeable@@ -65,22 +59,23 @@ , ComonadEnv [Provenance m (StdValue m)] ) -newtype StdThunk (m :: * -> *) = StdThunk- { _stdThunk :: StdCited m (NThunkF m (StdValue m)) }+newtype StdThunk (m :: Type -> Type) =+ StdThunk+ { _stdThunk :: StdCited m (NThunkF m (StdValue m)) } type StdValue' m = NValue' (StdThunk m) (StdCited m) m (StdValue m) type StdValue m = NValue (StdThunk m) (StdCited m) m instance Show (StdThunk m) where- show _ = "<thunk>"+ show _ = toString thunkStubText instance HasCitations1 m (StdValue m) (StdCited m) where citations1 (StdCited c) = citations1 c- addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)+ addProvenance1 x (StdCited c) = StdCited $ addProvenance1 x c instance HasCitations m (StdValue m) (StdThunk m) where citations (StdThunk c) = citations1 c- addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c)+ addProvenance x (StdThunk c) = StdThunk $ addProvenance1 x c instance MonadReader (Context m (StdValue m)) m => Scoped (StdValue m) m where currentScopes = currentScopesReader@@ -105,7 +100,7 @@ , Typeable m , Scoped (StdValue m) m , MonadReader (Context m (StdValue m)) m- , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m+ , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m , MonadDataErrorContext (StdThunk m) (StdCited m) m , MonadThunk (StdThunk m) m (StdValue m) , MonadValue (StdValue m) m@@ -139,11 +134,11 @@ -> m (StdThunk m) thunk = fmap (StdThunk . StdCited) . thunk - queryM+ query :: m (StdValue m) -> StdThunk m -> m (StdValue m)- queryM b = queryM b . _stdCited . _stdThunk+ query b = query b . _stdCited . _stdThunk force :: StdThunk m@@ -173,14 +168,14 @@ ) => MonadThunkF (StdThunk m) m (StdValue m) where - queryMF+ queryF :: ( StdValue m -> m r ) -> m r -> StdThunk m -> m r- queryMF k b x = queryMF k b (_stdCited (_stdThunk x))+ queryF k b = queryF k b . _stdCited . _stdThunk forceF :: ( StdValue m@@ -188,7 +183,7 @@ ) -> StdThunk m -> m r- forceF k t = forceF k (_stdCited $ _stdThunk t)+ forceF k = forceF k . _stdCited . _stdThunk forceEffF :: ( StdValue m@@ -196,7 +191,7 @@ ) -> StdThunk m -> m r- forceEffF k t = forceEffF k (_stdCited $ _stdThunk t)+ forceEffF k = forceEffF k . _stdCited . _stdThunk furtherF :: ( m (StdValue m)@@ -204,7 +199,7 @@ ) -> StdThunk m -> m (StdThunk m)- furtherF k t = StdThunk . StdCited <$> furtherF k (_stdCited $ _stdThunk t)+ furtherF k = fmap (StdThunk . StdCited) . furtherF k . _stdCited . _stdThunk -- * @instance MonadValue (StdValue m) m@@@ -217,6 +212,7 @@ , MonadThunkId m ) => MonadValue (StdValue m) m where+ defer :: m (StdValue m) -> m (StdValue m)@@ -327,7 +323,7 @@ mkStandardT :: ReaderT (Context (StandardT m) (StdValue (StandardT m)))- (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)+ (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a -> StandardT m a mkStandardT = Fix1T . StandardTF@@ -336,7 +332,7 @@ :: StandardT m a -> ReaderT (Context (StandardT m) (StdValue (StandardT m)))- (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)+ (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a runStandardT (Fix1T (StandardTF m)) = m @@ -349,7 +345,7 @@ go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT where go action = do- i <- newVar (1 :: Int)+ i <- newRef (1 :: Int) runFreshIdT i action runWithBasicEffectsIO :: Options -> StandardT (StdIdT IO) a -> IO a
src/Nix/String.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Nix.String@@ -65,7 +64,7 @@ newtype NixLikeContext = NixLikeContext- { getNixLikeContext :: M.HashMap Text NixLikeContextValue+ { getNixLikeContext :: AttrSet NixLikeContextValue } deriving (Eq, Ord, Show, Generic) @@ -94,11 +93,7 @@ -- | A monad for accumulating string context while producing a result string. newtype WithStringContextT m a = WithStringContextT- (WriterT- (S.HashSet StringContext)- m- a- )+ (WriterT (S.HashSet StringContext) m a ) deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (S.HashSet StringContext)) type WithStringContext = WithStringContextT Identity@@ -133,7 +128,7 @@ -- | Create NixString using a singleton context makeNixStringWithSingletonContext :: Text -> StringContext -> NixString-makeNixStringWithSingletonContext s c = NixString s $ S.singleton c+makeNixStringWithSingletonContext s c = NixString s $ one c -- | Create NixString from a Text and context makeNixString :: Text -> S.HashSet StringContext -> NixString@@ -144,7 +139,7 @@ -- | Returns True if the NixString has an associated context stringHasContext :: NixString -> Bool-stringHasContext (NixString _ c) = not (null c)+stringHasContext (NixString _ c) = not $ null c -- ** Getters@@ -170,8 +165,7 @@ extractNixString :: Monad m => NixString -> WithStringContextT m Text extractNixString (NixString s c) = WithStringContextT $- tell c $>- s+ s <$ tell c -- ** Setters@@ -190,7 +184,7 @@ NixLikeContextValue _ True _ -> mkLstCtxFor AllOutputs cv { nlcvAllOutputs = False } NixLikeContextValue _ _ ls | not (null ls) ->- fmap (mkCtxFor . DerivationOutput) ls+ mkCtxFor . DerivationOutput <$> ls _ -> mempty where mkCtxFor = StringContext path@@ -224,7 +218,7 @@ -- | Add a 'StringContext' into the resulting set. addSingletonStringContext :: Monad m => StringContext -> WithStringContextT m ()-addSingletonStringContext = WithStringContextT . tell . S.singleton+addSingletonStringContext = WithStringContextT . tell . one -- | Run an action producing a string with a context and put those into a 'NixString'. runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString@@ -257,7 +251,7 @@ intercalateNixString _ [] = mempty intercalateNixString _ [ns] = ns intercalateNixString sep nss =- uncurry NixString (mapPair intertwine unpackNss)+ uncurry NixString $ mapPair intertwine unpackNss where intertwine =
src/Nix/String/Coerce.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} module Nix.String.Coerce where @@ -13,10 +12,8 @@ import Nix.Value.Monad #ifdef MIN_VERSION_ghc_datasize-#if MIN_VERSION_ghc_datasize(0,2,0) import GHC.DataSize #endif-#endif -- | Data type to avoid boolean blindness on what used to be called coerceMore data CoercionLevel@@ -111,12 +108,13 @@ err v = throwError $ ErrorCall $ "Expected a string, but saw: " <> show v castToNixString = pure . makeNixStringWithoutContext - nixStringUnwords = intercalateNixString (makeNixStringWithoutContext " ")+ nixStringUnwords = intercalateNixString $ makeNixStringWithoutContext " " storePathToNixString :: StorePath -> NixString- storePathToNixString sp = makeNixStringWithSingletonContext- t- (StringContext t DirectPath)+ storePathToNixString sp =+ makeNixStringWithSingletonContext+ t+ (StringContext t DirectPath) where t = toText $ unStorePath sp
src/Nix/TH.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} @@ -43,46 +41,42 @@ freeVars e = case unFix e of (NConstant _ ) -> mempty (NStr string ) -> mapFreeVars string- (NSym var ) -> Set.singleton var+ (NSym var ) -> one var (NList list ) -> mapFreeVars list (NSet NNonRecursive bindings) -> bindFreeVars bindings (NSet NRecursive bindings) -> Set.difference (bindFreeVars bindings) (bindDefs bindings) (NLiteralPath _ ) -> mempty (NEnvPath _ ) -> mempty (NUnary _ expr ) -> freeVars expr- (NBinary _ left right ) -> Set.union (freeVars left) (freeVars right)+ (NBinary _ left right ) -> ((<>) `on` freeVars) left right (NSelect expr path orExpr) -> Set.unions [ freeVars expr , pathFree path , maybe mempty freeVars orExpr ]- (NHasAttr expr path) -> Set.union (freeVars expr) (pathFree path)+ (NHasAttr expr path) -> freeVars expr <> pathFree path (NAbs (Param varname) expr) -> Set.delete varname (freeVars expr) (NAbs (ParamSet set _ varname) expr) ->- Set.union- -- Include all free variables from the expression and the default arguments- (freeVars expr)- -- But remove the argument name if existing, and all arguments in the parameter set+ -- Include all free variables from the expression and the default arguments+ freeVars expr <>+ -- But remove the argument name if existing, and all arguments in the parameter set+ Set.difference+ (Set.unions $ freeVars <$> mapMaybe snd set) (Set.difference- (Set.unions $ freeVars <$> mapMaybe snd set)- (Set.difference- (maybe mempty Set.singleton varname)- (Set.fromList $ fmap fst set)- )+ (maybe mempty one varname)+ (Set.fromList $ fst <$> set) ) (NLet bindings expr ) ->- Set.union- (freeVars expr)- (Set.difference- (bindFreeVars bindings)- (bindDefs bindings)- )+ freeVars expr <>+ Set.difference+ (bindFreeVars bindings)+ (bindDefs bindings) (NIf cond th el ) -> Set.unions $ freeVars <$> [cond, th, el] -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it -- This also makes sense because its value can be overridden by `x: with y; x`- (NWith set expr ) -> Set.union (freeVars set ) (freeVars expr)- (NAssert assertion expr ) -> Set.union (freeVars assertion) (freeVars expr)+ (NWith set expr ) -> ((<>) `on` freeVars) set expr+ (NAssert assertion expr ) -> ((<>) `on` freeVars) assertion expr (NSynHole _ ) -> mempty where@@ -93,7 +87,7 @@ bind1Def :: Binding r -> Set VarName bind1Def (Inherit Nothing _ _) = mempty bind1Def (Inherit (Just _ ) keys _) = Set.fromList $ mapMaybe staticKey keys- bind1Def (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname+ bind1Def (NamedVar (StaticKey varname :| _) _ _) = one varname bind1Def (NamedVar (DynamicKey _ :| _) _ _) = mempty bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName@@ -102,7 +96,7 @@ bind1Free :: Binding NExpr -> Set VarName bind1Free (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys bind1Free (Inherit (Just scope) _ _) = freeVars scope- bind1Free (NamedVar path expr _) = Set.union (pathFree path) (freeVars expr)+ bind1Free (NamedVar path expr _) = pathFree path <> freeVars expr staticKey :: NKeyName r -> Maybe VarName staticKey (StaticKey varname) = pure varname
src/Nix/Thunk.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} @@ -20,7 +19,7 @@ ) => MonadThunkId m where- type ThunkId m :: *+ type ThunkId m :: Type freshId :: m (ThunkId m) default freshId@@ -69,14 +68,17 @@ => MonadThunk t m a | t -> m, t -> a where - -- | Return an identifier for the thunk unless it is a pure value (i.e.,- -- strictly an encapsulation of some 'a' without any additional- -- structure). For pure values represented as thunks, returns mempty.+ -- | Return thunk ID. thunkId :: t -> ThunkId m + -- | Create new thunk thunk :: m a -> m t - queryM :: m a -> t -> m a+ -- | Non-blocking query.+ -- If thunk got computed+ -- then return its value+ -- otherwise return default value (1st arg).+ query :: m a -> t -> m a force :: t -> m a forceEff :: t -> m a @@ -91,7 +93,7 @@ class MonadThunkF t m a | t -> m, t -> a where- queryMF :: (a -> m r) -> m r -> t -> m r+ queryF :: (a -> m r) -> m r -> t -> m r forceF :: (a -> m r) -> t -> m r forceEffF :: (a -> m r) -> t -> m r furtherF :: (m a -> m a) -> t -> m t@@ -106,3 +108,8 @@ show (ThunkLoop i) = toString $ "ThunkLoop " <> i instance Exception ThunkLoop++-- ** Utils++thunkStubText :: Text+thunkStubText = "<thunk>"
src/Nix/Thunk/Basic.hs view
@@ -1,29 +1,26 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE InstanceSigs #-}-+{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Nix.Thunk.Basic ( NThunkF(..) , Deferred(..)+ , deferred , MonadBasicThunk ) where import Prelude hiding ( force ) import Relude.Extra ( dup )+import Control.Monad.Ref ( MonadRef(Ref, newRef, readRef, writeRef)+ , MonadAtomicRef(atomicModifyRef)+ ) import Control.Monad.Catch ( MonadCatch(..) , MonadThrow(throwM) ) import qualified Text.Show import Nix.Thunk-import Nix.Var -- * Data type @Deferred@@@ -38,8 +35,8 @@ -- | Apply second if @Deferred@, otherwise (@Computed@) - apply first. -- Analog of @either@ for @Deferred = Computed|Deferred@. deferred :: (v -> b) -> (m v -> b) -> Deferred m v -> b-deferred f1 f2 def =- case def of+deferred f1 f2 =+ \case Computed v -> f1 v Deferred action -> f2 action {-# inline deferred #-}@@ -49,51 +46,51 @@ -- | Thunk resource reference (@ref-tf: Ref m@), and as such also also hold -- a @Bool@ lock flag.-type ThunkRef m = (Var m Bool)+type ThunkRef m = Ref m Bool -- | Reference (@ref-tf: Ref m v@) to a value that the thunk holds.-type ThunkValueRef m v = Var m (Deferred m v)+type ThunkValueRef m v = Ref m (Deferred m v) -- | @ref-tf@ lock instruction for @Ref m@ (@ThunkRef@).-lock :: Bool -> (Bool, Bool)-lock = (True, )+lockVal :: Bool -> (Bool, Bool)+lockVal = (True, ) -- | @ref-tf@ unlock instruction for @Ref m@ (@ThunkRef@).-unlock :: Bool -> (Bool, Bool)-unlock = (False, )+unlockVal :: Bool -> (Bool, Bool)+unlockVal = (False, ) -- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation.-lockThunk+lock :: ( MonadBasicThunk m , MonadCatch m ) => ThunkRef m -> m Bool-lockThunk r = atomicModifyVar r lock+lock r = atomicModifyRef r lockVal -- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation.-unlockThunk+unlock :: ( MonadBasicThunk m , MonadCatch m ) => ThunkRef m -> m Bool-unlockThunk r = atomicModifyVar r unlock+unlock r = atomicModifyRef r unlockVal -- * Data type for thunks: @NThunkF@ -- | The type of very basic thunks-data NThunkF m v- = Thunk (ThunkId m) (ThunkRef m) (ThunkValueRef m v)+data NThunkF m v =+ Thunk (ThunkId m) (ThunkRef m) (ThunkValueRef m v) instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where Thunk x _ _ == Thunk y _ _ = x == y instance Show (NThunkF m v) where- show Thunk{} = "<thunk>"+ show Thunk{} = toString thunkStubText -type MonadBasicThunk m = (MonadThunkId m, MonadVar m)+type MonadBasicThunk m = (MonadThunkId m, MonadAtomicRef m) -- ** @instance MonadThunk NThunkF@@@ -101,26 +98,22 @@ instance (MonadBasicThunk m, MonadCatch m) => MonadThunk (NThunkF m v) m v where - -- | Return thunk ID thunkId :: NThunkF m v -> ThunkId m thunkId (Thunk n _ _) = n - -- | Create new thunk thunk :: m v -> m (NThunkF m v) thunk action = do freshThunkId <- freshId- Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)+ liftA2 (Thunk freshThunkId)+ (newRef False )+ (newRef $ Deferred action) - -- | Non-blocking query, return value if @Computed@,- -- return first argument otherwise.- queryM :: m v -> NThunkF m v -> m v- queryM n (Thunk _ _ ref) =+ query :: m v -> NThunkF m v -> m v+ query vStub (Thunk _ _ lTValRef) = do- deferred- pure- (const n)- =<< readVar ref+ v <- readRef lTValRef+ deferred pure (const vStub) v force :: NThunkF m v -> m v force = forceMain@@ -132,7 +125,7 @@ further t@(Thunk _ _ ref) = do _ <-- atomicModifyVar+ atomicModifyRef ref dup pure t@@ -140,38 +133,42 @@ -- *** United body of `force*` --- | If @m v@ is @Computed@ - returns is+-- | Always returns computed @m v@.+--+-- Checks if resource is computed,+-- if not - with locking evaluates the resource. forceMain :: ( MonadBasicThunk m , MonadCatch m ) => NThunkF m v -> m v-forceMain (Thunk n thunkRef thunkValRef) =- deferred- pure- (\ action ->- do- lockedIt <- lockThunk thunkRef- bool- lockFailed- (do- v <- action `catch` actionFailed- writeVar thunkValRef (Computed v)- _unlockedIt <- unlockThunk thunkRef- pure v- )- (not lockedIt)- )- =<< readVar thunkValRef+forceMain (Thunk tIdV tRefV tValRefV) =+ do+ v <- readRef tValRefV+ deferred pure computeW v where- lockFailed = throwM $ ThunkLoop $ show n+ computeW vDefferred =+ do+ locked <- lock tRefV+ bool+ lockFailedV+ (do+ v <- vDefferred `catch` bindFailedW+ writeRef tValRefV $ Computed v -- Proclaim value computed+ unlockRef+ pure v+ )+ (not locked) - actionFailed (e :: SomeException) =+ lockFailedV = throwM $ ThunkLoop $ show tIdV++ bindFailedW (e :: SomeException) = do- _unlockedIt <- unlockThunk thunkRef+ unlockRef throwM e + unlockRef = unlock tRefV {-# inline forceMain #-} -- it is big function, but internal, and look at its use. @@ -181,30 +178,32 @@ instance (MonadBasicThunk m, MonadCatch m) => MonadThunkF (NThunkF m v) m v where - queryMF+ queryF :: (v -> m r) -> m r -> NThunkF m v -> m r- queryMF k n (Thunk _ thunkRef thunkValRef) =+ queryF k n (Thunk _ thunkRef thunkValRef) = do- lockedIt <- lockThunk thunkRef+ locked <- lock thunkRef bool n go- (not lockedIt)+ (not locked) where go = do- eres <- readVar thunkValRef+ eres <- readRef thunkValRef res <- deferred k (const n) eres- _unlockedIt <- unlockThunk thunkRef+ unlockRef pure res + unlockRef = unlock thunkRef+ forceF :: (v -> m a) -> NThunkF m v@@ -223,7 +222,7 @@ -> m (NThunkF m v) furtherF k t@(Thunk _ _ ref) = do- _modifiedIt <- atomicModifyVar ref $+ _modifiedIt <- atomicModifyRef ref $ \x -> deferred (const (x, x))
src/Nix/Type/Assumption.hs view
@@ -1,5 +1,6 @@ -- | Basing on the Nix (Hindley–Milner) type system (that provides decidable type inference): -- gathering assumptions (inference evidence) about polymorphic types.+{-# LANGUAGE TypeFamilies #-} module Nix.Type.Assumption ( Assumption(..) , empty@@ -22,6 +23,19 @@ newtype Assumption = Assumption { assumptions :: [(Name, Type)] } deriving (Eq, Show) +-- We pretend that Assumptions can be inconsistent (nonunique keys),+-- (just like people in real life).+-- The consistency between assumptions is the inference responcibility.+instance Semigroup Assumption where+ (<>) = merge++instance Monoid Assumption where+ mempty = empty++instance One Assumption where+ type OneItem Assumption = (Name, Type)+ one (x, y) = Assumption [(x, y)]+ empty :: Assumption empty = Assumption mempty @@ -49,7 +63,7 @@ Assumption $ a <> b mergeAssumptions :: [Assumption] -> Assumption-mergeAssumptions = foldl' merge empty+mergeAssumptions = foldl' (<>) mempty singleton :: Name -> Type -> Assumption singleton x y = Assumption [(x, y)]
src/Nix/Type/Env.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Nix.Type.Env ( Env(..) , empty@@ -26,45 +27,54 @@ -- * Typing Environment -newtype Env = TypeEnv { types :: Map.Map Name [Scheme] }+newtype Env = TypeEnv (Map.Map Name [Scheme]) deriving (Eq, Show) +instance Semigroup Env where+ -- | Right-biased merge (override). Analogous to @//@ in @Nix@+ -- Since nature of environment is to update & grow.+ (<>) = mergeRight++instance Monoid Env where+ mempty = empty++instance One Env where+ type OneItem Env = (Name, Scheme)+ one = uncurry singleton+ empty :: Env empty = TypeEnv mempty extend :: Env -> (Name, [Scheme]) -> Env-extend env (x, s) = env { types = Map.insert x s (types env) }+extend env (x, s) = TypeEnv $ Map.insert x s $ coerce env remove :: Env -> Name -> Env-remove (TypeEnv env) var = TypeEnv (Map.delete var env)+remove (TypeEnv env) var = TypeEnv $ Map.delete var env extends :: Env -> [(Name, [Scheme])] -> Env-extends env xs = env { types = Map.union (Map.fromList xs) (types env) }+extends env xs = TypeEnv $ Map.fromList xs <> coerce env lookup :: Name -> Env -> Maybe [Scheme] lookup key (TypeEnv tys) = Map.lookup key tys merge :: Env -> Env -> Env-merge (TypeEnv a) (TypeEnv b) = TypeEnv (Map.union a b)+merge (TypeEnv a) (TypeEnv b) = TypeEnv $ a <> b +mergeRight :: Env -> Env -> Env+mergeRight (TypeEnv a) (TypeEnv b) = TypeEnv $ b <> a+ mergeEnvs :: [Env] -> Env-mergeEnvs = foldl' merge empty+mergeEnvs = foldl' (<>) mempty singleton :: Name -> Scheme -> Env-singleton x y = TypeEnv (Map.singleton x [y])+singleton x y = TypeEnv $ one (x, [y]) keys :: Env -> [Name] keys (TypeEnv env) = Map.keys env fromList :: [(Name, [Scheme])] -> Env-fromList xs = TypeEnv (Map.fromList xs)+fromList xs = TypeEnv $ Map.fromList xs toList :: Env -> [(Name, [Scheme])] toList (TypeEnv env) = Map.toList env -instance Semigroup Env where- (<>) = merge--instance Monoid Env where- mempty = empty- mappend = merge
src/Nix/Type/Infer.hs view
@@ -3,18 +3,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -60,17 +52,26 @@ import Nix.Convert import Nix.Eval ( MonadEval(..) ) import qualified Nix.Eval as Eval+ ( eval+ , evalWithAttrSet+ ) import Nix.Expr.Types import Nix.Expr.Types.Annotated import Nix.Fresh import Nix.String import Nix.Scope+import Nix.Type.Assumption hiding ( assumptions+ , extend+ ) import qualified Nix.Type.Assumption as Assumption-import Nix.Type.Env hiding ( empty )+ ( remove+ , lookup+ , keys+ )+import Nix.Type.Env import qualified Nix.Type.Env as Env import Nix.Type.Type import Nix.Value.Monad-import Nix.Var normalizeScheme :: Scheme -> Scheme@@ -90,7 +91,7 @@ normtype (a :~> b ) = normtype a :~> normtype b normtype (TCon a ) = TCon a- normtype (TSet b a) = TSet b $ normtype `M.map` a+ normtype (TSet b a) = TSet b $ normtype <$> a normtype (TList a ) = TList $ normtype <$> a normtype (TMany ts) = TMany $ normtype <$> ts normtype (TVar a ) =@@ -200,8 +201,8 @@ compose :: Subst -> Subst -> Subst Subst s1 `compose` Subst s2 = Subst $- apply (Subst s1) `Map.map`- (s2 `Map.union` s1)+ apply (Subst s1) <$>+ (s2 <> s1) -- * class @Substitutable@ @@ -218,11 +219,11 @@ instance Substitutable Type where apply _ ( TCon a ) = TCon a- apply s ( TSet b a ) = TSet b $ apply s `M.map` a- apply s ( TList a ) = TList $ apply s <$> a+ apply s ( TSet b a ) = TSet b $ apply s <$> a+ apply s ( TList a ) = TList $ apply s <$> a apply (Subst s) t@(TVar a ) = Map.findWithDefault t a s apply s ( t1 :~> t2) = apply s t1 :~> apply s t2- apply s ( TMany ts ) = TMany $ apply s <$> ts+ apply s ( TMany ts ) = TMany $ apply s <$> ts instance Substitutable Scheme where apply (Subst s) (Forall as t) = Forall as $ apply s' t@@ -255,7 +256,7 @@ data Judgment s = Judgment- { assumptions :: Assumption.Assumption+ { assumptions :: Assumption , typeConstraints :: [Constraint] , inferredType :: Type }@@ -339,7 +340,7 @@ where fromValueMay (Judgment _ _ (TSet _ xs)) = do- let sing _ = Judgment Assumption.empty mempty+ let sing _ = Judgment mempty mempty pure $ pure (M.mapWithKey sing xs, mempty) fromValueMay _ = stub fromValue =@@ -354,30 +355,38 @@ toValue (xs, _) = liftA3 Judgment- (foldrM go Assumption.empty xs)- (concat <$> traverse ((typeConstraints <$>) . demand) xs)- (TSet True <$> traverse ((inferredType <$>) . demand) xs)+ (foldrM go mempty xs)+ (fun concat typeConstraints)+ (fun (TSet True) inferredType ) where go x rest = do x' <- demand x- pure $ Assumption.merge (assumptions x') rest+ pure $ assumptions x' <> rest + fun :: (AttrSet b -> b1) -> (Judgment s -> b) -> InferT s m b1+ fun g f =+ g <$> traverse ((f <$>) . demand) xs+ instance MonadInfer m => ToValue [Judgment s] (InferT s m) (Judgment s) where toValue xs = liftA3 Judgment- (foldrM go Assumption.empty xs)- (concat <$> traverse ((typeConstraints <$>) . demand) xs)- (TList <$> traverse ((inferredType <$>) . demand) xs)+ (foldrM go mempty xs)+ (fun concat typeConstraints)+ (fun TList inferredType ) where go x rest = do x' <- demand x- pure $ Assumption.merge (assumptions x') rest+ pure $ assumptions x' <> rest + fun :: ([b] -> b1) -> (Judgment s -> b) -> InferT s m b1+ fun g f =+ g <$> traverse ((f <$>) . demand) xs+ instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where- toValue _ = pure $ Judgment Assumption.empty mempty typeBool+ toValue _ = pure $ Judgment mempty mempty typeBool instance Monad m@@ -433,38 +442,38 @@ thunk = fmap JThunk . thunk - queryM b (JThunk x) = queryM b x+ query b (JThunk x) = query b x -- If we have a thunk loop, we just don't know the type. force (JThunk t) = catch (force t) $ \(_ :: ThunkLoop) ->- f =<< Judgment Assumption.empty mempty <$> fresh+ f =<< Judgment mempty mempty <$> fresh -- If we have a thunk loop, we just don't know the type. forceEff (JThunk t) = catch (forceEff t) $ \(_ :: ThunkLoop) ->- f =<< Judgment Assumption.empty mempty <$> fresh+ f =<< Judgment mempty mempty <$> fresh -} instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where freeVariable var = do tv <- fresh- pure $ Judgment (Assumption.singleton var tv) mempty tv+ pure $ Judgment (one (var, tv)) mempty tv synHole var = do tv <- fresh- pure $ Judgment (Assumption.singleton var tv) mempty tv+ pure $ Judgment (one (var, tv)) mempty tv -- If we fail to look up an attribute, we just don't know the type.- attrMissing _ _ = Judgment Assumption.empty mempty <$> fresh+ attrMissing _ _ = Judgment mempty mempty <$> fresh evaledSym _ = pure evalCurPos = pure $ Judgment- Assumption.empty mempty+ mempty (TSet False $ M.fromList [ ("file", typePath)@@ -473,7 +482,7 @@ ] ) - evalConstant c = pure $ Judgment Assumption.empty mempty $ go c+ evalConstant c = pure $ Judgment mempty mempty $ go c where go = \case NURI _ -> typeString@@ -482,9 +491,9 @@ NBool _ -> typeBool NNull -> typeNull - evalString = const $ pure $ Judgment Assumption.empty mempty typeString- evalLiteralPath = const $ pure $ Judgment Assumption.empty mempty typePath- evalEnvPath = const $ pure $ Judgment Assumption.empty mempty typePath+ evalString = const $ pure $ Judgment mempty mempty typeString+ evalLiteralPath = const $ pure $ Judgment mempty mempty typePath+ evalEnvPath = const $ pure $ Judgment mempty mempty typePath evalUnary op (Judgment as1 cs1 t1) = do tv <- fresh@@ -499,7 +508,7 @@ tv <- fresh pure $ Judgment- (as1 `Assumption.merge` as2)+ (as1 <> as2) ( cs1 <> cs2 <> binops@@ -514,7 +523,7 @@ Judgment as2 cs2 t2 <- t Judgment as3 cs3 t3 <- f pure $ Judgment- (as1 `Assumption.merge` as2 `Assumption.merge` as3)+ (as1 <> as2 <> as3) (cs1 <> cs2 <> cs3 <> [EqConst t1 typeBool, EqConst t2 t3]) t2 @@ -522,7 +531,7 @@ Judgment as2 cs2 t2 <- body pure $ Judgment- (as1 `Assumption.merge` as2)+ (as1 <> as2) (cs1 <> cs2 <> [EqConst t1 typeBool]) t2 @@ -531,7 +540,7 @@ tv <- fresh pure $ Judgment- (as1 `Assumption.merge` as2)+ (as1 <> as2) (cs1 <> cs2 <> [EqConst t1 (t2 :~> tv)]) tv @@ -544,7 +553,7 @@ (k (pure $ Judgment- (Assumption.singleton x tv)+ (one (x, tv)) mempty tv )@@ -568,9 +577,8 @@ ps let- (env, tys) =- (\f -> foldl' f (Assumption.empty, mempty) js) $ \(as1, t1) (k, t) ->- (as1 `Assumption.merge` Assumption.singleton k t, M.insert k t t1)+ f (as1, t1) (k, t) = (as1 <> one (k, t), M.insert k t t1)+ (env, tys) = foldl' f (mempty, mempty) js arg = pure $ Judgment env mempty $ TSet True tys call = k arg $ \args b -> (args, ) <$> b names = fst <$> js@@ -599,23 +607,23 @@ instance FreeTypeVars Type where ftv TCon{} = mempty- ftv (TVar a ) = Set.singleton a+ ftv (TVar a ) = one a ftv (TSet _ a ) = Set.unions $ ftv <$> M.elems a ftv (TList a ) = Set.unions $ ftv <$> a- ftv (t1 :~> t2) = ftv t1 `Set.union` ftv t2+ ftv (t1 :~> t2) = ftv t1 <> ftv t2 ftv (TMany ts ) = Set.unions $ ftv <$> ts instance FreeTypeVars TVar where- ftv = Set.singleton+ ftv = one instance FreeTypeVars Scheme where ftv (Forall as t) = ftv t `Set.difference` Set.fromList as instance FreeTypeVars a => FreeTypeVars [a] where- ftv = foldr (Set.union . ftv) mempty+ ftv = foldr ((<>) . ftv) mempty instance (Ord a, FreeTypeVars a) => FreeTypeVars (Set.Set a) where- ftv = foldr (Set.union . ftv) mempty+ ftv = foldr ((<>) . ftv) mempty -- * class @ActiveTypeVars@ @@ -625,32 +633,32 @@ -- ** Instances instance ActiveTypeVars Constraint where- atv (EqConst t1 t2 ) = ftv t1 `Set.union` ftv t2- atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2)- atv (ExpInstConst t s ) = ftv t `Set.union` ftv s+ atv (EqConst t1 t2 ) = ftv t1 <> ftv t2+ atv (ImpInstConst t1 ms t2) = ftv t1 <> (ftv ms `Set.intersection` ftv t2)+ atv (ExpInstConst t s ) = ftv t <> ftv s instance ActiveTypeVars a => ActiveTypeVars [a] where- atv = foldr (Set.union . atv) mempty+ atv = foldr ((<>) . atv) mempty -- * Other type MonadInfer m = ({- MonadThunkId m,-}- MonadVar m, MonadFix m)+ MonadAtomicRef m, MonadFix m) -- | Run the inference monad runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a) runInfer' = runExceptT . (`evalStateT` initInfer)- . (`runReaderT` (mempty, emptyScopes))+ . (`runReaderT` (mempty, mempty)) . getInfer runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a runInfer m = runST $ do- i <- newVar (1 :: Int)+ i <- newRef (1 :: Int) runFreshIdT i $ runInfer' m inferType@@ -793,7 +801,7 @@ lift = Solver . lift . lift instance Monad m => MonadError TypeError (Solver m) where- throwError err = Solver $ lift (modify (err :)) *> empty+ throwError err = Solver $ lift (modify (err :)) *> mempty catchError _ _ = error "This is never used" -- * Other@@ -801,7 +809,7 @@ bind :: Monad m => TVar -> Type -> Solver m Subst bind a t | t == TVar a = stub | occursCheck a t = throwError $ InfiniteType a t- | otherwise = pure $ Subst $ Map.singleton a t+ | otherwise = pure $ Subst $ one (a, t) considering :: [a] -> Solver m a considering xs = Solver $ LogicT $ \c n -> foldr c n xs
src/Nix/Utils.hs view
@@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} @@ -31,22 +28,35 @@ -- Well, since it is currently CPP intermingled with Debug.Trace, required to use String here. trace :: String -> a -> a trace = const id+{-# inline trace #-} traceM :: Monad m => String -> m () traceM = const pass+{-# inline traceM #-} #endif -$(makeLensesBy (\n -> pure ("_" <> n)) ''Fix)+$(makeLensesBy (\n -> pure $ "_" <> n) ''Fix) +-- | > Hashmap Text -- type synonym type AttrSet = HashMap Text --- | F-algebra defines how to reduce the fixed-point of a functor to a--- value.+-- | F-algebra defines how to reduce the fixed-point of a functor to a value.+-- > type Alg f a = f a -> a type Alg f a = f a -> a +-- | > type AlgM f m a = f a -> m a type AlgM f m a = f a -> m a --- | "Transform" here means a modification of a catamorphism.-type Transform f a = (Fix f -> a) -> Fix f -> a+-- | Do according transformation.+--+-- It is a transformation of a recursion scheme.+-- See @TransformF@.+type Transform f a = TransformF (Fix f) a+-- | Do according transformation.+--+-- It is a transformation between functors.+-- ...+-- You got me, it is a natural transformation.+type TransformF f a = (f -> a) -> f -> a loeb :: Functor f => f (f a -> a) -> f a loeb x = go@@ -91,6 +101,9 @@ f $ Fix . (go <$>) +-- | Replace:+-- @a -> Pure a@+-- @Fix -> Free@ fixToFree :: Functor f => Fix f -> Free f a fixToFree = Free . go where@@ -103,16 +116,24 @@ -- Essentially, it does for evaluation what recursion schemes do for -- representation: allows threading layers through existing structure, only -- in this case through behavior.-adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a-adi f g = g $ f . (adi f g <$>) . unFix+adi+ :: Functor f+ => Transform f a+ -> Alg f a+ -> Fix f+ -> a+adi g f = g $ f . (adi g f <$>) . unFix adiM- :: (Traversable t, Monad m)- => (t a -> m a)- -> ((Fix t -> m a) -> Fix t -> m a)+ :: ( Traversable t+ , Monad m+ )+ => Transform t (m a)+ -> AlgM t m a -> Fix t -> m a-adiM f g = g $ f <=< traverse (adiM f g) . unFix+adiM g f = g $ f <=< traverse (adiM g f) . unFix+ class Has a b where hasLens :: Lens' a b
src/Nix/Utils/Fix1.hs view
@@ -1,12 +1,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Nix.Utils.Fix1 where@@ -19,9 +15,10 @@ , MonadMask , MonadThrow ) --- | The fixpoint combinator, courtesy of Gregory Malecha.--- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced-newtype Fix1 (t :: (k -> *) -> k -> *) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a }+-- | The fixpoint combinator.+-- Courtesy of Gregory Malecha.+-- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced+newtype Fix1 (t :: (k -> Type) -> k -> Type) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a } deriving instance Functor (t (Fix1 t)) => Functor (Fix1 t)@@ -47,7 +44,7 @@ deriving instance MonadState s (t (Fix1 t)) => MonadState s (Fix1 t) -newtype Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k)+newtype Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k) = Fix1T { unFix1T :: t (Fix1T t m) m a } deriving instance Functor (t (Fix1T t m) m)
src/Nix/Value.hs view
@@ -2,15 +2,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} @@ -53,7 +47,7 @@ import Nix.Thunk --- * @__NValueF__@: Base functor+-- * @__NValueF__@: Base functor (F) -- | An NValueF p m r represents all the possible types of Nix values. --@@ -126,6 +120,11 @@ | NVStrF NixString | NVPathF FilePath | NVListF [r]+ -- 2021-05-22: NOTE: Please flip this and dependent functions.+ -- Quite frequently actions/processing happens with values+ -- (for example - forcing of values & recreation of the monad),+ -- but SourcePos does not change then+ -- That would be good to flip all 'AttrSet.* AttrSet SourcePos' | NVSetF (AttrSet r) (AttrSet SourcePos) | NVClosureF (Params ()) (p -> m r) -- ^ A function is a closed set of parameters representing the "call@@ -446,8 +445,8 @@ -- | Haskell key-value to the Nix key-value, nvSet' :: Applicative f- => HashMap Text SourcePos- -> HashMap Text r+ => AttrSet SourcePos+ -> AttrSet r -> NValue' t f m r nvSet' x s = NValue' $ pure $ NVSetF s x @@ -514,27 +513,35 @@ -- ** Free --- | @iter@+-- | HOF of @iter@ from @Free@ iterNValue :: forall t f m r . MonadDataContext f m- => (t -> (NValue t f m -> r) -> r)+ => ((Free (NValue' t f m) t -> r) -> t -> r) -> (NValue' t f m r -> r)- -> NValue t f m+ -> Free (NValue' t f m) t -> r-iterNValue k f = iter f . fmap (\t -> k t (iterNValue k f))+iterNValue k f = iter f . fmap (k (iterNValue k f)) +iterNValueByDiscardWith+ :: MonadDataContext f m+ => r+ -> (NValue' t f m r -> r)+ -> Free (NValue' t f m) t+ -> r+iterNValueByDiscardWith dflt = iterNValue (\ _ _ -> dflt) --- | @iter@ for monadic values++-- | HOF of @iterM@ from @Free@ iterNValueM :: (MonadDataContext f m, Monad n) => (forall x . n x -> m x)- -> (t -> (NValue t f m -> n r) -> n r)+ -> ((NValue t f m -> n r) -> t -> n r) -> (NValue' t f m (n r) -> n r) -> NValue t f m -> n r iterNValueM transform k f =- iterM f <=< go . ((\t -> k t $ iterNValueM transform k f) <$>)+ iterM f <=< go . (k (iterNValueM transform k f) <$>) where go (Pure x) = Pure <$> x go (Free fa) = Free <$> bindNValue' transform go fa@@ -600,7 +607,12 @@ -> NValue t f m nvStr = Free . nvStr' +nvStrWithoutContext :: Applicative f+ => Text+ -> NValue t f m+nvStrWithoutContext = nvStr . makeNixStringWithoutContext + -- | Life of a Haskell FilePath to the life of a Nix path nvPath :: Applicative f => FilePath@@ -615,8 +627,8 @@ nvSet :: Applicative f- => HashMap Text SourcePos- -> HashMap Text (NValue t f m)+ => AttrSet SourcePos+ -> AttrSet (NValue t f m) -> NValue t f m nvSet x s = Free $ nvSet' x s @@ -779,7 +791,7 @@ -- * @MonadDataContext@ -type MonadDataContext f (m :: * -> *)+type MonadDataContext f (m :: Type -> Type) = (Comonad f, Applicative f, Traversable f, Monad m) -- * @MonadDataErrorContext@
src/Nix/Value/Equal.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}
src/Nix/Value/Monad.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE MultiParamTypeClasses #-} module Nix.Value.Monad where -- * @MonadValue@ - a main implementation class class MonadValue v m where+ -- | Wrap value into a thunk. defer :: m v -> m v+ -- | Force the evaluation of the value. demand :: v -> m v -- | If 'v' is a thunk, 'inform' allows us to modify the action to be -- performed by the thunk, perhaps by enriching it with scope info, for
src/Nix/Var.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-}-+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -module Nix.Var where+module Nix.Var ()+where import Control.Monad.Ref import Data.GADT.Compare ( GEq(..) )@@ -15,37 +15,21 @@ import Unsafe.Coerce ( unsafeCoerce ) -type Var m = Ref m--type MonadVar m = MonadAtomicRef m--eqVar :: forall m a . GEq (Ref m) => Ref m a -> Ref m a -> Bool+eqVar :: GEq (Ref m) => Ref m a -> Ref m a -> Bool eqVar a b = isJust $ geq a b -newVar :: MonadRef m => a -> m (Ref m a)-newVar = newRef--readVar :: MonadRef m => Ref m a -> m a-readVar = readRef--writeVar :: MonadRef m => Ref m a -> a -> m ()-writeVar = writeRef--atomicModifyVar :: MonadAtomicRef m => Ref m a -> (a -> (a, b)) -> m b-atomicModifyVar = atomicModifyRef- --TODO: Upstream GEq instances--- 2021-02-25: NOTE: Currently, upstreaming would require adding a dependency on the according packages.+-- Upstream thread: https://github.com/haskellari/some/pull/34 instance GEq IORef where- a `geq` b =- bool- Nothing- (pure $ unsafeCoerce Refl)- (a == unsafeCoerce b)+ geq = gEqual instance GEq (STRef s) where- a `geq` b =- bool- Nothing- (pure $ unsafeCoerce Refl)- (a == unsafeCoerce b)+ geq = gEqual++-- | Simply a helper function+gEqual :: Eq a => a -> b -> Maybe c+gEqual a b =+ bool+ Nothing+ (pure $ unsafeCoerce Refl)+ (a == unsafeCoerce b)
src/Nix/XML.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Nix.XML@@ -19,7 +17,7 @@ ) toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString-toXML = runWithStringContext . fmap pp . iterNValue (\_ _ -> cyc) phi+toXML = runWithStringContext . fmap pp . iterNValueByDiscardWith cyc phi where cyc = pure $ mkEVal "string" "<expr>"
tests/EvalTests.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}
tests/Main.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} module Main where
tests/PrettyParseTests.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoMonomorphismRestriction #-}
tests/TestCommon.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} module TestCommon where