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

Simplify Standard by splitting off Cited.Basic

This commit is contained in:
John Wiegley 2019-03-17 18:43:23 -07:00
parent 3881101ebd
commit 015ced236e
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
9 changed files with 194 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hnix.cabal
View File

@ -440,6 +440,7 @@ library
Nix.Builtins
Nix.Cache
Nix.Cited
Nix.Cited.Basic
Nix.Context
Nix.Convert
Nix.Effects

5
main/Main.hs
View File

@ -5,9 +5,11 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import Control.Comonad ( extract )
import qualified Control.DeepSeq as Deep
import qualified Control.Exception as Exc
import Control.Monad
@ -26,7 +28,6 @@ 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.Json
@ -156,7 +157,7 @@ main = do
go prefix s = do
xs <-
forM (sortOn fst (M.toList s))
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
$ \(k, nv@(StdThunk (extract -> t))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k

29
src/Nix/Cited.hs
View File

@ -20,11 +20,10 @@ import Lens.Family2.TH
import Nix.Expr.Types.Annotated
import Nix.Scope
import Nix.Value
data Provenance t f m = Provenance
data Provenance t m v = Provenance
{ _lexicalScope :: Scopes m t
, _originExpr :: NExprLocF (Maybe (NValue t f m))
, _originExpr :: NExprLocF (Maybe v)
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
@ -32,34 +31,34 @@ data Provenance t f m = Provenance
}
deriving (Generic, Typeable, Show)
data NCited t f m a = NCited
{ _provenance :: [Provenance t f m]
data NCited t m v a = NCited
{ _provenance :: [Provenance t m v]
, _cited :: a
}
deriving (Generic, Typeable, Functor, Foldable, Traversable, Show)
instance Applicative (NCited t f m) where
instance Applicative (NCited t m v) where
pure = NCited []
NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)
instance Comonad (NCited t f m) where
instance Comonad (NCited t m v) where
duplicate p = NCited (_provenance p) p
extract = _cited
instance ComonadEnv [Provenance t f m] (NCited t f m) where
instance ComonadEnv [Provenance t m v] (NCited t m v) where
ask = _provenance
$(makeLenses ''Provenance)
$(makeLenses ''NCited)
class HasCitations t f m a where
citations :: a -> [Provenance t f m]
addProvenance :: Provenance t f m -> a -> a
class HasCitations t m v a where
citations :: a -> [Provenance t m v]
addProvenance :: Provenance t m v -> a -> a
instance HasCitations t f m (NCited t f m a) where
instance HasCitations t m v (NCited t m v a) where
citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v)
class HasCitations1 t f m where
citations1 :: f a -> [Provenance t f m]
addProvenance1 :: Provenance t f m -> f a -> f a
class HasCitations1 t m v f where
citations1 :: f a -> [Provenance t m v]
addProvenance1 :: Provenance t m v -> f a -> f a

103
src/Nix/Cited/Basic.hs Normal file
View File

@ -0,0 +1,103 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Nix.Cited.Basic where
import Control.Comonad ( Comonad )
import Control.Comonad.Env ( ComonadEnv )
import Control.Monad.Catch hiding ( catchJust )
import Control.Monad.Reader
import Data.Fix
import GHC.Generics
import Nix.Cited
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Options
import Nix.Thunk
import Nix.Utils
import Nix.Value
newtype Cited t f m a = Cited { getCited :: NCited t m (NValue t f m) a }
deriving
( Generic
, Typeable
, Functor
, Applicative
, Foldable
, Traversable
, Comonad
, ComonadEnv [Provenance t m (NValue t f m)]
)
instance HasCitations1 t m (NValue t f m) (Cited t f m) where
citations1 (Cited c) = citations c
addProvenance1 x (Cited c) = Cited (addProvenance x c)
instance ( Has e Options
, Framed e m
, MonadThunk t m v
, Typeable m
, Typeable u
, MonadCatch m
)
=> MonadThunk (Cited u f m t) m v where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- 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 s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (Cited . NCited ps) . thunk $ mv
else fmap (Cited . NCited []) . thunk $ mv
thunkId (Cited (NCited _ t)) = thunkId @_ @m t
query (Cited (NCited _ t)) = query t
queryM (Cited (NCited _ t)) = queryM t
-- | 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 (Cited (NCited ps t)) f =
catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann s _)) : _ ->
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
forceEff (Cited (NCited ps t)) f = catch
go
(throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann s _)) : _ ->
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
wrapValue = Cited . NCited [] . wrapValue
getValue (Cited (NCited _ v)) = getValue v

3
src/Nix/Effects.hs
View File

@ -79,7 +79,8 @@ recursiveSize
class Monad m => MonadExec m where
exec' :: [String] -> m (Either ErrorCall NExprLoc)
default exec' :: (MonadTrans t, MonadExec m', m ~ t m') => [String] -> m (Either ErrorCall NExprLoc)
default exec' :: (MonadTrans t, MonadExec m', m ~ t m')
=> [String] -> m (Either ErrorCall NExprLoc)
exec' = lift . exec'
instance MonadExec IO where

50
src/Nix/Exec.hs
View File

@ -84,39 +84,42 @@ import GHC.DataSize
#endif
#endif
type Cited t f m = (HasCitations1 t f m, MonadDataContext f m)
type MonadCited t f m
= ( HasCitations1 t m (NValue t f m) f
, MonadDataContext f m
)
nvConstantP :: Cited t f m => Provenance t f m -> NAtom -> NValue t f m
nvConstantP :: MonadCited t f m => Provenance t m (NValue t f m) -> NAtom -> NValue t f m
nvConstantP p x = addProvenance p (nvConstant x)
nvStrP :: Cited t f m => Provenance t f m -> NixString -> NValue t f m
nvStrP :: MonadCited t f m => Provenance t m (NValue t f m) -> NixString -> NValue t f m
nvStrP p ns = addProvenance p (nvStr ns)
nvPathP :: Cited t f m => Provenance t f m -> FilePath -> NValue t f m
nvPathP :: MonadCited t f m => Provenance t m (NValue t f m) -> FilePath -> NValue t f m
nvPathP p x = addProvenance p (nvPath x)
nvListP :: Cited t f m => Provenance t f m -> [t] -> NValue t f m
nvListP :: MonadCited t f m => Provenance t m (NValue t f m) -> [t] -> NValue t f m
nvListP p l = addProvenance p (nvList l)
nvSetP
:: Cited t f m
=> Provenance t f m
:: MonadCited t f m
=> Provenance t m (NValue t f m)
-> AttrSet t
-> AttrSet SourcePos
-> NValue t f m
nvSetP p s x = addProvenance p (nvSet s x)
nvClosureP
:: Cited t f m
=> Provenance t f m
:: MonadCited t f m
=> Provenance t m (NValue t f m)
-> Params ()
-> (m (NValue t f m) -> m t)
-> NValue t f m
nvClosureP p x f = addProvenance p (nvClosure x f)
nvBuiltinP
:: Cited t f m
=> Provenance t f m
:: MonadCited t f m
=> Provenance t m (NValue t f m)
-> String
-> (m (NValue t f m) -> m t)
-> NValue t f m
@ -125,7 +128,7 @@ nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
type MonadCitedThunks t f m
= ( MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations1 t f m
, HasCitations1 t m (NValue t f m) f
)
type MonadNix e t f m
@ -192,13 +195,15 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
evalCurPos = do
scope <- currentScopes
span@(SrcSpan delta _) <- currentPos
addProvenance @_ @f (Provenance scope (NSym_ span "__curPos"))
addProvenance @_ @_ @(NValue t f m)
(Provenance scope (NSym_ span "__curPos"))
<$> toValue delta
evaledSym name val = do
scope <- currentScopes
span <- currentPos
pure $ addProvenance @_ @f (Provenance scope (NSym_ span name)) val
pure $ addProvenance @_ @_ @(NValue t f m)
(Provenance scope (NSym_ span name)) val
evalConstant c = do
scope <- currentScopes
@ -312,7 +317,7 @@ callFunc fun arg = do
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp
:: (Framed e m, Cited t f m, Show t)
:: (Framed e m, MonadCited t f m, Show t)
=> Scopes m t
-> SrcSpan
-> NUnaryOp
@ -367,7 +372,7 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l
execBinaryOp scope span op lval rarg = do
rval <- rarg
let bin :: (Provenance t f m -> a) -> a
let bin :: (Provenance t m (NValue t f m) -> a) -> a
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
toBool = pure . bin nvConstantP . NBool
case (lval, rval) of
@ -487,7 +492,7 @@ execBinaryOp scope span op lval rarg = do
++ show rval
numBinOp
:: (forall r . (Provenance t f m -> r) -> r)
:: (forall r . (Provenance t m (NValue t f m) -> r) -> r)
-> (forall a . Num a => a -> a -> a)
-> NAtom
-> NAtom
@ -495,7 +500,7 @@ execBinaryOp scope span op lval rarg = do
numBinOp bin f = numBinOp' bin f f
numBinOp'
:: (forall r . (Provenance t f m -> r) -> r)
:: (forall r . (Provenance t m (NValue t f m) -> r) -> r)
-> (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom
@ -586,6 +591,8 @@ newtype Lazy t (f :: * -> *) m a = Lazy
, MonadPlus
, MonadFix
, MonadIO
, MonadCatch
, MonadThrow
, MonadReader (Context (Lazy t f m) t)
)
@ -603,13 +610,6 @@ instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where
instance (MonadFile m, Monad m) => MonadFile (Lazy t f m)
instance MonadCatch m => MonadCatch (Lazy t f m) where
catch (Lazy (ReaderT m)) f =
Lazy $ ReaderT $ \e -> catch (m e) ((`runReaderT` e) . runLazy . f)
instance MonadThrow m => MonadThrow (Lazy t f m) where
throwM = Lazy . throwM
#ifdef MIN_VERSION_haskeline
instance MonadException m => MonadException (Lazy t f m) where
controlIO f = Lazy $ controlIO $ \(RunIO run) ->

18
src/Nix/Pretty.hs
View File

@ -192,14 +192,14 @@ prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom
prettyNix :: NExpr -> Doc ann
prettyNix = withoutParens . cata exprFNixDoc
instance HasCitations1 t f m
=> HasCitations t f m (NValue' t f m a) where
instance HasCitations1 t m v f
=> HasCitations t m v (NValue' t f m a) where
citations (NValue f) = citations1 f
addProvenance x (NValue f) = NValue (addProvenance1 x f)
prettyOriginExpr
:: forall t f m ann
. HasCitations1 t f m
. HasCitations1 t m (NValue t f m) f
=> NExprLocF (Maybe (NValue t f m))
-> Doc ann
prettyOriginExpr = withoutParens . go
@ -208,7 +208,7 @@ prettyOriginExpr = withoutParens . go
render :: Maybe (NValue t f m) -> NixDoc ann
render Nothing = simpleExpr $ "_"
render (Just (reverse . citations @t @f @m -> p:_)) = go (_originExpr p)
render (Just (reverse . citations @t @m -> p:_)) = go (_originExpr p)
render _ = simpleExpr "?"
-- render (Just (NValue (citations -> ps))) =
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
@ -370,14 +370,14 @@ prettyNValue = fmap prettyNValueNF . removeEffectsM
prettyNValueProv
:: forall t f m ann
. ( HasCitations1 t f m
. ( HasCitations1 t m (NValue t f m) f
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> NValue t f m
-> m (Doc ann)
prettyNValueProv v@(NValue nv) = do
let ps = citations1 @t @f @m nv
let ps = citations1 @t @m @(NValue t f m) @f nv
case ps of
[] -> prettyNValue v
ps -> do
@ -394,15 +394,15 @@ prettyNValueProv v@(NValue nv) = do
prettyNThunk
:: forall t f m ann
. ( HasCitations t f m t
, HasCitations1 t f m
. ( HasCitations t m (NValue t f m) t
, HasCitations1 t m (NValue t f m) f
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> t
-> m (Doc ann)
prettyNThunk t = do
let ps = citations @t @f @m @t t
let ps = citations @t @m @(NValue t f m) @t t
v' <- prettyNValueNF <$> dethunk t
pure
$ fillSep

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

@ -12,6 +12,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
@ -23,27 +24,28 @@ import Control.Comonad ( Comonad )
import Control.Comonad.Env ( ComonadEnv )
import Control.Monad.Catch hiding ( catchJust )
import Control.Monad.Reader
import Data.Fix
import Control.Monad.Ref
import Data.Typeable
import GHC.Generics
import Nix.Cited
import Nix.Cited.Basic
import Nix.Effects
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.Options
import Nix.Render
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var ( MonadVar
, newVar
)
newtype StdThunk m = StdThunk
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
newtype StdCited m a = StdCited
{ _stdCited :: NCited (StdThunk m) (StdCited m) (StdLazy m) a }
{ _stdCited :: Cited (StdThunk m) (StdCited m) (StdLazy m) a }
deriving
( Generic
, Typeable
@ -52,75 +54,37 @@ newtype StdCited m a = StdCited
, Foldable
, Traversable
, Comonad
, ComonadEnv [Provenance (StdThunk m) (StdCited m) (StdLazy m)]
, ComonadEnv [Provenance (StdThunk m) (StdLazy m) (StdValue m)]
)
newtype StdThunk m = StdThunk
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy 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 StdIdT m = FreshIdT Int m
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT m)
type MonadStdThunk m = (MonadVar m, MonadCatch m, MonadThrow m, Typeable m)
instance MonadStdThunk m
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- 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 s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
else fmap (StdThunk . StdCited . NCited []) . thunk $ mv
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
query (StdThunk (StdCited (NCited _ t))) = query t
queryM (StdThunk (StdCited (NCited _ t))) = queryM t
-- | 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 (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann s _)) : _ ->
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
forceEff (StdThunk (StdCited (NCited ps t))) f = catch
go
(throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann s _)) : _ ->
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT 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 MonadStdThunk m
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
thunk = fmap (StdThunk . StdCited) . thunk
thunkId = thunkId . _stdCited . _stdThunk
query x b f = query (_stdCited (_stdThunk x)) b f
queryM x b f = queryM (_stdCited (_stdThunk x)) b f
force = force . _stdCited . _stdThunk
forceEff = forceEff . _stdCited . _stdThunk
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
@ -148,9 +112,9 @@ instance (MonadEffects t f m, MonadDataContext f m)
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m
instance HasCitations1 (StdThunk m) (StdCited m) (StdLazy m) where
citations1 (StdCited c) = citations c
addProvenance1 x (StdCited c) = StdCited (addProvenance x c)
instance HasCitations1 (StdThunk m) (StdLazy m) (StdValue m) (StdCited 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

3
tests/TestCommon.hs
View File

@ -11,6 +11,9 @@ import Data.Text ( Text
)
import Data.Time
import Nix
import Nix.Exec ()
import Nix.Cited ()
import Nix.Cited.Basic ()
import Nix.Thunk.Standard
import System.Environment
import System.IO