picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Hopefully finished up with Value.hs and Normal.hs

Browse source
This commit is contained in:
John Wiegley 2019-03-13 10:53:58 -07:00
parent 505591515f
commit 67bc3f2a69
No known key found for this signature in database
GPG key ID: C144D8F4F19FE630
3 changed files with 124 additions and 112 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

121
src/Nix/Normal.hs
View file

@ -15,82 +15,87 @@ module Nix.Normal where
import Control.Monad
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import qualified Data.HashMap.Lazy as M
import Data.List (find)
import Data.Maybe (isJust)
import Data.Functor.Compose
import Data.Set
import Nix.Frames
-- import Nix.Pretty
import Nix.String
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var
newtype NormalLoop m = NormalLoop (NValue m)
deriving Show
instance (MonadDataContext m, Typeable m) => Exception (NormalLoop m)
normalFormBy
:: forall e m. (Framed e m, MonadVar m, Typeable m)
=> (forall r. NThunk m -> (NValue m -> StateT [Var m Bool] m r)
-> StateT [Var m Bool] m r)
-> Int
-> NValue m
-> StateT [Var m Bool] m (NValueNF m)
normalFormBy k n v = case v of
NVConstant a -> return $ Free $ NVConstantF a
NVStr ns -> return $ Free $ NVStrF ns
NVList l ->
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
k t (next t)
NVSet s p ->
fmap (Free . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
traceM $ show n ++ ": normalFormBy: Set{" ++ show ky ++ "}"
k t (next t)
NVClosure p f -> return $ Free $ NVClosureF p f
NVPath fp -> return $ Free $ NVPathF fp
NVBuiltin name f -> return $ Free $ NVBuiltinF name f
_ -> error "Pattern synonyms mask complete matches"
normalForm'
:: forall e m.
(Framed e m,
Typeable m,
MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m)
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
-> NValue m -> m (NValueNF m)
normalForm' f = run . nValueToNFM run go
where
next t val = do
b <- seen t
if b
then return $ Pure val
else normalFormBy k (succ n) val
start = 0 :: Int
table = mempty
-- jww (2019-03-11): NYI
-- seen (NThunk (NCited _ (Thunk _ b _))) = do
-- res <- gets (isJust . find (eqVar @m b))
-- unless res $
-- modify (b:)
-- return res
seen _ = pure False
run :: ReaderT Int (StateT (Set Int) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
normalForm' :: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
-> NValue m -> m (NValueNF m)
normalForm' f = flip evalStateT mempty . normalFormBy go 0
where
go :: NThunk m
-> (NValue m -> StateT [Var m Bool] m r)
-> StateT [Var m Bool] m r
-> (NValue m -> ReaderT Int (StateT (Set Int) m) (NValueNF m))
-> ReaderT Int (StateT (Set Int) m) (NValueNF m)
go t k = do
s <- get
(res, s') <- lift $ f t $ \v -> runStateT (k v) s
put s'
i <- ask
when (i > 2000) $
error "Exceeded maximum normalization depth of 2000 levels"
s <- lift get
(res, s') <- lift $ lift $ f t $ \v ->
(`runStateT` s) . (`runReaderT` i) $ local succ $ do
b <- seen t
if b
then return $ NValueNF $ Pure v
else k v
lift $ put s'
return res
normalForm :: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> NValue m -> m (NValueNF m)
seen t = do
let tid = thunkId t
lift $ do
res <- gets (member tid)
unless res $ modify (insert tid)
return res
normalForm
:: forall e m.
(Framed e m,
Typeable m,
MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m)
=> NValue m -> m (NValueNF m)
normalForm = normalForm' force
normalForm_
:: forall e m. (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
:: forall e m.
(Framed e m,
Typeable m,
MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m)
=> NValue m -> m ()
normalForm_ = void . normalForm' (forceEffects . _cited . _nThunk)
normalForm_ = void . normalForm' forceEff
removeEffects :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValue m -> NValueNF m
removeEffects = nValueToNF (flip query opaque)
removeEffectsM :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValue m -> m (NValueNF m)
removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
opaque :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValueNF m
opaque = NValueNF $ Free $ Compose $ pure $ NVStrF @(NValue m) $
principledMakeNixStringWithoutContext "<thunk>"

2
src/Nix/Thunk/Basic.hs
View file

@ -12,7 +12,7 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Thunk.Basic where
module Nix.Thunk.Basic () where
import Control.Exception hiding (catch)
import Control.Monad.Catch

113
src/Nix/Value.hs
View file

@ -105,7 +105,7 @@ comapNValueFArg f = \case
newtype NValueNF m
= NValueNF { _nValueNF :: Free (Compose (ValueContext m)
(NValueF (NValueNF m) m)) (NValueNF m) }
(NValueF (NValue m) m)) (NValue m) }
deriving (Generic, Typeable)
class (Monad m,
@ -143,18 +143,22 @@ thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
iterNValue
:: forall m r. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (NThunk m -> r)
=> (NThunk m -> (NValue m -> r) -> r)
-> (ValueContext m (NValueF (NValue m) m r) -> r)
-> NValue m -> r
iterNValue h f (NValue (Fix (Compose (fmap getCompose -> v)))) =
f (fmap (fmap h) v)
iterNValue k f (NValue (Fix (Compose (fmap getCompose -> v)))) =
f (fmap (fmap (\t -> k t (iterNValue k f))) v)
iterNValueM
:: forall m r. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (NThunk m -> m r)
-> (ValueContext m (NValueF (NValue m) m r) -> m r)
-> NValue m -> m r
iterNValueM h f (NValue (Fix (Compose (fmap getCompose -> v)))) =
:: forall m n r.
(MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m,
Monad n)
=> (forall x. n x -> m x)
-> (NThunk m -> (NValue m -> n r) -> n r)
-> (ValueContext m (NValueF (NValue m) m r) -> n r)
-> NValue m -> n r
iterNValueM transform k f (NValue (Fix (Compose (fmap getCompose -> v)))) =
f =<< traverse go v
where
go = \case
@ -163,23 +167,31 @@ iterNValueM h f (NValue (Fix (Compose (fmap getCompose -> v)))) =
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 (h <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (h <=< g)
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 r. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (ValueContext m (NValueF (NValueNF m) m r) -> r)
=> (ValueContext m (NValueF (NValue m) m r) -> r)
-> (NValue m -> r)
-> NValueNF m -> r
iterNValueNF f (NValueNF (Pure v)) = iterNValueNF f v
iterNValueNF f (NValueNF (Free (Compose v))) =
f (fmap (fmap (iterNValueNF f . NValueNF)) v)
iterNValueNF _ k (NValueNF (Pure v)) = k v
iterNValueNF f k (NValueNF (Free (Compose v))) =
f (fmap (fmap (iterNValueNF f k . NValueNF)) v)
iterNValueNFM
:: forall m r. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (ValueContext m (NValueF (NValueNF m) m r) -> m r)
-> NValueNF m -> m r
iterNValueNFM f (NValueNF (Pure v)) = iterNValueNFM f v
iterNValueNFM f (NValueNF (Free (Compose v))) =
:: forall m n r.
(MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m,
Monad n)
=> (forall x. n x -> m x)
-> (ValueContext m (NValueF (NValue m) m r) -> n r)
-> (NValue m -> n r)
-> NValueNF m -> n r
iterNValueNFM _ _ k (NValueNF (Pure v)) = k v
iterNValueNFM transform f k (NValueNF (Free (Compose v))) =
f =<< traverse go v
where
go = \case
@ -188,44 +200,34 @@ iterNValueNFM f (NValueNF (Free (Compose v))) =
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 (h <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (h <=< g)
NVClosureF p g -> pure $ NVClosureF p (transform . h <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . h <=< g)
where
h = iterNValueNFM f . NValueNF
h = iterNValueNFM transform f k . NValueNF
nValueFromNF :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (NValue m -> NValueNF m) -> NValueNF m -> NValue m
nValueFromNF f = iterNValueNF $
NValue . Fix . Compose . fmap (Compose . fmap wrapValue . comapNValueFArg f)
=> NValueNF m -> NValue m
nValueFromNF =
iterNValueNF (NValue . Fix . Compose . fmap (Compose . fmap wrapValue)) id
nValueToNF :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (NThunk m -> NValueNF m) -> (NValueNF m -> NValue m) -> NValue m
=> (NThunk m -> (NValue m -> NValueNF m) -> NValueNF m)
-> NValue m
-> NValueNF m
nValueToNF k f = iterNValue k $
NValueNF . Free . Compose . fmap (fmap _nValueNF . comapNValueFArg f)
nValueToNF k =
iterNValue k $ NValueNF . Free . Compose . fmap (fmap _nValueNF)
removeEffects :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValue m -> NValueNF m
removeEffects =
nValueToNF (\t -> query t opaque removeEffects) (nValueFromNF removeEffects)
nValueToNFM :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> (NThunk m -> m (NValueNF m)) -> (NValueNF m -> NValue m) -> NValue m
-> m (NValueNF m)
nValueToNFM k f = iterNValueM k $
pure . NValueNF . Free . Compose
. fmap (fmap _nValueNF . comapNValueFArg f)
removeEffectsM :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValue m -> m (NValueNF m)
removeEffectsM =
nValueToNFM (\t -> queryM t (pure opaque) removeEffectsM)
(nValueFromNF removeEffects)
opaque :: forall m. (MonadThunk (NValue m) (NThunk m) m, MonadDataContext m)
=> NValueNF m
opaque = NValueNF $ Free $ Compose $ pure $ NVStrF @(NValueNF m) $
principledMakeNixStringWithoutContext "<thunk>"
nValueToNFM
:: forall m n.
(MonadThunk (NValue m) (NThunk m) m,
MonadDataContext m,
Monad n)
=> (forall x. n x -> m x)
-> (NThunk m -> (NValue m -> n (NValueNF m)) -> n (NValueNF m))
-> NValue m
-> n (NValueNF m)
nValueToNFM transform k = iterNValueM transform k $
pure . NValueNF . Free . Compose . fmap (fmap _nValueNF)
-- addProvenance :: (NValue m -> Provenance t (NValue m) m) -> NValue m -> NValue m
-- addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
@ -439,10 +441,15 @@ instance MonadDataContext m => Show (NValue m) where
. _nValue
instance Show (NValueF (NValue m) m
(f (Fix (Compose g (Compose (NValueF (NValue m) m) f))))) where
(f (Fix (Compose g
(Compose (NValueF (NValue m) m)
f))))) where
show = describeValue . valueType
instance Show (NValueF (NValueNF m) m r) where
instance Show (NValueF (NValue m) m
(Free (Compose g
(NValueF (NValue m) m))
r)) where
show = describeValue . valueType
-- instance MonadDataContext m => Show (NValue m) where