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

Use NSet for both recursive and non-recursive sets 

Simplifies the AST
This commit is contained in:
Silvan Mosberger 2019-05-16 22:30:52 +02:00 committed by John Wiegley
parent 3db38d0663
commit 82b2d8af7f
10 changed files with 74 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Nix/Eval.hs
View File

@ -141,11 +141,11 @@ eval (NList l ) = do
scope <- currentScopes
for l (defer @v @m . withScopes @v scope) >>= toValue
eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
eval (NSet NNonRecursive binds) =
evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue
eval (NRecSet binds) =
evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue
eval (NSet NRecursive binds) =
evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue
eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst

16
src/Nix/Expr/Shorthands.hs
View File

@ -18,6 +18,7 @@ import Text.Megaparsec.Pos ( SourcePos )
mkInt :: Integer -> NExpr
mkInt = Fix . mkIntF
mkIntF :: Integer -> NExprF a
mkIntF = NConstant . NInt
@ -101,10 +102,10 @@ mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr
mkParamset params variadic = ParamSet params variadic Nothing
mkRecSet :: [Binding NExpr] -> NExpr
mkRecSet = Fix . NRecSet
mkRecSet = Fix . NSet NRecursive
mkNonRecSet :: [Binding NExpr] -> NExpr
mkNonRecSet = Fix . NSet
mkNonRecSet = Fix . NSet NNonRecursive
mkLets :: [Binding NExpr] -> NExpr -> NExpr
mkLets bindings = Fix . NLet bindings
@ -161,10 +162,9 @@ infixr 2 $=
-- `let a = 1; b = 2; c = 3; in 4`.
appendBindings :: [Binding NExpr] -> NExpr -> NExpr
appendBindings newBindings (Fix e) = case e of
NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e'
NSet bindings -> Fix $ NSet (bindings <> newBindings)
NRecSet bindings -> Fix $ NRecSet (bindings <> newBindings)
_ -> error "Can only append bindings to a set or a let"
NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e'
NSet recur bindings -> Fix $ NSet recur (bindings <> newBindings)
_ -> error "Can only append bindings to a set or a let"
-- | Applies a transformation to the body of a nix function.
modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr
@ -182,11 +182,11 @@ letE varName varExpr = letsE [(varName, varExpr)]
-- | Make an attribute set (non-recursive).
attrsE :: [(Text, NExpr)] -> NExpr
attrsE pairs = Fix $ NSet (map (uncurry bindTo) pairs)
attrsE pairs = Fix $ NSet NNonRecursive (map (uncurry bindTo) pairs)
-- | Make an attribute set (recursive).
recAttrsE :: [(Text, NExpr)] -> NExpr
recAttrsE pairs = Fix $ NRecSet (map (uncurry bindTo) pairs)
recAttrsE pairs = Fix $ NSet NRecursive (map (uncurry bindTo) pairs)
-- | Logical negation.
mkNot :: NExpr -> NExpr

26
src/Nix/Expr/Types.hs
View File

@ -111,10 +111,8 @@ data NExprF r
-- as @NSym "f"@ and @a@ as @NSym "a"@.
| NList ![r]
-- ^ A list literal.
| NSet ![Binding r]
-- ^ An attribute set literal, not recursive.
| NRecSet ![Binding r]
-- ^ An attribute set literal, recursive.
| NSet !NRecordType ![Binding r]
-- ^ An attribute set literal
| NLiteralPath !FilePath
-- ^ A path expression, which is evaluated to a store path. The path here
-- can be relative, in which case it's evaluated relative to the file in
@ -436,6 +434,16 @@ data NBinaryOp
instance Serialise NBinaryOp
#endif
data NRecordType
= NNonRecursive
| NRecursive
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
NFData, Hashable)
#ifdef MIN_VERSION_serialise
instance Serialise NRecordType
#endif
-- | Get the name out of the parameter (there might be none).
paramName :: Params r -> Maybe VarName
paramName (Param n ) = Just n
@ -488,6 +496,7 @@ instance Binary a => Binary (Params a)
instance Binary NAtom
instance Binary NUnaryOp
instance Binary NBinaryOp
instance Binary NRecordType
instance Binary a => Binary (NExprF a)
instance (ToJSON v, ToJSON a) => ToJSON (Antiquoted v a)
@ -501,6 +510,7 @@ instance ToJSON a => ToJSON (Params a)
instance ToJSON NAtom
instance ToJSON NUnaryOp
instance ToJSON NBinaryOp
instance ToJSON NRecordType
instance ToJSON a => ToJSON (NExprF a)
instance ToJSON NExpr
@ -515,6 +525,7 @@ instance FromJSON a => FromJSON (Params a)
instance FromJSON NAtom
instance FromJSON NUnaryOp
instance FromJSON NBinaryOp
instance FromJSON NRecordType
instance FromJSON a => FromJSON (NExprF a)
instance FromJSON NExpr
@ -538,7 +549,7 @@ ekey
=> NonEmpty Text
-> SourcePos
-> Lens' (Fix g) (Maybe (Fix g))
ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x = case go xs of
ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = case go xs of
((v, [] ) : _) -> fromMaybe e <$> f (Just v)
((v, r : rest) : _) -> ekey (r :| rest) pos f v
@ -546,7 +557,7 @@ ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x = case go xs of
Nothing -> e
Just v ->
let entry = NamedVar (NE.map StaticKey keys) v pos
in Fix (toNExpr (NSet (entry : xs), ann))
in Fix (toNExpr (NSet NNonRecursive (entry : xs), ann))
where
go xs = do
let keys' = NE.toList keys
@ -563,8 +574,7 @@ ekey _ _ f e = fromMaybe e <$> f Nothing
stripPositionInfo :: NExpr -> NExpr
stripPositionInfo = transport phi
where
phi (NSet binds ) = NSet (map go binds)
phi (NRecSet binds ) = NRecSet (map go binds)
phi (NSet recur binds) = NSet recur (map go binds)
phi (NLet binds body) = NLet (map go binds) body
phi x = x

7
src/Nix/Expr/Types/Annotated.hs
View File

@ -210,11 +210,8 @@ pattern NStr_ ann x = Compose (Ann ann (NStr x))
pattern NList_ :: SrcSpan -> [r] -> NExprLocF r
pattern NList_ ann x = Compose (Ann ann (NList x))
pattern NSet_ :: SrcSpan -> [Binding r] -> NExprLocF r
pattern NSet_ ann x = Compose (Ann ann (NSet x))
pattern NRecSet_ :: SrcSpan -> [Binding r] -> NExprLocF r
pattern NRecSet_ ann x = Compose (Ann ann (NRecSet x))
pattern NSet_ :: SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r
pattern NSet_ ann recur x = Compose (Ann ann (NSet recur x))
pattern NLiteralPath_ :: SrcSpan -> FilePath -> NExprLocF r
pattern NLiteralPath_ ann x = Compose (Ann ann (NLiteralPath x))

4
src/Nix/Parser.hs
View File

@ -252,7 +252,7 @@ nixLet = annotateLocation1
-- Let expressions `let {..., body = ...}' are just desugared
-- into `(rec {..., body = ...}).body'.
letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
aset = annotateLocation1 $ NSet NRecursive <$> braces nixBinders
nixIf :: Parser NExprLoc
nixIf = annotateLocation1
@ -418,7 +418,7 @@ keyName = dynamicKey <+> staticKey where
nixSet :: Parser NExprLoc
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set")
where isRec = (reserved "rec" $> NRecSet <?> "recursive set") <+> pure NSet
where isRec = (reserved "rec" $> NSet NRecursive <?> "recursive set") <+> pure (NSet NNonRecursive)
parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
parseNixFile =

10
src/Nix/Pretty.hs
View File

@ -235,16 +235,16 @@ exprFNixDoc = \case
$ vsep
$ concat
$ [[lbracket], map (wrapParens appOpNonAssoc) xs, [rbracket]]
NSet [] -> simpleExpr $ lbrace <> rbrace
NSet xs ->
NSet NNonRecursive [] -> simpleExpr $ lbrace <> rbrace
NSet NNonRecursive xs ->
simpleExpr
$ group
$ nest 2
$ vsep
$ concat
$ [[lbrace], map prettyBind xs, [rbrace]]
NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
NRecSet xs ->
NSet NRecursive [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
NSet NRecursive xs ->
simpleExpr
$ group
$ nest 2
@ -330,7 +330,7 @@ valueToExpr = iterNValue (\_ _ -> thk) phi
phi (NVConstant' a ) = Fix $ NConstant a
phi (NVStr' ns) = mkStr ns
phi (NVList' l ) = Fix $ NList l
phi (NVSet' s p ) = Fix $ NSet
phi (NVSet' s p ) = Fix $ NSet NNonRecursive
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s
]

18
src/Nix/Reduce.hs
View File

@ -210,7 +210,7 @@ reduce base@(NSelect_ _ _ attrs _)
n@(NamedVar (a' :| _) _ _) | a' == a -> Just n
_ -> findBind xs attrs
-- Follow the attrpath recursively in sets.
inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
inspectSet (NSet_ _ NNonRecursive binds) attrs = case findBind binds attrs of
Just (NamedVar _ e _) -> case NE.uncons attrs of
(_, Just attrs) -> inspectSet (unFix e) attrs
_ -> pure e
@ -221,18 +221,18 @@ reduce base@(NSelect_ _ _ attrs _)
-- | Reduce a set by inlining its binds outside of the set
-- if none of the binds inherit the super set.
reduce e@(NSet_ ann binds) = do
reduce e@(NSet_ ann NNonRecursive binds) = do
let usesInherit = flip any binds $ \case
Inherit{} -> True
_ -> False
if usesInherit
then clearScopes @NExprLoc $ Fix . NSet_ ann <$> traverse sequence binds
then clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds
else Fix <$> sequence e
-- Encountering a 'rec set' construction eliminates any hope of inlining
-- definitions.
reduce (NRecSet_ ann binds) =
clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds
reduce (NSet_ ann NRecursive binds) =
clearScopes @NExprLoc $ Fix . NSet_ ann NRecursive <$> traverse sequence binds
-- Encountering a 'with' construction eliminates any hope of inlining
-- definitions.
@ -320,11 +320,9 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
NList l | reduceLists opts -> Just $ NList (catMaybes l)
| otherwise -> Just $ NList (map (fromMaybe nNull) l)
NSet binds | reduceSets opts -> Just $ NSet (mapMaybe sequence binds)
| otherwise -> Just $ NSet (map (fmap (fromMaybe nNull)) binds)
NRecSet binds
| reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds)
| otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds)
NSet recur binds
| reduceSets opts -> Just $ NSet recur (mapMaybe sequence binds)
| otherwise -> Just $ NSet recur (map (fmap (fromMaybe nNull)) binds)
NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
Just $ case mapMaybe pruneBinding binds of

4
src/Nix/TH.hs
View File

@ -43,8 +43,8 @@ freeVars e = case unFix e of
(NStr string ) -> foldMap freeVars string
(NSym var ) -> Set.singleton var
(NList list ) -> foldMap freeVars list
(NSet bindings) -> foldMap bindFree bindings
(NRecSet bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings
(NSet NNonRecursive bindings) -> foldMap bindFree bindings
(NSet NRecursive bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings
(NLiteralPath _ ) -> Set.empty
(NEnvPath _ ) -> Set.empty
(NUnary _ expr ) -> freeVars expr

44
tests/ParserTests.hs
View File

@ -71,51 +71,51 @@ case_constant_uri = do
assertParseFail "+:acdcd"
case_simple_set = do
assertParseText "{ a = 23; b = 4; }" $ Fix $ NSet
assertParseText "{ a = 23; b = 4; }" $ Fix $ NSet NNonRecursive
[ NamedVar (mkSelector "a") (mkInt 23) nullPos
, NamedVar (mkSelector "b") (mkInt 4) nullPos
]
assertParseFail "{ a = 23 }"
case_set_inherit = do
assertParseText "{ e = 3; inherit a b; }" $ Fix $ NSet
assertParseText "{ e = 3; inherit a b; }" $ Fix $ NSet NNonRecursive
[ NamedVar (mkSelector "e") (mkInt 3) nullPos
, Inherit Nothing (StaticKey <$> ["a", "b"]) nullPos
]
assertParseText "{ inherit; }" $ Fix $ NSet [ Inherit Nothing [] nullPos ]
assertParseText "{ inherit; }" $ Fix $ NSet NNonRecursive [ Inherit Nothing [] nullPos ]
case_set_scoped_inherit = assertParseText "{ inherit (a) b c; e = 4; inherit(a)b c; }" $ Fix $ NSet
case_set_scoped_inherit = assertParseText "{ inherit (a) b c; e = 4; inherit(a)b c; }" $ Fix $ NSet NNonRecursive
[ Inherit (Just (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos
, NamedVar (mkSelector "e") (mkInt 4) nullPos
, Inherit (Just (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos
]
case_set_rec = assertParseText "rec { a = 3; b = a; }" $ Fix $ NRecSet
case_set_rec = assertParseText "rec { a = 3; b = a; }" $ Fix $ NSet NRecursive
[ NamedVar (mkSelector "a") (mkInt 3) nullPos
, NamedVar (mkSelector "b") (mkSym "a") nullPos
]
case_set_complex_keynames = do
assertParseText "{ \"\" = null; }" $ Fix $ NSet
assertParseText "{ \"\" = null; }" $ Fix $ NSet NNonRecursive
[ NamedVar (DynamicKey (Plain (DoubleQuoted [])) :| []) mkNull nullPos ]
assertParseText "{ a.b = 3; a.c = 4; }" $ Fix $ NSet
assertParseText "{ a.b = 3; a.c = 4; }" $ Fix $ NSet NNonRecursive
[ NamedVar (StaticKey "a" :| [StaticKey "b"]) (mkInt 3) nullPos
, NamedVar (StaticKey "a" :| [StaticKey "c"]) (mkInt 4) nullPos
]
assertParseText "{ ${let a = \"b\"; in a} = 4; }" $ Fix $ NSet
assertParseText "{ ${let a = \"b\"; in a} = 4; }" $ Fix $ NSet NNonRecursive
[ NamedVar (DynamicKey (Antiquoted letExpr) :| []) (mkInt 4) nullPos ]
assertParseText "{ \"a${let a = \"b\"; in a}c\".e = 4; }" $ Fix $ NSet
assertParseText "{ \"a${let a = \"b\"; in a}c\".e = 4; }" $ Fix $ NSet NNonRecursive
[ NamedVar (DynamicKey (Plain str) :| [StaticKey "e"]) (mkInt 4) nullPos ]
where
letExpr = Fix $ NLet [NamedVar (mkSelector "a") (mkStr "b") nullPos] (mkSym "a")
str = DoubleQuoted [Plain "a", Antiquoted letExpr, Plain "c"]
case_set_inherit_direct = assertParseText "{ inherit ({a = 3;}); }" $ Fix $ NSet
[ Inherit (Just $ Fix $ NSet [NamedVar (mkSelector "a") (mkInt 3) nullPos]) [] nullPos
case_set_inherit_direct = assertParseText "{ inherit ({a = 3;}); }" $ Fix $ NSet NNonRecursive
[ Inherit (Just $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]) [] nullPos
]
case_inherit_selector = do
assertParseText "{ inherit \"a\"; }" $ Fix $ NSet
assertParseText "{ inherit \"a\"; }" $ Fix $ NSet NNonRecursive
[Inherit Nothing [DynamicKey (Plain (DoubleQuoted [Plain "a"]))] nullPos]
assertParseFail "{ inherit a.x; }"
@ -126,7 +126,7 @@ case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (map (Fix . N
case_mixed_list = do
assertParseText "[{a = 3;}.a (if true then null else false) null false 4 [] c.d or null]" $ Fix $ NList
[ Fix (NSelect (Fix (NSet [NamedVar (mkSelector "a") (mkInt 3) nullPos]))
[ Fix (NSelect (Fix (NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]))
(mkSelector "a") Nothing)
, Fix (NIf (mkBool True) mkNull (mkBool False))
, mkNull, mkBool False, mkInt 4, Fix (NList [])
@ -143,7 +143,7 @@ case_lambda_or_uri = do
assertParseText "a :b" $ Fix $ NAbs (Param "a") (mkSym "b")
assertParseText "a c:def" $ Fix $ NBinary NApp (mkSym "a") (mkStr "c:def")
assertParseText "c:def: c" $ Fix $ NBinary NApp (mkStr "c:def:") (mkSym "c")
assertParseText "a:{}" $ Fix $ NAbs (Param "a") $ Fix $ NSet []
assertParseText "a:{}" $ Fix $ NAbs (Param "a") $ Fix $ NSet NNonRecursive []
assertParseText "a:[a]" $ Fix $ NAbs (Param "a") $ Fix $ NList [mkSym "a"]
assertParseFail "def:"
@ -184,7 +184,7 @@ case_simple_let = do
case_let_body = assertParseText "let { body = 1; }" letBody
where
letBody = Fix $ NSelect aset (mkSelector "body") Nothing
aset = Fix $ NRecSet [NamedVar (mkSelector "body") (mkInt 1) nullPos]
aset = Fix $ NSet NRecursive [NamedVar (mkSelector "body") (mkInt 1) nullPos]
case_nested_let = do
assertParseText "let a = 4; in let b = 5; in a" $ Fix $ NLet
@ -255,11 +255,11 @@ case_select = do
assertParseText "a.e . d or null" $ Fix $ NSelect (mkSym "a")
(StaticKey "e" :| [StaticKey "d"])
(Just mkNull)
assertParseText "{}.\"\"or null" $ Fix $ NSelect (Fix (NSet []))
assertParseText "{}.\"\"or null" $ Fix $ NSelect (Fix (NSet NNonRecursive []))
(DynamicKey (Plain (DoubleQuoted [])) :| []) (Just mkNull)
assertParseText "{ a = [1]; }.a or [2] ++ [3]" $ Fix $ NBinary NConcat
(Fix (NSelect
(Fix (NSet [NamedVar (StaticKey "a" :| [])
(Fix (NSet NNonRecursive [NamedVar (StaticKey "a" :| [])
(Fix (NList [Fix (NConstant (NInt 1))]))
nullPos]))
(StaticKey "a" :| [])
@ -269,14 +269,14 @@ case_select = do
case_select_path = do
assertParseText "f ./." $ Fix $ NBinary NApp (mkSym "f") (mkPath False "./.")
assertParseText "f.b ../a" $ Fix $ NBinary NApp select (mkPath False "../a")
assertParseText "{}./def" $ Fix $ NBinary NApp (Fix (NSet [])) (mkPath False "./def")
assertParseText "{}./def" $ Fix $ NBinary NApp (Fix (NSet NNonRecursive [])) (mkPath False "./def")
assertParseText "{}.\"\"./def" $ Fix $ NBinary NApp
(Fix $ NSelect (Fix (NSet [])) (DynamicKey (Plain (DoubleQuoted [])) :| []) Nothing)
(Fix $ NSelect (Fix (NSet NNonRecursive [])) (DynamicKey (Plain (DoubleQuoted [])) :| []) Nothing)
(mkPath False "./def")
where select = Fix $ NSelect (mkSym "f") (mkSelector "b") Nothing
case_select_keyword = do
assertParseText "{ false = \"foo\"; }" $ Fix $ NSet [NamedVar (mkSelector "false") (mkStr "foo") nullPos]
assertParseText "{ false = \"foo\"; }" $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "false") (mkStr "foo") nullPos]
case_fun_app = do
assertParseText "f a b" $ Fix $ NBinary NApp (Fix $ NBinary NApp (mkSym "f") (mkSym "a")) (mkSym "b")
@ -313,8 +313,8 @@ case_operators = do
assertParseText "1 + (if true then 2 else 3)" $ mkOper2 NPlus (mkInt 1) $ Fix $ NIf
(mkBool True) (mkInt 2) (mkInt 3)
assertParseText "{ a = 3; } // rec { b = 4; }" $ mkOper2 NUpdate
(Fix $ NSet [NamedVar (mkSelector "a") (mkInt 3) nullPos])
(Fix $ NRecSet [NamedVar (mkSelector "b") (mkInt 4) nullPos])
(Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos])
(Fix $ NSet NRecursive [NamedVar (mkSelector "b") (mkInt 4) nullPos])
assertParseText "--a" $ mkOper NNeg $ mkOper NNeg $ mkSym "a"
assertParseText "a - b - c" $ mkOper2 NMinus
(mkOper2 NMinus (mkSym "a") (mkSym "b")) $

7
tests/PrettyParseTests.hs
View File

@ -120,8 +120,8 @@ genExpr = Gen.sized $ \(Size n) -> Fix <$> if n < 2
genStr = NStr <$> genString
genSym = NSym <$> asciiText
genList = NList <$> fairList genExpr
genSet = NSet <$> fairList genBinding
genRecSet = NRecSet <$> fairList genBinding
genSet = NSet NNonRecursive <$> fairList genBinding
genRecSet = NSet NRecursive <$> fairList genBinding
genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
genEnvPath = NEnvPath <$> asciiString
genUnary = NUnary <$> Gen.enumBounded <*> genExpr
@ -152,8 +152,7 @@ normalize = cata $ \case
NConstant (NFloat n) | n < 0 ->
Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n)))))
NSet binds -> Fix (NSet (map normBinding binds))
NRecSet binds -> Fix (NRecSet (map normBinding binds))
NSet recur binds -> Fix (NSet recur (map normBinding binds))
NLet binds r -> Fix (NLet (map normBinding binds) r)
NAbs params r -> Fix (NAbs (normParams params) r)