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

Factor out FreshIdT from Standard

This commit is contained in:
John Wiegley 2019-03-17 19:04:38 -07:00
parent 015ced236e
commit 7b5d134d22
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
7 changed files with 103 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hnix.cabal
View File

@ -452,6 +452,7 @@ library
Nix.Expr.Types.Annotated
Nix.Frames
Nix.Fresh
Nix.Fresh.Basic
Nix.Json
Nix.Lint
Nix.Normal

13
main/Main.hs
View File

@ -30,6 +30,8 @@ import Data.Text.Prettyprint.Doc.Render.Text
import Nix
import Nix.Convert
import qualified Nix.Eval as Eval
import Nix.Fresh
import Nix.Fresh.Basic
import Nix.Json
-- import Nix.Lint
import Nix.Options.Parser
@ -49,7 +51,8 @@ main :: IO ()
main = do
time <- liftIO getCurrentTime
opts <- execParser (nixOptionsInfo time)
runStdLazyM opts $ case readFrom opts of
i <- newVar (1 :: Int)
runStdLazyM opts (runFreshIdT i) $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
@ -95,7 +98,7 @@ main = do
NixException frames ->
errorWithoutStackTrace
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
=<< renderFrames @(StdValue StdIdT IO) @(StdThunk StdIdT IO) frames
when (repl opts) $ withNixContext Nothing $ Repl.main
@ -132,7 +135,7 @@ main = do
where
printer
| finder opts
= fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
= fromValue @(AttrSet (StdThunk StdIdT IO)) >=> findAttrs
| xml opts
= liftIO
. putStrLn
@ -162,7 +165,7 @@ main = do
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar @(StdLazy IO) ref
val <- readVar @(StdLazy StdIdT IO) ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k, ) <$> forceEntry path nv
@ -204,7 +207,7 @@ main = do
. (k ++)
. (": " ++)
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
=<< renderFrames @(StdValue StdIdT IO) @(StdThunk StdIdT IO) frames
return Nothing
reduction path mp x = do

45
src/Nix/Fresh/Basic.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Fresh.Basic where
import Control.Monad.Reader
import Nix.Effects
import Nix.Render
import Nix.Fresh
import Nix.Value
type StdIdT = FreshIdT Int
instance MonadFile m => MonadFile (StdIdT m)
instance MonadIntrospect m => MonadIntrospect (StdIdT m)
instance MonadStore m => MonadStore (StdIdT m) where
addPath' = lift . addPath'
toFile_' = (lift .) . toFile_'
instance MonadPutStr m => MonadPutStr (StdIdT m)
instance MonadHttp m => MonadHttp (StdIdT m)
instance MonadEnv m => MonadEnv (StdIdT m)
instance MonadInstantiate m => MonadInstantiate (StdIdT m)
instance MonadExec m => MonadExec (StdIdT m)
instance (MonadEffects t f m, MonadDataContext f m)
=> MonadEffects t f (StdIdT m) where
makeAbsolutePath = lift . makeAbsolutePath @t @f @m
findEnvPath = lift . findEnvPath @t @f @m
findPath = (lift .) . findPath @t @f @m
importPath path = do
i <- FreshIdT ask
p <- lift $ importPath @t @f @m path
return $ liftNValue (runFreshIdT i) p
pathToDefaultNix = lift . pathToDefaultNix @t @f @m
derivationStrict v = do
i <- FreshIdT ask
p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v)
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m

75
src/Nix/Thunk/Standard.hs
View File

@ -29,23 +29,18 @@ import Data.Typeable
import GHC.Generics
import Nix.Cited
import Nix.Cited.Basic
import Nix.Effects
import Nix.Exec
import Nix.Fresh
import Nix.Options
import Nix.Render
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Value
import Nix.Var ( MonadVar
, newVar
)
import Nix.Var
newtype StdThunk m = StdThunk
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
newtype StdThunk (u :: (* -> *) -> * -> *) (m :: * -> *) = StdThunk
{ _stdThunk :: StdCited u m (NThunkF (StdLazy u m) (StdValue u m)) }
newtype StdCited m a = StdCited
{ _stdCited :: Cited (StdThunk m) (StdCited m) (StdLazy m) a }
newtype StdCited u m a = StdCited
{ _stdCited :: Cited (StdThunk u m) (StdCited u m) (StdLazy u m) a }
deriving
( Generic
, Typeable
@ -54,16 +49,16 @@ newtype StdCited m a = StdCited
, Foldable
, Traversable
, Comonad
, ComonadEnv [Provenance (StdThunk m) (StdLazy m) (StdValue m)]
, ComonadEnv [Provenance (StdThunk u m) (StdLazy u m) (StdValue u m)]
)
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy m)
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) (StdLazy m)
type StdIdT m = FreshIdT Int m
type StdValue u m = NValue (StdThunk u m) (StdCited u m) (StdLazy u m)
type StdValueNF u m = NValueNF (StdThunk u m) (StdCited u m) (StdLazy u m)
-- type StdIdT m = FreshIdT Int m
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT m)
type StdLazy u m = Lazy (StdThunk u m) (StdCited u m) (u m)
instance Show (StdThunk m) where
instance Show (StdThunk u m) where
show _ = "<thunk>" -- jww (2019-03-15): NYI
type MonadStdThunk m
@ -74,8 +69,13 @@ type MonadStdThunk m
, MonadAtomicRef m
)
instance MonadStdThunk m
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
instance ( MonadStdThunk (u m)
, MonadThunkId (u m)
, MonadTrans u
, Typeable u
, Typeable m
)
=> MonadThunk (StdThunk u m) (StdLazy u m) (StdValue u m) where
thunk = fmap (StdThunk . StdCited) . thunk
thunkId = thunkId . _stdCited . _stdThunk
query x b f = query (_stdCited (_stdThunk x)) b f
@ -85,38 +85,13 @@ instance MonadStdThunk m
wrapValue = StdThunk . StdCited . wrapValue
getValue = getValue . _stdCited . _stdThunk
instance MonadFile m => MonadFile (StdIdT m)
instance MonadIntrospect m => MonadIntrospect (StdIdT m)
instance MonadStore m => MonadStore (StdIdT m) where
addPath' = lift . addPath'
toFile_' = (lift .) . toFile_'
instance MonadPutStr m => MonadPutStr (StdIdT m)
instance MonadHttp m => MonadHttp (StdIdT m)
instance MonadEnv m => MonadEnv (StdIdT m)
instance MonadInstantiate m => MonadInstantiate (StdIdT m)
instance MonadExec m => MonadExec (StdIdT m)
instance (MonadEffects t f m, MonadDataContext f m)
=> MonadEffects t f (StdIdT m) where
makeAbsolutePath = lift . makeAbsolutePath @t @f @m
findEnvPath = lift . findEnvPath @t @f @m
findPath = (lift .) . findPath @t @f @m
importPath path = do
i <- FreshIdT ask
p <- lift $ importPath @t @f @m path
return $ liftNValue (runFreshIdT i) p
pathToDefaultNix = lift . pathToDefaultNix @t @f @m
derivationStrict v = do
i <- FreshIdT ask
p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v)
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m
instance HasCitations1 (StdThunk m) (StdLazy m) (StdValue m) (StdCited m) where
instance HasCitations1 (StdThunk u m) (StdLazy u m) (StdValue u m) (StdCited u m) where
citations1 (StdCited c) = citations1 c
addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)
runStdLazyM :: (MonadVar m, MonadIO m) => Options -> StdLazy m a -> m a
runStdLazyM opts action = do
i <- newVar (1 :: Int)
runFreshIdT i $ runLazyM opts action
runStdLazyM :: (MonadVar m, MonadIO m, MonadIO (u m))
=> Options -> (u m a -> m a) -> StdLazy u m a -> m a
runStdLazyM opts run action = do
-- i <- newVar (1 :: Int)
-- runFreshIdT i $ runLazyM opts action
run $ runLazyM opts action

9
tests/EvalTests.hs
View File

@ -22,7 +22,9 @@ import Data.Text (Text)
import Data.Time
import Nix
import Nix.TH
import Nix.Fresh
import Nix.Thunk.Standard
import Nix.Var
import qualified System.Directory as D
import System.Environment
import System.FilePath
@ -423,7 +425,8 @@ constantEqual a b = do
time <- liftIO getCurrentTime
let opts = defaultOptions time
-- putStrLn =<< lint (stripAnnotation a)
res <- runStdLazyM opts $ do
j <- newVar (1 :: Int)
res <- runStdLazyM opts (runFreshIdT j) $ do
a' <- normalForm =<< nixEvalExprLoc Nothing a
b' <- normalForm =<< nixEvalExprLoc Nothing b
return $ valueNFEq a' b'
@ -447,8 +450,10 @@ assertNixEvalThrows a = do
let Success a' = parseNixTextLoc a
time <- liftIO getCurrentTime
let opts = defaultOptions time
j <- newVar (1 :: Int)
errored <- catch
(False <$ runStdLazyM opts (normalForm =<< nixEvalExprLoc Nothing a'))
(False <$ runStdLazyM opts (runFreshIdT j)
(normalForm =<< nixEvalExprLoc Nothing a'))
(\(_ :: NixException) -> pure True)
if errored then
pure ()

8
tests/Main.hs
View File

@ -19,11 +19,13 @@ import Data.Time
import qualified EvalTests
import qualified Nix
import Nix.Expr.Types
import Nix.Fresh
import Nix.String
import Nix.Options
import Nix.Parser
import Nix.Value
import Nix.Thunk.Standard
import Nix.Value
import Nix.Var
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
@ -58,7 +60,9 @@ ensureNixpkgsCanParse =
}|]) $ \expr -> do
NVStr ns <- do
time <- liftIO getCurrentTime
runStdLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
j <- newVar (1 :: Int)
runStdLazyM (defaultOptions time) (runFreshIdT j) $
Nix.nixEvalExprLoc Nothing expr
let dir = hackyStringIgnoreContext ns
exists <- fileExist (unpack dir)
unless exists $

17
tests/TestCommon.hs
View File

@ -14,7 +14,10 @@ import Nix
import Nix.Exec ()
import Nix.Cited ()
import Nix.Cited.Basic ()
import Nix.Fresh
import Nix.Fresh.Basic
import Nix.Thunk.Standard
import Nix.Var
import System.Environment
import System.IO
import System.Posix.Files
@ -22,7 +25,7 @@ import System.Posix.Temp
import System.Process
import Test.Tasty.HUnit
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF IO)
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF StdIdT IO)
hnixEvalFile opts file = do
parseResult <- parseNixFileLoc file
case parseResult of
@ -30,15 +33,16 @@ hnixEvalFile opts file = do
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
Success expr -> do
setEnv "TEST_VAR" "foo"
runStdLazyM opts
i <- newVar (1 :: Int)
runStdLazyM opts (runFreshIdT i)
$ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr)
$ \case
NixException frames ->
errorWithoutStackTrace
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
=<< renderFrames @(StdValue StdIdT IO) @(StdThunk StdIdT IO) frames
hnixEvalText :: Options -> Text -> IO (StdValueNF IO)
hnixEvalText :: Options -> Text -> IO (StdValueNF StdIdT IO)
hnixEvalText opts src = case parseNixText src of
Failure err ->
error
@ -46,8 +50,9 @@ hnixEvalText opts src = case parseNixText src of
++ unpack src
++ "`.\n"
++ show err
Success expr ->
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
Success expr -> do
i <- newVar (1 :: Int)
runStdLazyM opts (runFreshIdT i) $ normalForm =<< nixEvalExpr Nothing expr
nixEvalString :: String -> IO String
nixEvalString expr = do