mirror of
https://github.com/haskell-nix/hnix.git
synced 2024-09-11 06:55:38 +03:00
Merge #1009: Unify accessor naming
This commit is contained in:
commit
27e357db89
16
main/Main.hs
16
main/Main.hs
@ -178,24 +178,24 @@ main' opts@Options{..} = runWithBasicEffectsIO opts execContentsFilesOrRepl
|
||||
| isFinder = findAttrs <=< fromValue @(AttrSet StdVal)
|
||||
| otherwise = printer'
|
||||
where
|
||||
printer'
|
||||
| isXml = fun (ignoreContext . toXML) normalForm
|
||||
-- 2021-05-27: NOTE: With naive fix of the #941
|
||||
-- This is overall a naive printer implementation, as options should interact/respect one another.
|
||||
-- A nice question: "Should respect one another to what degree?": Go full combinator way, for which
|
||||
-- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI),
|
||||
-- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys.
|
||||
| isJson = fun (ignoreContext . mempty . toJSONNixString) normalForm
|
||||
| isStrict = fun (show . prettyNValue) normalForm
|
||||
| isValues = fun (show . prettyNValueProv) removeEffects
|
||||
| otherwise = fun (show . prettyNValue) removeEffects
|
||||
printer'
|
||||
| isXml = out (ignoreContext . toXML) normalForm
|
||||
| isJson = out (ignoreContext . mempty . toJSONNixString) normalForm
|
||||
| isStrict = out (show . prettyNValue) normalForm
|
||||
| isValues = out (show . prettyNValueProv) removeEffects
|
||||
| otherwise = out (show . prettyNValue) removeEffects
|
||||
where
|
||||
fun
|
||||
out
|
||||
:: (b -> Text)
|
||||
-> (a -> StandardIO b)
|
||||
-> a
|
||||
-> StdIO
|
||||
fun g f = liftIO . Text.putStrLn . g <=< f
|
||||
out transform val = liftIO . Text.putStrLn . transform <=< val
|
||||
|
||||
findAttrs
|
||||
:: AttrSet StdVal
|
||||
|
@ -247,7 +247,6 @@ instance Show VersionComponent where
|
||||
|
||||
splitVersion :: Text -> [VersionComponent]
|
||||
splitVersion s =
|
||||
whenJust
|
||||
(\ (x, xs) -> if
|
||||
| isRight eDigitsPart ->
|
||||
either
|
||||
@ -261,8 +260,7 @@ splitVersion s =
|
||||
| x `elem` separators -> splitVersion xs
|
||||
|
||||
| otherwise -> one charsPart <> splitVersion rest2
|
||||
)
|
||||
(Text.uncons s)
|
||||
) `whenJust` Text.uncons s
|
||||
where
|
||||
-- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44
|
||||
separators :: String
|
||||
|
@ -16,8 +16,9 @@ import Control.Monad.Free ( Free(Pure, Free) )
|
||||
|
||||
data Provenance m v =
|
||||
Provenance
|
||||
{ _lexicalScope :: Scopes m v
|
||||
, _originExpr :: NExprLocF (Maybe v)
|
||||
{ getLexicalScope :: Scopes m v
|
||||
-- 2021-11-09: NOTE: Better name?
|
||||
, getOriginExpr :: 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
|
||||
@ -27,8 +28,8 @@ data Provenance m v =
|
||||
|
||||
data NCited m v a =
|
||||
NCited
|
||||
{ _provenance :: [Provenance m v]
|
||||
, _cited :: a
|
||||
{ getProvenance :: [Provenance m v]
|
||||
, getCited :: a
|
||||
}
|
||||
deriving (Generic, Typeable, Functor, Foldable, Traversable, Show)
|
||||
|
||||
@ -37,11 +38,11 @@ instance Applicative (NCited m v) where
|
||||
(<*>) (NCited xs f) (NCited ys x) = NCited (xs <> ys) (f x)
|
||||
|
||||
instance Comonad (NCited m v) where
|
||||
duplicate p = NCited (_provenance p) p
|
||||
extract = _cited
|
||||
duplicate p = NCited (getProvenance p) p
|
||||
extract = getCited
|
||||
|
||||
instance ComonadEnv [Provenance m v] (NCited m v) where
|
||||
ask = _provenance
|
||||
ask = getProvenance
|
||||
|
||||
$(makeLenses ''Provenance)
|
||||
$(makeLenses ''NCited)
|
||||
@ -55,7 +56,7 @@ class HasCitations m v a where
|
||||
addProvenance :: Provenance m v -> a -> a
|
||||
|
||||
instance HasCitations m v (NCited m v a) where
|
||||
citations = _provenance
|
||||
citations = getProvenance
|
||||
addProvenance x (NCited p v) = NCited (x : p) v
|
||||
|
||||
instance HasCitations1 m v f
|
||||
|
@ -39,14 +39,16 @@ runAntiquoted nl f _ EscapedNewline = f nl
|
||||
runAntiquoted _ _ k (Antiquoted r) = k r
|
||||
|
||||
-- | Split a stream representing a string with antiquotes on line breaks.
|
||||
splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]]
|
||||
splitLines = uncurry (flip (:)) . go where
|
||||
go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls
|
||||
splitLines :: forall r . [Antiquoted Text r] -> [[Antiquoted Text r]]
|
||||
splitLines = uncurry (flip (:)) . go
|
||||
where
|
||||
go :: [Antiquoted Text r] -> ([[Antiquoted Text r]], [Antiquoted Text r])
|
||||
go (Plain t : xs) = (one (Plain l) <>) <$> foldr f (go xs) ls
|
||||
where
|
||||
(l : ls) = T.split (== '\n') t
|
||||
f prefix (finished, current) = ((Plain prefix : current) : finished, mempty)
|
||||
go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs
|
||||
go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs
|
||||
go (Antiquoted a : xs) = (one (Antiquoted a) <>) <$> go xs
|
||||
go (EscapedNewline : xs) = (one EscapedNewline <>) <$> go xs
|
||||
go [] = mempty
|
||||
|
||||
-- | Join a stream of strings containing antiquotes again. This is the inverse
|
||||
@ -108,10 +110,17 @@ stripIndent xs =
|
||||
|
||||
escapeCodes :: [(Char, Char)]
|
||||
escapeCodes =
|
||||
[('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')]
|
||||
[('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('"', '"'), ('$', '$'), ('\\', '\\')]
|
||||
|
||||
fromEscapeCode :: Char -> Maybe Char
|
||||
fromEscapeCode = (`lookup` (swap <$> escapeCodes))
|
||||
|
||||
toEscapeCode :: Char -> Maybe Char
|
||||
toEscapeCode = (`lookup` escapeCodes)
|
||||
|
||||
escapeMap :: [(Text, Text)]
|
||||
escapeMap =
|
||||
[("\n", "\\n"), ("\r", "\\r"), ("\t", "\\t"), ("\"", "\\\""), ("${", "\\${"), ("\\", "\\\\")]
|
||||
|
||||
escapeString :: Text -> Text
|
||||
escapeString = applyAll (fmap (uncurry T.replace) escapeMap)
|
||||
|
@ -776,9 +776,9 @@ getFreeVars e =
|
||||
(NAbs (ParamSet varname _ pset) expr) ->
|
||||
Set.difference
|
||||
-- Include all free variables from the expression and the default arguments
|
||||
(getFreeVars expr <> (Set.unions $ getFreeVars <$> mapMaybe snd pset))
|
||||
(getFreeVars expr <> Set.unions (getFreeVars <$> mapMaybe snd pset))
|
||||
-- But remove the argument name if existing, and all arguments in the parameter set
|
||||
((one `whenJust` varname) <> (Set.fromList $ fst <$> pset))
|
||||
((one `whenJust` varname) <> Set.fromList (fst <$> pset))
|
||||
(NLet bindings expr ) ->
|
||||
Set.difference
|
||||
(getFreeVars expr <> bindFreeVars bindings)
|
||||
|
@ -100,7 +100,9 @@ normalizeValueF f = run . iterNValueM run (flip go) (fmap Free . sequenceNValue'
|
||||
(do
|
||||
i <- ask
|
||||
when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels"
|
||||
lifted (lifted $ f t) $ local succ . k
|
||||
(lifted . lifted)
|
||||
(f t)
|
||||
(local succ . k)
|
||||
)
|
||||
(pure $ pure t)
|
||||
b
|
||||
|
@ -271,11 +271,29 @@ nixAntiquoted p =
|
||||
antiquotedLexeme
|
||||
<|> Plain <$> p
|
||||
|
||||
nixString' :: Parser (NString NExprLoc)
|
||||
nixString' = label "string" $ lexeme $ doubleQuoted <|> indented
|
||||
escapeCode :: Parser Char
|
||||
escapeCode =
|
||||
msum
|
||||
[ c <$ char e | (c, e) <- escapeCodes ]
|
||||
<|> anySingle
|
||||
|
||||
stringChar
|
||||
:: Parser ()
|
||||
-> Parser ()
|
||||
-> Parser (Antiquoted Text NExprLoc)
|
||||
-> Parser (Antiquoted Text NExprLoc)
|
||||
stringChar end escStart esc =
|
||||
antiquoted
|
||||
<|> Plain . one <$> char '$'
|
||||
<|> esc
|
||||
<|> Plain . fromString <$> some plainChar
|
||||
where
|
||||
doubleQuoted :: Parser (NString NExprLoc)
|
||||
doubleQuoted =
|
||||
plainChar :: Parser Char
|
||||
plainChar =
|
||||
notFollowedBy (end <|> void (char '$') <|> escStart) *> anySingle
|
||||
|
||||
doubleQuoted :: Parser (NString NExprLoc)
|
||||
doubleQuoted =
|
||||
label "double quoted string" $
|
||||
DoubleQuoted . removeEmptyPlains . mergePlain <$>
|
||||
inQuotationMarks (many $ stringChar quotationMark (void $ char '\\') doubleEscape)
|
||||
@ -289,12 +307,14 @@ nixString' = label "string" $ lexeme $ doubleQuoted <|> indented
|
||||
doubleEscape :: Parser (Antiquoted Text r)
|
||||
doubleEscape = Plain . one <$> (char '\\' *> escapeCode)
|
||||
|
||||
indented :: Parser (NString NExprLoc)
|
||||
indented =
|
||||
|
||||
indented :: Parser (NString NExprLoc)
|
||||
indented =
|
||||
label "indented string" $
|
||||
stripIndent <$>
|
||||
inIndentedQuotation (many $ join stringChar indentedQuotationMark indentedEscape)
|
||||
where
|
||||
-- | Read escaping inside of the "'' <expr> ''"
|
||||
indentedEscape :: Parser (Antiquoted Text r)
|
||||
indentedEscape =
|
||||
try $
|
||||
@ -312,32 +332,17 @@ nixString' = label "string" $ lexeme $ doubleQuoted <|> indented
|
||||
(Plain $ one c)
|
||||
(c /= '\n')
|
||||
|
||||
-- | Enclosed into indented quatation "'' <expr> ''"
|
||||
inIndentedQuotation :: Parser a -> Parser a
|
||||
inIndentedQuotation expr = indentedQuotationMark *> expr <* indentedQuotationMark
|
||||
|
||||
-- | Symbol "''"
|
||||
indentedQuotationMark :: Parser ()
|
||||
indentedQuotationMark = label "\"''\"" . void $ chunk "''"
|
||||
|
||||
stringChar
|
||||
:: Parser ()
|
||||
-> Parser ()
|
||||
-> Parser (Antiquoted Text NExprLoc)
|
||||
-> Parser (Antiquoted Text NExprLoc)
|
||||
stringChar end escStart esc =
|
||||
antiquoted
|
||||
<|> Plain . one <$> char '$'
|
||||
<|> esc
|
||||
<|> Plain . fromString <$> some plainChar
|
||||
where
|
||||
plainChar :: Parser Char
|
||||
plainChar =
|
||||
notFollowedBy (end <|> void (char '$') <|> escStart) *> anySingle
|
||||
|
||||
escapeCode :: Parser Char
|
||||
escapeCode =
|
||||
msum
|
||||
[ c <$ char e | (c, e) <- escapeCodes ]
|
||||
<|> anySingle
|
||||
nixString' :: Parser (NString NExprLoc)
|
||||
nixString' = label "string" $ lexeme $ doubleQuoted <|> indented
|
||||
|
||||
nixString :: Parser NExprLoc
|
||||
nixString = annNStr <$> annotateLocation1 nixString'
|
||||
@ -587,6 +592,7 @@ nixOperators selector =
|
||||
one $ binaryR NImpl "->"
|
||||
]
|
||||
|
||||
-- 2021-11-09: NOTE: rename OperatorInfo accessors to `get*`
|
||||
-- 2021-08-10: NOTE:
|
||||
-- All this is a sidecar:
|
||||
-- * This type
|
||||
@ -596,11 +602,13 @@ nixOperators selector =
|
||||
-- * getSpecialOperation
|
||||
-- can reduced in favour of adding precedence field into @NOperatorDef@.
|
||||
-- details: https://github.com/haskell-nix/hnix/issues/982
|
||||
data OperatorInfo = OperatorInfo
|
||||
data OperatorInfo =
|
||||
OperatorInfo
|
||||
{ precedence :: Int
|
||||
, associativity :: NAssoc
|
||||
, operatorName :: Text
|
||||
} deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
}
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
detectPrecedence
|
||||
:: Ord a
|
||||
|
@ -1,11 +1,9 @@
|
||||
{-# language CPP #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language ViewPatterns, PatternSynonyms, OverloadedStrings #-}
|
||||
|
||||
|
||||
{-# options_ghc -fno-warn-name-shadowing #-}
|
||||
|
||||
|
||||
module Nix.Pretty where
|
||||
|
||||
import Prelude hiding ( toList, group )
|
||||
@ -35,8 +33,8 @@ import Nix.Value
|
||||
-- | This type represents a pretty printed nix expression
|
||||
-- together with some information about the expression.
|
||||
data NixDoc ann = NixDoc
|
||||
{ -- | The rendered expression, without any parentheses.
|
||||
withoutParens :: Doc ann
|
||||
{ -- | Rendered expression. Without surrounding parenthesis.
|
||||
getDoc :: Doc ann
|
||||
|
||||
-- | The root operator is the operator at the root of
|
||||
-- the expression tree. For example, in '(a * b) + c', '+' would be the root
|
||||
@ -47,8 +45,16 @@ data NixDoc ann = NixDoc
|
||||
-- we can add brackets appropriately
|
||||
}
|
||||
|
||||
-- | Represent Nix antiquotes.
|
||||
--
|
||||
-- >
|
||||
-- > ${ expr }
|
||||
-- >
|
||||
antiquote :: NixDoc ann -> Doc ann
|
||||
antiquote x = "${" <> getDoc x <> "}"
|
||||
|
||||
mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann
|
||||
mkNixDoc o d = NixDoc { withoutParens = d, rootOp = o, wasPath = False }
|
||||
mkNixDoc o d = NixDoc { getDoc = d, rootOp = o, wasPath = False }
|
||||
|
||||
-- | A simple expression is never wrapped in parentheses. The expression
|
||||
-- behaves as if its root operator had a precedence higher than all
|
||||
@ -66,13 +72,13 @@ pathExpr d = (simpleExpr d) { wasPath = True }
|
||||
-- binding).
|
||||
leastPrecedence :: Doc ann -> NixDoc ann
|
||||
leastPrecedence =
|
||||
mkNixDoc (OperatorInfo maxBound NAssocNone "least precedence")
|
||||
mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
|
||||
|
||||
appOp :: OperatorInfo
|
||||
appOp = getBinaryOperator NApp
|
||||
|
||||
appOpNonAssoc :: OperatorInfo
|
||||
appOpNonAssoc = (getBinaryOperator NApp) { associativity = NAssocNone }
|
||||
appOpNonAssoc = appOp { associativity = NAssocNone }
|
||||
|
||||
selectOp :: OperatorInfo
|
||||
selectOp = getSpecialOperator NSelectOp
|
||||
@ -80,64 +86,68 @@ selectOp = getSpecialOperator NSelectOp
|
||||
hasAttrOp :: OperatorInfo
|
||||
hasAttrOp = getSpecialOperator NHasAttrOp
|
||||
|
||||
wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann
|
||||
wrapParens op sub =
|
||||
-- | Determine if to return doc wraped into parens,
|
||||
-- according the given operator.
|
||||
precedenceWrap :: OperatorInfo -> NixDoc ann -> Doc ann
|
||||
precedenceWrap op subExpr =
|
||||
maybeWrap $ getDoc subExpr
|
||||
where
|
||||
maybeWrap :: Doc ann -> Doc ann
|
||||
maybeWrap =
|
||||
bool
|
||||
(\ a -> "(" <> a <> ")")
|
||||
parens
|
||||
id
|
||||
( precedence (rootOp sub) < precedence op
|
||||
|| (precedence (rootOp sub) == precedence op
|
||||
&& associativity (rootOp sub) == associativity op
|
||||
&& associativity op /= NAssocNone)
|
||||
needsParens
|
||||
where
|
||||
needsParens :: Bool
|
||||
needsParens =
|
||||
precedence root < precedence op
|
||||
|| ( precedence root == precedence op
|
||||
&& associativity root == associativity op
|
||||
&& associativity op /= NAssocNone
|
||||
)
|
||||
(withoutParens sub)
|
||||
|
||||
root = rootOp subExpr
|
||||
|
||||
|
||||
-- Used in the selector case to print a path in a selector as
|
||||
-- "${./abc}"
|
||||
wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann
|
||||
wrapPath op sub =
|
||||
bool
|
||||
(wrapParens op sub)
|
||||
("\"${" <> withoutParens sub <> "}\"")
|
||||
(precedenceWrap op sub)
|
||||
(dquotes $ antiquote sub)
|
||||
(wasPath sub)
|
||||
|
||||
|
||||
infixr 5 :<
|
||||
pattern (:<) :: Char -> Text -> Text
|
||||
pattern t :< ts <- (Text.uncons -> Just (t, ts))
|
||||
where (:<) = Text.cons
|
||||
|
||||
escapeDoubleQuoteString :: Text -> Text
|
||||
escapeDoubleQuoteString ('"':<xs) = "\\\"" <> escapeDoubleQuoteString xs
|
||||
escapeDoubleQuoteString ('$':<'{':<xs) = "\\${" <> escapeDoubleQuoteString xs
|
||||
escapeDoubleQuoteString ('$':<xs) = '$' :< escapeDoubleQuoteString xs
|
||||
escapeDoubleQuoteString (x:<xs) = maybe (one x) (('\\' :<) . one) (toEscapeCode x)
|
||||
<> escapeDoubleQuoteString xs
|
||||
escapeDoubleQuoteString a = a
|
||||
|
||||
|
||||
-- | Handle Output representation of the string escape codes.
|
||||
prettyString :: NString (NixDoc ann) -> Doc ann
|
||||
prettyString (DoubleQuoted parts) = "\"" <> foldMap prettyPart parts <> "\""
|
||||
prettyString (DoubleQuoted parts) =
|
||||
dquotes $ foldMap prettyPart parts
|
||||
where
|
||||
prettyPart (Plain t) = pretty $ escapeDoubleQuoteString t
|
||||
prettyPart (Plain t) = pretty $ escapeString t
|
||||
prettyPart EscapedNewline = "''\\n"
|
||||
prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}"
|
||||
prettyString (Indented _ parts) = group $ nest 2 $ vcat
|
||||
["''", content, "''"]
|
||||
prettyPart (Antiquoted r) = antiquote r
|
||||
prettyString (Indented _ parts) =
|
||||
group $ nest 2 $ vcat ["''", content, "''"]
|
||||
where
|
||||
content = vsep . fmap prettyLine . stripLastIfEmpty . splitLines $ parts
|
||||
stripLastIfEmpty :: [[Antiquoted Text r]] -> [[Antiquoted Text r]]
|
||||
stripLastIfEmpty = filter flt
|
||||
stripLastIfEmpty =
|
||||
filter flt
|
||||
where
|
||||
flt :: [Antiquoted Text r] -> Bool
|
||||
flt [Plain t] | Text.null (strip t) = False
|
||||
flt _ = True
|
||||
|
||||
prettyLine = hcat . fmap prettyPart
|
||||
prettyLine :: [Antiquoted Text (NixDoc ann)] -> Doc ann
|
||||
prettyLine =
|
||||
hcat . fmap prettyPart
|
||||
where
|
||||
prettyPart :: Antiquoted Text (NixDoc ann) -> Doc ann
|
||||
prettyPart (Plain t) =
|
||||
pretty . replace "${" "''${" . replace "''" "'''" $ t
|
||||
prettyPart EscapedNewline = "\\n"
|
||||
prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}"
|
||||
prettyPart (Antiquoted r) = antiquote r
|
||||
|
||||
prettyVarName :: VarName -> Doc ann
|
||||
prettyVarName = pretty @Text . coerce
|
||||
@ -152,49 +162,43 @@ prettyParams (ParamSet mname variadic pset) =
|
||||
toDoc (coerce -> name) =
|
||||
("@" <> pretty name) `whenFalse` Text.null name
|
||||
|
||||
prettyParamSet :: Variadic -> ParamSet (NixDoc ann) -> Doc ann
|
||||
prettyParamSet :: forall ann . Variadic -> ParamSet (NixDoc ann) -> Doc ann
|
||||
prettyParamSet variadic args =
|
||||
encloseSep
|
||||
"{ "
|
||||
(align " }")
|
||||
sep
|
||||
(align ", ")
|
||||
(fmap prettySetArg args <> one "..." `whenTrue` (variadic == Variadic))
|
||||
where
|
||||
prettySetArg :: (VarName, Maybe (NixDoc ann)) -> Doc ann
|
||||
prettySetArg (n, maybeDef) =
|
||||
maybe
|
||||
varName
|
||||
(\x -> varName <> " ? " <> withoutParens x)
|
||||
maybeDef
|
||||
where
|
||||
varName = prettyVarName n
|
||||
sep = align ", "
|
||||
(prettyVarName n <>) $ ((" ? " <>) . getDoc) `whenJust` maybeDef
|
||||
|
||||
prettyBind :: Binding (NixDoc ann) -> Doc ann
|
||||
prettyBind (NamedVar n v _p) =
|
||||
prettySelector n <> " = " <> withoutParens v <> ";"
|
||||
prettySelector n <> " = " <> getDoc v <> ";"
|
||||
prettyBind (Inherit s ns _p) =
|
||||
"inherit " <> scope <> align (fillSep $ prettyVarName <$> ns) <> ";"
|
||||
where
|
||||
scope =
|
||||
((<> " ") . parens . withoutParens) `whenJust` s
|
||||
((<> " ") . parens . getDoc) `whenJust` s
|
||||
|
||||
prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann
|
||||
prettyKeyName (StaticKey key) =
|
||||
bool
|
||||
"\"\""
|
||||
(bool
|
||||
varName
|
||||
("\"" <> varName <> "\"")
|
||||
id
|
||||
dquotes
|
||||
(HashSet.member key reservedNames)
|
||||
(prettyVarName key)
|
||||
)
|
||||
(not $ Text.null $ coerce key)
|
||||
where
|
||||
varName = prettyVarName key
|
||||
prettyKeyName (DynamicKey key) =
|
||||
runAntiquoted
|
||||
(DoubleQuoted $ one $ Plain "\n")
|
||||
prettyString
|
||||
(\ x -> "${" <> withoutParens x <> "}")
|
||||
antiquote
|
||||
key
|
||||
|
||||
prettySelector :: NAttrPath (NixDoc ann) -> Doc ann
|
||||
@ -204,32 +208,43 @@ prettyAtom :: NAtom -> NixDoc ann
|
||||
prettyAtom = simpleExpr . pretty . atomText
|
||||
|
||||
prettyNix :: NExpr -> Doc ann
|
||||
prettyNix = withoutParens . foldFix exprFNixDoc
|
||||
prettyNix = getDoc . foldFix exprFNixDoc
|
||||
|
||||
prettyOriginExpr
|
||||
:: forall t f m ann
|
||||
. HasCitations1 m (NValue t f m) f
|
||||
=> NExprLocF (Maybe (NValue t f m))
|
||||
-> Doc ann
|
||||
prettyOriginExpr = withoutParens . go
|
||||
prettyOriginExpr = getDoc . go
|
||||
where
|
||||
go :: NExprLocF (Maybe (NValue t f m)) -> NixDoc ann
|
||||
go = exprFNixDoc . stripAnnF . fmap render
|
||||
where
|
||||
render :: Maybe (NValue t f m) -> NixDoc ann
|
||||
render Nothing = simpleExpr "_"
|
||||
render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p)
|
||||
render (Just (Free (reverse . citations @m -> p:_))) = go (getOriginExpr p)
|
||||
render _ = simpleExpr "?"
|
||||
-- render (Just (NValue (citations -> ps))) =
|
||||
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
|
||||
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . getDoc
|
||||
-- . go . originExpr)
|
||||
-- mempty (reverse ps)
|
||||
|
||||
exprFNixDoc :: NExprF (NixDoc ann) -> NixDoc ann
|
||||
-- | Takes original expression from inside provenance information.
|
||||
-- Prettifies that expression.
|
||||
prettyExtractFromProvenance
|
||||
:: forall t f m ann
|
||||
. HasCitations1 m (NValue t f m) f
|
||||
=> [Provenance m (NValue t f m)] -> Doc ann
|
||||
prettyExtractFromProvenance =
|
||||
sep .
|
||||
fmap (prettyOriginExpr . getOriginExpr)
|
||||
|
||||
exprFNixDoc :: forall ann . NExprF (NixDoc ann) -> NixDoc ann
|
||||
exprFNixDoc = \case
|
||||
NConstant atom -> prettyAtom atom
|
||||
NStr str -> simpleExpr $ prettyString str
|
||||
NList xs ->
|
||||
prettyContainer "[" (wrapParens appOpNonAssoc) "]" xs
|
||||
prettyContainer "[" (precedenceWrap appOpNonAssoc) "]" xs
|
||||
NSet NonRecursive xs ->
|
||||
prettyContainer "{" prettyBind "}" xs
|
||||
NSet Recursive xs ->
|
||||
@ -239,10 +254,10 @@ exprFNixDoc = \case
|
||||
nest 2 $
|
||||
vsep
|
||||
[ prettyParams args <> ":"
|
||||
, withoutParens body
|
||||
, getDoc body
|
||||
]
|
||||
NBinary NApp fun arg ->
|
||||
mkNixDoc appOp (wrapParens appOp fun <> " " <> wrapParens appOpNonAssoc arg)
|
||||
mkNixDoc appOp (precedenceWrap appOp fun <> " " <> precedenceWrap appOpNonAssoc arg)
|
||||
NBinary op r1 r2 ->
|
||||
mkNixDoc
|
||||
opInfo $
|
||||
@ -253,9 +268,9 @@ exprFNixDoc = \case
|
||||
]
|
||||
where
|
||||
opInfo = getBinaryOperator op
|
||||
f :: NAssoc -> NixDoc ann1 -> Doc ann1
|
||||
f :: NAssoc -> NixDoc ann -> Doc ann
|
||||
f x =
|
||||
wrapParens
|
||||
precedenceWrap
|
||||
$ bool
|
||||
opInfo
|
||||
(opInfo { associativity = NAssocNone })
|
||||
@ -263,7 +278,7 @@ exprFNixDoc = \case
|
||||
NUnary op r1 ->
|
||||
mkNixDoc
|
||||
opInfo $
|
||||
pretty (operatorName opInfo) <> wrapParens opInfo r1
|
||||
pretty (operatorName opInfo) <> precedenceWrap opInfo r1
|
||||
where
|
||||
opInfo = getUnaryOperator op
|
||||
NSelect o r' attr ->
|
||||
@ -271,13 +286,10 @@ exprFNixDoc = \case
|
||||
(mkNixDoc selectOp)
|
||||
(const leastPrecedence)
|
||||
o
|
||||
$ wrapPath selectOp r <> "." <> prettySelector attr <> ordoc
|
||||
where
|
||||
r = mkNixDoc selectOp (wrapParens appOpNonAssoc r')
|
||||
ordoc =
|
||||
((" or " <>) . wrapParens appOpNonAssoc) `whenJust` o
|
||||
$ wrapPath selectOp (mkNixDoc selectOp (precedenceWrap appOpNonAssoc r')) <> "." <> prettySelector attr <>
|
||||
((" or " <>) . precedenceWrap appOpNonAssoc) `whenJust` o
|
||||
NHasAttr r attr ->
|
||||
mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr)
|
||||
mkNixDoc hasAttrOp (precedenceWrap hasAttrOp r <> " ? " <> prettySelector attr)
|
||||
NEnvPath p -> simpleExpr $ pretty @String $ "<" <> coerce p <> ">"
|
||||
NLiteralPath p ->
|
||||
pathExpr $
|
||||
@ -286,28 +298,32 @@ exprFNixDoc = \case
|
||||
"./" -> "./."
|
||||
"../" -> "../."
|
||||
".." -> "../."
|
||||
_txt ->
|
||||
path ->
|
||||
bool
|
||||
("./" <> _txt)
|
||||
_txt
|
||||
(any (`isPrefixOf` coerce _txt) ["/", "~/", "./", "../"])
|
||||
("./" <> path)
|
||||
path
|
||||
(any (`isPrefixOf` coerce path) ["/", "~/", "./", "../"])
|
||||
NSym name -> simpleExpr $ prettyVarName name
|
||||
NLet binds body ->
|
||||
leastPrecedence $
|
||||
group $
|
||||
vsep
|
||||
[ "let"
|
||||
, indent 2 (vsep (fmap prettyBind binds))
|
||||
, "in " <> withoutParens body
|
||||
, indent 2 (vsep $ fmap prettyBind binds)
|
||||
, "in " <> getDoc body
|
||||
]
|
||||
NIf cond trueBody falseBody ->
|
||||
leastPrecedence $
|
||||
group $
|
||||
nest 2 $
|
||||
ifThenElse getDoc
|
||||
where
|
||||
ifThenElse :: (NixDoc ann -> Doc ann) -> Doc ann
|
||||
ifThenElse wp =
|
||||
sep
|
||||
[ "if " <> withoutParens cond
|
||||
, align ("then " <> withoutParens trueBody)
|
||||
, align ("else " <> withoutParens falseBody)
|
||||
[ "if " <> wp cond
|
||||
, align ("then " <> wp trueBody)
|
||||
, align ("else " <> wp falseBody)
|
||||
]
|
||||
NWith scope body ->
|
||||
prettyAddScope "with " scope body
|
||||
@ -324,7 +340,7 @@ exprFNixDoc = \case
|
||||
prettyAddScope h c b =
|
||||
leastPrecedence $
|
||||
vsep
|
||||
[h <> withoutParens c <> ";", align $ withoutParens b]
|
||||
[h <> getDoc c <> ";", align $ getDoc b]
|
||||
|
||||
|
||||
valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr
|
||||
@ -348,6 +364,35 @@ prettyNValue
|
||||
:: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann
|
||||
prettyNValue = prettyNix . valueToExpr
|
||||
|
||||
-- | During the output, which can print only representation of value,
|
||||
-- lazy thunks need to looked into & so - be evaluated (*sic)
|
||||
-- This type is a simple manual witness "is the thunk gets shown".
|
||||
data ValueOrigin = WasThunk | Value
|
||||
deriving Eq
|
||||
|
||||
prettyProv
|
||||
:: forall t f m ann
|
||||
. ( HasCitations m (NValue t f m) t
|
||||
, HasCitations1 m (NValue t f m) f
|
||||
, MonadThunk t m (NValue t f m)
|
||||
, MonadDataContext f m
|
||||
)
|
||||
=> ValueOrigin -- ^ Was thunk?
|
||||
-> NValue t f m
|
||||
-> Doc ann
|
||||
prettyProv wasThunk v =
|
||||
list
|
||||
id
|
||||
(\ ps pv ->
|
||||
fillSep
|
||||
[ pv
|
||||
, indent 2 $
|
||||
"(" <> ("thunk " `whenTrue` (wasThunk == WasThunk) <> "from: " <> prettyExtractFromProvenance ps) <> ")"
|
||||
]
|
||||
)
|
||||
(citations @m @(NValue t f m) v)
|
||||
(prettyNValue v)
|
||||
|
||||
prettyNValueProv
|
||||
:: forall t f m ann
|
||||
. ( HasCitations m (NValue t f m) t
|
||||
@ -357,19 +402,8 @@ prettyNValueProv
|
||||
)
|
||||
=> NValue t f m
|
||||
-> Doc ann
|
||||
prettyNValueProv v =
|
||||
list
|
||||
prettyNVal
|
||||
(\ ps ->
|
||||
fillSep
|
||||
[ prettyNVal
|
||||
, indent 2 $
|
||||
"(" <> fold (one "from: " <> (prettyOriginExpr . _originExpr <$> ps)) <> ")"
|
||||
]
|
||||
)
|
||||
(citations @m @(NValue t f m) v)
|
||||
where
|
||||
prettyNVal = prettyNValue v
|
||||
prettyNValueProv =
|
||||
prettyProv Value
|
||||
|
||||
prettyNThunk
|
||||
:: forall t f m ann
|
||||
@ -381,26 +415,16 @@ prettyNThunk
|
||||
=> t
|
||||
-> m (Doc ann)
|
||||
prettyNThunk t =
|
||||
do
|
||||
let ps = citations @m @(NValue t f m) @t t
|
||||
v' <- prettyNValue <$> dethunk t
|
||||
pure $
|
||||
fillSep
|
||||
[ v'
|
||||
, indent 2 $
|
||||
"(" <> fold (one "thunk from: " <> (prettyOriginExpr . _originExpr <$> ps)) <> ")"
|
||||
]
|
||||
|
||||
prettyProv WasThunk <$> dethunk t
|
||||
|
||||
-- | This function is used only by the testing code.
|
||||
printNix :: forall t f m . MonadDataContext f m => NValue t f m -> Text
|
||||
printNix = iterNValueByDiscardWith thk phi
|
||||
printNix =
|
||||
iterNValueByDiscardWith thunkStubText phi
|
||||
where
|
||||
thk = thunkStubText
|
||||
|
||||
phi :: NValue' t f m Text -> Text
|
||||
phi (NVConstant' a ) = atomText a
|
||||
phi (NVStr' ns) = "\"" <> escapeDoubleQuoteString (ignoreContext ns) <> "\""
|
||||
phi (NVStr' ns) = "\"" <> escapeString (ignoreContext ns) <> "\""
|
||||
phi (NVList' l ) = "[ " <> unwords l <> " ]"
|
||||
phi (NVSet' _ s) =
|
||||
"{ " <>
|
||||
@ -415,10 +439,8 @@ printNix = iterNValueByDiscardWith thk phi
|
||||
v
|
||||
(tryRead @Int <|> tryRead @Float)
|
||||
where
|
||||
surround s = "\"" <> s <> "\""
|
||||
|
||||
tryRead :: forall a . (Read a, Show a) => Maybe Text
|
||||
tryRead = fmap (surround . show) (readMaybe (toString v) :: Maybe a)
|
||||
tryRead = fmap ((\ s -> "\"" <> s <> "\"") . show) $ readMaybe @a $ toString v
|
||||
phi NVClosure'{} = "<<lambda>>"
|
||||
phi (NVPath' fp ) = fromString $ coerce fp
|
||||
phi (NVBuiltin' name _) = "<<builtin " <> coerce name <> ">>"
|
||||
|
@ -13,6 +13,7 @@ module Nix.Utils
|
||||
, mapPair
|
||||
, iterateN
|
||||
, nestM
|
||||
, applyAll
|
||||
, traverse2
|
||||
, lifted
|
||||
|
||||
@ -153,6 +154,10 @@ nestM n f x =
|
||||
foldM (const . f) x $ replicate @() n mempty -- fuses. But also, can it be fix join?
|
||||
{-# inline nestM #-}
|
||||
|
||||
-- | In `foldr` order apply functions.
|
||||
applyAll :: Foldable t => t (a -> a) -> a -> a
|
||||
applyAll = flip (foldr id)
|
||||
|
||||
traverse2
|
||||
:: ( Applicative m
|
||||
, Applicative n
|
||||
|
@ -625,7 +625,7 @@ constantEqualText expected actual =
|
||||
do
|
||||
constantEqualText' expected actual
|
||||
mres <- liftIO $ on (<|>) lookupEnv "ALL_TESTS" "MATCHING_TESTS"
|
||||
whenJust (const $ assertEvalMatchesNix actual) mres
|
||||
whenJust (const $ assertEvalTextMatchesNix actual) mres
|
||||
|
||||
assertNixEvalThrows :: Text -> Assertion
|
||||
assertNixEvalThrows a =
|
||||
@ -649,9 +649,8 @@ sameFreeVars a xs =
|
||||
do
|
||||
let
|
||||
Right a' = parseNixText a
|
||||
xs' = S.fromList xs
|
||||
free' = getFreeVars a'
|
||||
assertEqual mempty xs' free'
|
||||
assertEqual mempty (S.fromList xs) free'
|
||||
|
||||
maskedFiles :: [Path]
|
||||
maskedFiles = one "builtins.fetchurl-01.nix"
|
||||
|
@ -24,7 +24,8 @@ hnixEvalFile opts file =
|
||||
do
|
||||
setEnv "TEST_VAR" "foo"
|
||||
runWithBasicEffects opts $
|
||||
catch (evaluateExpression (pure $ coerce file) nixEvalExprLoc normalForm expr) $
|
||||
evaluateExpression (pure $ coerce file) nixEvalExprLoc normalForm expr
|
||||
`catch`
|
||||
\case
|
||||
NixException frames ->
|
||||
errorWithoutStackTrace . show
|
||||
@ -35,6 +36,8 @@ hnixEvalFile opts file =
|
||||
)
|
||||
parseResult
|
||||
|
||||
nixEvalFile :: Path -> IO Text
|
||||
nixEvalFile (coerce -> fp) = fromString <$> readProcess "nix-instantiate" ["--eval", "--strict", fp] mempty
|
||||
hnixEvalText :: Options -> Text -> IO StdVal
|
||||
hnixEvalText opts src =
|
||||
either
|
||||
@ -42,8 +45,8 @@ hnixEvalText opts src =
|
||||
(runWithBasicEffects opts . (normalForm <=< nixEvalExpr mempty))
|
||||
$ parseNixText src
|
||||
|
||||
nixEvalString :: Text -> IO Text
|
||||
nixEvalString expr =
|
||||
nixEvalText :: Text -> IO Text
|
||||
nixEvalText expr =
|
||||
do
|
||||
(fp, h) <- mkstemp "nix-test-eval"
|
||||
Text.hPutStr h expr
|
||||
@ -52,21 +55,28 @@ nixEvalString expr =
|
||||
removeLink fp
|
||||
pure res
|
||||
|
||||
nixEvalFile :: Path -> IO Text
|
||||
nixEvalFile fp = fromString <$> readProcess "nix-instantiate" ["--eval", "--strict", coerce fp] mempty
|
||||
assertEvalMatchesNix
|
||||
:: ( Options
|
||||
-> Text -> IO (NValue t (StdCited StandardIO) StandardIO)
|
||||
)
|
||||
-> (Text -> IO Text)
|
||||
-> Text
|
||||
-> IO ()
|
||||
assertEvalMatchesNix evalHNix evalNix fp =
|
||||
do
|
||||
time <- liftIO getCurrentTime
|
||||
hnixVal <- (<> "\n") . printNix <$> evalHNix (defaultOptions time) fp
|
||||
nixVal <- evalNix fp
|
||||
assertEqual (toString fp) nixVal hnixVal
|
||||
|
||||
-- | Compares @HNix@ & @Nix@ return results.
|
||||
assertEvalFileMatchesNix :: Path -> Assertion
|
||||
assertEvalFileMatchesNix fp =
|
||||
do
|
||||
time <- liftIO getCurrentTime
|
||||
hnixVal <- (<> "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp
|
||||
nixVal <- nixEvalFile fp
|
||||
assertEqual (coerce fp) nixVal hnixVal
|
||||
assertEvalMatchesNix
|
||||
(\ o -> hnixEvalFile o . coerce . toString)
|
||||
(nixEvalFile . coerce . toString)
|
||||
$ fromString $ coerce fp
|
||||
|
||||
assertEvalMatchesNix :: Text -> Assertion
|
||||
assertEvalMatchesNix expr =
|
||||
do
|
||||
time <- liftIO getCurrentTime
|
||||
hnixVal <- (<> "\n") . printNix <$> hnixEvalText (defaultOptions time) expr
|
||||
nixVal <- nixEvalString expr
|
||||
assertEqual (toString expr) nixVal hnixVal
|
||||
assertEvalTextMatchesNix :: Text -> Assertion
|
||||
assertEvalTextMatchesNix =
|
||||
assertEvalMatchesNix hnixEvalText nixEvalText
|
||||
|
Loading…
Reference in New Issue
Block a user