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

update fork from master contd

Browse source
This commit is contained in:
gb 2018-07-28 14:17:37 -04:00
parent ea3b675f28
commit 9c3e5e995c
13 changed files with 170 additions and 202 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Nix/Builtins.hs
View file

@ -802,7 +802,7 @@ lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
(NInt a, NFloat b) -> pure $ fromInteger a < b
(NFloat a, NFloat b) -> pure $ a < b
_ -> badType
(NVStr a, NVStr b) -> pure $ a < b
(NVStr a, NVStr b) -> pure $ stringIntentionallyDropContext a < stringIntentionallyDropContext b
_ -> badType
concatLists :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)

15
src/Nix/Cache.hs
View file

@ -5,29 +5,34 @@ module Nix.Cache where
import qualified Data.ByteString.Lazy as BS
import Nix.Expr.Types.Annotated
#ifdef __linux__
#if defined (__linux__) && MIN_VERSION_base(4, 10, 0)
#define USE_COMPACT 1
#endif
#ifdef USE_COMPACT
import qualified Data.Compact as C
import qualified Data.Compact.Serialize as C
#else
#endif
#ifdef MIN_VERSION_serialise
import qualified Codec.Serialise as S
#endif
readCache :: FilePath -> IO NExprLoc
readCache path = do
#ifdef USE_COMPACT
#if USE_COMPACT
eres <- C.unsafeReadCompact path
case eres of
Left err -> error $ "Error reading cache file: " ++ err
Right expr -> return $ C.getCompact expr
#else
#ifdef MIN_VERSION_serialise
eres <- S.deserialiseOrFail <$> BS.readFile path
case eres of
Left err -> error $ "Error reading cache file: " ++ show err
Right expr -> return expr
#else
error "readCache not implemented for this platform"
#endif
#endif
writeCache :: FilePath -> NExprLoc -> IO ()
@ -35,5 +40,9 @@ writeCache path expr =
#ifdef USE_COMPACT
C.writeCompact path =<< C.compact expr
#else
#ifdef MIN_VERSION_serialise
BS.writeFile path (S.serialise expr)
#else
error "writeCache not implemented for this platform"
#endif
#endif

7
src/Nix/Effects.hs
View file

@ -13,10 +13,16 @@ class MonadFile m => MonadEffects m where
-- | Import a path into the nix store, and return the resulting path
addPath :: FilePath -> m StorePath
toFile_ :: FilePath -> String -> m StorePath
-- | Determine the absolute path of relative path in the current context
makeAbsolutePath :: FilePath -> m FilePath
findEnvPath :: String -> m FilePath
-- | Having an explicit list of sets corresponding to the NIX_PATH
-- and a file path try to find an existing path
findPath :: [NThunk m] -> FilePath -> m FilePath
pathExists :: FilePath -> m Bool
importPath :: AttrSet (NThunk m) -> FilePath -> m (NValue m)
@ -38,3 +44,4 @@ class MonadFile m => MonadEffects m where
traceEffect :: String -> m ()
exec :: [String] -> m (NValue m)

15
src/Nix/Lint.hs
View file

@ -56,7 +56,6 @@ data TAtom
| TFloat
| TBool
| TNull
| TUri
deriving (Show, Eq, Ord)
data NTypeF (m :: * -> *) r
@ -131,7 +130,6 @@ renderSymbolic = unpackSymbolic >=> \case
TFloat -> return "float"
TBool -> return "bool"
TNull -> return "null"
TUri -> return "uri"
TStr -> return "string"
TList r -> do
x <- force r renderSymbolic
@ -283,7 +281,6 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
NFloat _ -> TFloat
NBool _ -> TBool
NNull -> TNull
NUri _ -> TUri
evalString = const $ mkSymbolic [TStr]
evalLiteralPath = const $ mkSymbolic [TPath]
@ -332,17 +329,17 @@ lintBinaryOp op lsym rarg = do
y <- thunk everyPossible
case op of
NApp -> symerr "lintBinaryOp:NApp: should never get here"
NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri]
NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
, TStr
, TList y ]
NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri]
NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
, TStr
, TList y ]
NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
NGt -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
NGte -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NGt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NGte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NAnd -> check lsym rsym [ TConstant [TBool] ]
NOr -> check lsym rsym [ TConstant [TBool] ]

2
src/Nix/Normal.hs
View file

@ -40,7 +40,7 @@ normalFormBy k n v = do
when (n > 2000) $ throwError $ NormalLoop v
case v of
NVConstant a -> return $ Fix $ NVConstantF a
NVStr ns -> return $ Fix $ NVStrF $ ns
NVStr ns -> return $ Fix $ NVStrF ns
NVList l ->
fmap (Fix . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ replicate n ' ' ++ "normalFormBy: List[" ++ show i ++ "]"

127
src/Nix/Options.hs
View file

@ -1,13 +1,7 @@
module Nix.Options where
import Control.Arrow (second)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Options.Applicative hiding (ParserResult(..))
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
data Options = Options
{ verbose :: Verbosity
@ -22,7 +16,6 @@ data Options = Options
, finder :: Bool
, findFile :: Maybe FilePath
, strict :: Bool
, normalize :: Bool
, evaluate :: Bool
, json :: Bool
, xml :: Bool
@ -56,7 +49,6 @@ defaultOptions current = Options
, finder = False
, findFile = Nothing
, strict = False
, normalize = False
, evaluate = False
, json = False
, xml = False
@ -83,122 +75,3 @@ data Verbosity
| DebugInfo
| Vomit
deriving (Eq, Ord, Enum, Bounded, Show)
decodeVerbosity :: Int -> Verbosity
decodeVerbosity 0 = ErrorsOnly
decodeVerbosity 1 = Informational
decodeVerbosity 2 = Talkative
decodeVerbosity 3 = Chatty
decodeVerbosity 4 = DebugInfo
decodeVerbosity _ = Vomit
argPair :: Mod OptionFields (Text, Text) -> Parser (Text, Text)
argPair = option $ str >>= \s ->
case Text.findIndex (== '=') s of
Nothing -> errorWithoutStackTrace
"Format of --arg/--argstr in hnix is: name=expr"
Just i -> return $ second Text.tail $ Text.splitAt i s
nixOptions :: UTCTime -> Parser Options
nixOptions current = Options
<$> (fromMaybe ErrorsOnly <$>
optional
(option (do a <- str
if all isDigit a
then pure $ decodeVerbosity (read a)
else fail "Argument to -v/--verbose must be a number")
( short 'v'
<> long "verbose"
<> help "Verbose output")))
<*> switch
( long "trace"
<> help "Enable tracing code (even more can be seen if built with --flags=tracing)")
<*> switch
( long "thunks"
<> help "Enable reporting of thunk tracing as well as regular evaluation")
<*> switch
( long "values"
<> help "Enable reporting of value provenance in error messages")
<*> optional (strOption
( long "reduce"
<> help "When done evaluating, output the evaluated part of the expression to FILE"))
<*> switch
( long "reduce-sets"
<> help "Reduce set members that aren't used; breaks if hasAttr is used")
<*> switch
( long "reduce-lists"
<> help "Reduce list members that aren't used; breaks if elemAt is used")
<*> switch
( long "parse"
<> help "Whether to parse the file (also the default right now)")
<*> switch
( long "parse-only"
<> help "Whether to parse only, no pretty printing or checking")
<*> switch
( long "find"
<> help "If selected, find paths within attr trees")
<*> optional (strOption
( long "find-file"
<> help "Look up the given files in Nix's search path"))
<*> switch
( long "strict"
<> help "When used with --eval, recursively evaluate list elements and attributes")
<*> switch
( long "force"
<> help "Whether to force the results of evaluation to normal form")
<*> switch
( long "eval"
<> help "Whether to evaluate, or just pretty-print")
<*> switch
( long "json"
<> help "Print the resulting value as an JSON representation")
<*> switch
( long "xml"
<> help "Print the resulting value as an XML representation")
<*> optional (strOption
( short 'A'
<> long "attr"
<> help "Select an attribute from the top-level Nix expression being evaluated"))
<*> many (strOption
( short 'I'
<> long "include"
<> help "Add a path to the Nix expression search path"))
<*> switch
( long "check"
<> help "Whether to check for syntax errors after parsing")
<*> optional (strOption
( long "read"
<> help "Read in an expression tree from a binary cache"))
<*> switch
( long "cache"
<> help "Write out the parsed expression tree to a binary cache")
<*> switch
( long "repl"
<> help "After performing any indicated actions, enter the REPL")
<*> switch
( long "ignore-errors"
<> help "Continue parsing files, even if there are errors")
<*> optional (strOption
( short 'E'
<> long "expr"
<> help "Expression to parse or evaluate"))
<*> many (argPair
( long "arg"
<> help "Argument to pass to an evaluated lambda"))
<*> many (argPair
( long "argstr"
<> help "Argument string to pass to an evaluated lambda"))
<*> optional (strOption
( short 'f'
<> long "file"
<> help "Parse all of the files given in FILE; - means stdin"))
<*> option (parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str)
( long "now"
<> value current
<> help "Set current time for testing purposes")
<*> many (strArgument (metavar "FILE" <> help "Path of file to parse"))
nixOptionsInfo :: UTCTime -> ParserInfo Options
nixOptionsInfo current =
info (helper <*> nixOptions current)
(fullDesc <> progDesc "" <> header "hnix")

29
src/Nix/Parser.hs
View file

@ -186,8 +186,7 @@ nixLet = annotateLocation1 (reserved "let"
<*> (reserved "in" *> nixToplevelForm)
-- Let expressions `let {..., body = ...}' are just desugared
-- into `(rec {..., body = ...}).body'.
letBody = (\x pos -> NSelect x (StaticKey "body" (Just pos) :| []) Nothing)
<$> aset <*> getPosition
letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
nixIf :: Parser NExprLoc
@ -223,7 +222,8 @@ nixUri = annotateLocation1 $ lexeme $ try $ do
_ <- string ":"
address <- some $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
return $ mkUriF $ pack $ start : protocol ++ ':' : address
return $ NStr $
DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address]
nixString :: Parser (NString NExprLoc)
nixString = lexeme (doubleQuoted <+> indented <?> "string")
@ -312,19 +312,24 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
nixBinders :: Parser [Binding NExprLoc]
nixBinders = (inherit <+> namedVar) `endBy` semi where
inherit = Inherit <$> (reserved "inherit" *> optional scope)
<*> many keyName
<?> "inherited binding"
namedVar = NamedVar <$> (annotated <$> nixSelector)
<*> (equals *> nixToplevelForm)
<?> "variable binding"
inherit = do
-- We can't use 'reserved' here because it would consume the whitespace
-- after the keyword, which is not exactly the semantics of C++ Nix.
try $ string "inherit" *> lookAhead (void (satisfy reservedEnd))
p <- getPosition
x <- whiteSpace *> optional scope
Inherit x <$> many keyName <*> pure p <?> "inherited binding"
namedVar = do
p <- getPosition
NamedVar <$> (annotated <$> nixSelector)
<*> (equals *> nixToplevelForm)
<*> pure p
<?> "variable binding"
scope = parens nixToplevelForm <?> "inherit scope"
keyName :: Parser (NKeyName NExprLoc)
keyName = dynamicKey <+> staticKey where
staticKey = do
beg <- getPosition
StaticKey <$> identifier <*> pure (Just beg)
staticKey = StaticKey <$> identifier
dynamicKey = DynamicKey <$> nixAntiquoted nixString
nixSet :: Parser NExprLoc

14
src/Nix/Pretty.hs
View file

@ -20,7 +20,7 @@ import qualified Data.HashSet as HashSet
import Data.List (isPrefixOf, sort)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Maybe (isJust, fromMaybe)
import Data.Text (pack, unpack, replace, strip)
import qualified Data.Text as Text
import Nix.Atoms
@ -138,17 +138,17 @@ prettyParamSet args var =
sep = align (comma <> space)
prettyBind :: Binding NixDoc -> Doc
prettyBind (NamedVar n v) =
prettyBind (NamedVar n v _p) =
prettySelector n <+> equals <+> withoutParens v <> semi
prettyBind (Inherit s ns)
prettyBind (Inherit s ns _p)
= text "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi
where scope = maybe empty ((<> space) . parens . withoutParens) s
prettyKeyName :: NKeyName NixDoc -> Doc
prettyKeyName (StaticKey "" _) = dquotes $ text ""
prettyKeyName (StaticKey key _)
prettyKeyName (StaticKey "") = dquotes $ text ""
prettyKeyName (StaticKey key)
| HashSet.member key reservedNames = dquotes $ text $ unpack key
prettyKeyName (StaticKey key _) = text . unpack $ key
prettyKeyName (StaticKey key) = text . unpack $ key
prettyKeyName (DynamicKey key) =
runAntiquoted (DoubleQuoted [Plain "\n"])
prettyString ((text "$" <>) . braces . withoutParens) key
@ -243,7 +243,7 @@ prettyNValueNF = prettyNix . valueToExpr
go (NVStrF ns) = NStr (DoubleQuoted [Plain (stringIntentionallyDropContext ns)])
go (NVListF l) = NList l
go (NVSetF s p) = NSet
[ NamedVar (StaticKey k (M.lookup k p) :| []) v
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s ]
go (NVClosureF _ _) = NSym . pack $ "<closure>"
go (NVPathF p) = NLiteralPath p

99
src/Nix/Reduce.hs
View file

@ -78,32 +78,30 @@ staticImport
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
staticImport pann path = do
mfile <- asks fst
path <- liftIO $ pathToDefaultNixFile path
path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
(maybe path (\p -> takeDirectory p </> path) mfile)
imports <- get
case M.lookup path imports of
case M.lookup path' imports of
Just expr -> pure expr
Nothing -> go
Nothing -> go path'
where
go = do
mfile <- asks fst
path <- liftIO $ pathToDefaultNixFile path
path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
(maybe path (\p -> takeDirectory p </> path) mfile)
go path = do
liftIO $ putStrLn $ "Importing file " ++ path
liftIO $ putStrLn $ "Importing file " ++ path'
eres <- liftIO $ parseNixFileLoc path'
eres <- liftIO $ parseNixFileLoc path
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success x -> do
let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
span = SrcSpan pos pos
cur = NamedVar
(StaticKey "__cur_file" (Just pos) :| [])
(Fix (NLiteralPath_ pann path'))
cur = NamedVar (StaticKey "__cur_file" :| [])
(Fix (NLiteralPath_ pann path)) pos
x' = Fix (NLet_ span [cur] x)
modify (M.insert path x')
local (const (Just path',
emptyScopes @m @NExprLoc)) $ do
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
x'' <- cata reduce x'
modify (M.insert path x'')
return x''
@ -126,10 +124,13 @@ reduce :: forall e m.
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
-- | Reduce the variable to its value if defined.
-- Leave it as it is otherwise.
reduce (NSym_ ann var) = lookupVar var <&> \case
Nothing -> Fix (NSym_ ann var)
Just v -> v
-- | Reduce binary and integer negation.
reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
(NNeg, Fix (NConstant_ cann (NInt n))) ->
return $ Fix $ NConstant_ cann (NInt (negate n))
@ -137,6 +138,12 @@ reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
return $ Fix $ NConstant_ cann (NBool (not b))
_ -> return $ Fix $ NUnary_ uann op x
-- | Reduce function applications.
--
-- * Reduce an import to the actual imported expression.
--
-- * Reduce a lambda function by adding its name to the local
-- scope and recursively reducing its body.
reduce (NBinary_ bann NApp fun arg) = fun >>= \case
f@(Fix (NSym_ _ "import")) -> arg >>= \case
-- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath
@ -149,6 +156,7 @@ reduce (NBinary_ bann NApp fun arg) = fun >>= \case
f -> Fix . NBinary_ bann NApp f <$> arg
-- | Reduce an integer addition to its result.
reduce (NBinary_ bann op larg rarg) = do
lval <- larg
rval <- rarg
@ -157,13 +165,44 @@ reduce (NBinary_ bann op larg rarg) = do
return $ Fix (NConstant_ ann (NInt (x + y)))
_ -> pure $ Fix $ NBinary_ bann op lval rval
-- reduce (NSelect aset attr alt) = do
-- | Reduce a select on a Set by substituing the set to the selected value.
--
-- Before applying this reduction, we need to ensure that:
--
-- 1. The selected expr is indeed a set.
-- 2. The selection AttrPath is a list of StaticKeys.
-- 3. The selected AttrPath exists in the set.
reduce base@(NSelect_ _ _ attrs _)
| sAttrPath $ NE.toList attrs = do
(NSelect_ _ aset attrs _) <- sequence base
inspectSet (unFix aset) attrs
| otherwise = sId
where
sId = Fix <$> sequence base
-- The selection AttrPath is composed of StaticKeys.
sAttrPath (StaticKey _:xs) = sAttrPath xs
sAttrPath [] = True
sAttrPath _ = False
-- Find appropriate bind in set's binds.
findBind [] _ = Nothing
findBind (x:xs) attrs@(a:|_) = case x of
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
Just (NamedVar _ e _) -> case NE.uncons attrs of
(_,Just attrs) -> inspectSet (unFix e) attrs
_ -> pure e
_ -> sId
inspectSet _ _ = sId
-- reduce (NHasAttr aset attr) =
-- | 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
let usesInherit = flip any binds $ \case
Inherit _ _ -> True
Inherit {} -> True
_ -> False
if usesInherit
then clearScopes @NExprLoc $
@ -180,9 +219,11 @@ reduce (NRecSet_ ann binds) =
reduce (NWith_ ann scope body) =
clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body
-- | Reduce a let binds section by pushing lambdas,
-- constants and strings to the body scope.
reduce (NLet_ ann binds body) = do
s <- fmap (M.fromList . catMaybes) $ forM binds $ \case
NamedVar (StaticKey name _ :| []) def -> def >>= \case
NamedVar (StaticKey name :| []) def _pos -> def >>= \case
d@(Fix NAbs_ {}) -> pure $ Just (name, d)
d@(Fix NConstant_ {}) -> pure $ Just (name, d)
d@(Fix NStr_ {}) -> pure $ Just (name, d)
@ -204,10 +245,14 @@ reduce (NLet_ ann binds body) = do
-- go (M.insert name v m) xs
-- _ -> go m xs
-- | Reduce an if to the relevant path if
-- the condition is a boolean constant.
reduce e@(NIf_ _ b t f) = b >>= \case
Fix (NConstant_ _ (NBool b')) -> if b' then t else f
_ -> Fix <$> sequence e
-- | Reduce an assert atom to its encapsulated
-- symbol if the assertion is a boolean constant.
reduce e@(NAssert_ _ b body) = b >>= \case
Fix (NConstant_ _ (NBool b')) | b' -> body
_ -> Fix <$> sequence e
@ -325,10 +370,10 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k)
pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (StaticKey n p) = StaticKey n p
pruneKeyName (StaticKey n) = StaticKey n
pruneKeyName (DynamicKey k)
| Just k' <- pruneAntiquoted k = DynamicKey k'
| otherwise = StaticKey "<unused?>" Nothing
| otherwise = StaticKey "<unused?>"
pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param n) = Param n
@ -340,13 +385,13 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n
pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar _ Nothing) = Nothing
pruneBinding (NamedVar xs (Just x)) =
Just (NamedVar (NE.map pruneKeyName xs) x)
pruneBinding (Inherit _ []) = Nothing
pruneBinding (Inherit (join -> Nothing) _) = Nothing
pruneBinding (Inherit (join -> m) xs) =
Just (Inherit m (map pruneKeyName xs))
pruneBinding (NamedVar _ Nothing _) = Nothing
pruneBinding (NamedVar xs (Just x) pos) =
Just (NamedVar (NE.map pruneKeyName xs) x pos)
pruneBinding (Inherit _ [] _) = Nothing
pruneBinding (Inherit (join -> Nothing) _ _) = Nothing
pruneBinding (Inherit (join -> m) xs pos) =
Just (Inherit m (map pruneKeyName xs) pos)
reducingEvalExpr
:: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)

50
src/Nix/TH.hs
View file

@ -1,36 +1,74 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
module Nix.TH where
import Data.Fix
import Data.Foldable
import Data.Generics.Aliases
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Nix.Atoms
import Nix.Expr
import Nix.Parser
quoteExprExp :: String -> ExpQ
quoteExprExp s = do
expr <- case parseNixText (Text.pack s) of
expr <- case parseNixTextLoc (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
freeVars :: NExpr -> Set VarName
freeVars = error "NYI: Implement an evaluator to find free variables"
quoteExprPat :: String -> PatQ
quoteExprPat s = do
expr <- case parseNixTextLoc (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
metaExp :: Set VarName -> NExpr -> Maybe ExpQ
metaExp fvs (Fix (NSym x)) | x `Set.member` fvs =
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
freeVars :: NExprLoc -> Set VarName
freeVars = cata $ \case
NSym_ _ var -> Set.singleton var
Compose (Ann _ x) -> fold x
class ToExpr a where
toExpr :: a -> NExprLoc
instance ToExpr NExprLoc where
toExpr = id
instance ToExpr VarName where
toExpr = Fix . NSym_ nullSpan
instance ToExpr Int where
toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
instance ToExpr Integer where
toExpr = Fix . NConstant_ nullSpan . NInt
instance ToExpr Float where
toExpr = Fix . NConstant_ nullSpan . NFloat
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
metaExp _ _ = Nothing
metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just (varP (mkName (Text.unpack x)))
metaPat _ _ = Nothing
nix :: QuasiQuoter
nix = QuasiQuoter
{ quoteExp = quoteExprExp
, quotePat = quoteExprPat
}

9
src/Nix/Value.hs
View file

@ -173,7 +173,7 @@ instance Eq (NValue m) where
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
NVConstant (NInt x) == NVConstant (NInt y) = x == y
NVConstant (NFloat x) == NVConstant (NFloat y) = x == y
NVStr x == NVStr y = x == y
NVStr x == NVStr y = stringIntentionallyDropContext x == stringIntentionallyDropContext y
NVPath x == NVPath y = x == y
_ == _ = False
@ -182,7 +182,7 @@ instance Ord (NValue m) where
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y
NVStr x <= NVStr y = x < y
NVStr x <= NVStr y = stringIntentionallyDropContext x < stringIntentionallyDropContext y
NVPath x <= NVPath y = x < y
_ <= _ = False
@ -244,8 +244,6 @@ isDerivation m = case M.lookup "type" m of
valueEq :: MonadThunk (NValue m) (NThunk m) m
=> NValue m -> NValue m -> m Bool
valueEq l r = case (l, r) of
(NVStr ns, NVConstant (NUri ru)) -> pure (stringNoContext ns == Just ru)
(NVConstant (NUri lu), NVStr ns) -> pure (Just lu == stringNoContext ns)
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
(NVStr ls, NVStr rs) -> pure (ls == rs)
(NVStr ns, NVConstant NNull) -> pure (stringNoContext ns == Just "")
@ -267,7 +265,6 @@ data ValueType
= TInt
| TFloat
| TBool
| TUri
| TNull
| TString
| TList
@ -283,7 +280,6 @@ valueType = \case
NInt _ -> TInt
NFloat _ -> TFloat
NBool _ -> TBool
NUri _ -> TUri
NNull -> TNull
NVStrF {} -> TString
NVListF {} -> TList
@ -297,7 +293,6 @@ describeValue = \case
TInt -> "an integer"
TFloat -> "a float"
TBool -> "a boolean"
TUri -> "a URI"
TNull -> "a null"
TString -> "a string"
TList -> "a list"

1
src/Nix/XML.hs
View file

@ -25,7 +25,6 @@ toXML = (.) ((++ "\n") .
NFloat f -> mkElem "float" "value" (show f)
NBool b -> mkElem "bool" "value" (if b then "true" else "false")
NNull -> Element (unqual "null") [] [] Nothing
NUri u -> mkElem "uri" "value" (Text.unpack u)
NVStrF ns -> mkElem "string" "value" (Text.unpack $ stringIntentionallyDropContext ns)
NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing

2
tests/EvalTests.hs
View file

@ -297,7 +297,7 @@ genEvalCompareTests = do
instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
NVConstantF x == NVConstantF y = x == y
NVStrF ls == NVStrF rs = ls == rs
NVStrF ls == NVStrF rs = stringIntentionallyDropContext ls == stringIntentionallyDropContext rs
NVListF x == NVListF y = and (zipWith (==) x y)
NVSetF x _ == NVSetF y _ =
M.keys x == M.keys y &&