Simplify Standard.hs further by creating Nix.Utils.Fix1
This commit is contained in:
John Wiegley
parent
77c52fd43c
commit
9e22c63bd5
|
|
@ -35,7 +35,6 @@
|
|||
}:
|
||||
|
||||
let
|
||||
|
||||
hnix-store-src = pkgs.fetchFromGitHub {
|
||||
owner = "haskell-nix";
|
||||
repo = "hnix-store";
|
||||
|
|
@ -94,7 +93,7 @@ let
|
|||
haskellPackages = pkgs.haskell.packages.${compiler}.override
|
||||
overrideHaskellPackages;
|
||||
|
||||
drv = haskellPackages.developPackage {
|
||||
in haskellPackages.developPackage {
|
||||
name = "hnix";
|
||||
root = ./.;
|
||||
|
||||
|
|
@ -126,6 +125,4 @@ drv = haskellPackages.developPackage {
|
|||
});
|
||||
|
||||
returnShellEnv = false;
|
||||
};
|
||||
|
||||
in drv
|
||||
}
|
||||
|
|
|
|||
|
|
@ -475,6 +475,7 @@ library
|
|||
Nix.Type.Infer
|
||||
Nix.Type.Type
|
||||
Nix.Utils
|
||||
Nix.Utils.Fix1
|
||||
Nix.Value
|
||||
Nix.Value.Equal
|
||||
Nix.Value.Monad
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
|
@ -44,6 +45,7 @@ import Nix.Render
|
|||
import Nix.Scope
|
||||
import Nix.Thunk
|
||||
import Nix.Thunk.Basic
|
||||
import Nix.Utils.Fix1
|
||||
import Nix.Value
|
||||
import Nix.Value.Monad
|
||||
import Nix.Var
|
||||
|
|
@ -51,64 +53,21 @@ import Nix.Var
|
|||
import System.Console.Haskeline.MonadException hiding(catch)
|
||||
#endif
|
||||
|
||||
newtype StdThunk (m :: * -> *) = StdThunk
|
||||
{ _stdThunk :: StdCited m (NThunkF m (StdValue m)) }
|
||||
-- All of the following type classes defer to the underlying 'm'.
|
||||
|
||||
newtype StdCited m a = StdCited
|
||||
{ _stdCited :: Cited (StdThunk m) (StdCited m) m a }
|
||||
deriving
|
||||
( Generic
|
||||
, Typeable
|
||||
, Functor
|
||||
, Applicative
|
||||
, Foldable
|
||||
, Traversable
|
||||
, Comonad
|
||||
, ComonadEnv [Provenance m (StdValue m)]
|
||||
)
|
||||
deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t)
|
||||
deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t)
|
||||
deriving instance MonadEnv (t (Fix1 t)) => MonadEnv (Fix1 t)
|
||||
deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t)
|
||||
deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t)
|
||||
deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t)
|
||||
|
||||
type StdValue m = NValue (StdThunk m) (StdCited m) m
|
||||
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) m
|
||||
-- type StdIdT m = FreshIdT Int m
|
||||
|
||||
instance Show (StdThunk m) where
|
||||
show _ = "<thunk>" -- jww (2019-03-15): NYI
|
||||
|
||||
type MonadStdThunk m
|
||||
= (MonadVar m, MonadCatch m, MonadThrow m, Typeable m, MonadAtomicRef m)
|
||||
|
||||
instance HasCitations m (StdValue m) (StdThunk m) where
|
||||
citations (StdThunk c) = citations1 c
|
||||
addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c)
|
||||
|
||||
instance HasCitations1 m (StdValue m) (StdCited m) where
|
||||
citations1 (StdCited c) = citations1 c
|
||||
addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)
|
||||
|
||||
-- jww (2019-03-22): NYI
|
||||
-- whileForcingThunk
|
||||
-- :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
|
||||
-- whileForcingThunk frame =
|
||||
-- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
|
||||
|
||||
newtype StandardT m a = StandardT
|
||||
{ runStandardT
|
||||
:: ReaderT (Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
(StdIdT m)) a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadFix
|
||||
, MonadIO
|
||||
, MonadCatch
|
||||
, MonadThrow
|
||||
, MonadReader (Context (StandardT m) (StdValue (StandardT m)))
|
||||
, MonadState (HashMap FilePath NExprLoc)
|
||||
)
|
||||
deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m)
|
||||
deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m)
|
||||
deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m)
|
||||
deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m)
|
||||
deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m)
|
||||
deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m)
|
||||
|
||||
#ifdef MIN_VERSION_haskeline
|
||||
-- For whatever reason, using the default StateT instance provided by
|
||||
|
|
@ -119,71 +78,64 @@ instance MonadException m
|
|||
run' = RunIO (fmap (StateT . const) . run . flip runStateT s)
|
||||
in fmap (flip runStateT s) $ f run'
|
||||
|
||||
instance MonadException m => MonadException (StandardT m) where
|
||||
controlIO f = StandardT $ controlIO $ \(RunIO run) ->
|
||||
let run' = RunIO (fmap StandardT . run . runStandardT)
|
||||
instance MonadException m => MonadException (Fix1T StandardTF m) where
|
||||
controlIO f = mkStandardT $ controlIO $ \(RunIO run) ->
|
||||
let run' = RunIO (fmap mkStandardT . run . runStandardT)
|
||||
in runStandardT <$> f run'
|
||||
#endif
|
||||
|
||||
instance MonadTrans StandardT where
|
||||
lift = StandardT . lift . lift . lift
|
||||
type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m))
|
||||
|
||||
instance MonadRef m => MonadRef (StandardT m) where
|
||||
type Ref (StandardT m) = Ref m
|
||||
instance (MonadFix1T t m, MonadRef m) => MonadRef (Fix1T t m) where
|
||||
type Ref (Fix1T t m) = Ref m
|
||||
newRef = lift . newRef
|
||||
readRef = lift . readRef
|
||||
writeRef r = lift . writeRef r
|
||||
|
||||
instance MonadAtomicRef m => MonadAtomicRef (StandardT m) where
|
||||
instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where
|
||||
atomicModifyRef r = lift . atomicModifyRef r
|
||||
|
||||
instance (MonadFile m, Monad m) => MonadFile (StandardT m)
|
||||
instance (MonadFix1T t m, MonadFile m) => MonadFile (Fix1T t m)
|
||||
|
||||
instance MonadStore m => MonadStore (StandardT m) where
|
||||
instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where
|
||||
addPath' = lift . addPath'
|
||||
toFile_' n = lift . toFile_' n
|
||||
|
||||
instance MonadPutStr m => MonadPutStr (StandardT m)
|
||||
instance MonadHttp m => MonadHttp (StandardT m)
|
||||
instance MonadEnv m => MonadEnv (StandardT m)
|
||||
instance MonadInstantiate m => MonadInstantiate (StandardT m)
|
||||
instance MonadExec m => MonadExec (StandardT m)
|
||||
instance MonadIntrospect m => MonadIntrospect (StandardT m)
|
||||
{------------------------------------------------------------------------}
|
||||
|
||||
instance MonadAtomicRef m => MonadThunkId (StandardT m) where
|
||||
type ThunkId (StandardT m) = Int
|
||||
freshId = StandardT $ lift $ lift freshId
|
||||
newtype StdCited m a = StdCited
|
||||
{ _stdCited :: Cited (StdThunk m) (StdCited m) m a }
|
||||
deriving
|
||||
( Generic
|
||||
, Typeable
|
||||
, Functor
|
||||
, Applicative
|
||||
, Foldable
|
||||
, Traversable
|
||||
, Comonad
|
||||
, ComonadEnv [Provenance m (StdValue m)]
|
||||
)
|
||||
|
||||
instance ( MonadAtomicRef m
|
||||
, MonadCatch m
|
||||
, Typeable m
|
||||
)
|
||||
=> MonadThunk (StdThunk (StandardT m))
|
||||
(StandardT m)
|
||||
(StdValue (StandardT m)) where
|
||||
thunk = fmap (StdThunk . StdCited) . thunk
|
||||
thunkId = thunkId . _stdCited . _stdThunk
|
||||
queryM x b f = queryM (_stdCited (_stdThunk x)) b f
|
||||
force = force . _stdCited . _stdThunk
|
||||
forceEff = forceEff . _stdCited . _stdThunk
|
||||
further = (fmap (StdThunk . StdCited) .) . further . _stdCited . _stdThunk
|
||||
newtype StdThunk (m :: * -> *) = StdThunk
|
||||
{ _stdThunk :: StdCited m (NThunkF m (StdValue m)) }
|
||||
|
||||
instance ( MonadAtomicRef m
|
||||
, MonadCatch m
|
||||
, Typeable m
|
||||
)
|
||||
=> MonadValue (StdValue (StandardT m)) (StandardT m) where
|
||||
defer = fmap Pure . thunk
|
||||
type StdValue m = NValue (StdThunk m) (StdCited m) m
|
||||
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) m
|
||||
|
||||
demand (Pure v) f = force v (flip demand f)
|
||||
demand (Free v) f = f (Free v)
|
||||
instance Show (StdThunk m) where
|
||||
show _ = "<thunk>"
|
||||
|
||||
inform (Pure t) f = Pure <$> further t f
|
||||
inform (Free v) f = Free <$> bindNValue' id (flip inform f) v
|
||||
instance HasCitations1 m (StdValue m) (StdCited m) where
|
||||
citations1 (StdCited c) = citations1 c
|
||||
addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)
|
||||
|
||||
instance Monad m => Scoped (StdValue (StandardT m)) (StandardT m) where
|
||||
instance HasCitations m (StdValue m) (StdThunk m) where
|
||||
citations (StdThunk c) = citations1 c
|
||||
addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c)
|
||||
|
||||
instance MonadReader (Context m (StdValue m)) m => Scoped (StdValue m) m where
|
||||
currentScopes = currentScopesReader
|
||||
clearScopes = clearScopesReader @(StandardT m) @(StdValue (StandardT m))
|
||||
clearScopes = clearScopesReader @m @(StdValue m)
|
||||
pushScopes = pushScopesReader
|
||||
lookupVar = lookupVarReader
|
||||
|
||||
|
|
@ -200,10 +152,14 @@ instance ( MonadFix m
|
|||
, MonadStore m
|
||||
, MonadAtomicRef m
|
||||
, Typeable m
|
||||
, Scoped (StdValue m) m
|
||||
, MonadReader (Context m (StdValue m)) m
|
||||
, MonadState (HashMap FilePath NExprLoc) m
|
||||
, MonadDataErrorContext (StdThunk m) (StdCited m) m
|
||||
, MonadThunk (StdThunk m) m (StdValue m)
|
||||
, MonadValue (StdValue m) m
|
||||
)
|
||||
=> MonadEffects (StdThunk (StandardT m))
|
||||
(StdCited (StandardT m))
|
||||
(StandardT m) where
|
||||
=> MonadEffects (StdThunk m) (StdCited m) m where
|
||||
makeAbsolutePath = defaultMakeAbsolutePath
|
||||
findEnvPath = defaultFindEnvPath
|
||||
findPath = defaultFindPath
|
||||
|
|
@ -212,10 +168,103 @@ instance ( MonadFix m
|
|||
derivationStrict = defaultDerivationStrict
|
||||
traceEffect = defaultTraceEffect
|
||||
|
||||
runWithBasicEffects
|
||||
:: (MonadIO m, MonadVar m) => Options -> StandardT m a -> m a
|
||||
instance ( MonadAtomicRef m
|
||||
, MonadCatch m
|
||||
, Typeable m
|
||||
, MonadReader (Context m (StdValue m)) m
|
||||
, MonadThunkId m
|
||||
)
|
||||
=> MonadThunk (StdThunk m) m (StdValue m) where
|
||||
thunk = fmap (StdThunk . StdCited) . thunk
|
||||
thunkId = thunkId . _stdCited . _stdThunk
|
||||
queryM x b f = queryM (_stdCited (_stdThunk x)) b f
|
||||
force = force . _stdCited . _stdThunk
|
||||
forceEff = forceEff . _stdCited . _stdThunk
|
||||
further = (fmap (StdThunk . StdCited) .) . further . _stdCited . _stdThunk
|
||||
|
||||
instance ( MonadAtomicRef m
|
||||
, MonadCatch m
|
||||
, Typeable m
|
||||
, MonadReader (Context m (StdValue m)) m
|
||||
, MonadThunkId m
|
||||
)
|
||||
=> MonadValue (StdValue m) m where
|
||||
defer = fmap Pure . thunk
|
||||
|
||||
demand (Pure v) f = force v (flip demand f)
|
||||
demand (Free v) f = f (Free v)
|
||||
|
||||
inform (Pure t) f = Pure <$> further t f
|
||||
inform (Free v) f = Free <$> bindNValue' id (flip inform f) v
|
||||
|
||||
{------------------------------------------------------------------------}
|
||||
|
||||
-- jww (2019-03-22): NYI
|
||||
-- whileForcingThunk
|
||||
-- :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
|
||||
-- whileForcingThunk frame =
|
||||
-- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
|
||||
|
||||
newtype StandardTF r m a
|
||||
= StandardTF (ReaderT (Context r (StdValue r))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
(StdIdT m)) a)
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadFix
|
||||
, MonadIO
|
||||
, MonadCatch
|
||||
, MonadThrow
|
||||
, MonadReader (Context r (StdValue r))
|
||||
, MonadState (HashMap FilePath NExprLoc)
|
||||
)
|
||||
|
||||
instance MonadTrans (StandardTF m) where
|
||||
lift = StandardTF . lift . lift . lift
|
||||
|
||||
instance (MonadPutStr m, MonadPutStr r) => MonadPutStr (StandardTF m r)
|
||||
instance (MonadHttp m, MonadHttp r) => MonadHttp (StandardTF m r)
|
||||
instance (MonadEnv m, MonadEnv r) => MonadEnv (StandardTF m r)
|
||||
instance (MonadInstantiate m, MonadInstantiate r) => MonadInstantiate (StandardTF m r)
|
||||
instance (MonadExec m, MonadExec r) => MonadExec (StandardTF m r)
|
||||
instance (MonadIntrospect m, MonadIntrospect r) => MonadIntrospect (StandardTF m r)
|
||||
|
||||
{------------------------------------------------------------------------}
|
||||
|
||||
type StandardT m = Fix1T StandardTF m
|
||||
|
||||
instance MonadTrans (Fix1T StandardTF) where
|
||||
lift = Fix1T . lift
|
||||
|
||||
-- | This instance is based on the 'StdIdT' layer of 'StandardTF m'.
|
||||
instance MonadAtomicRef m => MonadThunkId (Fix1T StandardTF m) where
|
||||
type ThunkId (Fix1T StandardTF m) = Int
|
||||
freshId = mkStandardT $ lift $ lift freshId
|
||||
|
||||
mkStandardT
|
||||
:: ReaderT (Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
(StdIdT m)) a
|
||||
-> StandardT m a
|
||||
mkStandardT = Fix1T . StandardTF
|
||||
|
||||
runStandardT
|
||||
:: StandardT m a
|
||||
-> ReaderT (Context (StandardT m) (StdValue (StandardT m)))
|
||||
(StateT (HashMap FilePath NExprLoc)
|
||||
(StdIdT m)) a
|
||||
runStandardT (Fix1T (StandardTF m)) = m
|
||||
|
||||
runWithBasicEffects :: (MonadIO m, MonadAtomicRef m)
|
||||
=> Options -> StandardT m a -> m a
|
||||
runWithBasicEffects opts =
|
||||
go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
|
||||
go . (`evalStateT` mempty)
|
||||
. (`runReaderT` newContext opts)
|
||||
. runStandardT
|
||||
where
|
||||
go action = do
|
||||
i <- newVar (1 :: Int)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,64 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Nix.Utils.Fix1 where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
-- | 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 }
|
||||
|
||||
deriving instance Functor (t (Fix1 t)) => Functor (Fix1 t)
|
||||
deriving instance Applicative (t (Fix1 t)) => Applicative (Fix1 t)
|
||||
deriving instance Alternative (t (Fix1 t)) => Alternative (Fix1 t)
|
||||
deriving instance Monad (t (Fix1 t)) => Monad (Fix1 t)
|
||||
deriving instance MonadPlus (t (Fix1 t)) => MonadPlus (Fix1 t)
|
||||
deriving instance MonadFix (t (Fix1 t)) => MonadFix (Fix1 t)
|
||||
deriving instance MonadIO (t (Fix1 t)) => MonadIO (Fix1 t)
|
||||
deriving instance MonadCatch (t (Fix1 t)) => MonadCatch (Fix1 t)
|
||||
deriving instance MonadThrow (t (Fix1 t)) => MonadThrow (Fix1 t)
|
||||
|
||||
deriving instance MonadReader e (t (Fix1 t)) => MonadReader e (Fix1 t)
|
||||
deriving instance MonadState s (t (Fix1 t)) => MonadState s (Fix1 t)
|
||||
|
||||
newtype Fix1T (t :: (k -> *) -> (* -> *) -> k -> *) (m :: * -> *) (a :: k)
|
||||
= Fix1T { unFix1T :: t (Fix1T t m) m a }
|
||||
|
||||
deriving instance Functor (t (Fix1T t m) m) => Functor (Fix1T t m)
|
||||
deriving instance Applicative (t (Fix1T t m) m) => Applicative (Fix1T t m)
|
||||
deriving instance Alternative (t (Fix1T t m) m) => Alternative (Fix1T t m)
|
||||
deriving instance Monad (t (Fix1T t m) m) => Monad (Fix1T t m)
|
||||
deriving instance MonadPlus (t (Fix1T t m) m) => MonadPlus (Fix1T t m)
|
||||
deriving instance MonadFix (t (Fix1T t m) m) => MonadFix (Fix1T t m)
|
||||
deriving instance MonadIO (t (Fix1T t m) m) => MonadIO (Fix1T t m)
|
||||
deriving instance MonadCatch (t (Fix1T t m) m) => MonadCatch (Fix1T t m)
|
||||
deriving instance MonadThrow (t (Fix1T t m) m) => MonadThrow (Fix1T t m)
|
||||
|
||||
deriving instance MonadReader e (t (Fix1T t m) m) => MonadReader e (Fix1T t m)
|
||||
deriving instance MonadState s (t (Fix1T t m) m) => MonadState s (Fix1T t m)
|
||||
|
||||
{-
|
||||
|
||||
newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a }
|
||||
|
||||
-- | Natural Transformations (Included from
|
||||
-- [compdata](https://hackage.haskell.org/package/compdata))
|
||||
type (:->) f g = forall a. f a -> g a
|
||||
|
||||
class HFunctor f where
|
||||
hfmap :: a :-> b -> f a :-> f b
|
||||
|
||||
-}
|
||||
Loading…
Reference in New Issue