Further revision in Value.hs
This commit is contained in:
John Wiegley
parent
6daaf18018
commit
ba33d8c117
|
|
@ -63,3 +63,14 @@ class HasCitations1 t v m f where
|
|||
|
||||
instance HasCitations1 t v m f => HasCitations1 t v m (Compose f g) where
|
||||
citations1 (Compose f) = citations1 f
|
||||
|
||||
-- addProvenance :: (NValue t f m a -> Provenance t (NValue t f m a) m) -> NValue t f m a -> NValue t f m a
|
||||
-- addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
|
||||
|
||||
-- nvConstantP p x = NValue (NCited [p] (NVConstantF x))
|
||||
-- nvStrP p ns = NValue (NCited [p] (NVStrF ns))
|
||||
-- nvPathP p x = NValue (NCited [p] (NVPathF x))
|
||||
-- nvListP p l = NValue (NCited [p] (NVListF l))
|
||||
-- nvSetP p s x = NValue (NCited [p] (NVSetF s x))
|
||||
-- nvClosureP p x f = NValue (NCited [p] (NVClosureF x f))
|
||||
-- nvBuiltinP p name f = NValue (NCited [p] (NVBuiltinF name f))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ module Nix.Thunk where
|
|||
import Control.Exception hiding (catch)
|
||||
import Data.Typeable
|
||||
|
||||
class Monad m => MonadThunk v t m | t -> m, t -> v where
|
||||
class Monad m => MonadThunk t m v | t -> m, t -> v where
|
||||
thunk :: m v -> m t
|
||||
thunkId :: t -> Int
|
||||
query :: t -> r -> (v -> r) -> r
|
||||
|
|
|
|||
513
src/Nix/Value.hs
513
src/Nix/Value.hs
|
|
@ -38,7 +38,6 @@ import Control.Monad.Trans.Class
|
|||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Align
|
||||
import Data.Fix
|
||||
import Data.Functor.Classes
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
|
|
@ -53,7 +52,7 @@ import Lens.Family2.TH
|
|||
import Nix.Atoms
|
||||
import Nix.Expr.Types
|
||||
import Nix.Expr.Types.Annotated
|
||||
-- import Nix.Frames
|
||||
import Nix.Frames
|
||||
import Nix.String
|
||||
import Nix.Thunk
|
||||
import Nix.Utils
|
||||
|
|
@ -61,7 +60,7 @@ import Nix.Utils
|
|||
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is
|
||||
-- completed. 's' is related to the type of errors that might occur during
|
||||
-- construction or use of a value.
|
||||
data NValueF a m r
|
||||
data NValueF p m r
|
||||
= NVConstantF NAtom
|
||||
-- | A string has a value and a context, which can be used to record what a
|
||||
-- string has been build from
|
||||
|
|
@ -69,7 +68,7 @@ data NValueF a m r
|
|||
| NVPathF FilePath
|
||||
| NVListF [r]
|
||||
| NVSetF (AttrSet r) (AttrSet SourcePos)
|
||||
| NVClosureF (Params ()) (m a -> m r)
|
||||
| NVClosureF (Params ()) (m p -> m r)
|
||||
-- ^ A function is a closed set of parameters representing the "call
|
||||
-- signature", used at application time to check the type of arguments
|
||||
-- passed to the function. Since it supports default values which may
|
||||
|
|
@ -81,24 +80,38 @@ data NValueF a m r
|
|||
-- Note that 'm r' is being used here because effectively a function
|
||||
-- and its set of default arguments is "never fully evaluated". This
|
||||
-- enforces in the type that it must be re-evaluated for each call.
|
||||
| NVBuiltinF String (m a -> m r)
|
||||
| NVBuiltinF String (m p -> m r)
|
||||
-- ^ A builtin function is itself already in normal form. Also, it may
|
||||
-- or may not choose to evaluate its argument in the production of a
|
||||
-- result.
|
||||
deriving (Generic, Typeable, Functor)
|
||||
|
||||
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f g m' is
|
||||
-- a value in head normal form, where only the "top layer" has been
|
||||
-- evaluated. An action of type 'm (NValue f g m)' is a pending evualation that
|
||||
-- has yet to be performed. An 'NThunk f g m' is either a pending evaluation, or
|
||||
-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys
|
||||
-- to thunks.
|
||||
--
|
||||
-- The 'Free' structure is used here to represent the possibility that
|
||||
-- cycles may appear during normalization.
|
||||
-- | This 'Foldable' instance only folds what the value actually is known to
|
||||
-- contain at time of fold.
|
||||
instance Foldable (NValueF p m) where
|
||||
foldMap f = \case
|
||||
NVConstantF _ -> mempty
|
||||
NVStrF _ -> mempty
|
||||
NVPathF _ -> mempty
|
||||
NVListF l -> foldMap f l
|
||||
NVSetF s _ -> foldMap f s
|
||||
NVClosureF _ _ -> mempty
|
||||
NVBuiltinF _ _ -> mempty
|
||||
|
||||
comapNValueFArg :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
|
||||
comapNValueFArg f = \case
|
||||
bindNValueF :: (Monad m, Monad n)
|
||||
=> (forall x. n x -> m x) -> (a -> n b) -> NValueF p m a
|
||||
-> n (NValueF p m b)
|
||||
bindNValueF transform f = \case
|
||||
NVConstantF a -> pure $ NVConstantF a
|
||||
NVStrF s -> pure $ NVStrF s
|
||||
NVPathF p -> pure $ NVPathF p
|
||||
NVListF l -> NVListF <$> traverse f l
|
||||
NVSetF s p -> NVSetF <$> traverse f s <*> pure p
|
||||
NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g)
|
||||
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g)
|
||||
|
||||
lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
|
||||
lmapNValueF f = \case
|
||||
NVConstantF a -> NVConstantF a
|
||||
NVStrF s -> NVStrF s
|
||||
NVPathF p -> NVPathF p
|
||||
|
|
@ -107,196 +120,15 @@ comapNValueFArg f = \case
|
|||
NVClosureF p g -> NVClosureF p (g . fmap f)
|
||||
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
|
||||
|
||||
-- type IsNValueNF v m = (MonadDataContext f m, v ~ NValueNF f g m)
|
||||
|
||||
type NValueNF f g m
|
||||
= Free (Compose f (NValueF (NValue f g m) m)) (NValue f g m)
|
||||
|
||||
type MonadDataContext f (m :: * -> *) =
|
||||
(Monad m, Show1 f, Comonad f, Applicative f, Traversable f)
|
||||
(Show1 f, Comonad f, Applicative f, Traversable f, Monad m)
|
||||
|
||||
newtype NValue f g m = NValue
|
||||
{ _nValue :: Fix (Compose f (Compose (NValueF (NValue f g m) m) g)) }
|
||||
-- | At the time of constructor, the expected arguments to closures are values
|
||||
-- that may contain thunks. The type of such thunks are fixed at that time.
|
||||
newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
|
||||
deriving (Generic, Typeable, Functor, Foldable)
|
||||
|
||||
type IsNThunk t f g m =
|
||||
(MonadThunk (NValue f g m) t m, MonadDataContext f m, t ~ NThunk f g m)
|
||||
|
||||
type NThunk f g m
|
||||
= g (Fix (Compose f (Compose (NValueF (NValue f g m) m) g)))
|
||||
|
||||
class HasNValueF f g v m s r | v -> f, v -> g, v -> s, v -> r, v -> m where
|
||||
nValueF :: (s -> a) -> (f (NValueF (NValue f g m) m r) -> a) -> v -> a
|
||||
|
||||
instance MonadDataContext f m
|
||||
=> HasNValueF f g (NValue f g m) m Void (NThunk f g m) where
|
||||
nValueF _ r (NValue (Fix (Compose (fmap getCompose -> v)))) = r v
|
||||
|
||||
instance MonadDataContext f m
|
||||
=> HasNValueF f g (NValueNF f g m) m
|
||||
(NValue f g m)
|
||||
(NValueNF f g m) where
|
||||
nValueF s _ (Pure v) = s v
|
||||
nValueF _ r (Free (Compose v)) = r v
|
||||
|
||||
type ValueSet f g m = AttrSet (NThunk f g m)
|
||||
|
||||
thunkEq :: IsNThunk t f g m => t -> t -> m Bool
|
||||
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||
let unsafePtrEq = case (lt, rt) of
|
||||
(thunkId -> lid, thunkId -> rid)
|
||||
| lid == rid -> return True
|
||||
_ -> valueEq lv rv
|
||||
in case (lv, rv) of
|
||||
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
||||
(NVList _, NVList _) -> unsafePtrEq
|
||||
(NVSet _ _, NVSet _ _) -> unsafePtrEq
|
||||
_ -> valueEq lv rv
|
||||
|
||||
iterNValue
|
||||
:: forall t m f g r. IsNThunk t f g m
|
||||
=> (t -> (NValue f g m -> r) -> r)
|
||||
-> (f (NValueF (NValue f g m) m r) -> r)
|
||||
-> NValue f g m -> r
|
||||
iterNValue k f = nValueF absurd (f . fmap (fmap (\t -> k t (iterNValue k f))))
|
||||
|
||||
iterNValueM
|
||||
:: forall t m n f g r. (IsNThunk t f g m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
-> (t -> (NValue f g m -> n r) -> n r)
|
||||
-> (f (NValueF (NValue f g m) m r) -> n r)
|
||||
-> NValue f g m -> n r
|
||||
iterNValueM transform k f = nValueF absurd (f <=< traverse go)
|
||||
where
|
||||
go = \case
|
||||
NVConstantF a -> pure $ NVConstantF a
|
||||
NVStrF s -> pure $ NVStrF s
|
||||
NVPathF p -> pure $ NVPathF p
|
||||
NVListF l -> NVListF <$> traverse h l
|
||||
NVSetF s p -> NVSetF <$> traverse h s <*> pure p
|
||||
NVClosureF p g -> pure $ NVClosureF p (transform . h <=< g)
|
||||
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . h <=< g)
|
||||
where
|
||||
h t = k t (iterNValueM transform k f)
|
||||
|
||||
iterNValueNF
|
||||
:: forall m f g r. MonadDataContext f m
|
||||
=> (NValue f g m -> r)
|
||||
-> (f (NValueF (NValue f g m) m r) -> r)
|
||||
-> NValueNF f g m -> r
|
||||
iterNValueNF k f = nValueF k (f . fmap (fmap (iterNValueNF k f)))
|
||||
|
||||
iterNValueNFM
|
||||
:: forall m n f g r. (MonadDataContext f m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
-> (NValue f g m -> n r)
|
||||
-> (f (NValueF (NValue f g m) m r) -> n r)
|
||||
-> NValueNF f g m -> n r
|
||||
iterNValueNFM transform k f = nValueF k (f <=< traverse go)
|
||||
where
|
||||
go = \case
|
||||
NVConstantF a -> pure $ NVConstantF a
|
||||
NVStrF s -> pure $ NVStrF s
|
||||
NVPathF p -> pure $ NVPathF p
|
||||
NVListF l -> NVListF <$> traverse h l
|
||||
NVSetF s p -> NVSetF <$> traverse h s <*> pure p
|
||||
NVClosureF p g -> pure $ NVClosureF p (transform . h <=< g)
|
||||
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . h <=< g)
|
||||
where
|
||||
h = iterNValueNFM transform k f
|
||||
|
||||
nValueFromNF :: forall m f g. (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> NValueNF f g m -> NValue f g m
|
||||
nValueFromNF =
|
||||
iterNValueNF id (NValue . Fix . Compose . fmap (Compose . fmap wrapValue))
|
||||
|
||||
nValueToNF :: forall m f g. (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> (NThunk f g m -> (NValue f g m -> NValueNF f g m) -> NValueNF f g m)
|
||||
-> NValue f g m
|
||||
-> NValueNF f g m
|
||||
nValueToNF k = iterNValue k $ Free . Compose
|
||||
|
||||
nValueToNFM
|
||||
:: forall t m n f g. (IsNThunk t f g m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
-> (t -> (NValue f g m -> n (NValueNF f g m)) -> n (NValueNF f g m))
|
||||
-> NValue f g m
|
||||
-> n (NValueNF f g m)
|
||||
nValueToNFM transform k = iterNValueM transform k $ pure . Free . Compose
|
||||
|
||||
-- addProvenance :: (NValue f g m -> Provenance t (NValue f g m) m) -> NValue f g m -> NValue f g m
|
||||
-- addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
|
||||
|
||||
pattern NVConstant x <- NValue (Fix (Compose (extract -> Compose (NVConstantF x))))
|
||||
pattern NVConstantNF x <- Free (Compose (extract -> NVConstantF x))
|
||||
|
||||
nvConstant :: MonadDataContext f m => NAtom -> NValue f g m
|
||||
nvConstant x = NValue (Fix (Compose (pure (Compose (NVConstantF x)))))
|
||||
nvConstantNF :: MonadDataContext f m => NAtom -> NValueNF f g m
|
||||
nvConstantNF x = Free (Compose (pure (NVConstantF x)))
|
||||
-- nvConstantP p x = NValue (NCited [p] (NVConstantF x))
|
||||
|
||||
pattern NVStr ns <- NValue (Fix (Compose (extract -> Compose (NVStrF ns))))
|
||||
pattern NVStrNF ns <- Free (Compose (extract -> NVStrF ns))
|
||||
|
||||
nvStr :: MonadDataContext f m => NixString -> NValue f g m
|
||||
nvStr ns = NValue (Fix (Compose (pure (Compose (NVStrF ns)))))
|
||||
nvStrNF :: MonadDataContext f m => NixString -> NValueNF f g m
|
||||
nvStrNF ns = Free (Compose (pure (NVStrF ns)))
|
||||
-- nvStrP p ns = NValue (NCited [p] (NVStrF ns))
|
||||
|
||||
pattern NVPath x <- NValue (Fix (Compose (extract -> Compose (NVPathF x))))
|
||||
pattern NVPathNF x <- Free (Compose (extract -> NVPathF x))
|
||||
|
||||
nvPath :: MonadDataContext f m => FilePath -> NValue f g m
|
||||
nvPath x = NValue (Fix (Compose (pure (Compose (NVPathF x)))))
|
||||
nvPathNF :: MonadDataContext f m => FilePath -> NValueNF f g m
|
||||
nvPathNF x = Free (Compose (pure (NVPathF x)))
|
||||
-- nvPathP p x = NValue (NCited [p] (NVPathF x))
|
||||
|
||||
pattern NVList l <- NValue (Fix (Compose (extract -> Compose (NVListF l))))
|
||||
pattern NVListNF l <- Free (Compose (extract -> NVListF l))
|
||||
|
||||
nvList :: MonadDataContext f m => [NThunk f g m] -> NValue f g m
|
||||
nvList l = NValue (Fix (Compose (pure (Compose (NVListF l)))))
|
||||
nvListNF :: MonadDataContext f m => [NValueNF f g m] -> NValueNF f g m
|
||||
nvListNF l = Free (Compose (pure (NVListF l)))
|
||||
-- nvListP p l = NValue (NCited [p] (NVListF l))
|
||||
|
||||
pattern NVSet s x <- NValue (Fix (Compose (extract -> Compose (NVSetF s x))))
|
||||
pattern NVSetNF s x <- Free (Compose (extract -> NVSetF s x))
|
||||
|
||||
nvSet :: MonadDataContext f m
|
||||
=> HashMap Text (NThunk f g m) -> HashMap Text SourcePos -> NValue f g m
|
||||
nvSet s x = NValue (Fix (Compose (pure (Compose (NVSetF s x)))))
|
||||
nvSetNF :: MonadDataContext f m
|
||||
=> HashMap Text (NValueNF f g m) -> HashMap Text SourcePos -> NValueNF f g m
|
||||
nvSetNF s x = Free (Compose (pure (NVSetF s x)))
|
||||
-- nvSetP p s x = NValue (NCited [p] (NVSetF s x))
|
||||
|
||||
pattern NVClosure x f <- NValue (Fix (Compose (extract -> Compose (NVClosureF x f))))
|
||||
pattern NVClosureNF x f <- Free (Compose (extract -> NVClosureF x f))
|
||||
|
||||
nvClosure :: MonadDataContext f m
|
||||
=> Params () -> (m (NValue f g m) -> m (NThunk f g m)) -> NValue f g m
|
||||
nvClosure x f = NValue (Fix (Compose (pure (Compose (NVClosureF x f)))))
|
||||
nvClosureNF :: MonadDataContext f m
|
||||
=> Params () -> (m (NValue f g m) -> m (NValueNF f g m)) -> NValueNF f g m
|
||||
nvClosureNF x f = Free (Compose (pure (NVClosureF x f)))
|
||||
-- nvClosureP p x f = NValue (NCited [p] (NVClosureF x f))
|
||||
|
||||
pattern NVBuiltin name f <- NValue (Fix (Compose (extract -> Compose (NVBuiltinF name f))))
|
||||
pattern NVBuiltinNF name f <- Free (Compose (extract -> NVBuiltinF name f))
|
||||
|
||||
nvBuiltin :: MonadDataContext f m
|
||||
=> String -> (m (NValue f g m) -> m (NThunk f g m)) -> NValue f g m
|
||||
nvBuiltin name f = NValue (Fix (Compose (pure (Compose (NVBuiltinF name f)))))
|
||||
nvBuiltinNF :: MonadDataContext f m
|
||||
=> String -> (m (NValue f g m) -> m (NValueNF f g m)) -> NValueNF f g m
|
||||
nvBuiltinNF name f = Free (Compose (pure (NVBuiltinF name f)))
|
||||
-- nvBuiltinP p name f = NValue (NCited [p] (NVBuiltinF name f))
|
||||
|
||||
{-
|
||||
instance Show (NValueF (NValue f g m) m (Fix (NValueF (NValue f g m) m))) where
|
||||
instance Show r => Show (NValueF p m r) where
|
||||
showsPrec = flip go where
|
||||
go (NVConstantF atom) = showsCon1 "NVConstant" atom
|
||||
go (NVStrF ns) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
|
||||
|
|
@ -309,21 +141,141 @@ instance Show (NValueF (NValue f g m) m (Fix (NValueF (NValue f g m) m))) where
|
|||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
||||
showsCon1 con a d =
|
||||
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
||||
-}
|
||||
|
||||
{-
|
||||
showsCon2 :: (Show a, Show b)
|
||||
=> String -> a -> b -> Int -> String -> String
|
||||
showsCon2 con a b d =
|
||||
showParen (d > 10)
|
||||
$ showString (con ++ " ")
|
||||
. showsPrec 11 a
|
||||
. showString " "
|
||||
. showsPrec 11 b
|
||||
-}
|
||||
instance (MonadDataContext f m, Show a) => Show (NValue' t f m a) where
|
||||
show (NValue (extract -> v)) = show v
|
||||
|
||||
{-
|
||||
instance Eq (NValue f g m) where
|
||||
type NValue t f m = NValue' t f m t
|
||||
|
||||
bindNValue :: (Traversable f, Monad m, Monad n)
|
||||
=> (forall x. n x -> m x) -> (a -> n b) -> NValue' t f m a
|
||||
-> n (NValue' t f m b)
|
||||
bindNValue transform f (NValue v) =
|
||||
NValue <$> traverse (bindNValueF transform f) v
|
||||
|
||||
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is
|
||||
-- a value in head normal form, where only the "top layer" has been
|
||||
-- evaluated. An action of type 'm (NValue f t m)' is a pending evualation that
|
||||
-- has yet to be performed. An 't' is either a pending evaluation, or
|
||||
-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys
|
||||
-- to thunks.
|
||||
--
|
||||
-- The 'Free' structure is used here to represent the possibility that
|
||||
-- cycles may appear during normalization.
|
||||
|
||||
type NValueNF t f m = Free (NValue' t f m) (NValue' t f m Void)
|
||||
|
||||
iterNValue
|
||||
:: forall t f m a r. MonadDataContext f m
|
||||
=> (a -> (NValue' t f m a -> r) -> r)
|
||||
-> (NValue' t f m r -> r)
|
||||
-> NValue' t f m a -> r
|
||||
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
|
||||
|
||||
iterNValueM
|
||||
:: (MonadDataContext f m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
-> (a -> (NValue' t f m a -> n r) -> n r)
|
||||
-> (NValue' t f m r -> n r)
|
||||
-> NValue' t f m a -> n r
|
||||
iterNValueM transform k f =
|
||||
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
|
||||
|
||||
iterNValueNF
|
||||
:: MonadDataContext f m
|
||||
=> (NValue' t f m Void -> r)
|
||||
-> (NValue' t f m r -> r)
|
||||
-> NValueNF t f m -> r
|
||||
iterNValueNF k f = iter f . fmap k
|
||||
|
||||
iterNValueNFM
|
||||
:: forall f m n t r. (MonadDataContext f m, Monad n)
|
||||
=> (NValue' t f m Void -> n r)
|
||||
-> (NValue' t f m (n r) -> n r)
|
||||
-> NValueNF t f m -> n r
|
||||
iterNValueNFM k f v = join (iterM (pure . f . fmap join) (fmap k v))
|
||||
|
||||
nValueFromNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValueNF t f m -> NValue t f m
|
||||
nValueFromNF = iterNValueNF (fmap absurd) (fmap wrapValue)
|
||||
|
||||
nValueToNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
|
||||
-> NValue t f m
|
||||
-> NValueNF t f m
|
||||
nValueToNF k = iterNValue k Free
|
||||
|
||||
nValueToNFM
|
||||
:: (MonadDataContext f m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
-> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
|
||||
-> NValue t f m
|
||||
-> n (NValueNF t f m)
|
||||
nValueToNFM transform k = iterNValueM transform k $ pure . Free
|
||||
|
||||
pattern NVConstant x <- NValue (extract -> NVConstantF x)
|
||||
pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))
|
||||
|
||||
nvConstant :: MonadDataContext f m => NAtom -> NValue t f m
|
||||
nvConstant x = NValue (pure (NVConstantF x))
|
||||
nvConstantNF :: MonadDataContext f m => NAtom -> NValueNF t f m
|
||||
nvConstantNF x = Free (NValue (pure (NVConstantF x)))
|
||||
|
||||
pattern NVStr ns <- NValue (extract -> NVStrF ns)
|
||||
pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))
|
||||
|
||||
nvStr :: MonadDataContext f m => NixString -> NValue t f m
|
||||
nvStr ns = NValue (pure (NVStrF ns))
|
||||
nvStrNF :: MonadDataContext f m => NixString -> NValueNF t f m
|
||||
nvStrNF ns = Free (NValue (pure (NVStrF ns)))
|
||||
|
||||
pattern NVPath x <- NValue (extract -> NVPathF x)
|
||||
pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))
|
||||
|
||||
nvPath :: MonadDataContext f m => FilePath -> NValue t f m
|
||||
nvPath x = NValue (pure (NVPathF x))
|
||||
nvPathNF :: MonadDataContext f m => FilePath -> NValueNF t f m
|
||||
nvPathNF x = Free (NValue (pure (NVPathF x)))
|
||||
|
||||
pattern NVList l <- NValue (extract -> NVListF l)
|
||||
pattern NVListNF l <- Free (NValue (extract -> NVListF l))
|
||||
|
||||
nvList :: MonadDataContext f m => [t] -> NValue t f m
|
||||
nvList l = NValue (pure (NVListF l))
|
||||
nvListNF :: MonadDataContext f m => [NValueNF t f m] -> NValueNF t f m
|
||||
nvListNF l = Free (NValue (pure (NVListF l)))
|
||||
|
||||
pattern NVSet s x <- NValue (extract -> NVSetF s x)
|
||||
pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))
|
||||
|
||||
nvSet :: MonadDataContext f m
|
||||
=> HashMap Text t -> HashMap Text SourcePos -> NValue t f m
|
||||
nvSet s x = NValue (pure (NVSetF s x))
|
||||
nvSetNF :: MonadDataContext f m
|
||||
=> HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m
|
||||
nvSetNF s x = Free (NValue (pure (NVSetF s x)))
|
||||
|
||||
pattern NVClosure x f <- NValue (extract -> NVClosureF x f)
|
||||
pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))
|
||||
|
||||
nvClosure :: MonadDataContext f m
|
||||
=> Params () -> (m (NValue t f m) -> m t) -> NValue t f m
|
||||
nvClosure x f = NValue (pure (NVClosureF x f))
|
||||
nvClosureNF :: MonadDataContext f m
|
||||
=> Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
|
||||
nvClosureNF x f = Free (NValue (pure (NVClosureF x f)))
|
||||
|
||||
pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)
|
||||
pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))
|
||||
|
||||
nvBuiltin :: MonadDataContext f m
|
||||
=> String -> (m (NValue t f m) -> m t) -> NValue t f m
|
||||
nvBuiltin name f = NValue (pure (NVBuiltinF name f))
|
||||
nvBuiltinNF :: MonadDataContext f m
|
||||
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
|
||||
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
|
||||
|
||||
instance MonadDataContext f m => Eq (NValue t f m) where
|
||||
NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y
|
||||
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
|
||||
NVConstant (NInt x) == NVConstant (NInt y) = x == y
|
||||
|
|
@ -332,7 +284,7 @@ instance Eq (NValue f g m) where
|
|||
NVPath x == NVPath y = x == y
|
||||
_ == _ = False
|
||||
|
||||
instance Ord (NValue f g m) where
|
||||
instance MonadDataContext f m => Ord (NValue t f m) where
|
||||
NVConstant (NFloat x) <= NVConstant (NInt y) = x <= fromInteger y
|
||||
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
|
||||
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
|
||||
|
|
@ -341,7 +293,8 @@ instance Ord (NValue f g m) where
|
|||
NVPath x <= NVPath y = x <= y
|
||||
_ <= _ = False
|
||||
|
||||
checkComparable :: (Framed e m, Typeable m) => NValue f g m -> NValue f g m -> m ()
|
||||
checkComparable :: (Framed e m, MonadDataErrorContext t f m)
|
||||
=> NValue t f m -> NValue t f m -> m ()
|
||||
checkComparable x y = case (x, y) of
|
||||
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
|
||||
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
|
||||
|
|
@ -350,26 +303,39 @@ checkComparable x y = case (x, y) of
|
|||
(NVStr _, NVStr _) -> pure ()
|
||||
(NVPath _, NVPath _) -> pure ()
|
||||
_ -> throwError $ Comparison x y
|
||||
-}
|
||||
|
||||
builtin :: forall m f g. (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> String -> (m (NValue f g m) -> m (NValue f g m)) -> m (NValue f g m)
|
||||
type IsThunk f m t = (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
|
||||
thunkEq :: IsThunk f m t => t -> t -> m Bool
|
||||
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||
let unsafePtrEq = case (lt, rt) of
|
||||
(thunkId -> lid, thunkId -> rid)
|
||||
| lid == rid -> return True
|
||||
_ -> valueEq lv rv
|
||||
in case (lv, rv) of
|
||||
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
||||
(NVList _, NVList _) -> unsafePtrEq
|
||||
(NVSet _ _, NVSet _ _) -> unsafePtrEq
|
||||
_ -> valueEq lv rv
|
||||
|
||||
builtin :: forall m f t. (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> String -> (m (NValue t f m) -> m (NValue t f m)) -> m (NValue t f m)
|
||||
builtin name f = return $ nvBuiltin name $ thunk . f
|
||||
|
||||
builtin2 :: (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> String -> (m (NValue f g m) -> m (NValue f g m) -> m (NValue f g m))
|
||||
-> m (NValue f g m)
|
||||
builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> String -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
|
||||
-> m (NValue t f m)
|
||||
builtin2 name f = builtin name (builtin name . f)
|
||||
|
||||
builtin3 :: (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> String
|
||||
-> (m (NValue f g m) -> m (NValue f g m) -> m (NValue f g m) -> m (NValue f g m))
|
||||
-> m (NValue f g m)
|
||||
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
|
||||
-> m (NValue t f m)
|
||||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
isClosureNF :: MonadDataContext f m => NValueNF f g m -> Bool
|
||||
isClosureNF (Free (Compose (extract -> NVClosureF {}))) = True
|
||||
isClosureNF :: MonadDataContext f m => NValueNF t f m -> Bool
|
||||
isClosureNF NVClosureNF {} = True
|
||||
isClosureNF _ = False
|
||||
|
||||
-- | Checks whether two containers are equal, using the given item equality
|
||||
|
|
@ -387,8 +353,8 @@ alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
|
|||
_ -> throwE ()
|
||||
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
|
||||
|
||||
isDerivation :: (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> AttrSet (NThunk f g m) -> m Bool
|
||||
isDerivation :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> AttrSet t -> m Bool
|
||||
isDerivation m = case M.lookup "type" m of
|
||||
Nothing -> pure False
|
||||
Just t -> force t $ \case
|
||||
|
|
@ -397,8 +363,8 @@ isDerivation m = case M.lookup "type" m of
|
|||
NVStr s -> pure $ principledStringIgnoreContext s == "derivation"
|
||||
_ -> pure False
|
||||
|
||||
valueEq :: (MonadThunk (NValue f g m) (NThunk f g m) m, MonadDataContext f m)
|
||||
=> NValue f g m -> NValue f g m -> m Bool
|
||||
valueEq :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m -> NValue t f m -> m Bool
|
||||
valueEq = curry $ \case
|
||||
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
|
||||
(NVStr ls, NVStr rs) ->
|
||||
|
|
@ -462,36 +428,7 @@ describeValue = \case
|
|||
TPath -> "a path"
|
||||
TBuiltin -> "a builtin function"
|
||||
|
||||
instance MonadDataContext f m => Show (NValue f g m) where
|
||||
show = describeValue
|
||||
. valueType
|
||||
. getCompose
|
||||
. extract
|
||||
. getCompose
|
||||
. unFix
|
||||
. _nValue
|
||||
|
||||
{-
|
||||
instance Show (NValueF (NValue f g m) m
|
||||
(f (Fix (Compose g
|
||||
(Compose (NValueF (NValue f g m) m)
|
||||
f))))) where
|
||||
show = describeValue . valueType
|
||||
|
||||
instance Show (NValueF (NValue f g m) m
|
||||
(Free (Compose g
|
||||
(NValueF (NValue f g m) m)) v)) where
|
||||
show = describeValue . valueType
|
||||
|
||||
instance MonadDataContext f m
|
||||
=> Show (Free (Compose g
|
||||
(NValueF (NValue f g m) m))
|
||||
(NValue f g m)) where
|
||||
show (Pure v) = show v
|
||||
show (Free (Compose (extract -> v))) = show v
|
||||
-}
|
||||
|
||||
instance Eq1 (NValueF (NValue f g m) m) where
|
||||
instance Eq1 (NValueF (NValue' t f m a) m) where
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
liftEq _ (NVStrF x) (NVStrF y) = x == y
|
||||
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
|
||||
|
|
@ -499,36 +436,40 @@ instance Eq1 (NValueF (NValue f g m) m) where
|
|||
liftEq _ (NVPathF x) (NVPathF y) = x == y
|
||||
liftEq _ _ _ = False
|
||||
|
||||
instance Show1 (NValueF (NValue f g m) m) where
|
||||
instance MonadDataContext f m => Show1 (NValue' t f m) where
|
||||
liftShowsPrec sp sl p = \case
|
||||
NVConstantF atom -> showsUnaryWith showsPrec "NVConstantF" p atom
|
||||
NVStrF ns -> showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
|
||||
NVListF lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
|
||||
NVSetF attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
|
||||
NVClosureF c _ -> showsUnaryWith showsPrec "NVClosureF" p c
|
||||
NVPathF path -> showsUnaryWith showsPrec "NVPathF" p path
|
||||
NVBuiltinF name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
|
||||
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
|
||||
NVStr ns -> showsUnaryWith showsPrec "NVStrF" p
|
||||
(hackyStringIgnoreContext ns)
|
||||
NVList lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
|
||||
NVSet attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
|
||||
NVPath path -> showsUnaryWith showsPrec "NVPathF" p path
|
||||
NVClosure c _ -> showsUnaryWith showsPrec "NVClosureF" p c
|
||||
NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
|
||||
_ -> error "Pattern synonyms mask coverage"
|
||||
|
||||
data ValueFrame f g m
|
||||
data ValueFrame t f m
|
||||
= ForcingThunk
|
||||
| ConcerningValue (NValue f g m)
|
||||
| Comparison (NValue f g m) (NValue f g m)
|
||||
| Addition (NValue f g m) (NValue f g m)
|
||||
| Multiplication (NValue f g m) (NValue f g m)
|
||||
| Division (NValue f g m) (NValue f g m)
|
||||
| ConcerningValue (NValue t f m)
|
||||
| Comparison (NValue t f m) (NValue t f m)
|
||||
| Addition (NValue t f m) (NValue t f m)
|
||||
| Multiplication (NValue t f m) (NValue t f m)
|
||||
| Division (NValue t f m) (NValue t f m)
|
||||
| Coercion ValueType ValueType
|
||||
| CoercionToJson (NValue f g m)
|
||||
| CoercionToJson (NValue t f m)
|
||||
| CoercionFromJson A.Value
|
||||
| ExpectationNF ValueType (NValueNF f g m)
|
||||
| Expectation ValueType (NValue f g m)
|
||||
| ExpectationNF ValueType (NValueNF t f m)
|
||||
| Expectation ValueType (NValue t f m)
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance (Typeable m, Typeable f, Typeable g, MonadDataContext f m)
|
||||
=> Exception (ValueFrame f g m)
|
||||
type MonadDataErrorContext t f m =
|
||||
(Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
|
||||
|
||||
instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)
|
||||
|
||||
$(makeTraversals ''NValueF)
|
||||
$(makeLenses ''NValue)
|
||||
$(makeLenses ''NValue')
|
||||
|
||||
key :: MonadDataContext f m
|
||||
=> VarName -> LensLike' f (NValue f g m) (Maybe (NThunk f g m))
|
||||
key k = nValue._unFix._getCompose.traverse._getCompose._NVSetF._1.hashAt k
|
||||
key :: (MonadDataContext f m, Applicative g)
|
||||
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
|
||||
key k = nValue.traverse._NVSetF._1.hashAt k
|
||||
|
|
|
|||
Loading…
Reference in a new issue