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

Some refactoring and simplification in Eval.hs

Browse source
This commit is contained in:
John Wiegley 2018-05-10 00:33:46 -07:00
parent 1d5c0370ae
commit f59a17db72
No known key found for this signature in database
GPG key ID: C144D8F4F19FE630
1 changed files with 55 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

146
src/Nix/Eval.hs
View file

@ -1,19 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@ -23,16 +18,16 @@ import Control.Monad
import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Align.Key
import Data.Fix
import Data.Align.Key (alignWithKey)
import Data.Either (isRight)
import Data.Fix (Fix(Fix))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.These
import Data.These (These(..))
import Data.Traversable (for)
import Nix.Atoms
import Nix.Convert
@ -44,10 +39,9 @@ import Nix.Thunk
import Nix.Utils
class (Show v, Monad m) => MonadEval v m | v -> m where
freeVariable :: Text -> m v
attrMissing :: NonEmpty Text -> Maybe v -> m v
evaledSym :: Text -> v -> m v
freeVariable :: Text -> m v
attrMissing :: NonEmpty Text -> Maybe v -> m v
evaledSym :: Text -> v -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: NString (m v) -> m v
@ -64,7 +58,6 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalAbs :: Params (m v)
-> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v))
-> m v
{-
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
evalHasAttr :: v -> NonEmpty Text -> m v
@ -80,7 +73,6 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalLetElem :: Text -> m v -> m v
evalLet :: m v -> m v
-}
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
@ -109,52 +101,35 @@ eval (NSym "__curPos") = evalCurPos
eval (NSym var) =
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x) = evalConstant x
eval (NStr str) = evalString str
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NConstant x) = evalConstant x
eval (NStr str) = evalString str
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
evalApp ?? withScopes scope arg =<< fun
fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= \lval -> evalBinary op lval rarg
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
eval (NSelect aset attr alt) = do
traceM "NSelect"
mres <- evalSelect aset attr
traceM "NSelect..2"
case mres of
Right v -> v
Left (s, ks) -> fromMaybe (attrMissing ks (Just s)) alt
eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id
where
go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
eval (NHasAttr aset attr) =
toValue . either (const False) (const True) =<< evalSelect aset attr
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l) = do
scope <- currentScopes
toValue =<< for l (thunk . withScopes @t scope)
for l (thunk . withScopes @t scope) >>= toValue
eval (NSet binds) = do
traceM "NSet..1"
(s, p) <- evalBinds False (desugarBinds (eval . NSet) binds)
traceM $ "NSet..2: s = " ++ show (void s)
traceM $ "NSet..2: p = " ++ show (void p)
toValue (s, p)
eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
eval (NRecSet binds) = do
traceM "NRecSet..1"
(s, p) <- evalBinds True (desugarBinds (eval . NRecSet) binds)
traceM $ "NRecSet..2: s = " ++ show (void s)
traceM $ "NRecSet..2: p = " ++ show (void p)
toValue (s, p)
eval (NRecSet binds) =
evalBinds True (desugarBinds (eval . NRecSet) binds) >>= toValue
eval (NLet binds body) = do
traceM "Let..1"
(s, _) <- evalBinds True binds
traceM $ "Let..2: s = " ++ show (void s)
pushScope s body
eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
@ -168,21 +143,20 @@ eval (NAbs params body) = do
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes @_ @t
evalAbs params $ \arg k ->
withScopes @t scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
evalAbs params $ \arg k -> withScopes @t scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- this implementation may be used as an implementation for 'evalWith'.
evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v
evalWithAttrSet scope body = do
evalWithAttrSet aset body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
cur <- currentScopes @_ @t
s <- thunk $ withScopes cur scope
scope <- currentScopes @_ @t
s <- thunk $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
@ -195,15 +169,14 @@ attrSetAlter :: forall e v t m. MonadNixEval e v t m
-> m (AttrSet (m v), AttrSet SourcePos)
attrSetAlter [] _ _ _ _ =
evalError @v $ ErrorCall "invalid selector with no components"
attrSetAlter (k:ks) pos m p val = case M.lookup k m of
Nothing
| null ks -> go
| otherwise -> recurse M.empty M.empty
Just x
| null ks -> go
| otherwise ->
x >>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(st, sp) -> recurse (force ?? pure <$> st) sp
Nothing | null ks -> go
| otherwise -> recurse M.empty M.empty
Just x | null ks -> go
| otherwise ->
x >>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(st, sp) -> recurse (force ?? pure <$> st) sp
where
go = return (M.insert k val m, M.insert k pos p)
@ -222,7 +195,7 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
m <- get
put $ M.insert x ?? m $ case M.lookup x m of
Nothing -> (p, [NamedVar (y:|ys) val p])
Just (p, v) -> (p, NamedVar (y:|ys) val p : v)
Just (q, v) -> (q, NamedVar (y:|ys) val q : v)
pure $ Left x
collect x = pure $ Right x
@ -275,8 +248,8 @@ evalBinds recursive binds = do
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
evalSetterKeyName >=> \case
Nothing -> return Nothing
Just key -> return $ Just ([key], pos, do
Nothing -> pure Nothing
Just key -> pure $ Just ([key], pos, do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s -> s
@ -294,10 +267,12 @@ evalBinds recursive binds = do
(s, p) <- foldM insert (M.empty, M.empty) bindings
res <- if recursive
then loebM (encapsulate <$> s)
else traverse (thunk . withScopes scope) s
else traverse mkThunk s
return (res, p)
where
encapsulate f attrs = thunk . withScopes scope . pushScope attrs $ f
mkThunk = thunk . withScopes scope
encapsulate f attrs = mkThunk . pushScope attrs $ f
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
@ -306,27 +281,17 @@ evalSelect :: forall e v t m. MonadNixEval e v t m
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
evalSelect aset attr = do
traceM "evalSelect"
s <- aset
traceM "evalSelect..2"
path <- traverse evalGetterKeyName attr
traceM $ "evalSelect..3: " ++ show path
res <- extract s path
traceM "evalSelect..4"
return res
extract s path
where
extract x path@(k:|ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos) ->
case M.lookup k s of
Just t -> do
traceM $ "Forcing value at selector " ++ Text.unpack k
case ks of
[] -> pure $ Right $ force t pure
y:ys -> force t $ extract ?? (y:|ys)
Nothing ->
Left . (, path) <$> toValue (s, p)
Nothing ->
return $ Left (x, path)
Just (s :: AttrSet t, p :: AttrSet SourcePos)
| Just t <- M.lookup k s -> case ks of
[] -> pure $ Right $ force t pure
y:ys -> force t $ extract ?? (y:|ys)
| otherwise -> Left . (, path) <$> toValue (s, p)
Nothing -> return $ Left (x, path)
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
@ -341,7 +306,7 @@ evalGetterKeyName = evalSetterKeyName >=> \case
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName = \case
StaticKey k -> pure (Just k)
StaticKey k -> pure (Just k)
DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k
<&> \case Just (t, _) -> Just t
_ -> Nothing
@ -352,17 +317,16 @@ assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay)
fromParts = fmap (fmap mconcat . sequence) . traverse go
fromParts parts = fmap mconcat . sequence <$> mapM go parts
go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay)
buildArgument :: forall e v t m. MonadNixEval e v t m
=> Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do
scope <- currentScopes @_ @t
case params of
Param name -> M.singleton name
<$> thunk (withScopes scope arg)
Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m ->
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(args, _) -> do