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

Use closures to capture the environment of a lambda abstraction

Browse source 
Fixes #108
This commit is contained in:
John Wiegley 2018-04-03 14:40:49 -07:00
parent b33c2647ec
commit ea36f85338
7 changed files with 52 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Nix/Builtins.hs
View file

@ -420,7 +420,7 @@ isList = force >=> \case
isFunction :: MonadBuiltins e m => NThunk m -> m (NValue m)
isFunction = force >=> \case
NVFunction _ _ -> toValue True
NVClosure {} -> toValue True
_ -> toValue False
isString :: MonadBuiltins e m => NThunk m -> m (NValue m)

18
Nix/Eval.hs
View file

@ -219,7 +219,7 @@ eval (NIf cond t f) = do
eval (NWith scope body) = do
traceM "NWith"
s <- thunk scope
pushWeakScope s ?? body $ force >=> \case
pushWeakScope ?? body $ force s >>= \case
NVSet s -> return s
_ -> throwError "scope must be a set in with statement"
@ -242,20 +242,18 @@ eval (NAbs params body) = do
-- body are forced during application.
scope <- currentScopes @_ @(NThunk m)
traceM $ "Creating lambda abstraction in scope: " ++ show scope
return $ NVFunction
(thunk . pushScopes scope <$> params)
(thunk (pushScopes scope body))
return $ NVClosure scope (thunk <$> params) (thunk body)
infixl 1 `evalApp`
evalApp :: forall e m. (MonadNixEval e m, MonadEval (NThunk m) (NValue m) m)
=> m (NValue m) -> m (NValue m) -> m (NValue m)
evalApp fun arg = fun >>= \case
NVFunction params f -> do
NVClosure scope params f -> do
traceM "evalApp:NVFunction"
args <- buildArgument params =<< valueThunk =<< arg
traceM $ "Evaluating function application with args: "
++ show (newScope args)
clearScopes @(NThunk m) (pushScope args (force =<< f))
withScopes @(NThunk m) scope $ pushScope args $ force =<< f
NVBuiltin name f -> do
traceM $ "evalApp:NVBuiltin " ++ name
f =<< valueThunk =<< arg
@ -306,7 +304,7 @@ valueEq l r = case (l, r) of
-----
normalForm :: (MonadNix m, MonadIO m) => NValue m -> m (NValueNF m)
normalForm :: forall e m. MonadNixEval e m => NValue m -> m (NValueNF m)
normalForm = \case
NVConstant a -> return $ Fix $ NVConstant a
NVStr t s -> return $ Fix $ NVStr t s
@ -314,10 +312,10 @@ normalForm = \case
Fix . NVList <$> traverse (normalForm <=< force) l
NVSet s ->
Fix . NVSet <$> traverse (normalForm <=< force) s
NVFunction p f -> do
NVClosure s p f -> withScopes @(NThunk m) s $ do
p' <- traverse (fmap (normalForm <=< force)) p
return $ Fix $
NVFunction p' (normalForm =<< force =<< f)
NVClosure emptyScopes p' (normalForm =<< force =<< f)
NVLiteralPath fp -> return $ Fix $ NVLiteralPath fp
NVEnvPath p -> return $ Fix $ NVEnvPath p
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
@ -334,7 +332,7 @@ valueText addPathsToStore = cata phi where
-- TODO: Should this be run through valueText recursively?
M.lookup "__asString" set = asString
| otherwise = throwError "Cannot coerce a set to a string"
phi (NVFunction _ _) = throwError "Cannot coerce a function to a string"
phi NVClosure {} = throwError "Cannot coerce a function to a string"
phi (NVLiteralPath originalPath)
| addPathsToStore = do
-- TODO: Capture and use the path of the file being processed as the

26
Nix/Lint.hs
View file

@ -43,7 +43,7 @@ data NTypeF (m :: * -> *) r
| TStr
| TList r
| TSet (Maybe (HashMap Text r))
| TFunction (Params (m r)) (m r)
| TClosure (Scopes m r) (Params (m r)) (m r)
| TPath
| TBuiltin String (Symbolic m -> m r)
deriving Functor
@ -61,9 +61,9 @@ compareTypes _ (TList _) = GT
compareTypes (TSet _) (TSet _) = EQ
compareTypes (TSet _) _ = LT
compareTypes _ (TSet _) = GT
compareTypes (TFunction _ _) (TFunction _ _) = EQ
compareTypes (TFunction _ _) _ = LT
compareTypes _ (TFunction _ _) = GT
compareTypes TClosure {} TClosure {} = EQ
compareTypes TClosure {} _ = LT
compareTypes _ TClosure {} = GT
compareTypes TPath TPath = EQ
compareTypes TPath _ = LT
compareTypes _ TPath = GT
@ -120,12 +120,13 @@ renderSymbolic = unpackSymbolic >=> \case
TSet (Just s) -> do
x <- traverse (renderSymbolic <=< sforce) s
return $ "{" ++ show x ++ "}"
f@(TFunction p _) -> do
f@(TClosure s p _) -> do
(args, sym) <-
lintApp (NAbs (void p) ()) (mkSymbolic [f]) everyPossible
args' <- traverse renderSymbolic args
sym' <- renderSymbolic sym
return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
return $ "(" ++ show s ++ " over " ++ show args'
++ " -> " ++ sym' ++ ")"
TPath -> return "path"
TBuiltin _n _f -> return "<builtin function>"
@ -158,7 +159,7 @@ merge context = go
if M.null m
then go xs ys
else (TSet (Just m) :) <$> go xs ys
(TFunction _ _, TFunction _ _) ->
(TClosure {}, TClosure {}) ->
throwError "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
throwError "Cannot unify builtin functions"
@ -181,7 +182,7 @@ merge context = go
then go xs ys
else do
g <- unify context fl fr
(TFunction (ParamSet m' False nl) g :)
(TClosure (ParamSet m' False nl) g :)
<$> go xs ys
-}
@ -336,7 +337,7 @@ lint e@(NIf cond t f) = do
lint (NWith scope body) = do
s <- sthunk scope
pushWeakScope s ?? body $ sforce >=> unpackSymbolic >=> \case
pushWeakScope ?? body $ sforce s >>= unpackSymbolic >>= \case
NMany [TSet (Just s')] -> return s'
NMany [TSet Nothing] -> error "with unknown set"
_ -> throwError "scope must be a set in with statement"
@ -349,8 +350,7 @@ lint e@(NApp fun arg) = snd <$> lintApp (void e) fun arg
lint (NAbs params body) = do
scope <- currentScopes @_ @(SThunk m)
mkSymbolic [TFunction (sthunk . pushScopes scope <$> params)
(sthunk (pushScopes scope body))]
mkSymbolic [TClosure scope (sthunk <$> params) (sthunk body)]
infixl 1 `lintApp`
lintApp :: forall e m. MonadNixLint e m
@ -360,7 +360,7 @@ lintApp context fun arg = fun >>= unpackSymbolic >>= \case
NAny -> throwError "Cannot apply something not known to be a function"
NMany xs -> do
(args:_, ys) <- fmap unzip $ forM xs $ \case
TFunction params f -> arg >>= unpackSymbolic >>= \case
TClosure scope params f -> arg >>= unpackSymbolic >>= \case
NAny -> do
pset <- case params of
Param name ->
@ -371,7 +371,7 @@ lintApp context fun arg = fun >>= unpackSymbolic >>= \case
pset' <- traverse (sthunk . pure) pset
arg' <- sthunk $ mkSymbolic [TSet (Just pset')]
args <- buildArgument params arg'
res <- clearScopes @(SThunk m) $
res <- withScopes @(SThunk m) scope $
pushScope args $ sforce =<< f
return (pset, res)

5
Nix/Monad.hs
View file

@ -20,6 +20,7 @@ import Nix.Atoms
import Nix.Expr.Types
import Nix.Thunk
import Nix.Utils
import Nix.Scope
newtype NThunk m = NThunk (Thunk m (NValue m))
@ -41,7 +42,7 @@ data NValueF m r
| NVStr Text (DList Text)
| NVList [r]
| NVSet (HashMap Text r)
| NVFunction (Params (m r)) (m r)
| NVClosure (Scopes m r) (Params (m r)) (m r)
-- ^ A function is a closed set of parameters representing the "call
-- signature", used at application time to check the type of arguments
-- passed to the function. Since it supports default values which may
@ -78,7 +79,7 @@ instance Show f => Show (NValueF m f) where
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
go (NVList list) = showsCon1 "NVList" list
go (NVSet attrs) = showsCon1 "NVSet" attrs
go (NVFunction r _) = showsCon1 "NVFunction" (() <$ r)
go (NVClosure s r _) = showsCon2 "NVClosure" s (() <$ r)
go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
go (NVEnvPath p) = showsCon1 "NVEnvPath" p
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name

20
Nix/Pretty.hs
View file

@ -128,7 +128,7 @@ prettyNix = withoutParens . cata phi where
phi (NRecSet xs) = simpleExpr $ group $
nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace
phi (NAbs args body) = leastPrecedence $
(prettyParams args <> colon) </> (indent 2 (withoutParens body))
(prettyParams args <> colon) </> indent 2 (withoutParens body)
phi (NBinary op r1 r2) = flip NixDoc opInfo $ hsep
[ wrapParens (f NAssocLeft) r1
, text $ operatorName opInfo
@ -178,15 +178,19 @@ prettyNixValue :: Functor m => NValueNF m -> Doc
prettyNixValue = prettyNix . valueToExpr
where valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = hmap go
-- hmap does the recursive conversion from NValue to NExpr
-- fun fact: it is not defined in data-fixed, but I was certain it should exists so I found it in unification-fd by hoogling its type
hmap :: (Functor f, Functor g) => (forall a. f a -> g a) -> Fix f -> Fix g
-- hmap does the recursive conversion from NValue to NExpr.
-- fun fact: it is not defined in data-fixed, but I was certain it
-- should exists so I found it in unification-fd by hoogling its type
hmap :: (Functor f, Functor g) => (forall a. f a -> g a)
-> Fix f -> Fix g
hmap eps = ana (eps . unFix)
go (NVConstant a) = NConstant a
go (NVStr t _) = NStr (DoubleQuoted [Plain t])
go (NVList l) = NList l
go (NVSet s) = NSet [NamedVar [StaticKey k] v | (k, v) <- toList s]
go (NVFunction p _) = NSym . pack $ ("<function with " ++ show (() <$ p) ++ ">")
go (NVClosure s p _) =
NSym . pack $ "<closure in " ++ show s
++ " with " ++ show (() <$ p) ++ ">"
go (NVLiteralPath fp) = NLiteralPath fp
go (NVEnvPath p) = NEnvPath p
go (NVBuiltin name _) = NSym $ Text.pack $ "builtins." ++ name
@ -198,8 +202,10 @@ printNix = cata phi
phi (NVConstant a) = unpack $ atomText a
phi (NVStr t _) = show t
phi (NVList l) = "[ " ++ unwords l ++ " ]"
phi (NVSet s) = "{ " ++ concat [ unpack k ++ " = " ++ v ++ "; " | (k, v) <- sort $ toList s ] ++ "}"
phi (NVFunction _ _) = "<<lambda>>"
phi (NVSet s) =
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
phi NVClosure {} = "<<lambda>>"
phi (NVLiteralPath fp) = fp
phi (NVEnvPath p) = p
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"

23
Nix/Scope.hs
View file

@ -1,5 +1,8 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -15,28 +18,29 @@ import Nix.Utils
data Scope m a
= Scope (HashMap Text a)
| WeakScope a (a -> m (HashMap Text a))
| WeakScope (m (HashMap Text a))
-- ^ Weak scopes (used by 'with') are delayed until first needed.
deriving (Functor, Foldable, Traversable)
instance Show (Scope m a) where
show (Scope m) = show (M.keys m)
show (WeakScope _ _) = "<weak scope>"
show (WeakScope _) = "<weak scope>"
newScope :: HashMap Text a -> Scope m a
newScope = Scope
newWeakScope :: a -> (a -> m (HashMap Text a)) -> Scope m a
newWeakScope :: m (HashMap Text a) -> Scope m a
newWeakScope = WeakScope
isWeakScope :: Scope m a -> Bool
isWeakScope (WeakScope _ _) = True
isWeakScope (WeakScope _) = True
isWeakScope _ = False
scopeLookup :: MonadIO m => Text -> [Scope m v] -> m (Maybe v)
scopeLookup key = paraM go Nothing
where
go (Scope m) _ rest = return $ M.lookup key m <|> rest
go (WeakScope m f) ms rest = do
go (WeakScope m) ms rest = do
-- If the symbol lookup is in a weak scope, first see if there are any
-- matching symbols from the *non-weak* scopes after this one. If so,
-- prefer that, otherwise perform the lookup here. This way, if there
@ -45,9 +49,8 @@ scopeLookup key = paraM go Nothing
-- prefer it from the first weak scope that matched.
mres <- scopeLookup key (filter (not . isWeakScope) ms)
case mres of
Nothing ->
f m >>= \m' ->
return $ M.lookup key m' <|> rest
Nothing -> m >>= \m' ->
return $ M.lookup key m' <|> rest
_ -> return mres
type Scopes m v = [Scope m v]
@ -67,8 +70,8 @@ pushScope :: forall v m e r. Scoped e v m => HashMap Text v -> m r -> m r
pushScope s = local (over hasLens (Scope @m s :))
pushWeakScope :: forall v m e r. Scoped e v m
=> v -> (v -> m (HashMap Text v)) -> m r -> m r
pushWeakScope s f = local (over hasLens (WeakScope s f :))
=> m (HashMap Text v) -> m r -> m r
pushWeakScope s = local (over hasLens (WeakScope s :))
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
pushScopes s = local (over hasLens (s ++))

2
main/Main.hs
View file

@ -10,7 +10,7 @@ import Nix.Expr.Types.Annotated (stripAnnotation)
import Nix.Lint
import Nix.Parser
import Nix.Pretty
import Nix.TH
-- import Nix.TH
import Options.Applicative hiding (ParserResult(..))
import System.IO
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))