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

Further work on Standard.hs

This commit is contained in:
John Wiegley 2019-03-15 22:54:29 -07:00
parent 209a9ae9a5
commit 145e69c9a4
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
7 changed files with 139 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hnix.cabal
View File

@ -505,6 +505,7 @@ library
, lens-family-th
, logict
, megaparsec >=7.0 && <7.1
, monad-control
, monadlist
, mtl
, optparse-applicative
@ -523,6 +524,7 @@ library
, these
, time
, transformers
, transformers-base
, unix
, unordered-containers >=0.2.9 && <0.3
, vector
@ -588,6 +590,7 @@ executable hnix
, optparse-applicative
, pretty-show
, prettyprinter
, ref-tf
, repline
, template-haskell
, text

52
main/Main.hs
View File

@ -13,6 +13,8 @@ import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Ref
import Control.Monad.Trans.Class
-- import Control.Monad.ST
import qualified Data.Aeson.Text as A
import qualified Data.HashMap.Lazy as M
@ -26,12 +28,15 @@ import qualified Data.Text.Lazy.IO as TL
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text
import Nix
import Nix.Cited
import Nix.Convert
import qualified Nix.Eval as Eval
import Nix.Fresh
import Nix.Json
-- import Nix.Lint
import Nix.Options.Parser
import Nix.Thunk.Basic
import Nix.Thunk.Standard
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import Nix.Utils
@ -46,7 +51,7 @@ main :: IO ()
main = do
time <- liftIO getCurrentTime
opts <- execParser (nixOptionsInfo time)
runLazyM opts $ case readFrom opts of
runStdLazyM opts $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
@ -54,18 +59,18 @@ main = do
Just s -> handleResult opts Nothing (parseNixTextLoc s)
Nothing -> case fromFile opts of
Just "-" ->
mapM_ (processFile opts)
=<< (lines <$> liftIO getContents)
liftIO $ mapM_ (processFile opts)
=<< (lines <$> getContents)
Just path ->
mapM_ (processFile opts)
=<< (lines <$> liftIO (readFile path))
liftIO $ mapM_ (processFile opts)
=<< (lines <$> readFile path)
Nothing -> case filePaths opts of
[] -> withNixContext Nothing $ Repl.main
["-"] ->
handleResult opts Nothing . parseNixTextLoc
=<< liftIO Text.getContents
paths ->
mapM_ (processFile opts) paths
liftIO $ mapM_ (processFile opts) paths
where
processFile opts path = do
eres <- parseNixFileLoc path
@ -93,7 +98,7 @@ main = do
catch (process opts mpath expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames @(NThunk (Lazy IO)) frames
=<< renderFrames frames
when (repl opts) $
withNixContext Nothing $ Repl.main
@ -135,13 +140,25 @@ main = do
. prettyNix
. stripAnnotation $ expr
where
printer :: forall e m. (MonadNix e m, MonadIO m, Typeable m)
=> NValue m -> m ()
printer
:: forall e t f m.
( MonadNix e t f m
, MonadRef m
, MonadFreshId Int m
, MonadVar m
, MonadIO m
, Typeable m
)
=> NValue t f m -> m ()
printer
| finder opts =
fromValue @(AttrSet (NThunk m)) >=> findAttrs
fromValue @(AttrSet (StdThunk m)) >=> findAttrs
| xml opts =
liftIO . putStrLn . Text.unpack . principledStringIgnoreContext . toXML <=< normalForm
liftIO . putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts =
liftIO . Text.putStrLn
. principledStringIgnoreContext
@ -157,12 +174,12 @@ main = do
where
go prefix s = do
xs <- forM (sortOn fst (M.toList s))
$ \(k, nv@(NThunk (NCited _ t))) -> case t of
$ \(k, nv@(StdThunk (NCited _ t))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar ref
val <- readVar @m ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k,) <$> forceEntry path nv
@ -176,7 +193,8 @@ main = do
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ -> go (path ++ ".") s'
StdValue (NVSet s' _) ->
go (path ++ ".") s'
_ -> return ()
where
filterEntry path k = case (path, k) of
@ -202,7 +220,7 @@ main = do
. ("Exception forcing " ++)
. (k ++)
. (": " ++) . show
=<< renderFrames @(NThunk (Lazy IO)) frames
=<< renderFrames @(StdThunk m) frames
return Nothing
reduction path mp x = do
@ -212,8 +230,8 @@ main = do
handleReduced :: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue m))
-> m (NValue m)
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path

16
src/Nix/Exec.hs
View File

@ -56,6 +56,7 @@ import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Fresh (MonadFreshId(..))
import Nix.Normal
import Nix.Options
import Nix.Parser
@ -520,8 +521,16 @@ fromStringNoContext ns =
newtype Lazy t (f :: * -> *) m a = Lazy
{ runLazy :: ReaderT (Context (Lazy t f m) t)
(StateT (HashMap FilePath NExprLoc) m) a }
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
MonadFix, MonadIO, MonadReader (Context (Lazy t f m) t))
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadFix
, MonadIO
, MonadReader (Context (Lazy t f m) t)
)
instance MonadTrans (Lazy t f) where
lift = Lazy . lift . lift
@ -567,6 +576,9 @@ instance MonadExec m => MonadExec (Lazy t f m)
instance MonadIntrospect m => MonadIntrospect (Lazy t f m)
instance MonadFreshId Int m => MonadFreshId Int (Lazy t f m) where
freshId = Lazy $ lift $ lift freshId
instance (MonadFix m, MonadCatch m, MonadFile m,
MonadStore m, MonadPutStr m, MonadHttp m,
MonadEnv m, MonadInstantiate m,

15
src/Nix/Fresh.hs
View File

@ -14,12 +14,14 @@
module Nix.Fresh where
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Trans.Control
import Control.Monad.Writer
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
@ -50,6 +52,19 @@ newtype FreshIdT i m a = FreshIdT { unFreshIdT :: StateT i m a }
#endif
)
instance MonadBase b m => MonadBase b (FreshIdT i m) where
liftBase = FreshIdT . liftBase
instance MonadTransControl (FreshIdT i) where
type StT (FreshIdT i) a = StT (StateT i) a
liftWith = defaultLiftWith FreshIdT unFreshIdT
restoreT = defaultRestoreT FreshIdT
instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where
type StM (FreshIdT i m) a = ComposeSt (FreshIdT i) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance (Monad m, Num i) => MonadFreshId i (FreshIdT i m) where
freshId = FreshIdT $ get <* modify (+ 1)

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

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

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

@ -18,9 +18,8 @@ module Nix.Thunk.Standard where
import Control.Monad.Catch hiding (catchJust)
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.Trans.Control
import Data.Fix
import Data.GADT.Compare
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import Nix.Cited
@ -36,69 +35,99 @@ import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var (MonadVar)
newtype NThunk f m = NThunk
{ _nThunk :: NCited (NThunk f m) (NValue (NThunk f m) f m) m
(NThunkF m (NValue (NThunk f m) f m)) }
newtype StdThunk m = StdThunk
{ _stdThunk ::
NCited (StdThunk m) (StdValue m)
(FreshIdT Int m)
(NThunkF (FreshIdT Int m) (StdValue m)) }
instance (MonadNix e t f m, MonadFreshId Int m, MonadAtomicRef m, GEq (Ref m))
=> MonadThunk (NThunk f m) m (NValue (NThunk f m) f m) where
newtype StdValue m = StdValue
{ _stdValue ::
NValue (StdThunk m)
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
(FreshIdT Int m) }
newtype StdValueNF m = StdValueNF
{ _stdValueNF ::
NValueNF (StdThunk m)
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
(FreshIdT Int m) }
type StdLazy m =
Lazy (StdThunk m)
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
(FreshIdT Int m)
instance (MonadNix e t f m, MonadVar m)
=> MonadThunk (StdThunk m) (FreshIdT Int m) (StdValue m) where
thunk mv = do
opts :: Options <- asks (view hasLens)
opts :: Options <- lift $ asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
frames :: Frames <- lift $ 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
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
(Fix (Compose (Ann s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (NThunk . NCited ps) . thunk $ mv
fmap (StdThunk . NCited ps) . thunk $ mv
else
fmap (NThunk . NCited []) . thunk $ mv
fmap (StdThunk . NCited []) . thunk $ mv
thunkId = error "jww (2019-03-15): NYI"
query = error "jww (2019-03-15): NYI"
queryM = error "jww (2019-03-15): NYI"
-- 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 (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
force (StdThunk (NCited ps t)) f =
catch go (lift . throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(force t f)
Provenance scope e@(Compose (Ann s _)):_ -> do
r <- liftWith $ \run -> do
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(run (force t f))
restoreT $ return r
forceEff (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
forceEff (StdThunk (NCited ps t)) f =
catch go (lift . throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceEff t f)
Provenance scope e@(Compose (Ann s _)):_ -> do
r <- liftWith $ \run -> do
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(run (forceEff t f))
restoreT $ return r
wrapValue = NThunk . NCited [] . wrapValue
getValue (NThunk (NCited _ v)) = getValue v
wrapValue = StdThunk . NCited [] . wrapValue
getValue (StdThunk (NCited _ v)) = getValue v
-- instance Monad m => MonadFreshId Int (Lazy t f m) where
-- freshId = Lazy $ lift $ lift freshId
instance FromValue NixString m (NThunk f m) where
instance FromValue Path m (NThunk f m) where
instance FromValue [NThunk f m] m (NThunk f m) where
instance FromValue (M.HashMap Text (NThunk f m)) m (NThunk f m) where
instance ToValue NixString m (NThunk f m) where
instance ToValue Int m (NThunk f m) where
instance ToValue () m (NThunk f m) where
instance FromValue [NixString] m (NThunk f m) where
instance FromNix [NixString] m (NThunk f m) where
instance ToValue (NThunk f m) m (NValue (NThunk f m) f m) where
instance ToNix (NThunk f m) m (NValue (NThunk f m) f m) where
instance FromValue NixString m (StdThunk m) where
instance FromValue Path m (StdThunk m) where
instance FromValue [StdThunk m] m (StdThunk m) where
instance FromValue (M.HashMap Text (StdThunk m)) m (StdThunk m) where
instance ToValue NixString m (StdThunk m) where
instance ToValue Int m (StdThunk m) where
instance ToValue () m (StdThunk m) where
instance FromValue [NixString] m (StdThunk m) where
instance FromNix [NixString] m (StdThunk m) where
instance ToValue (StdThunk m) m (NValue (StdThunk m) f m) where
instance ToNix (StdThunk m) m (NValue (StdThunk m) f m) where
runStdLazyM :: MonadIO m => Options -> StdLazy m a -> m a
runStdLazyM opts = runFreshIdT (1 :: Int) . runLazyM opts

9
tests/TestCommon.hs
View File

@ -8,6 +8,7 @@ import Control.Monad.IO.Class
import Data.Text (Text, unpack)
import Data.Time
import Nix
import Nix.Thunk.Standard
import System.Environment
import System.IO
import System.Posix.Files
@ -15,7 +16,7 @@ import System.Posix.Temp
import System.Process
import Test.Tasty.HUnit
hnixEvalFile :: Options -> FilePath -> IO (NValueNF (Lazy IO))
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF (StdLazy IO))
hnixEvalFile opts file = do
parseResult <- parseNixFileLoc file
case parseResult of
@ -23,20 +24,20 @@ hnixEvalFile opts file = do
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
Success expr -> do
setEnv "TEST_VAR" "foo"
runLazyM opts $
runStdLazyM opts $
catch (evaluateExpression (Just file) nixEvalExprLoc
normalForm expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames frames
hnixEvalText :: Options -> Text -> IO (NValueNF (Lazy IO))
hnixEvalText :: Options -> Text -> IO (StdValueNF (StdLazy IO))
hnixEvalText opts src = case parseNixText src of
Failure err ->
error $ "Parsing failed for expressien `"
++ unpack src ++ "`.\n" ++ show err
Success expr ->
runLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
nixEvalString :: String -> IO String
nixEvalString expr = do