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

Reformat all sources with Brittany, to restore consistency

This commit is contained in:
John Wiegley 2019-03-17 14:47:38 -07:00
parent 8cfb965e99
commit 94e0be3882
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
50 changed files with 6250 additions and 5221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
benchmarks/Main.hs
View File

@ -5,6 +5,4 @@ import Criterion.Main
import qualified ParserBench
main :: IO ()
main = defaultMain
[ ParserBench.benchmarks
]
main = defaultMain [ParserBench.benchmarks]

3
benchmarks/ParserBench.hs
View File

@ -9,7 +9,8 @@ benchFile :: FilePath -> Benchmark
benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++)
benchmarks :: Benchmark
benchmarks = bgroup "Parser"
benchmarks = bgroup
"Parser"
[ benchFile "nixpkgs-all-packages.nix"
, benchFile "nixpkgs-all-packages-pretty.nix"
, benchFile "let-comments.nix"

141
main/Main.hs
View File

@ -55,19 +55,16 @@ main = do
Nothing -> case expression opts of
Just s -> handleResult opts Nothing (parseNixTextLoc s)
Nothing -> case fromFile opts of
Just "-" ->
mapM_ (processFile opts)
=<< (lines <$> liftIO getContents)
Just "-" -> mapM_ (processFile opts) =<< (lines <$> liftIO getContents)
Just path ->
mapM_ (processFile opts)
=<< (lines <$> liftIO (readFile path))
mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path))
Nothing -> case filePaths opts of
[] -> withNixContext Nothing $ Repl.main
["-"] ->
handleResult opts Nothing . parseNixTextLoc
handleResult opts Nothing
. parseNixTextLoc
=<< liftIO Text.getContents
paths ->
mapM_ (processFile opts) paths
paths -> mapM_ (processFile opts) paths
where
processFile opts path = do
eres <- parseNixFileLoc path
@ -77,90 +74,88 @@ main = do
Failure err ->
(if ignoreErrors opts
then liftIO . hPutStrLn stderr
else errorWithoutStackTrace) $ "Parse failed: " ++ show err
else errorWithoutStackTrace
)
$ "Parse failed: "
++ show err
Success expr -> do
when (check opts) $ do
expr' <- liftIO (reduceExpr mpath expr)
case HM.inferTop Env.empty [("it", stripAnnotation expr')] of
Left err ->
errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
Right ty ->
liftIO $ putStrLn $ "Type of expression: "
++ PS.ppShow (fromJust (Map.lookup "it" (Env.types ty)))
Left err -> errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
Right ty -> liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow
(fromJust (Map.lookup "it" (Env.types ty)))
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (process opts mpath expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
errorWithoutStackTrace
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
when (repl opts) $
withNixContext Nothing $ Repl.main
when (repl opts) $ withNixContext Nothing $ Repl.main
process opts mpath expr
| evaluate opts, tracing opts =
evaluateExpression mpath
Nix.nixTracingEvalExprLoc printer expr
| evaluate opts, Just path <- reduce opts =
evaluateExpression mpath (reduction path) printer expr
| evaluate opts, not (null (arg opts) && null (argstr opts)) =
evaluateExpression mpath
Nix.nixEvalExprLoc printer expr
| evaluate opts =
processResult printer =<< Nix.nixEvalExprLoc mpath expr
| xml opts =
error "Rendering expression trees to XML is not yet implemented"
| json opts =
liftIO $ TL.putStrLn $
A.encodeToLazyText (stripAnnotation expr)
| verbose opts >= DebugInfo =
liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
| cache opts, Just path <- mpath =
liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
| parseOnly opts =
void $ liftIO $ Exc.evaluate $ Deep.force expr
| otherwise =
liftIO $ renderIO stdout
| evaluate opts
, tracing opts
= evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr
| evaluate opts
, Just path <- reduce opts
= evaluateExpression mpath (reduction path) printer expr
| evaluate opts
, not (null (arg opts) && null (argstr opts))
= evaluateExpression mpath Nix.nixEvalExprLoc printer expr
| evaluate opts
= processResult printer =<< Nix.nixEvalExprLoc mpath expr
| xml opts
= error "Rendering expression trees to XML is not yet implemented"
| json opts
= liftIO $ TL.putStrLn $ A.encodeToLazyText (stripAnnotation expr)
| verbose opts >= DebugInfo
= liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
| cache opts
, Just path <- mpath
= liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
| parseOnly opts
= void $ liftIO $ Exc.evaluate $ Deep.force expr
| otherwise
= liftIO
$ renderIO stdout
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
. prettyNix
. stripAnnotation $ expr
. stripAnnotation
$ expr
where
printer
| finder opts =
fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
| xml opts =
liftIO . putStrLn
| finder opts
= fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
| xml opts
= liftIO
. putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts =
liftIO . Text.putStrLn
| json opts
= liftIO
. Text.putStrLn
. principledStringIgnoreContext
<=< nvalueToJSONNixString
| strict opts =
liftIO . print . prettyNValueNF <=< normalForm
| values opts =
liftIO . print <=< prettyNValueProv
| otherwise =
liftIO . print <=< prettyNValue
| strict opts
= liftIO . print . prettyNValueNF <=< normalForm
| values opts
= liftIO . print <=< prettyNValueProv
| otherwise
= liftIO . print <=< prettyNValue
where
findAttrs = go ""
where
go prefix s = do
xs <- forM (sortOn fst (M.toList s))
xs <-
forM (sortOn fst (M.toList s))
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
@ -180,8 +175,7 @@ main = do
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ ->
go (path ++ ".") s'
NVSet s' _ -> go (path ++ ".") s'
_ -> return ()
where
filterEntry path k = case (path, k) of
@ -201,21 +195,24 @@ main = do
(_ , "drvAttrs" ) -> (False, False)
_ -> (True, True)
forceEntry k v = catch (Just <$> force v pure)
$ \(NixException frames) -> do
liftIO . putStrLn
forceEntry k v =
catch (Just <$> force v pure) $ \(NixException frames) -> do
liftIO
. putStrLn
. ("Exception forcing " ++)
. (k ++)
. (": " ++) . show
. (": " ++)
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
return Nothing
reduction path mp x = do
eres <- Nix.withNixContext mp $
Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
eres <- Nix.withNixContext mp
$ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
handleReduced path eres
handleReduced :: (MonadThrow m, MonadIO m)
handleReduced
:: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)

96
main/Repl.hs
View File

@ -22,7 +22,9 @@
module Repl where
import Nix hiding (exec, try)
import Nix hiding ( exec
, try
)
import Nix.Builtins ( MonadBuiltins )
import Nix.Cited
import Nix.Convert
@ -34,10 +36,14 @@ import Nix.Utils
import Control.Comonad
import qualified Data.HashMap.Lazy as M
import Data.List (isPrefixOf, foldl')
import Data.List ( isPrefixOf
, foldl'
)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (unpack, pack)
import Data.Text ( unpack
, pack
)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Version ( showVersion )
@ -55,15 +61,20 @@ import System.Exit
main :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => m ()
main = flip evalStateT initState $
main = flip evalStateT initState
#if MIN_VERSION_repline(0, 2, 0)
evalRepl (return prefix) cmd options (Just ':') completer welcomeText
$ evalRepl (return prefix) cmd options (Just ':') completer welcomeText
#else
evalRepl prefix cmd options completer welcomeText
$ evalRepl prefix cmd options completer welcomeText
#endif
where
prefix = "hnix> "
welcomeText = liftIO $ putStrLn $ "Welcome to hnix " <> showVersion version <> ". For help type :help\n"
welcomeText =
liftIO
$ putStrLn
$ "Welcome to hnix "
<> showVersion version
<> ". For help type :help\n"
-------------------------------------------------------------------------------
-- Types
@ -87,8 +98,12 @@ hoistErr (Failure err) = do
-- Execution
-------------------------------------------------------------------------------
exec :: forall e t f m. (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> Bool -> Text.Text -> Repl e t f m (NValue t f m)
exec
:: forall e t f m
. (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> Bool
-> Text.Text
-> Repl e t f m (NValue t f m)
exec update source = do
-- Get the current interpreter state
st <- get
@ -105,29 +120,28 @@ exec update source = do
case mVal of
Left (NixException frames) -> do
lift $ lift $ liftIO . print
=<< renderFrames @(NValue t f m) @t frames
lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames
abort
Right val -> do
-- Update the interpreter state
when update $ do
-- Create the new environment
put st { tmctx = tmctx st -- TODO: M.insert key val (tmctx st)
}
put st { tmctx = tmctx st } -- TODO: M.insert key val (tmctx st)
return val
cmd :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => String -> Repl e t f m ()
cmd
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> String
-> Repl e t f m ()
cmd source = do
val <- exec True (Text.pack source)
lift $ lift $ do
opts :: Nix.Options <- asks (view hasLens)
if | strict opts ->
liftIO . print . prettyNValueNF =<< normalForm val
| values opts ->
liftIO . print =<< prettyNValueProv val
| otherwise ->
liftIO . print =<< prettyNValue val
if
| strict opts -> liftIO . print . prettyNValueNF =<< normalForm val
| values opts -> liftIO . print =<< prettyNValueProv val
| otherwise -> liftIO . print =<< prettyNValue val
-------------------------------------------------------------------------------
-- Commands
-------------------------------------------------------------------------------
@ -140,21 +154,26 @@ browse _ = do
-- liftIO $ mapM_ putStrLn $ ppenv (tyctx st)
-- :load command
load :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => [String] -> Repl e t f m ()
load
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [String]
-> Repl e t f m ()
load args = do
contents <- liftIO $ Text.readFile (unwords args)
void $ exec True contents
-- :type command
typeof :: (MonadBuiltins e t f m, MonadException m, MonadIO m) => [String] -> Repl e t f m ()
typeof
:: (MonadBuiltins e t f m, MonadException m, MonadIO m)
=> [String]
-> Repl e t f m ()
typeof args = do
st <- get
val <- case M.lookup line (tmctx st) of
Just val -> return val
Nothing -> exec False line
liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val
where
line = Text.pack (unwords args)
where line = Text.pack (unwords args)
-- :quit command
quit :: (MonadBuiltins e t f m, MonadIO m) => a -> Repl e t f m ()
@ -166,8 +185,8 @@ quit _ = liftIO exitSuccess
-- Prefix tab completer
defaultMatcher :: MonadIO m => [(String, CompletionFunc m)]
defaultMatcher = [
(":load" , fileCompleter)
defaultMatcher =
[(":load", fileCompleter)
--, (":type" , values)
]
@ -177,24 +196,35 @@ comp n = do
let cmds = [":load", ":type", ":browse", ":quit"]
-- Env.TypeEnv ctx <- gets tyctx
-- let defs = map unpack $ Map.keys ctx
return $ filter (isPrefixOf n) (cmds {-++ defs-})
return $ filter (isPrefixOf n) (cmds {-++ defs-}
)
options :: (MonadBuiltins e t f m, MonadIO m, MonadException m)
options
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [(String, [String] -> Repl e t f m ())]
options = [
("load" , load)
options =
[ ( "load"
, load
)
--, ("browse" , browse)
, ("quit", quit)
, ("type", typeof)
, ("help", help)
]
help :: forall e t f m . (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [String] -> Repl e t f m ()
help
:: forall e t f m
. (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [String]
-> Repl e t f m ()
help _ = liftIO $ do
putStrLn "Available commands:\n"
mapM_ putStrLn $ map (\o -> ":" ++ (fst o)) (options @e @t @f @m)
completer :: (MonadBuiltins e t f m, MonadIO m)
completer
:: (MonadBuiltins e t f m, MonadIO m)
=> CompleterStyle (StateT (IState t f m) m)
completer = Prefix (wordCompleter comp) defaultMatcher

115
src/Nix.hs
View File

@ -4,23 +4,29 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Nix (module Nix.Cache,
module Nix.Exec,
module Nix.Expr,
module Nix.Frames,
module Nix.Render.Frame,
module Nix.Normal,
module Nix.Options,
module Nix.String,
module Nix.Parser,
module Nix.Pretty,
module Nix.Reduce,
module Nix.Thunk,
module Nix.Value,
module Nix.XML,
withNixContext,
nixEvalExpr, nixEvalExprLoc, nixTracingEvalExprLoc,
evaluateExpression, processResult) where
module Nix
( module Nix.Cache
, module Nix.Exec
, module Nix.Expr
, module Nix.Frames
, module Nix.Render.Frame
, module Nix.Normal
, module Nix.Options
, module Nix.String
, module Nix.Parser
, module Nix.Pretty
, module Nix.Reduce
, module Nix.Thunk
, module Nix.Value
, module Nix.XML
, withNixContext
, nixEvalExpr
, nixEvalExprLoc
, nixTracingEvalExprLoc
, evaluateExpression
, processResult
)
where
import Control.Applicative
import Control.Arrow ( second )
@ -50,20 +56,33 @@ import Nix.XML
-- | This is the entry point for all evaluations, whatever the expression tree
-- type. It sets up the common Nix environment and applies the
-- transformations, allowing them to be easily composed.
nixEval :: (MonadBuiltins e t f m, Has e Options, Functor g)
=> Maybe FilePath -> Transform g (m a) -> Alg g (m a) -> Fix g -> m a
nixEval
:: (MonadBuiltins e t f m, Has e Options, Functor g)
=> Maybe FilePath
-> Transform g (m a)
-> Alg g (m a)
-> Fix g
-> m a
nixEval mpath xform alg = withNixContext mpath . adi alg xform
-- | Evaluate a nix expression in the default context
nixEvalExpr :: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath -> NExpr -> m (NValue t f m)
nixEvalExpr
:: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> NExpr
-> m (NValue t f m)
nixEvalExpr mpath = nixEval mpath id Eval.eval
-- | Evaluate a nix expression in the default context
nixEvalExprLoc :: forall e t f m. (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
nixEvalExprLoc mpath =
nixEval mpath (Eval.addStackFrames @t . Eval.addSourcePositions)
nixEvalExprLoc
:: forall e t f m
. (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> NExprLoc
-> m (NValue t f m)
nixEvalExprLoc mpath = nixEval
mpath
(Eval.addStackFrames @t . Eval.addSourcePositions)
(Eval.eval . annotated . getCompose)
-- | Evaluate a nix expression with tracing in the default context. Note that
@ -73,7 +92,9 @@ nixEvalExprLoc mpath =
-- context.
nixTracingEvalExprLoc
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
=> Maybe FilePath
-> NExprLoc
-> m (NValue t f m)
nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
evaluateExpression
@ -85,9 +106,9 @@ evaluateExpression
-> m a
evaluateExpression mpath evaluator handler expr = do
opts :: Options <- asks (view hasLens)
args <- traverse (traverse eval') $
map (second parseArg) (arg opts) ++
map (second mkStr) (argstr opts)
args <- traverse (traverse eval') $ map (second parseArg) (arg opts) ++ map
(second mkStr)
(argstr opts)
compute evaluator expr (argmap args) handler
where
parseArg s = case parseNixText s of
@ -97,8 +118,7 @@ evaluateExpression mpath evaluator handler expr = do
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = pure $ nvSet (M.fromList args') mempty
where
args' = map (fmap (wrapValue . nValueFromNF)) args
where args' = map (fmap (wrapValue . nValueFromNF)) args
compute ev x args p = do
f :: NValue t f m <- ev mpath x
@ -106,8 +126,12 @@ evaluateExpression mpath evaluator handler expr = do
NVClosure _ g -> force ?? pure =<< g args
_ -> pure f
processResult :: forall e t f m a. (MonadNix e t f m, Has e Options)
=> (NValue t f m -> m a) -> NValue t f m -> m a
processResult
:: forall e t f m a
. (MonadNix e t f m, Has e Options)
=> (NValue t f m -> m a)
-> NValue t f m
-> m a
processResult h val = do
opts :: Options <- asks (view hasLens)
case attr opts of
@ -120,18 +144,25 @@ processResult h val = do
NVList xs -> case ks of
[] -> force @t @m @(NValue t f m) (xs !! n) h
_ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $
"Expected a list for selector '" ++ show n
++ "', but got: " ++ show v
_ ->
errorWithoutStackTrace
$ "Expected a list for selector '"
++ show n
++ "', but got: "
++ show v
go (k : ks) v = case v of
NVSet xs _ -> case M.lookup k xs of
Nothing ->
errorWithoutStackTrace $
"Set does not contain key '"
++ Text.unpack k ++ "'"
errorWithoutStackTrace
$ "Set does not contain key '"
++ Text.unpack k
++ "'"
Just v' -> case ks of
[] -> force v' h
_ -> force v' (go ks)
_ -> errorWithoutStackTrace $
"Expected a set for selector '" ++ Text.unpack k
++ "', but got: " ++ show v
_ ->
errorWithoutStackTrace
$ "Expected a set for selector '"
++ Text.unpack k
++ "', but got: "
++ show v

12
src/Nix/Atoms.hs
View File

@ -12,7 +12,9 @@ import Codec.Serialise
import Control.DeepSeq
import Data.Data
import Data.Hashable
import Data.Text (Text, pack)
import Data.Text ( Text
, pack
)
import GHC.Generics
-- | Atoms are values that evaluate to themselves. This means that
@ -41,3 +43,11 @@ atomText (NInt i) = pack (show i)
atomText (NFloat f) = pack (show f)
atomText (NBool b) = if b then "true" else "false"
atomText NNull = "null"

1001
src/Nix/Builtins.hs
View File

File diff suppressed because it is too large Load Diff

1
src/Nix/Cited.hs
View File

@ -40,7 +40,6 @@ data NCited t f m a = NCited
instance Applicative (NCited t f m) where
pure = NCited []
-- jww (2019-03-11): ??
NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)
instance Comonad (NCited t f m) where

4
src/Nix/Context.hs
View File

@ -8,7 +8,9 @@ import Nix.Options
import Nix.Scope
import Nix.Frames
import Nix.Utils
import Nix.Expr.Types.Annotated (SrcSpan, nullSpan)
import Nix.Expr.Types.Annotated ( SrcSpan
, nullSpan
)
data Context m t = Context
{ scopes :: Scopes m t

37
src/Nix/Convert.hs
View File

@ -33,7 +33,9 @@ import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Text ( Text )
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text.Encoding ( encodeUtf8
, decodeUtf8
)
import Nix.Atoms
import Nix.Effects
import Nix.Expr.Types
@ -60,8 +62,8 @@ class FromValue a m v where
fromValue :: v -> m a
fromValueMay :: v -> m (Maybe a)
type Convertible e t f m =
(Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
type Convertible e t f m
= (Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
instance Convertible e t f m => FromValue () m (NValueNF t f m) where
fromValueMay = \case
@ -150,8 +152,11 @@ instance (Convertible e t f m, MonadEffects t f m)
fromValueMay = \case
NVStrNF ns -> pure $ Just ns
NVPathNF p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
@ -165,8 +170,11 @@ instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
fromValueMay = \case
NVStr ns -> pure $ Just ns
NVPath p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
@ -345,7 +353,8 @@ instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
let pos = M.fromList
[ ("file" :: Text, wrapValue f')
, ("line" , wrapValue l')
, ("column", wrapValue c') ]
, ("column" , wrapValue c')
]
pure $ nvSet pos mempty
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
@ -376,8 +385,8 @@ instance Convertible e t f m => ToValue Bool m (NExprF r) where
instance Convertible e t f m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
whileForcingThunk :: forall t f m s e r. (Exception s, Convertible e t f m)
=> s -> m r -> m r
whileForcingThunk
:: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
whileForcingThunk frame =
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
@ -450,15 +459,15 @@ instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix [a] m (NValue t f m) where
toNix = fmap nvList . traverse (thunk . go)
where
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
<=< toNix
go =
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
instance (Convertible e t f m, ToNix a m (NValue t f m))
=> ToNix (HashMap Text a) m (NValue t f m) where
toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)
where
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
<=< toNix
go =
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
instance Convertible e t f m => ToNix () m (NValueNF t f m) where
instance Convertible e t f m => ToNix () m (NValue t f m) where

94
src/Nix/Effects.hs
View File

@ -10,7 +10,10 @@
module Nix.Effects where
import Prelude hiding (putStr, putStrLn, print)
import Prelude hiding ( putStr
, putStrLn
, print
)
import qualified Prelude
import Control.Monad.Trans
@ -83,21 +86,30 @@ instance MonadExec IO where
exec' = \case
[] -> return $ Left $ ErrorCall "exec: missing program"
(prog : args) -> do
(exitCode, out, _) <-
liftIO $ readProcessWithExitCode prog args ""
(exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args ""
let t = T.strip (T.pack out)
let emsg = "program[" ++ prog ++ "] args=" ++ show args
case exitCode of
ExitSuccess ->
if T.null t
ExitSuccess -> if T.null t
then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg
else case parseNixTextLoc t of
Failure err ->
return $ Left $ ErrorCall $
"Error parsing output of exec: " ++ show err ++ " " ++ emsg
return
$ Left
$ ErrorCall
$ "Error parsing output of exec: "
++ show err
++ " "
++ emsg
Success v -> return $ Right v
err -> return $ Left $ ErrorCall $
"exec failed: " ++ show err ++ " " ++ emsg
err ->
return
$ Left
$ ErrorCall
$ "exec failed: "
++ show err
++ " "
++ emsg
class Monad m => MonadInstantiate m where
instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
@ -106,20 +118,28 @@ class Monad m => MonadInstantiate m where
instance MonadInstantiate IO where
instantiateExpr expr = do
traceM $ "Executing: "
++ show ["nix-instantiate", "--eval", "--expr ", expr]
(exitCode, out, err) <-
readProcessWithExitCode "nix-instantiate"
[ "--eval", "--expr", expr] ""
traceM $ "Executing: " ++ show
["nix-instantiate", "--eval", "--expr ", expr]
(exitCode, out, err) <- readProcessWithExitCode "nix-instantiate"
["--eval", "--expr", expr]
""
case exitCode of
ExitSuccess -> case parseNixTextLoc (T.pack out) of
Failure e ->
return $ Left $ ErrorCall $
"Error parsing output of nix-instantiate: " ++ show e
return
$ Left
$ ErrorCall
$ "Error parsing output of nix-instantiate: "
++ show e
Success v -> return $ Right v
status ->
return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
return
$ Left
$ ErrorCall
$ "nix-instantiate failed: "
++ show status
++ ": "
++ err
pathExists :: MonadFile m => FilePath -> m Bool
pathExists = doesFileExist
@ -155,20 +175,28 @@ instance MonadHttp IO where
let urlstr = T.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr
req <- parseRequest urlstr
manager <-
if secure req
manager <- if secure req
then newTlsManager
else newManager defaultManagerSettings
-- print req
response <- httpLbs (req { method = "GET" }) manager
let status = statusCode (responseStatus response)
if status /= 200
then return $ Left $ ErrorCall $
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
then
return
$ Left
$ ErrorCall
$ "fail, got "
++ show status
++ " when fetching url:"
++ urlstr
else -- do
-- let bstr = responseBody response
return $ Left $ ErrorCall $
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
return
$ Left
$ ErrorCall
$ "success in downloading but hnix-store is not yet ready; url = "
++ urlstr
class Monad m => MonadPutStr m where
@ -196,14 +224,17 @@ class Monad m => MonadStore m where
instance MonadStore IO where
addPath' path = do
(exitCode, out, _) <-
readProcessWithExitCode "nix-store" ["--add", path] ""
(exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] ""
case exitCode of
ExitSuccess -> do
let dropTrailingLinefeed p = take (length p - 1) p
return $ Right $ StorePath $ dropTrailingLinefeed out
_ -> return $ Left $ ErrorCall $
"addPath: failed: nix-store --add " ++ show path
_ ->
return
$ Left
$ ErrorCall
$ "addPath: failed: nix-store --add "
++ show path
--TODO: Use a temp directory so we don't overwrite anything important
toFile_' filepath content = do
@ -217,3 +248,10 @@ addPath p = either throwError return =<< addPath' p
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ p contents = either throwError return =<< toFile_' p contents

233
src/Nix/Eval.hs
View File

@ -25,7 +25,9 @@ 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.Maybe ( fromMaybe
, catMaybes
)
import Data.Text ( Text )
import Data.These ( These(..) )
import Data.Traversable ( for )
@ -77,16 +79,17 @@ class (Show v, Monad m) => MonadEval v m where
-}
evalError :: Exception s => s -> m a
type MonadNixEval v t m =
(MonadEval v m,
Scoped t m,
MonadThunk t m v,
MonadFix m,
ToValue Bool m v,
ToValue [t] m v,
FromValue NixString m v,
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
type MonadNixEval v t m
= ( MonadEval v m
, Scoped t m
, MonadThunk t m v
, MonadFix m
, ToValue Bool m v
, ToValue [t] m v
, FromValue NixString m v
, ToValue (AttrSet t, AttrSet SourcePos) m v
, FromValue (AttrSet t, AttrSet SourcePos) m v
)
data EvalFrame m t
= EvaluatingExpr (Scopes m t) NExprLoc
@ -108,8 +111,8 @@ eval :: forall v t m. MonadNixEval v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var) =
(lookupVar var :: m (Maybe t)) >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NSym var ) = (lookupVar var :: m (Maybe t))
>>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x ) = evalConstant x
eval (NStr str ) = evalString str
@ -124,8 +127,7 @@ eval (NBinary NApp fun arg) = do
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id
where
go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
where go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
@ -169,10 +171,15 @@ evalWithAttrSet aset body = do
-- its value is only computed once.
scope <- currentScopes :: m (Scopes m t)
s <- thunk @t @m @v $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
pushWeakScope
?? body
$ force s
$ fmap fst
. fromValue @(AttrSet t, AttrSet SourcePos)
attrSetAlter :: forall v t m. MonadNixEval v t m
attrSetAlter
:: forall v t m
. MonadNixEval v t m
=> [Text]
-> SourcePos
-> AttrSet (m v)
@ -185,23 +192,34 @@ attrSetAlter [] _ _ _ _ =
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
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)
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
( M.insert k (toValue @(AttrSet t, AttrSet SourcePos)
=<< (, mempty) . fmap wrapValue <$> sequence st') st
, M.insert k pos sp )
( M.insert
k
( toValue @(AttrSet t, AttrSet SourcePos)
=<< (, mempty)
. fmap wrapValue
<$> sequence st'
)
st
, M.insert k pos sp
)
desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r]
desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
where
collect :: Binding r
-> State (HashMap VarName (SourcePos, [Binding r]))
collect
:: Binding r
-> State
(HashMap VarName (SourcePos, [Binding r]))
(Either VarName (Binding r))
collect (NamedVar (StaticKey x :| y : ys) val p) = do
m <- get
@ -211,19 +229,19 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
pure $ Left x
collect x = pure $ Right x
go :: Either VarName (Binding r)
-> State (HashMap VarName (SourcePos, [Binding r]))
(Binding r)
go
:: Either VarName (Binding r)
-> State (HashMap VarName (SourcePos, [Binding r])) (Binding r)
go (Right x) = pure x
go (Left x) = do
maybeValue <- gets (M.lookup x)
case maybeValue of
Nothing ->
fail ("No binding " ++ show x)
Just (p, v) ->
pure $ NamedVar (StaticKey x :| []) (embed v) p
Nothing -> fail ("No binding " ++ show x)
Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds :: forall v t m. MonadNixEval v t m
evalBinds
:: forall v t m
. MonadNixEval v t m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
@ -231,17 +249,18 @@ evalBinds recursive binds = do
scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) .
partition (\case
moveOverridesLast = uncurry (++) . partition
(\case
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
_ -> True)
_ -> True
)
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
finalValue >>= fromValue >>= \(o', p') ->
-- jww (2018-05-09): What to do with the key position here?
return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'),
force @t @m @v v pure))
return $ map
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure))
(M.toList o')
go _ (NamedVar pathExpr finalValue pos) = do
@ -249,9 +268,11 @@ evalBinds recursive binds = do
go = \case
h :| t -> evalSetterKeyName h >>= \case
Nothing ->
pure ([], nullPos,
toValue @(AttrSet t, AttrSet SourcePos)
(mempty, mempty))
pure
( []
, nullPos
, toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)
)
Just k -> case t of
[] -> pure ([k], pos, finalValue)
x : xs -> do
@ -263,28 +284,30 @@ evalBinds recursive binds = do
([], _, _) -> []
result -> [result]
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
evalSetterKeyName >=> \case
go scope (Inherit ms names pos) =
fmap catMaybes $ forM names $ evalSetterKeyName >=> \case
Nothing -> pure Nothing
Just key -> pure $ Just ([key], pos, do
Just key -> pure $ Just
( [key]
, pos
, do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s -> s
>>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(s, _) ->
Just s ->
s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> attrMissing (key :| []) Nothing
Just v -> force v pure)
Just v -> force v pure
)
buildResult :: Scopes m t
buildResult
:: Scopes m t
-> [([Text], SourcePos, m v)]
-> m (AttrSet t, AttrSet SourcePos)
buildResult scope bindings = do
(s, p) <- foldM insert (M.empty, M.empty) bindings
res <- if recursive
then loebM (encapsulate <$> s)
else traverse mkThunk s
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
return (res, p)
where
mkThunk = thunk . withScopes scope
@ -293,7 +316,9 @@ evalBinds recursive binds = do
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall v t m. MonadNixEval v t m
evalSelect
:: forall v t m
. MonadNixEval v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
@ -312,82 +337,106 @@ evalSelect aset attr = do
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
evalGetterKeyName :: forall v m. (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v) -> m Text
evalGetterKeyName
:: forall v m
. (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v)
-> m Text
evalGetterKeyName = evalSetterKeyName >=> \case
Just k -> pure k
Nothing -> evalError @v $ ErrorCall "value is null while a string was expected"
Nothing ->
evalError @v $ ErrorCall "value is null while a string was expected"
-- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName
:: (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v)
-> m (Maybe Text)
evalSetterKeyName = \case
StaticKey k -> pure (Just k)
DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
\case Just ns -> Just (hackyStringIgnoreContext ns)
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case
Just ns -> Just (hackyStringIgnoreContext ns)
_ -> Nothing
assembleString :: forall v m. (MonadEval v m, FromValue NixString m v)
=> NString (m v) -> m (Maybe NixString)
assembleString
:: forall v m
. (MonadEval v m, FromValue NixString m v)
=> NString (m v)
-> m (Maybe NixString)
assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go
go = runAntiquoted "\n" (pure . Just . principledMakeNixStringWithoutContext) (>>= fromValueMay)
go = runAntiquoted "\n"
(pure . Just . principledMakeNixStringWithoutContext)
(>>= fromValueMay)
buildArgument :: forall v t m. MonadNixEval v t m
=> Params (m v) -> m v -> m (AttrSet t)
buildArgument
:: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do
scope <- currentScopes :: m (Scopes m t)
case params of
Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m ->
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(args, _) -> do
arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do
let inject = case m of
Nothing -> id
Just n -> M.insert n $ const $
thunk (withScopes scope arg)
loebM (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
args (M.fromList s))
Just n -> M.insert n $ const $ thunk (withScopes scope arg)
loebM
(inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
args
(M.fromList s)
)
where
assemble :: Scopes m t
assemble
:: Scopes m t
-> Bool
-> Text
-> These t (Maybe (m v))
-> Maybe (AttrSet t -> m t)
assemble scope isVariadic k = \case
That Nothing -> Just $
const $ evalError @v $ ErrorCall $
"Missing value for parameter: " ++ show k
That (Just f) -> Just $ \args ->
thunk $ withScopes scope $ pushScope args f
This _ | isVariadic -> Nothing
| otherwise -> Just $
const $ evalError @v $ ErrorCall $
"Unexpected parameter: " ++ show k
That Nothing ->
Just
$ const
$ evalError @v
$ ErrorCall
$ "Missing value for parameter: "
++ show k
That (Just f) ->
Just $ \args -> thunk $ withScopes scope $ pushScope args f
This _
| isVariadic
-> Nothing
| otherwise
-> Just
$ const
$ evalError @v
$ ErrorCall
$ "Unexpected parameter: "
++ show k
These x _ -> Just (const (pure x))
addSourcePositions :: (MonadReader e m, Has e SrcSpan)
=> Transform NExprLocF (m a)
addSourcePositions
:: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)
addSourcePositions f v@(Fix (Compose (Ann ann _))) =
local (set hasLens ann) (f v)
addStackFrames
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m)
:: forall t e m a
. (Scoped t m, Framed e m, Typeable t, Typeable m)
=> Transform NExprLocF (m a)
addStackFrames f v = do
scopes <- currentScopes :: m (Scopes m t)
withFrame Info (EvaluatingExpr scopes v) (f v)
framedEvalExprLoc
:: forall t e v m.
(MonadNixEval v t m, Framed e m, Has e SrcSpan,
Typeable t, Typeable m)
=> NExprLoc -> m v
framedEvalExprLoc = adi (eval . annotated . getCompose)
(addStackFrames @t . addSourcePositions)
:: forall t e v m
. (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m)
=> NExprLoc
-> m v
framedEvalExprLoc =
adi (eval . annotated . getCompose) (addStackFrames @t . addSourcePositions)

410
src/Nix/Exec.hs
View File

@ -26,7 +26,10 @@
module Nix.Exec where
import Prelude hiding (putStr, putStrLn, print)
import Prelude hiding ( putStr
, putStrLn
, print
)
import Control.Applicative
import Control.Monad
@ -36,7 +39,8 @@ import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.State.Strict
import Control.Monad.Trans.Reader ( ReaderT(..) )
import Control.Monad.Trans.State.Strict (StateT(..))
import Control.Monad.Trans.State.Strict
( StateT(..) )
import Data.Fix
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
@ -80,54 +84,52 @@ import GHC.DataSize
#endif
#endif
type Cited t f m =
( HasCitations1 t f m
, MonadDataContext f m
)
type Cited t f m = (HasCitations1 t f m, MonadDataContext f m)
nvConstantP :: Cited t f m
=> Provenance t f m -> NAtom -> NValue t f m
nvConstantP :: Cited t f m => Provenance t f m -> NAtom -> NValue t f m
nvConstantP p x = addProvenance p (nvConstant x)
nvStrP :: Cited t f m
=> Provenance t f m -> NixString -> NValue t f m
nvStrP :: Cited t f m => Provenance t f m -> NixString -> NValue t f m
nvStrP p ns = addProvenance p (nvStr ns)
nvPathP :: Cited t f m
=> Provenance t f m -> FilePath -> NValue t f m
nvPathP :: Cited t f m => Provenance t f m -> FilePath -> NValue t f m
nvPathP p x = addProvenance p (nvPath x)
nvListP :: Cited t f m
=> Provenance t f m -> [t] -> NValue t f m
nvListP :: Cited t f m => Provenance t f m -> [t] -> NValue t f m
nvListP p l = addProvenance p (nvList l)
nvSetP :: Cited t f m
=> Provenance t f m -> AttrSet t -> AttrSet SourcePos
nvSetP
:: Cited t f m
=> Provenance t f m
-> AttrSet t
-> AttrSet SourcePos
-> NValue t f m
nvSetP p s x = addProvenance p (nvSet s x)
nvClosureP :: Cited t f m
nvClosureP
:: Cited t f m
=> Provenance t f m
-> Params ()
-> (m (NValue t f m) -> m t)
-> NValue t f m
nvClosureP p x f = addProvenance p (nvClosure x f)
nvBuiltinP :: Cited t f m
nvBuiltinP
:: Cited t f m
=> Provenance t f m
-> String
-> (m (NValue t f m) -> m t)
-> NValue t f m
nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
type MonadCitedThunks t f m =
( MonadThunk t m (NValue t f m)
type MonadCitedThunks t f m
= ( MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations1 t f m
)
type MonadNix e t f m =
( Has e SrcSpan
type MonadNix e t f m
= ( Has e SrcSpan
, Has e Options
, Scoped t m
, Framed e m
@ -145,9 +147,10 @@ data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
instance MonadDataErrorContext t f m => Exception (ExecFrame t f m)
nverr
:: forall e t f s m a.
(MonadNix e t f m, FromValue NixString m t, Exception s)
=> s -> m a
:: forall e t f s m a
. (MonadNix e t f m, FromValue NixString m t, Exception s)
=> s
-> m a
nverr = evalError @(NValue t f m)
currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan
@ -159,8 +162,12 @@ wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
instance ( MonadNix e t f m
, FromValue NixString m t
) => MonadEval (NValue t f m) m where
freeVariable var = nverr @e @t @f $
ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
freeVariable var =
nverr @e @t @f
$ ErrorCall
$ "Undefined variable '"
++ Text.unpack var
++ "'"
synHole name = do
span <- currentPos
@ -171,15 +178,19 @@ instance ( MonadNix e t f m
}
attrMissing ks Nothing =
evalError @(NValue t f m) $ ErrorCall $
"Inheriting unknown attribute: "
evalError @(NValue t f m)
$ ErrorCall
$ "Inheriting unknown attribute: "
++ intercalate "." (map Text.unpack (NE.toList ks))
attrMissing ks (Just s) = do
s' <- prettyNValue s
evalError @(NValue t f m) $ ErrorCall $ "Could not look up attribute "
evalError @(NValue t f m)
$ ErrorCall
$ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show s'
++ " in "
++ show s'
evalCurPos = do
scope <- currentScopes
@ -201,14 +212,19 @@ instance ( MonadNix e t f m
Just ns -> do
scope <- currentScopes
span <- currentPos
pure $ nvStrP (Provenance scope
(NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)]))) ns
pure $ nvStrP
(Provenance
scope
(NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)]))
)
ns
Nothing -> nverr $ ErrorCall "Failed to assemble string"
evalLiteralPath p = do
scope <- currentScopes
span <- currentPos
nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath @t @f @m p
nvPathP (Provenance scope (NLiteralPath_ span p))
<$> makeAbsolutePath @t @f @m p
evalEnvPath p = do
scope <- currentScopes
@ -234,17 +250,29 @@ instance ( MonadNix e t f m
evalIf c t f = do
scope <- currentScopes
span <- currentPos
fromValue c >>= \b ->
if b
then (\t -> addProvenance (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) t) <$> t
else (\f -> addProvenance (Provenance scope (NIf_ span (Just c) Nothing (Just f))) f) <$> f
fromValue c >>= \b -> if b
then
(\t -> addProvenance
(Provenance scope (NIf_ span (Just c) (Just t) Nothing))
t
)
<$> t
else
(\f -> addProvenance
(Provenance scope (NIf_ span (Just c) Nothing (Just f)))
f
)
<$> f
evalAssert c body = fromValue c >>= \b -> do
span <- currentPos
if b
then do
scope <- currentScopes
(\b -> addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b) <$> body
(\b ->
addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b
)
<$> body
else nverr $ Assertion span c
evalApp f x = do
@ -256,18 +284,24 @@ instance ( MonadNix e t f m
evalAbs p k = do
scope <- currentScopes
span <- currentPos
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
(void p) (\arg -> wrapValue . snd <$> k arg (\_ b -> ((),) <$> b))
pure $ nvClosureP
(Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
(void p)
(\arg -> wrapValue . snd <$> k arg (\_ b -> ((), ) <$> b))
evalError = throwError
infixl 1 `callFunc`
callFunc :: forall e t f m. MonadNix e t f m
=> NValue t f m -> m (NValue t f m) -> m (NValue t f m)
callFunc
:: forall e t f m
. MonadNix e t f m
=> NValue t f m
-> m (NValue t f m)
-> m (NValue t f m)
callFunc fun arg = do
frames :: Frames <- asks (view hasLens)
when (length frames > 2000) $
throwError $ ErrorCall "Function call stack exhausted"
when (length frames > 2000) $ throwError $ ErrorCall
"Function call stack exhausted"
case fun of
NVClosure params f -> do
traceM $ "callFunc:NVFunction taking " ++ show params
@ -280,8 +314,12 @@ callFunc fun arg = do
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp :: (Framed e m, Cited t f m, Show t)
=> Scopes m t -> SrcSpan -> NUnaryOp -> NValue t f m
execUnaryOp
:: (Framed e m, Cited t f m, Show t)
=> Scopes m t
-> SrcSpan
-> NUnaryOp
-> NValue t f m
-> m (NValue t f m)
execUnaryOp scope span op arg = do
traceM "NUnary"
@ -290,18 +328,23 @@ execUnaryOp scope span op arg = do
(NNeg, NInt i ) -> unaryOp $ NInt (-i)
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
(NNot, NBool b ) -> unaryOp $ NBool (not b)
_ -> throwError $ ErrorCall $
"unsupported argument type for unary operator " ++ show op
x -> throwError $ ErrorCall $ "argument to unary operator"
++ " must evaluate to an atomic type: " ++ show x
_ ->
throwError
$ ErrorCall
$ "unsupported argument type for unary operator "
++ show op
x ->
throwError
$ ErrorCall
$ "argument to unary operator"
++ " must evaluate to an atomic type: "
++ show x
where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
execBinaryOp
:: forall e t f m.
(MonadNix e t f m,
FromValue NixString m t,
MonadEval (NValue t f m) m)
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t, MonadEval (NValue t f m) m)
=> Scopes m t
-> SrcSpan
-> NBinaryOp
@ -309,21 +352,21 @@ execBinaryOp
-> m (NValue t f m)
-> m (NValue t f m)
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
if l
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> if l
then orOp Nothing True
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
where
orOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b)
orOp r b = pure $ nvConstantP
(Provenance scope (NBinary_ span NOr (Just larg) r))
(NBool b)
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
if l
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l
then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)
else andOp Nothing False
where
andOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b)
andOp r b = pure $ nvConstantP
(Provenance scope (NBinary_ span NAnd (Just larg) r))
(NBool b)
execBinaryOp scope span op lval rarg = do
rval <- rarg
@ -346,8 +389,7 @@ execBinaryOp scope span op lval rarg = do
(NMinus, l , r ) -> numBinOp bin (-) l r
(NMult , l , r ) -> numBinOp bin (*) l r
(NDiv , l , r ) -> numBinOp' bin div (/) l r
(NImpl,
NBool l, NBool r) -> toBool $ not l || r
(NImpl , NBool l, NBool r) -> toBool $ not l || r
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls, NVStr rs) -> case op of
@ -389,14 +431,16 @@ execBinaryOp scope span op lval rarg = do
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(ls@NVSet{}, NVStr rs) -> case op of
NPlus -> (\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))
NPlus ->
(\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))
<$> coerceToString DontCopyToStore CoerceStringy ls
NEq -> toBool =<< valueEqM lval rval
NNEq -> toBool . not =<< valueEqM lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls, rs@NVSet{}) -> case op of
NPlus -> (\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))
NPlus ->
(\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))
<$> coerceToString DontCopyToStore CoerceStringy rs
NEq -> toBool =<< valueEqM lval rval
NNEq -> toBool . not =<< valueEqM lval rval
@ -439,16 +483,27 @@ execBinaryOp scope span op lval rarg = do
unsupportedTypes :: Show a => a -> a -> String
unsupportedTypes lval rval =
"Unsupported argument types for binary operator "
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
++ show op
++ ": "
++ show lval
++ ", "
++ show rval
numBinOp :: (forall r. (Provenance t f m -> r) -> r)
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue t f m)
numBinOp
:: (forall r . (Provenance t f m -> r) -> r)
-> (forall a . Num a => a -> a -> a)
-> NAtom
-> NAtom
-> m (NValue t f m)
numBinOp bin f = numBinOp' bin f f
numBinOp' :: (forall r. (Provenance t f m -> r) -> r)
numBinOp'
:: (forall r . (Provenance t f m -> r) -> r)
-> (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> NAtom -> NAtom -> m (NValue t f m)
-> NAtom
-> NAtom
-> m (NValue t f m)
numBinOp' bin intF floatF l r = case (l, r) of
(NInt li, NInt ri ) -> toInt $ li `intF` ri
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
@ -475,43 +530,53 @@ data CopyToStoreMode
-- ^ Add paths to the store as they are encountered
deriving (Eq,Ord,Enum,Bounded)
coerceToString :: MonadNix e t f m => CopyToStoreMode -> CoercionLevel -> NValue t f m -> m NixString
coerceToString
:: MonadNix e t f m
=> CopyToStoreMode
-> CoercionLevel
-> NValue t f m
-> m NixString
coerceToString ctsm clevel = go
where
go = \case
NVConstant (NBool b)
|
-- TODO Return a singleton for "" and "1"
| b && clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext "1"
b && clevel == CoerceAny -> pure
$ principledMakeNixStringWithoutContext "1"
| clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
NVConstant (NInt n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant (NFloat n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant NNull | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
NVConstant (NInt n) | clevel == CoerceAny ->
pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant (NFloat n) | clevel == CoerceAny ->
pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant NNull | clevel == CoerceAny ->
pure $ principledMakeNixStringWithoutContext ""
NVStr ns -> pure ns
NVPath p | ctsm == CopyToStore -> storePathToNixString <$> addPath p
NVPath p
| ctsm == CopyToStore -> storePathToNixString <$> addPath p
| otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p
NVList l | clevel == CoerceAny -> nixStringUnwords <$> traverse (`force` go) l
NVList l | clevel == CoerceAny ->
nixStringUnwords <$> traverse (`force` go) l
v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
force p $ (`callFunc` pure v) >=> go
NVSet s _ | Just p <- M.lookup "outPath" s ->
force p go
NVSet s _ | Just p <- M.lookup "outPath" s -> force p go
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
nixStringUnwords = principledIntercalateNixString (principledMakeNixStringWithoutContext " ")
nixStringUnwords =
principledIntercalateNixString (principledMakeNixStringWithoutContext " ")
storePathToNixString :: StorePath -> NixString
storePathToNixString sp =
principledMakeNixStringWithSingletonContext t (StringContext t DirectPath)
where
t = Text.pack $ unStorePath sp
storePathToNixString sp = principledMakeNixStringWithSingletonContext
t
(StringContext t DirectPath)
where t = Text.pack $ unStorePath sp
fromStringNoContext :: MonadNix e t f m => NixString -> m Text
fromStringNoContext ns =
case principledGetStringNoContext ns of
fromStringNoContext ns = case principledGetStringNoContext ns of
Just str -> return str
Nothing -> throwError $ ErrorCall
"expected string with no context"
Nothing -> throwError $ ErrorCall "expected string with no context"
newtype Lazy t (f :: * -> *) m a = Lazy
{ runLazy :: ReaderT (Context (Lazy t f m) t)
@ -542,8 +607,8 @@ instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where
instance (MonadFile m, Monad m) => MonadFile (Lazy t f m)
instance MonadCatch m => MonadCatch (Lazy t f m) where
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
catch (m e) ((`runReaderT` e) . runLazy . f)
catch (Lazy (ReaderT m)) f =
Lazy $ ReaderT $ \e -> catch (m e) ((`runReaderT` e) . runLazy . f)
instance MonadThrow m => MonadThrow (Lazy t f m) where
throwM = Lazy . throwM
@ -591,14 +656,19 @@ instance ( MonadFix m
=> MonadEffects t f (Lazy t f m) where
makeAbsolutePath origPath = do
origPathExpanded <- expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
absPath <- if isAbsolute origPathExpanded
then pure origPathExpanded
else do
cwd <- do
mres <- lookupVar "__cur_file"
case mres of
Nothing -> getCurrentDirectory
Just v -> force v $ \case
NVPath s -> return $ takeDirectory s
v -> throwError $ ErrorCall $ "when resolving relative path,"
v ->
throwError
$ ErrorCall
$ "when resolving relative path,"
++ " __cur_file is in scope,"
++ " but is not a path; it is: "
++ show v
@ -621,20 +691,19 @@ instance ( MonadFix m
eres <- parseNixFileLoc path
case eres of
Failure err ->
throwError $ ErrorCall . show $ fillSep $
[ "Parse during import failed:"
, err
]
throwError
$ ErrorCall
. show
$ fillSep
$ ["Parse during import failed:", err]
Success expr -> do
Lazy $ ReaderT $ const $
modify (M.insert path expr)
Lazy $ ReaderT $ const $ modify (M.insert path expr)
pure expr
derivationStrict = fromValue @(AttrSet t) >=> \s -> do
nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s)
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
v' <- normalForm
=<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
v' <- normalForm =<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
where
mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b]
@ -655,8 +724,7 @@ instance ( MonadFix m
where
coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
coerceNixList =
toNix <=< traverse (\x -> force x coerceNix)
<=< fromValue @[t]
toNix <=< traverse (\x -> force x coerceNix) <=< fromValue @[t]
traceEffect = putStrLn
@ -664,9 +732,8 @@ getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m)
getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize
runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a
runLazyM opts = (`evalStateT` M.empty)
. (`runReaderT` newContext opts)
. runLazy
runLazyM opts =
(`evalStateT` M.empty) . (`runReaderT` newContext opts) . runLazy
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its
@ -674,7 +741,8 @@ runLazyM opts = (`evalStateT` M.empty)
-- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath
removeDotDotIndirections :: FilePath -> FilePath
removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
where go s [] = reverse s
where
go s [] = reverse s
go (_ : s) (".." : rest) = go s rest
go s (this : rest) = go (this : s) rest
@ -694,30 +762,33 @@ x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
| otherwise = joinByLargestOverlap x y
where
joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =
joinPath $ head [ xs ++ drop (length tx) ys
| tx <- tails xs, tx `elem` inits ys ]
joinPath $ head
[ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ]
findPathBy
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> (FilePath -> m (Maybe FilePath))
-> [t] -> FilePath -> m FilePath
-> [t]
-> FilePath
-> m FilePath
findPathBy finder l name = do
mpath <- foldM go Nothing l
case mpath of
Nothing ->
throwError $ ErrorCall $ "file '" ++ name
throwError
$ ErrorCall
$ "file '"
++ name
++ "' was not found in the Nix search path"
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
where
go :: Maybe FilePath -> t -> m (Maybe FilePath)
go p@(Just _) _ = pure p
go Nothing l = force l $ fromValue >=>
\(s :: HashMap Text t) -> do
go Nothing l = force l $ fromValue >=> \(s :: HashMap Text t) -> do
p <- resolvePath s
force p $ fromValue >=> \(Path path) ->
case M.lookup "prefix" s of
force p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
Nothing -> tryPath path Nothing
Just pf -> force pf $ fromValueMay >=> \case
Just (nsPfx :: NixString) ->
@ -736,13 +807,18 @@ findPathBy finder l name = do
Nothing -> case M.lookup "uri" s of
Just ut -> thunk $ fetchTarball (force ut pure)
Nothing ->
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: " ++ show s
throwError
$ ErrorCall
$ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: "
++ show s
findPathM
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> [t] -> FilePath -> m FilePath
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> [t]
-> FilePath
-> m FilePath
findPathM l name = findPathBy path l name
where
path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
@ -752,15 +828,16 @@ findPathM l name = findPathBy path l name
return $ if exists then Just path else Nothing
findEnvPathM
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> FilePath -> m FilePath
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
=> FilePath
-> m FilePath
findEnvPathM name = do
mres <- lookupVar "__nixPath"
case mres of
Nothing -> error "impossible"
Just x -> force x $ fromValue >=> \(l :: [t]) ->
findPathBy nixFilePath l name
Just x ->
force x $ fromValue >=> \(l :: [t]) -> findPathBy nixFilePath l name
where
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
nixFilePath path = do
@ -772,9 +849,10 @@ findEnvPathM name = do
exists <- doesFileExist path'
return $ if exists then Just path' else Nothing
addTracing :: (MonadNix e t f m, Has e Options,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
addTracing
:: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a)
-> Alg NExprLocF (n (m a))
addTracing k v = do
depth <- ask
guard (depth < 2000)
@ -782,8 +860,7 @@ addTracing k v = do
v'@(Compose (Ann span x)) <- sequence v
return $ do
opts :: Options <- asks (view hasLens)
let rendered =
if verbose opts >= Chatty
let rendered = if verbose opts >= Chatty
#ifdef MIN_VERSION_pretty_show
then pretty $ PS.ppShow (void x)
#else
@ -798,14 +875,15 @@ addTracing k v = do
return res
evalExprLoc
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t, Has e Options)
=> NExprLoc -> m (NValue t f m)
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t, Has e Options)
=> NExprLoc
-> m (NValue t f m)
evalExprLoc expr = do
opts :: Options <- asks (view hasLens)
if tracing opts
then join . (`runReaderT` (0 :: Int)) $
adi (addTracing phi)
then join . (`runReaderT` (0 :: Int)) $ adi
(addTracing phi)
(raise (addStackFrames @t . addSourcePositions))
expr
else adi phi (addStackFrames @t . addSourcePositions) expr
@ -814,23 +892,30 @@ evalExprLoc expr = do
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
fetchTarball
:: forall e t f m.
(MonadNix e t f m, FromValue NixString m t)
=> m (NValue t f m) -> m (NValue t f m)
:: forall e t f m
. (MonadNix e t f m, FromValue NixString m t)
=> m (NValue t f m)
-> m (NValue t f m)
fetchTarball v = v >>= \case
NVSet s _ -> case M.lookup "url" s of
Nothing -> throwError $ ErrorCall
"builtins.fetchTarball: Missing url attribute"
Nothing ->
throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute"
Just url -> force url $ go (M.lookup "sha256" s)
v@NVStr{} -> go Nothing v
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or set, got " ++ show v
v ->
throwError
$ ErrorCall
$ "builtins.fetchTarball: Expected URI or set, got "
++ show v
where
go :: Maybe t -> NValue t f m -> m (NValue t f m)
go msha = \case
NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or string, got " ++ show v
v ->
throwError
$ ErrorCall
$ "builtins.fetchTarball: Expected URI or string, got "
++ show v
{- jww (2018-04-11): This should be written using pipes in another module
fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m)
@ -846,28 +931,26 @@ fetchTarball v = v >>= \case
fetch :: Text -> Maybe t -> m (NValue t f m)
fetch uri Nothing =
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
Text.unpack uri ++ "\""
nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\""
fetch url (Just m) = fromValue m >>= \nsSha ->
let sha = hackyStringIgnoreContext nsSha
in nixInstantiateExpr $ "builtins.fetchTarball { "
++ "url = \"" ++ Text.unpack url ++ "\"; "
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
in nixInstantiateExpr
$ "builtins.fetchTarball { "
++ "url = \""
++ Text.unpack url
++ "\"; "
++ "sha256 = \""
++ Text.unpack sha
++ "\"; }"
exec
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
)
:: (MonadNix e t f m, MonadInstantiate m, FromValue NixString m t)
=> [String]
-> m (NValue t f m)
exec args = either throwError evalExprLoc =<< exec' args
nixInstantiateExpr
:: ( MonadNix e t f m
, MonadInstantiate m
, FromValue NixString m t
)
:: (MonadNix e t f m, MonadInstantiate m, FromValue NixString m t)
=> String
-> m (NValue t f m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
@ -877,3 +960,10 @@ instance Monad m => Scoped t (Lazy t f m) where
clearScopes = clearScopesReader @(Lazy t f m) @t
pushScopes = pushScopesReader
lookupVar = lookupVarReader

11
src/Nix/Expr.hs
View File

@ -1,9 +1,10 @@
-- | Wraps the expression submodules.
module Nix.Expr (
module Nix.Expr.Types,
module Nix.Expr.Types.Annotated,
module Nix.Expr.Shorthands
) where
module Nix.Expr
( module Nix.Expr.Types
, module Nix.Expr.Types.Annotated
, module Nix.Expr.Shorthands
)
where
import Nix.Expr.Types
import Nix.Expr.Shorthands

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

@ -201,8 +201,7 @@ mkBinop :: NBinaryOp -> NExpr -> NExpr -> NExpr
mkBinop op e1 e2 = Fix (NBinary op e1 e2)
-- | Various nix binary operators
($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->),
($//), ($+), ($-), ($*), ($/), ($++)
($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++)
:: NExpr -> NExpr -> NExpr
e1 $== e2 = mkBinop NEq e1 e2
e1 $!= e2 = mkBinop NNEq e1 e2

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

@ -46,12 +46,17 @@ import Data.Hashable
#if MIN_VERSION_hashable(1, 2, 5)
import Data.Hashable.Lifted
#endif
import Data.List (inits, tails)
import Data.List ( inits
, tails
)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe ( fromMaybe )
import Data.Ord.Deriving
import Data.Text (Text, pack, unpack)
import Data.Text ( Text
, pack
, unpack
)
import Data.Traversable
import GHC.Exts
import GHC.Generics
@ -245,10 +250,8 @@ data Antiquoted (v :: *) (r :: *) = Plain !v | EscapedNewline | Antiquoted !r
instance Hashable v => Hashable1 (Antiquoted v)
instance Hashable2 Antiquoted where
liftHashWithSalt2 ha _ salt (Plain a) =
ha (salt `hashWithSalt` (0 :: Int)) a
liftHashWithSalt2 _ _ salt EscapedNewline =
salt `hashWithSalt` (1 :: Int)
liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a
liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int)
liftHashWithSalt2 _ hb salt (Antiquoted b) =
hb (salt `hashWithSalt` (2 :: Int)) b
#endif
@ -369,7 +372,11 @@ instance Hashable1 NKeyName where
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Show1 NKeyName where
liftShowsPrec sp sl p = \case
DynamicKey a -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl) "DynamicKey" p a
DynamicKey a -> showsUnaryWith
(liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl)
"DynamicKey"
p
a
StaticKey t -> showsUnaryWith showsPrec "StaticKey" p t
-- Deriving this instance automatically is not possible because @r@
@ -526,12 +533,12 @@ class NExprAnn ann g | g -> ann where
fromNExpr :: g r -> (NExprF r, ann)
toNExpr :: (NExprF r, ann) -> g r
ekey :: NExprAnn ann g
ekey
:: NExprAnn ann g
=> 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 xs, ann) <- fromNExpr x = case go xs of
((v, [] ) : _) -> fromMaybe e <$> f (Just v)
((v, r : rest) : _) -> ekey (r :| rest) pos f v
@ -566,3 +573,6 @@ stripPositionInfo = transport phi
nullPos :: SourcePos
nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)

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

@ -18,14 +18,19 @@
module Nix.Expr.Types.Annotated
( module Nix.Expr.Types.Annotated
, module Data.Functor.Compose
, SourcePos(..), unPos, mkPos
) where
, SourcePos(..)
, unPos
, mkPos
)
where
#ifdef MIN_VERSION_serialise
import Codec.Serialise
#endif
import Control.DeepSeq
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
)
import Data.Aeson.TH
import Data.Binary ( Binary(..) )
import Data.Data
@ -38,11 +43,15 @@ import Data.Hashable
import Data.Hashable.Lifted
#endif
import Data.Ord.Deriving
import Data.Text (Text, pack)
import Data.Text ( Text
, pack
)
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Text.Megaparsec (unPos, mkPos)
import Text.Megaparsec ( unPos
, mkPos
)
import Text.Megaparsec.Pos ( SourcePos(..) )
import Text.Read.Deriving
import Text.Show.Deriving
@ -93,8 +102,7 @@ $(deriveJSON1 defaultOptions ''Ann)
$(deriveJSON2 defaultOptions ''Ann)
instance Semigroup SrcSpan where
s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2)
((max `on` spanEnd) s1 s2)
s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2)
type AnnF ann f = Compose (Ann ann) f
@ -153,8 +161,8 @@ nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) =
AnnE (s1 <> s2 <> s3) (NBinary b e1 e2)
nBinary _ _ _ = error "nBinary: unexpected"
nSelectLoc :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc
-> NExprLoc
nSelectLoc
:: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc
nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of
Nothing -> AnnE (s1 <> s2) (NSelect e1 ats Nothing)
Just (e2@(AnnE s3 _)) -> AnnE (s1 <> s2 <> s3) (NSelect e1 ats (Just e2))

26
src/Nix/Frames.hs
View File

@ -4,12 +4,22 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Nix.Frames (NixLevel(..), Frames, Framed, NixFrame(..),
NixException(..), withFrame, throwError,
module Data.Typeable,
module Control.Exception) where
module Nix.Frames
( NixLevel(..)
, Frames
, Framed
, NixFrame(..)
, NixException(..)
, withFrame
, throwError
, module Data.Typeable
, module Control.Exception
)
where
import Control.Exception hiding (catch, evaluate)
import Control.Exception hiding ( catch
, evaluate
)
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Typeable hiding ( typeOf )
@ -36,10 +46,12 @@ newtype NixException = NixException Frames
instance Exception NixException
withFrame :: forall s e m a. (Framed e m, Exception s) => NixLevel -> s -> m a -> m a
withFrame
:: forall s e m a . (Framed e m, Exception s) => NixLevel -> s -> m a -> m a
withFrame level f = local (over hasLens (NixFrame level (toException f) :))
throwError :: forall s e m a. (Framed e m, Exception s, MonadThrow m) => s -> m a
throwError
:: forall s e m a . (Framed e m, Exception s, MonadThrow m) => s -> m a
throwError err = do
context <- asks (view hasLens)
traceM "Throwing error..."

7
src/Nix/Fresh.hs
View File

@ -104,3 +104,10 @@ instance MonadAtomicRef (ST s) where
let (a, b) = f v
writeRef r $! a
return b

17
src/Nix/Json.hs
View File

@ -23,10 +23,14 @@ import Nix.Utils
import Nix.Value
nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString
nvalueToJSONNixString = runWithStringContextT
. fmap (TL.toStrict . TL.decodeUtf8
nvalueToJSONNixString =
runWithStringContextT
. fmap
( TL.toStrict
. TL.decodeUtf8
. A.encodingToLazyByteString
. toEncodingSorted)
. toEncodingSorted
)
. nvalueToJSON
nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
@ -37,11 +41,12 @@ nvalueToJSON = \case
NVConstant NNull -> pure $ A.Null
NVStr ns -> A.toJSON <$> extractNixString ns
NVList l ->
A.Array . V.fromList
A.Array
. V.fromList
<$> traverse (join . lift . flip force (return . nvalueToJSON)) l
NVSet m _ -> case HM.lookup "outPath" m of
Nothing -> A.Object
<$> traverse (join . lift . flip force (return . nvalueToJSON)) m
Nothing ->
A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
Just outPath -> join $ lift $ force outPath (return . nvalueToJSON)
NVPath p -> do
fp <- lift $ unStorePath <$> addPath p

117
src/Nix/Lint.hs
View File

@ -111,16 +111,15 @@ everyPossible = packSymbolic NAny
mkSymbolic :: MonadVar m => [NTypeF m (SThunk m)] -> m (Symbolic m)
mkSymbolic xs = packSymbolic (NMany xs)
packSymbolic :: MonadVar m
=> NSymbolicF (NTypeF m (SThunk m)) -> m (Symbolic m)
packSymbolic :: MonadVar m => NSymbolicF (NTypeF m (SThunk m)) -> m (Symbolic m)
packSymbolic = fmap coerce . newVar
unpackSymbolic :: MonadVar m
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
unpackSymbolic
:: MonadVar m => Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
MonadCatch m, MonadThunkId m)
type MonadLint e m
= (Scoped (SThunk m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId m)
symerr :: forall e m a . MonadLint e m => String -> m a
symerr = evalError @(Symbolic m) . ErrorCall
@ -153,13 +152,17 @@ renderSymbolic = unpackSymbolic >=> \case
TBuiltin _n _f -> return "<builtin function>"
-- This function is order and uniqueness preserving (of types).
merge :: forall e m. MonadLint e m
=> NExprF () -> [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
merge
:: forall e m
. MonadLint e m
=> NExprF ()
-> [NTypeF m (SThunk m)]
-> [NTypeF m (SThunk m)]
-> m [NTypeF m (SThunk m)]
merge context = go
where
go :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
-> m [NTypeF m (SThunk m)]
go
:: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] -> m [NTypeF m (SThunk m)]
go [] _ = return []
go _ [] = return []
go (x : xs) (y : ys) = case (x, y) of
@ -174,13 +177,14 @@ merge context = go
(TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys
(TSet (Just l), TSet (Just r)) -> do
m <- sequenceA $ M.intersectionWith
(\i j -> i >>= \i' -> j >>= \j' ->
force i' $ \i'' -> force j' $ \j'' ->
thunk $ unify context i'' j'')
(return <$> l) (return <$> r)
if M.null m
then go xs ys
else (TSet (Just m) :) <$> go xs ys
(\i j -> i >>= \i' ->
j
>>= \j' -> force i'
$ \i'' -> force j' $ \j'' -> thunk $ unify context i'' j''
)
(return <$> l)
(return <$> r)
if M.null m then go xs ys else (TSet (Just m) :) <$> go xs ys
(TClosure{}, TClosure{}) ->
throwError $ ErrorCall "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
@ -209,8 +213,13 @@ merge context = go
-}
-- | unify raises an error if the result is would be 'NMany []'.
unify :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify
:: forall e m
. MonadLint e m
=> NExprF ()
-> Symbolic m
-> Symbolic m
-> m (Symbolic m)
unify context (Symbolic x) (Symbolic y) = do
x' <- readVar x
y' <- readVar y
@ -259,18 +268,21 @@ instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where
getValue = getValue . getSThunk
instance MonadLint e m => MonadEval (Symbolic m) m where
freeVariable var = symerr $
"Undefined variable '" ++ Text.unpack var ++ "'"
freeVariable var = symerr $ "Undefined variable '" ++ Text.unpack var ++ "'"
attrMissing ks Nothing =
evalError @(Symbolic m) $ ErrorCall $
"Inheriting unknown attribute: "
evalError @(Symbolic m)
$ ErrorCall
$ "Inheriting unknown attribute: "
++ intercalate "." (map Text.unpack (NE.toList ks))
attrMissing ks (Just s) =
evalError @(Symbolic m) $ ErrorCall $ "Could not look up attribute "
evalError @(Symbolic m)
$ ErrorCall
$ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show s
++ " in "
++ show s
evalCurPos = do
f <- wrapValue <$> mkSymbolic [TPath]
@ -279,9 +291,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
mkSymbolic [TSet (Just (M.fromList (go f l c)))]
where
go f l c =
[ (Text.pack "file", f)
, (Text.pack "line", l)
, (Text.pack "col", c) ]
[(Text.pack "file", f), (Text.pack "line", l), (Text.pack "col", c)]
evalConstant c = mkSymbolic [TConstant [go c]]
where
@ -296,16 +306,15 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
evalEnvPath = const $ mkSymbolic [TPath]
evalUnary op arg =
unify (void (NUnary op arg)) arg
=<< mkSymbolic [TConstant [TInt, TBool]]
unify (void (NUnary op arg)) arg =<< mkSymbolic [TConstant [TInt, TBool]]
evalBinary = lintBinaryOp
-- 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.
evalWith scope 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.
s <- thunk @(SThunk m) @m @(Symbolic m) scope
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
NMany [TSet (Just s')] -> return s'
@ -331,19 +340,19 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
evalError = throwError
lintBinaryOp
:: forall e m. (MonadLint e m, MonadEval (Symbolic m) m)
=> NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
:: forall e m
. (MonadLint e m, MonadEval (Symbolic m) m)
=> NBinaryOp
-> Symbolic m
-> m (Symbolic m)
-> m (Symbolic m)
lintBinaryOp op lsym rarg = do
rsym <- rarg
y <- thunk everyPossible
case op of
NApp -> symerr "lintBinaryOp:NApp: should never get here"
NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
, TStr
, TList y ]
NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
, TStr
, TList y ]
NEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y]
NNEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y]
NLt -> check lsym rsym [TConstant [TInt, TBool, TNull]]
NLte -> check lsym rsym [TConstant [TInt, TBool, TNull]]
@ -372,12 +381,16 @@ lintBinaryOp op lsym rarg = do
unify (void e) lsym rsym
infixl 1 `lintApp`
lintApp :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> m (Symbolic m)
lintApp
:: forall e m
. MonadLint e m
=> NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp context fun arg = unpackSymbolic fun >>= \case
NAny -> throwError $ ErrorCall
"Cannot apply something not known to be a function"
NAny ->
throwError $ ErrorCall "Cannot apply something not known to be a function"
NMany xs -> do
(args, ys) <- fmap unzip $ forM xs $ \case
TClosure _params -> arg >>= unpackSymbolic >>= \case
@ -423,11 +436,13 @@ symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
symbolicBaseEnv = return emptyScopes
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint opts expr = runLintM opts $
symbolicBaseEnv
>>= (`pushScopes`
adi (Eval.eval . annotated . getCompose)
Eval.addSourcePositions expr)
lint opts expr =
runLintM opts
$ symbolicBaseEnv
>>= (`pushScopes` adi (Eval.eval . annotated . getCompose)
Eval.addSourcePositions
expr
)
instance Scoped (SThunk (Lint s)) (Lint s) where
currentScopes = currentScopesReader

45
src/Nix/Normal.hs
View File

@ -28,8 +28,8 @@ newtype NormalLoop t f m = NormalLoop (NValue t f m)
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalForm'
:: forall e t m f.
( Framed e m
:: forall e t m f
. ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
@ -45,9 +45,11 @@ normalForm' f = run . nValueToNFM run go
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
go :: t
go
:: t
-> ( NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
go t k = do
b <- seen t
@ -55,8 +57,8 @@ normalForm' f = run . nValueToNFM run go
then return $ pure t
else do
i <- ask
when (i > 2000) $
error "Exceeded maximum normalization depth of 2000 levels"
when (i > 2000)
$ error "Exceeded maximum normalization depth of 2000 levels"
s <- lift get
(res, s') <- lift $ lift $ f t $ \v ->
(`runStateT` s) . (`runReaderT` i) $ local succ $ k v
@ -68,8 +70,7 @@ normalForm' f = run . nValueToNFM run go
res <- gets (member tid)
unless res $ modify (insert tid)
return res
Nothing ->
return False
Nothing -> return False
normalForm
:: ( Framed e m
@ -77,7 +78,8 @@ normalForm
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m (NValueNF t f m)
=> NValue t f m
-> m (NValueNF t f m)
normalForm = normalForm' force
normalForm_
@ -86,21 +88,28 @@ normalForm_
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m ()
=> NValue t f m
-> m ()
normalForm_ = void <$> normalForm' forceEff
removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> NValueNF t f m
removeEffects
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> NValueNF t f m
removeEffects = nValueToNF (flip query opaque)
removeEffectsM :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> m (NValueNF t f m)
removeEffectsM
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> m (NValueNF t f m)
removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
opaque :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m
opaque
:: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m
opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"
dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t -> m (NValueNF t f m)
dethunk
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t
-> m (NValueNF t f m)
dethunk t = queryM t (pure opaque) removeEffectsM

3
src/Nix/Options.hs
View File

@ -37,8 +37,7 @@ data Options = Options
deriving Show
defaultOptions :: UTCTime -> Options
defaultOptions current = Options
{ verbose = ErrorsOnly
defaultOptions current = Options { verbose = ErrorsOnly
, tracing = False
, thunks = False
, values = False

171
src/Nix/Options/Parser.hs
View File

@ -18,112 +18,149 @@ 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"
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 Informational <$>
optional
(option (do a <- str
nixOptions current =
Options
<$> (fromMaybe Informational <$> 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")))
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)")
<> 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")
(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")
<> help "Enable reporting of value provenance in error messages"
)
<*> switch
( long "scopes"
<> help "Enable reporting of scopes in evaluation traces")
<*> optional (strOption
<> help "Enable reporting of scopes in evaluation traces"
)
<*> optional
(strOption
( long "reduce"
<> help "When done evaluating, output the evaluated part of the expression to FILE"))
<> 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")
(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")
(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)")
<> 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
<> 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"))
<> 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 "eval"
<> help "Whether to evaluate, or just pretty-print")
<> help
"When used with --eval, recursively evaluate list elements and attributes"
)
<*> switch (long "eval" <> help "Whether to evaluate, or just pretty-print")
<*> switch
( long "json"
<> help "Print the resulting value as an JSON representation")
<> help "Print the resulting value as an JSON representation"
)
<*> switch
( long "xml"
<> help "Print the resulting value as an XML representation")
<*> optional (strOption
<> 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"))
<> 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
<> help "Whether to check for syntax errors after parsing"
)
<*> optional
(strOption
( long "read"
<> help "Read in an expression tree from a binary cache"))
<> help "Read in an expression tree from a binary cache"
)
)
<*> switch
( long "cache"
<> help "Write out the parsed expression tree to a binary cache")
<> help "Write out the parsed expression tree to a binary cache"
)
<*> switch
( long "repl"
<> help "After performing any indicated actions, enter the 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
<> 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")
<> 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)
nixOptionsInfo current = info (helper <*> nixOptions current)
(fullDesc <> progDesc "" <> header "hnix")

359
src/Nix/Parser.hs
View File

@ -26,13 +26,11 @@ module Nix.Parser
, getUnaryOperator
, getBinaryOperator
, getSpecialOperator
, nixToplevelForm
, nixExpr
, nixSet
, nixBinders
, nixSelector
, nixSym
, nixPath
, nixString
@ -44,15 +42,21 @@ module Nix.Parser
, nixNull
, symbol
, whiteSpace
) where
)
where
import Prelude hiding ( readFile )
import Control.Applicative hiding (many, some)
import Control.Applicative hiding ( many
, some
)
import Control.DeepSeq
import Control.Monad
import Control.Monad.Combinators.Expr
import Data.Char (isAlpha, isDigit, isSpace)
import Data.Char ( isAlpha
, isDigit
, isSpace
)
import Data.Data ( Data(..) )
import Data.Foldable ( concat )
import Data.Functor
@ -63,8 +67,15 @@ import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Text ( Text )
import Data.Text hiding (map, foldr1, concat, concatMap, zipWith)
import Data.Text.Prettyprint.Doc (Doc, pretty)
import Data.Text hiding ( map
, foldr1
, concat
, concatMap
, zipWith
)
import Data.Text.Prettyprint.Doc ( Doc
, pretty
)
import Data.Text.Encoding
import Data.Typeable ( Typeable )
import Data.Void
@ -90,8 +101,10 @@ antiStart = symbol "${" <?> show ("${" :: String)
nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc)
nixAntiquoted p =
Antiquoted <$> (antiStart *> nixToplevelForm <* symbol "}")
<+> Plain <$> p
Antiquoted
<$> (antiStart *> nixToplevelForm <* symbol "}")
<+> Plain
<$> p
<?> "anti-quotation"
selDot :: Parser ()
@ -99,16 +112,15 @@ selDot = try (symbol "." *> notFollowedBy nixPath) <?> "."
nixSelect :: Parser NExprLoc -> Parser NExprLoc
nixSelect term = do
res <- build
<$> term
<*> optional ((,) <$> (selDot *> nixSelector)
<*> optional (reserved "or" *> nixTerm))
res <- build <$> term <*> optional
((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm))
continues <- optional $ lookAhead selDot
case continues of
Nothing -> pure res
Just _ -> nixSelect (pure res)
where
build :: NExprLoc
build
:: NExprLoc
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
-> NExprLoc
build t Nothing = t
@ -122,15 +134,23 @@ nixSelector = annotateLocation $ do
nixTerm :: Parser NExprLoc
nixTerm = do
c <- try $ lookAhead $ satisfy $ \x ->
pathChar x ||
x == '(' ||
x == '{' ||
x == '[' ||
x == '<' ||
x == '/' ||
x == '"' ||
x == '\''||
x == '^'
pathChar x
|| x
== '('
|| x
== '{'
|| x
== '['
|| x
== '<'
|| x
== '/'
|| x
== '"'
|| x
== '\''
|| x
== '^'
case c of
'(' -> nixSelect nixParens
'{' -> nixSelect nixSet
@ -140,21 +160,21 @@ nixTerm = do
'"' -> nixString
'\'' -> nixString
'^' -> nixSynHole
_ -> msum $
[ nixSelect nixSet | c == 'r' ] ++
[ nixPath | pathChar c ] ++
if isDigit c
then [ nixFloat
, nixInt ]
else [ nixUri | isAlpha c ] ++
[ nixBool | c == 't' || c == 'f' ] ++
[ nixNull | c == 'n' ] ++
[ nixSelect nixSym ]
_ ->
msum
$ [ nixSelect nixSet | c == 'r' ]
++ [ nixPath | pathChar c ]
++ if isDigit c
then [nixFloat, nixInt]
else
[ nixUri | isAlpha c ]
++ [ nixBool | c == 't' || c == 'f' ]
++ [ nixNull | c == 'n' ]
++ [nixSelect nixSym]
nixToplevelForm :: Parser NExprLoc
nixToplevelForm = keywords <+> nixLambda <+> nixExpr
where
keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
where keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
nixSym :: Parser NExprLoc
nixSym = annotateLocation1 $ mkSymF <$> identifier
@ -166,12 +186,13 @@ nixInt :: Parser NExprLoc
nixInt = annotateLocation1 (mkIntF <$> integer <?> "integer")
nixFloat :: Parser NExprLoc
nixFloat = annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
nixFloat =
annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
nixBool :: Parser NExprLoc
nixBool = annotateLocation1 (bool "true" True <+>
bool "false" False) <?> "bool" where
bool str b = mkBoolF b <$ reserved str
nixBool =
annotateLocation1 (bool "true" True <+> bool "false" False) <?> "bool"
where bool str b = mkBoolF b <$ reserved str
nixNull :: Parser NExprLoc
nixNull = annotateLocation1 (mkNullF <$ reserved "null" <?> "null")
@ -183,57 +204,80 @@ nixList :: Parser NExprLoc
nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list")
pathChar :: Char -> Bool
pathChar x = isAlpha x || isDigit x || x == '.' || x == '_' || x == '-' || x == '+' || x == '~'
pathChar x =
isAlpha x
|| isDigit x
|| x
== '.'
|| x
== '_'
|| x
== '-'
|| x
== '+'
|| x
== '~'
slash :: Parser Char
slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)))
slash =
try
( char '/'
<* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x))
)
<?> "slash"
-- | A path surrounded by angle brackets, indicating that it should be
-- looked up in the NIX_PATH environment variable at evaluation.
nixSearchPath :: Parser NExprLoc
nixSearchPath = annotateLocation1
(mkPathF True <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">")
<?> "spath")
( mkPathF True
<$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">")
<?> "spath"
)
pathStr :: Parser FilePath
pathStr = lexeme $ liftM2 (++) (many (satisfy pathChar))
pathStr = lexeme $ liftM2
(++)
(many (satisfy pathChar))
(Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar))))
nixPath :: Parser NExprLoc
nixPath = annotateLocation1 (try (mkPathF False <$> pathStr) <?> "path")
nixLet :: Parser NExprLoc
nixLet = annotateLocation1 (reserved "let"
*> (letBody <+> letBinders)
<?> "let block")
nixLet = annotateLocation1
(reserved "let" *> (letBody <+> letBinders) <?> "let block")
where
letBinders = NLet
<$> nixBinders
<*> (reserved "in" *> nixToplevelForm)
letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm)
-- Let expressions `let {..., body = ...}' are just desugared
-- into `(rec {..., body = ...}).body'.
letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
nixIf :: Parser NExprLoc
nixIf = annotateLocation1 (NIf
nixIf = annotateLocation1
( NIf
<$> (reserved "if" *> nixExpr)
<*> (reserved "then" *> nixToplevelForm)
<*> (reserved "else" *> nixToplevelForm)
<?> "if")
<?> "if"
)
nixAssert :: Parser NExprLoc
nixAssert = annotateLocation1 (NAssert
nixAssert = annotateLocation1
( NAssert
<$> (reserved "assert" *> nixExpr)
<*> (semi *> nixToplevelForm)
<?> "assert")
<?> "assert"
)
nixWith :: Parser NExprLoc
nixWith = annotateLocation1 (NWith
nixWith = annotateLocation1
( NWith
<$> (reserved "with" *> nixToplevelForm)
<*> (semi *> nixToplevelForm)
<?> "with")
<?> "with"
)
nixLambda :: Parser NExprLoc
nixLambda = nAbs <$> annotateLocation (try argExpr) <*> nixToplevelForm
@ -249,27 +293,33 @@ nixUri = annotateLocation1 $ lexeme $ try $ do
_ <- string ":"
address <- some $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
return $ NStr $
DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address]
return $ NStr $ DoubleQuoted
[Plain $ pack $ start : protocol ++ ':' : address]
nixString' :: Parser (NString NExprLoc)
nixString' = lexeme (doubleQuoted <+> indented <?> "string")
where
doubleQuoted :: Parser (NString NExprLoc)
doubleQuoted = DoubleQuoted . removePlainEmpty . mergePlain
<$> (doubleQ *> many (stringChar doubleQ (void $ char '\\')
doubleEscape)
<* doubleQ)
doubleQuoted =
DoubleQuoted
. removePlainEmpty
. mergePlain
<$> ( doubleQ
*> many (stringChar doubleQ (void $ char '\\') doubleEscape)
<* doubleQ
)
<?> "double quoted string"
doubleQ = void (char '"')
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
indented :: Parser (NString NExprLoc)
indented = stripIndent
<$> (indentedQ *> many (stringChar indentedQ indentedQ
indentedEscape)
<* indentedQ)
indented =
stripIndent
<$> ( indentedQ
*> many (stringChar indentedQ indentedQ indentedEscape)
<* indentedQ
)
<?> "indented string"
indentedQ = void (string "''" <?> "\"''\"")
@ -278,15 +328,18 @@ nixString' = lexeme (doubleQuoted <+> indented <?> "string")
(Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do
_ <- char '\\'
c <- escapeCode
pure $ if c == '\n'
then EscapedNewline
else Plain $ singleton c
pure $ if c == '\n' then EscapedNewline else Plain $ singleton c
stringChar end escStart esc =
Antiquoted <$> (antiStart *> nixToplevelForm <* char '}')
<+> Plain . singleton <$> char '$'
Antiquoted
<$> (antiStart *> nixToplevelForm <* char '}')
<+> Plain
. singleton
<$> char '$'
<+> esc
<+> Plain . pack <$> some plainChar
<+> Plain
. pack
<$> some plainChar
where
plainChar =
notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle
@ -300,8 +353,11 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
-- in the case of, for example `x:y`. Is it a lambda function `x: y`, or
-- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if
-- there's a valid URI parse here.
onlyname = msum [nixUri >> unexpected (Label ('v' NE.:| "alid uri")),
Param <$> identifier]
onlyname =
msum
[ nixUri >> unexpected (Label ('v' NE.:| "alid uri"))
, Param <$> identifier
]
-- Parameters named by an identifier on the left (`args @ {x, y}`)
atLeft = try $ do
@ -348,7 +404,8 @@ nixBinders = (inherit <+> namedVar) `endBy` semi where
Inherit x <$> many keyName <*> pure p <?> "inherited binding"
namedVar = do
p <- getSourcePos
NamedVar <$> (annotated <$> nixSelector)
NamedVar
<$> (annotated <$> nixSelector)
<*> (equals *> nixToplevelForm)
<*> pure p
<?> "variable binding"
@ -360,9 +417,8 @@ keyName = dynamicKey <+> staticKey where
dynamicKey = DynamicKey <$> nixAntiquoted nixString'
nixSet :: Parser NExprLoc
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set") where
isRec = (reserved "rec" $> NRecSet <?> "recursive set")
<+> pure NSet
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set")
where isRec = (reserved "rec" $> NRecSet <?> "recursive set") <+> pure NSet
parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
parseNixFile =
@ -381,8 +437,7 @@ parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
{- Parser.Library -}
skipLineComment' :: Tokens Text -> Parser ()
skipLineComment' prefix =
string prefix
skipLineComment' prefix = string prefix
*> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
whiteSpace :: Parser ()
@ -398,18 +453,41 @@ symbol :: Text -> Parser Text
symbol = lexeme . string
reservedEnd :: Char -> Bool
reservedEnd x = isSpace x ||
x == '{' || x == '(' || x == '[' ||
x == '}' || x == ')' || x == ']' ||
x == ';' || x == ':' || x == '.' ||
x == '"' || x == '\'' || x == ','
reservedEnd x =
isSpace x
|| x
== '{'
|| x
== '('
|| x
== '['
|| x
== '}'
|| x
== ')'
|| x
== ']'
|| x
== ';'
|| x
== ':'
|| x
== '.'
|| x
== '"'
|| x
== '\''
|| x
== ','
reserved :: Text -> Parser ()
reserved n = lexeme $ try $
string n *> lookAhead (void (satisfy reservedEnd) <|> eof)
reserved n =
lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof)
identifier = lexeme $ try $ do
ident <- cons <$> satisfy (\x -> isAlpha x || x == '_')
ident <-
cons
<$> satisfy (\x -> isAlpha x || x == '_')
<*> takeWhileP Nothing identLetter
guard (not (ident `HashSet.member` reservedNames))
return ident
@ -435,12 +513,7 @@ float = lexeme L.float
reservedNames :: HashSet Text
reservedNames = HashSet.fromList
[ "let", "in"
, "if", "then", "else"
, "assert"
, "with"
, "rec"
, "inherit" ]
["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"]
type Parser = ParsecT Void Text Identity
@ -449,13 +522,13 @@ data Result a = Success a | Failure (Doc Void) deriving (Show, Functor)
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
parseFromFileEx p path = do
txt <- decodeUtf8 <$> readFile path
return $ either (Failure . pretty . errorBundlePretty) Success
$ parse p path txt
return $ either (Failure . pretty . errorBundlePretty) Success $ parse p
path
txt
parseFromText :: Parser a -> Text -> Result a
parseFromText p txt =
either (Failure . pretty . errorBundlePretty) Success $
parse p "<string>" txt
either (Failure . pretty . errorBundlePretty) Success $ parse p "<string>" txt
{- Parser.Operators -}
@ -491,17 +564,18 @@ operator n = symbol n
opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a
opWithLoc name op f = do
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} operator name
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -}
operator name
return $ f (Ann ann op)
binaryN name op = (NBinaryDef name op NAssocNone,
InfixN (opWithLoc name op nBinary))
binaryL name op = (NBinaryDef name op NAssocLeft,
InfixL (opWithLoc name op nBinary))
binaryR name op = (NBinaryDef name op NAssocRight,
InfixR (opWithLoc name op nBinary))
prefix name op = (NUnaryDef name op,
Prefix (manyUnaryOp (opWithLoc name op nUnary)))
binaryN name op =
(NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary))
binaryL name op =
(NBinaryDef name op NAssocLeft, InfixL (opWithLoc name op nBinary))
binaryR name op =
(NBinaryDef name op NAssocRight, InfixR (opWithLoc name op nBinary))
prefix name op =
(NUnaryDef name op, Prefix (manyUnaryOp (opWithLoc name op nUnary)))
-- postfix name op = (NUnaryDef name op,
-- Postfix (opWithLoc name op nUnary))
@ -521,28 +595,40 @@ nixOperators selector =
-- mor <- optional (reserved "or" *> term)
-- return $ \x -> nSelectLoc x sel mor) ]
{- 2 -} [ (NBinaryDef " " NApp NAssocLeft,
{- 2 -}
[ ( NBinaryDef " " NApp NAssocLeft
,
-- Thanks to Brent Yorgey for showing me this trick!
InfixL $ nApp <$ symbol "") ]
, {- 3 -} [ prefix "-" NNeg ]
, {- 4 -} [ (NSpecialDef "?" NHasAttrOp NAssocLeft,
Postfix $ symbol "?" *> (flip nHasAttr <$> selector)) ]
, {- 5 -} [ binaryR "++" NConcat ]
, {- 6 -} [ binaryL "*" NMult
, binaryL "/" NDiv ]
, {- 7 -} [ binaryL "+" NPlus
, binaryL "-" NMinus ]
, {- 8 -} [ prefix "!" NNot ]
, {- 9 -} [ binaryR "//" NUpdate ]
, {- 10 -} [ binaryL "<" NLt
, binaryL ">" NGt
, binaryL "<=" NLte
, binaryL ">=" NGte ]
, {- 11 -} [ binaryN "==" NEq
, binaryN "!=" NNEq ]
, {- 12 -} [ binaryL "&&" NAnd ]
, {- 13 -} [ binaryL "||" NOr ]
, {- 14 -} [ binaryN "->" NImpl ]
InfixL $ nApp <$ symbol ""
)
]
, {- 3 -}
[prefix "-" NNeg]
, {- 4 -}
[ ( NSpecialDef "?" NHasAttrOp NAssocLeft
, Postfix $ symbol "?" *> (flip nHasAttr <$> selector)
)
]
, {- 5 -}
[binaryR "++" NConcat]
, {- 6 -}
[binaryL "*" NMult, binaryL "/" NDiv]
, {- 7 -}
[binaryL "+" NPlus, binaryL "-" NMinus]
, {- 8 -}
[prefix "!" NNot]
, {- 9 -}
[binaryR "//" NUpdate]
, {- 10 -}
[binaryL "<" NLt, binaryL ">" NGt, binaryL "<=" NLte, binaryL ">=" NGte]
, {- 11 -}
[binaryN "==" NEq, binaryN "!=" NNEq]
, {- 12 -}
[binaryL "&&" NAnd]
, {- 13 -}
[binaryL "||" NOr]
, {- 14 -}
[binaryN "->" NImpl]
]
data OperatorInfo = OperatorInfo
@ -553,7 +639,8 @@ data OperatorInfo = OperatorInfo
getUnaryOperator :: NUnaryOp -> OperatorInfo
getUnaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)]
@ -561,7 +648,8 @@ getUnaryOperator = (m Map.!) where
getBinaryOperator :: NBinaryOp -> OperatorInfo
getBinaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
@ -570,8 +658,17 @@ getBinaryOperator = (m Map.!) where
getSpecialOperator :: NSpecialOp -> OperatorInfo
getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "."
getSpecialOperator o = m Map.! o where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> []

229
src/Nix/Pretty.hs
View File

@ -22,11 +22,19 @@ import Data.Fix
import Data.HashMap.Lazy ( toList )
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as HashSet
import Data.List (isPrefixOf, sort)
import Data.List ( isPrefixOf
, sort
)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust, fromMaybe)
import Data.Text (pack, unpack, replace, strip)
import Data.Maybe ( isJust
, fromMaybe
)
import Data.Text ( pack
, unpack
, replace
, strip
)
import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Nix.Atoms
@ -96,29 +104,35 @@ hasAttrOp = getSpecialOperator NHasAttrOp
wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann
wrapParens op sub
| precedence (rootOp sub) < precedence op = withoutParens sub
| precedence (rootOp sub) == precedence op
&& associativity (rootOp sub) == associativity op
&& associativity op /= NAssocNone = withoutParens sub
| otherwise = parens $ withoutParens sub
| precedence (rootOp sub) < precedence op
= withoutParens sub
| precedence (rootOp sub)
== precedence op
&& associativity (rootOp sub)
== associativity op
&& associativity op
/= NAssocNone
= withoutParens sub
| otherwise
= parens $ withoutParens sub
-- Used in the selector case to print a path in a selector as
-- "${./abc}"
wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann
wrapPath op sub =
if wasPath sub
wrapPath op sub = if wasPath sub
then dquotes $ "$" <> braces (withoutParens sub)
else wrapParens op sub
prettyString :: NString (NixDoc ann) -> Doc ann
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
where prettyPart (Plain t) = pretty . concatMap escape . unpack $ t
where
prettyPart (Plain t) = pretty . concatMap escape . unpack $ t
prettyPart EscapedNewline = "''\\n"
prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
escape '"' = "\\\""
escape x = maybe [x] (('\\' :) . (: [])) $ toEscapeCode x
prettyString (Indented _ parts)
= group $ nest 2 $ vcat [dsquote, content, dsquote]
prettyString (Indented _ parts) = group $ nest 2 $ vcat
[dsquote, content, dsquote]
where
dsquote = squote <> squote
content = vsep . map prettyLine . stripLastIfEmpty . splitLines $ parts
@ -126,7 +140,8 @@ prettyString (Indented _ parts)
f ([Plain t] : xs) | Text.null (strip t) = xs
f xs = xs
prettyLine = hcat . map prettyPart
prettyPart (Plain t) = pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t
prettyPart (Plain t) =
pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t
prettyPart EscapedNewline = "\\n"
prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
@ -138,8 +153,11 @@ prettyParams (ParamSet s v mname) = prettyParamSet s v <> case mname of
| otherwise -> "@" <> pretty (unpack name)
prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann
prettyParamSet args var =
encloseSep (lbrace <> space) (align (space <> rbrace)) sep (map prettySetArg args ++ prettyVariadic)
prettyParamSet args var = encloseSep
(lbrace <> space)
(align (space <> rbrace))
sep
(map prettySetArg args ++ prettyVariadic)
where
prettySetArg (n, maybeDef) = case maybeDef of
Nothing -> pretty (unpack n)
@ -150,18 +168,20 @@ prettyParamSet args var =
prettyBind :: Binding (NixDoc ann) -> Doc ann
prettyBind (NamedVar n v _p) =
prettySelector n <+> equals <+> withoutParens v <> semi
prettyBind (Inherit s ns _p)
= "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi
prettyBind (Inherit s ns _p) =
"inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi
where scope = maybe mempty ((<> space) . parens . withoutParens) s
prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann
prettyKeyName (StaticKey "") = dquotes ""
prettyKeyName (StaticKey key)
| HashSet.member key reservedNames = dquotes $ pretty $ unpack key
prettyKeyName (StaticKey key) | HashSet.member key reservedNames =
dquotes $ pretty $ unpack key
prettyKeyName (StaticKey key) = pretty . unpack $ key
prettyKeyName (DynamicKey key) =
runAntiquoted (DoubleQuoted [Plain "\n"])
prettyString (("$" <>) . braces . withoutParens) key
prettyKeyName (DynamicKey key) = runAntiquoted
(DoubleQuoted [Plain "\n"])
prettyString
(("$" <>) . braces . withoutParens)
key
prettySelector :: NAttrPath (NixDoc ann) -> Doc ann
prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList
@ -177,8 +197,11 @@ instance HasCitations1 t f m
citations (NValue f) = citations1 f
addProvenance x (NValue f) = NValue (addProvenance1 x f)
prettyOriginExpr :: forall t f m ann. HasCitations1 t f m
=> NExprLocF (Maybe (NValue t f m)) -> Doc ann
prettyOriginExpr
:: forall t f m ann
. HasCitations1 t f m
=> NExprLocF (Maybe (NValue t f m))
-> Doc ann
prettyOriginExpr = withoutParens . go
where
go = exprFNixDoc . annotated . getCompose . fmap render
@ -197,27 +220,34 @@ exprFNixDoc = \case
NConstant atom -> prettyAtom atom
NStr str -> simpleExpr $ prettyString str
NList [] -> simpleExpr $ lbracket <> rbracket
NList xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
[ [lbracket]
, map (wrapParens appOpNonAssoc) xs
, [rbracket]
]
NList xs ->
simpleExpr
$ group
$ nest 2
$ vsep
$ concat
$ [[lbracket], map (wrapParens appOpNonAssoc) xs, [rbracket]]
NSet [] -> simpleExpr $ lbrace <> rbrace
NSet xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
[ [lbrace]
, map prettyBind xs
, [rbrace]
]
NSet xs ->
simpleExpr
$ group
$ nest 2
$ vsep
$ concat
$ [[lbrace], map prettyBind xs, [rbrace]]
NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
NRecSet xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
[ [recPrefix <> lbrace]
, map prettyBind xs
, [rbrace]
]
NAbs args body -> leastPrecedence $ nest 2 $ vsep $
[ prettyParams args <> colon
, withoutParens body
]
NRecSet xs ->
simpleExpr
$ group
$ nest 2
$ vsep
$ concat
$ [[recPrefix <> lbrace], map prettyBind xs, [rbrace]]
NAbs args body ->
leastPrecedence
$ nest 2
$ vsep
$ [prettyParams args <> colon, withoutParens body]
NBinary NApp fun arg ->
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
@ -229,12 +259,16 @@ exprFNixDoc = \case
opInfo = getBinaryOperator op
f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }
| otherwise = opInfo
NUnary op r1 ->
mkNixDoc (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
NUnary op r1 -> mkNixDoc
(pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1)
opInfo
where opInfo = getUnaryOperator op
NSelect r' attr o ->
(if isJust o then leastPrecedence else flip mkNixDoc selectOp) $
wrapPath selectOp r <> dot <> prettySelector attr <> ordoc
(if isJust o then leastPrecedence else flip mkNixDoc selectOp)
$ wrapPath selectOp r
<> dot
<> prettySelector attr
<> ordoc
where
r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r'
ordoc = maybe mempty (((space <> "or") <+>) . wrapParens appOpNonAssoc) o
@ -251,28 +285,33 @@ exprFNixDoc = \case
| "../" `isPrefixOf` txt -> txt
| otherwise -> "./" ++ txt
NSym name -> simpleExpr $ pretty (unpack name)
NLet binds body -> leastPrecedence $ group $ vsep $
[ "let"
NLet binds body ->
leastPrecedence
$ group
$ vsep
$ [ "let"
, indent 2 (vsep (map prettyBind binds))
, "in" <+> withoutParens body
]
NIf cond trueBody falseBody -> leastPrecedence $
group $ nest 2 $ vsep $
[ "if" <+> withoutParens cond
NIf cond trueBody falseBody ->
leastPrecedence
$ group
$ nest 2
$ vsep
$ [ "if" <+> withoutParens cond
, align ("then" <+> withoutParens trueBody)
, align ("else" <+> withoutParens falseBody)
]
NWith scope body -> leastPrecedence $ vsep $
[ "with" <+> withoutParens scope <> semi
, align $ withoutParens body
]
NAssert cond body -> leastPrecedence $ vsep $
[ "assert" <+> withoutParens cond <> semi
, align $ withoutParens body
]
NWith scope body ->
leastPrecedence
$ vsep
$ ["with" <+> withoutParens scope <> semi, align $ withoutParens body]
NAssert cond body ->
leastPrecedence
$ vsep
$ ["assert" <+> withoutParens cond <> semi, align $ withoutParens body]
NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
where
recPrefix = "rec" <> space
where recPrefix = "rec" <> space
valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr
valueToExpr = iterNValueNF
@ -285,7 +324,8 @@ valueToExpr = iterNValueNF
phi (NVList l ) = Fix $ NList l
phi (NVSet s p ) = Fix $ NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s ]
| (k, v) <- toList s
]
phi (NVClosure _ _ ) = Fix . NSym . pack $ "<closure>"
phi (NVPath p ) = Fix $ NLiteralPath p
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
@ -304,15 +344,19 @@ printNix = iterNValueNF (const "<CYCLE>") phi
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
phi (NVList l ) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
"{ " ++ concat [ check (unpack k) ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
"{ "
++ concat
[ check (unpack k) ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s
]
++ "}"
where
check v =
fromMaybe v
check v = fromMaybe
v
( (fmap (surround . show) (readMaybe v :: Maybe Int))
<|> (fmap (surround . show) (readMaybe v :: Maybe Float)))
where
surround s = "\"" ++ s ++ "\""
<|> (fmap (surround . show) (readMaybe v :: Maybe Float))
)
where surround s = "\"" ++ s ++ "\""
phi NVClosure{} = "<<lambda>>"
phi (NVPath fp ) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
@ -320,43 +364,60 @@ printNix = iterNValueNF (const "<CYCLE>") phi
prettyNValue
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> m (Doc ann)
=> NValue t f m
-> m (Doc ann)
prettyNValue = fmap prettyNValueNF . removeEffectsM
prettyNValueProv
:: forall t f m ann.
( HasCitations1 t f m
:: forall t f m ann
. ( HasCitations1 t f m
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> NValue t f m -> m (Doc ann)
=> NValue t f m
-> m (Doc ann)
prettyNValueProv v@(NValue nv) = do
let ps = citations1 @t @f @m nv
case ps of
[] -> prettyNValue v
ps -> do
v' <- prettyNValue v
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
pure
$ fillSep
$ [ v'
, indent 2
$ parens
$ mconcat
$ "from: "
: map (prettyOriginExpr . _originExpr) ps
]
prettyNThunk
:: forall t f m ann.
( HasCitations t f m t
:: forall t f m ann
. ( HasCitations t f m t
, HasCitations1 t f m
, MonadThunk t m (NValue t f m)
, MonadDataContext f m
)
=> t -> m (Doc ann)
=> t
-> m (Doc ann)
prettyNThunk t = do
let ps = citations @t @f @m @t t
v' <- prettyNValueNF <$> dethunk t
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
pure
$ fillSep
$ [ v'
, indent 2
$ parens
$ mconcat
$ "thunk from: "
: map (prettyOriginExpr . _originExpr) ps
]

98
src/Nix/Reduce.hs
View File

@ -41,7 +41,8 @@ import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Reader ( ReaderT(..) )
import Control.Monad.Trans.State.Strict (StateT(..))
import Control.Monad.Trans.State.Strict
( StateT(..) )
import Data.Fix
-- import Data.Foldable
import Data.HashMap.Lazy ( HashMap )
@ -51,13 +52,19 @@ import qualified Data.HashMap.Lazy as M
import Data.IORef
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
import Data.Maybe ( fromMaybe
, mapMaybe
, catMaybes
)
import Data.Text ( Text )
import Nix.Atoms
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Options (Options, reduceSets, reduceLists)
import Nix.Options ( Options
, reduceSets
, reduceLists
)
import Nix.Parser
import Nix.Scope
import Nix.Utils
@ -73,11 +80,16 @@ newtype Reducer m a = Reducer
MonadState (HashMap FilePath NExprLoc))
staticImport
:: forall m.
(MonadIO m, Scoped NExprLoc m, MonadFail m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
:: forall m
. ( MonadIO m
, Scoped NExprLoc m
, MonadFail m
, MonadReader (Maybe FilePath, Scopes m NExprLoc) m
, MonadState (HashMap FilePath NExprLoc) m
)
=> SrcSpan
-> FilePath
-> m NExprLoc
staticImport pann path = do
mfile <- asks fst
path <- liftIO $ pathToDefaultNixFile path
@ -96,10 +108,12 @@ staticImport pann path = do
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success x -> do
let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
let
pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
span = SrcSpan pos pos
cur = NamedVar (StaticKey "__cur_file" :| [])
(Fix (NLiteralPath_ pann path)) pos
(Fix (NLiteralPath_ pann path))
pos
x' = Fix (NLet_ span [cur] x)
modify (M.insert path x')
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
@ -112,19 +126,24 @@ staticImport pann path = do
-- NSym_ _ var -> S.singleton var
-- Compose (Ann _ x) -> fold x
reduceExpr :: (MonadIO m, MonadFail m)
=> Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr mpath expr
= (`evalStateT` M.empty)
reduceExpr
:: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr mpath expr =
(`evalStateT` M.empty)
. (`runReaderT` (mpath, emptyScopes))
. runReducer
$ cata reduce expr
reduce :: forall m.
(MonadIO m, Scoped NExprLoc m, MonadFail m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
reduce
:: forall m
. ( MonadIO m
, Scoped NExprLoc m
, MonadFail m
, MonadReader (Maybe FilePath, Scopes m NExprLoc) 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.
@ -207,8 +226,7 @@ reduce e@(NSet_ ann binds) = do
Inherit{} -> True
_ -> False
if usesInherit
then clearScopes @NExprLoc $
Fix . NSet_ ann <$> traverse sequence binds
then clearScopes @NExprLoc $ Fix . NSet_ ann <$> traverse sequence binds
else Fix <$> sequence e
-- Encountering a 'rec set' construction eliminates any hope of inlining
@ -280,8 +298,7 @@ instance Show (f r) => Show (FlaggedF f r) where
type Flagged f = Fix (FlaggedF f)
flagExprLoc :: (MonadIO n, Traversable f)
=> Fix f -> n (Flagged f)
flagExprLoc :: (MonadIO n, Traversable f) => Fix f -> n (Flagged f)
flagExprLoc = cataM $ \x -> do
flag <- liftIO $ newIORef False
pure $ Fix $ FlaggedF (flag, x)
@ -292,21 +309,21 @@ flagExprLoc = cataM $ \x -> do
pruneTree :: MonadIO n => Options -> Flagged NExprLocF -> n (Maybe NExprLoc)
pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
used <- liftIO $ readIORef b
pure $ if used
then Fix . Compose <$> traverse prune x
else Nothing
pure $ if used then Fix . Compose <$> traverse prune x else Nothing
where
prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
prune = \case
NStr str -> Just $ NStr (pruneString str)
NHasAttr (Just aset) attr -> Just $ NHasAttr aset (NE.map pruneKeyName attr)
NHasAttr (Just aset) attr ->
Just $ NHasAttr aset (NE.map pruneKeyName attr)
NAbs params (Just body) -> Just $ NAbs (pruneParams params) body
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)
NRecSet binds
| reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds)
| otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds)
NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
@ -341,8 +358,7 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body
NAssert (Just cond) _ -> Just $ NAssert cond nNull
NIf Nothing _ _ ->
error "How can an if be used, but its condition not?"
NIf Nothing _ _ -> error "How can an if be used, but its condition not?"
NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f
NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t
@ -352,12 +368,10 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
pruneString (DoubleQuoted xs) =
DoubleQuoted (mapMaybe pruneAntiquotedText xs)
pruneString (Indented n xs) =
Indented n (mapMaybe pruneAntiquotedText xs)
pruneString (Indented n xs) = Indented n (mapMaybe pruneAntiquotedText xs)
pruneAntiquotedText
:: Antiquoted Text (Maybe NExprLoc)
-> Maybe (Antiquoted Text NExprLoc)
:: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText (Plain v) = Just (Plain v)
pruneAntiquotedText EscapedNewline = Just EscapedNewline
pruneAntiquotedText (Antiquoted Nothing ) = Nothing
@ -373,18 +387,17 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (StaticKey n) = StaticKey n
pruneKeyName (DynamicKey k)
| Just k' <- pruneAntiquoted k = DynamicKey k'
pruneKeyName (DynamicKey k) | Just k' <- pruneAntiquoted k = DynamicKey k'
| otherwise = StaticKey "<unused?>"
pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param n) = Param n
pruneParams (ParamSet xs b n)
| reduceSets opts =
ParamSet (map (second (maybe (Just nNull) Just
. fmap (fromMaybe nNull))) xs) b n
| otherwise =
ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n
| reduceSets opts = ParamSet
(map (second (maybe (Just nNull) Just . fmap (fromMaybe nNull))) xs)
b
n
| otherwise = ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n
pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar _ Nothing _) = Nothing
@ -407,8 +420,7 @@ reducingEvalExpr eval mpath expr = do
opts :: Options <- asks (view hasLens)
expr'' <- pruneTree opts expr'
return (fromMaybe nNull expr'', eres)
where
addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
where addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
instance Monad m => Scoped NExprLoc (Reducer m) where
currentScopes = currentScopesReader

45
src/Nix/Render.hs
View File

@ -68,48 +68,59 @@ instance MonadFile IO where
getSymbolicLinkStatus = S.getSymbolicLinkStatus
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg (SourcePos _ lineNo _) msg =
FancyError (unPos lineNo)
posAndMsg (SourcePos _ lineNo _) msg = FancyError
(unPos lineNo)
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
renderLocation (SrcSpan (SourcePos file begLine begCol)
(SourcePos file' endLine endCol)) msg
| file /= "<string>" && file == file' = do
renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg
| file /= "<string>" && file == file'
= do
exist <- doesFileExist file
if exist
then do
txt <- sourceContext file begLine begCol endLine endCol msg
return $ vsep
[ "In file " <> errorContext file begLine begCol endLine endCol <> ":"
return
$ vsep
[ "In file "
<> errorContext file begLine begCol endLine endCol
<> ":"
, txt
]
else return msg
renderLocation (SrcSpan beg end) msg =
fail $ "Don't know how to render range from " ++ show beg ++ " to " ++ show end
++ " for error: " ++ show msg
fail
$ "Don't know how to render range from "
++ show beg
++ " to "
++ show end
++ " for error: "
++ show msg
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext path bl bc _el _ec =
pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc)
sourceContext :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext path (unPos -> begLine) (unPos -> _begCol)
(unPos -> endLine) (unPos -> _endCol) msg = do
sourceContext
:: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg
= do
let beg' = max 1 (min begLine (begLine - 3))
end' = max endLine (endLine + 3)
ls <- map pretty
ls <-
map pretty
. take (end' - beg')
. drop (pred beg')
. T.lines
. T.decodeUtf8
<$> readFile path
let nums = map (show . fst) $ zip [beg'..] ls
let
nums = map (show . fst) $ zip [beg' ..] ls
longest = maximum (map length nums)
nums' = flip map nums $ \n ->
replicate (longest - length n) ' ' ++ n
nums' = flip map nums $ \n -> replicate (longest - length n) ' ' ++ n
pad n | read n == begLine = "==> " ++ n
| otherwise = " " ++ n
ls' = zipWith (<+>) (map (pretty . pad) nums')
ls' = zipWith (<+>)
(map (pretty . pad) nums')
(zipWith (<+>) (repeat "| ") ls)
pure $ vsep $ ls' ++ [msg]

164
src/Nix/Render/Frame.hs
View File

@ -41,18 +41,17 @@ renderFrames
, MonadCitedThunks t f m
, Typeable v
)
=> Frames -> m (Doc ann)
=> Frames
-> m (Doc ann)
renderFrames [] = pure mempty
renderFrames (x : xs) = do
opts :: Options <- asks (view hasLens)
frames <-
if | verbose opts <= ErrorsOnly ->
renderFrame @v @t @f x
frames <- if
| verbose opts <= ErrorsOnly -> renderFrame @v @t @f x
| verbose opts <= Informational -> do
f <- renderFrame @v @t @f x
pure $ concatMap go (reverse xs) ++ f
| otherwise ->
concat <$> mapM (renderFrame @v @t @f) (reverse (x:xs))
| otherwise -> concat <$> mapM (renderFrame @v @t @f) (reverse (x : xs))
pure $ case frames of
[] -> mempty
_ -> vsep frames
@ -60,29 +59,30 @@ renderFrames (x:xs) = do
go :: NixFrame -> [Doc ann]
go f = case framePos @v @m f of
Just pos ->
["While evaluating at "
<> pretty (sourcePosPretty pos)
<> colon]
["While evaluating at " <> pretty (sourcePosPretty pos) <> colon]
Nothing -> []
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v)
=> NixFrame -> Maybe SourcePos
framePos
:: forall v (m :: * -> *)
. (Typeable m, Typeable v)
=> NixFrame
-> Maybe SourcePos
framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
Just beg
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg
_ -> Nothing
| otherwise = Nothing
renderFrame
:: forall v t f e m ann.
( MonadReader e m
:: forall v t f e m ann
. ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
, Typeable v
)
=> NixFrame -> m [Doc ann]
=> NixFrame
-> m [Doc ann]
renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
@ -96,39 +96,50 @@ renderFrame (NixFrame level f)
wrapExpr :: NExprF r -> NExpr
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel -> EvalFrame m v -> m [Doc ann]
renderEvalFrame
:: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel
-> EvalFrame m v
-> m [Doc ann]
renderEvalFrame level f = do
opts :: Options <- asks (view hasLens)
case f of
EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do
let scopeInfo | scopes opts = [pretty $ show scope]
| otherwise = []
fmap (\x -> scopeInfo ++ [x]) $ renderLocation ann
fmap (\x -> scopeInfo ++ [x])
$ renderLocation ann
=<< renderExpr level "While evaluating" "Expression" e
ForcingExpr _scope e@(Fix (Compose (Ann ann _)))
| thunks opts ->
fmap (:[]) $ renderLocation ann
=<< renderExpr level "While forcing thunk from"
"Forcing thunk" e
ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts ->
fmap (: [])
$ renderLocation ann
=<< renderExpr level "While forcing thunk from" "Forcing thunk" e
Calling name ann ->
fmap (:[]) $ renderLocation ann $
"While calling builtins." <> pretty name
fmap (: [])
$ renderLocation ann
$ "While calling builtins."
<> pretty name
SynHole synfo -> sequence $
let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
in [ renderLocation ann =<<
renderExpr level "While evaluating" "Syntactic Hole" e
SynHole synfo ->
sequence
$ let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
in [ renderLocation ann
=<< renderExpr level "While evaluating" "Syntactic Hole" e
, pure $ pretty $ show (_synHoleInfo_scope synfo)
]
ForcingExpr _ _ -> pure []
renderExpr :: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel -> String -> String -> NExprLoc -> m (Doc ann)
renderExpr
:: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel
-> String
-> String
-> NExprLoc
-> m (Doc ann)
renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
opts :: Options <- asks (view hasLens)
let rendered
@ -138,25 +149,19 @@ renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
#else
pretty (show (stripAnnotation e))
#endif
| verbose opts >= Chatty =
prettyNix (stripAnnotation e)
| otherwise =
prettyNix (Fix (Fix (NSym "<?>") <$ x))
| verbose opts >= Chatty = prettyNix (stripAnnotation e)
| otherwise = prettyNix (Fix (Fix (NSym "<?>") <$ x))
pure $ if verbose opts >= Chatty
then vsep $
[ pretty (longLabel ++ ":\n>>>>>>>>")
, indent 2 rendered
, "<<<<<<<<"
]
then
vsep
$ [pretty (longLabel ++ ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"]
else pretty shortLabel <> fillSep [": ", rendered]
renderValueFrame
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> ValueFrame t f m -> m [Doc ann]
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
=> NixLevel
-> ValueFrame t f m
-> m [Doc ann]
renderValueFrame level = fmap (: []) . \case
ForcingThunk -> pure "ForcingThunk"
ConcerningValue _v -> pure "ConcerningValue"
@ -165,12 +170,8 @@ renderValueFrame level = fmap (:[]) . \case
Division _ _ -> pure "Dividing"
Multiplication _ _ -> pure "Multiplying"
Coercion x y -> pure $ mconcat
[ desc
, pretty (describeValue x)
, " to "
, pretty (describeValue y)
]
Coercion x y -> pure
$ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)]
where
desc | level <= Error = "Cannot coerce "
| otherwise = "While coercing "
@ -182,49 +183,54 @@ renderValueFrame level = fmap (:[]) . \case
ExpectationNF _t _v -> pure "ExpectationNF"
Expectation t v -> do
v' <- renderValue level "" "" v
pure $ "Saw " <> v'
<> " but expected " <> pretty (describeValue t)
pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
renderValue
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
=> NixLevel
-> String
-> String
-> NValue t f m
-> m (Doc ann)
renderValue _level _longLabel _shortLabel v = do
opts :: Options <- asks (view hasLens)
if values opts
then prettyNValueProv v
else prettyNValue v
if values opts then prettyNValueProv v else prettyNValue v
renderExecFrame
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> ExecFrame t f m -> m [Doc ann]
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
=> NixLevel
-> ExecFrame t f m
-> m [Doc ann]
renderExecFrame level = \case
Assertion ann v ->
fmap (:[]) $ renderLocation ann
fmap (: [])
$ renderLocation ann
=<< ( (\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v)
<$> renderValue level "" "" v
)
renderThunkLoop
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> NixLevel -> ThunkLoop -> m [Doc ann]
=> NixLevel
-> ThunkLoop
-> m [Doc ann]
renderThunkLoop _level = pure . (: []) . \case
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n
renderNormalLoop
:: ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
)
=> NixLevel -> NormalLoop t f m -> m [Doc ann]
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
=> NixLevel
-> NormalLoop t f m
-> m [Doc ann]
renderNormalLoop level = fmap (: []) . \case
NormalLoop v -> do
v' <- renderValue level "" "" v
pure $ "Infinite recursion during normalization forcing " <> v'

27
src/Nix/Scope.hs
View File

@ -31,8 +31,7 @@ newScope = Scope
scopeLookup :: Text -> [Scope t] -> Maybe t
scopeLookup key = foldr go Nothing
where
go (Scope m) rest = M.lookup key m <|> rest
where go (Scope m) rest = M.lookup key m <|> rest
data Scopes m t = Scopes
{ lexicalScopes :: [Scope t]
@ -41,8 +40,7 @@ data Scopes m t = Scopes
instance Show (Scopes m t) where
show (Scopes m t) =
"Scopes: " ++ show m ++ ", and "
++ show (length t) ++ " with-scopes"
"Scopes: " ++ show m ++ ", and " ++ show (length t) ++ " with-scopes"
instance Semigroup (Scopes m t) where
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
@ -60,10 +58,12 @@ class Scoped t m | m -> t where
pushScopes :: Scopes m t -> m a -> m a
lookupVar :: Text -> m (Maybe t)
currentScopesReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)
currentScopesReader
:: forall m t e . (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)
currentScopesReader = asks (view hasLens)
clearScopesReader :: forall m t e a. (MonadReader e m, Has e (Scopes m t)) => m a -> m a
clearScopesReader
:: forall m t e a . (MonadReader e m, Has e (Scopes m t)) => m a -> m a
clearScopesReader = local (set hasLens (emptyScopes @m @t))
pushScope :: Scoped t m => AttrSet t -> m a -> m a
@ -72,22 +72,27 @@ pushScope s = pushScopes (Scopes [Scope s] [])
pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
pushScopesReader :: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a
pushScopesReader
:: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a
pushScopesReader s = local (over hasLens (s <>))
lookupVarReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)
lookupVarReader
:: forall m t e . (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)
lookupVarReader k = do
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
case mres of
Just sym -> return $ Just sym
Nothing -> do
ws <- asks (dynamicScopes . view hasLens)
foldr (\x rest -> do
foldr
(\x rest -> do
mres' <- M.lookup k . getScope <$> x
case mres' of
Just sym -> return $ Just sym
Nothing -> rest)
(return Nothing) ws
Nothing -> rest
)
(return Nothing)
ws
withScopes :: Scoped t m => Scopes m t -> m a -> m a
withScopes scope = clearScopes . pushScopes scope

25
src/Nix/String.hs
View File

@ -2,8 +2,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Nix.String (
NixString
module Nix.String
( NixString
, principledGetContext
, principledMakeNixString
, principledMempty
@ -29,7 +29,8 @@ module Nix.String (
, addSingletonStringContext
, runWithStringContextT
, runWithStringContext
) where
)
where
import Control.Monad.Writer
import Data.Functor.Identity
@ -73,11 +74,13 @@ principledMempty = NixString "" mempty
-- | Combine two NixStrings using mappend
principledStringMappend :: NixString -> NixString -> NixString
principledStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
principledStringMappend (NixString s1 t1) (NixString s2 t2) =
NixString (s1 <> s2) (t1 <> t2)
-- | Combine two NixStrings using mappend
hackyStringMappend :: NixString -> NixString -> NixString
hackyStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
hackyStringMappend (NixString s1 t1) (NixString s2 t2) =
NixString (s1 <> s2) (t1 <> t2)
-- | Combine NixStrings with a separator
principledIntercalateNixString :: NixString -> [NixString] -> NixString
@ -98,7 +101,8 @@ principledStringMempty = NixString mempty mempty
-- | Combine NixStrings using mconcat
principledStringMConcat :: [NixString] -> NixString
principledStringMConcat = foldr principledStringMappend (NixString mempty mempty)
principledStringMConcat =
foldr principledStringMappend (NixString mempty mempty)
--instance Semigroup NixString where
--NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
@ -142,7 +146,8 @@ principledModifyNixContents :: (Text -> Text) -> NixString -> NixString
principledModifyNixContents f (NixString s c) = NixString (f s) c
-- | Create a NixString using a singleton context
principledMakeNixStringWithSingletonContext :: Text -> StringContext -> NixString
principledMakeNixStringWithSingletonContext
:: Text -> StringContext -> NixString
principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)
-- | Create a NixString from a Text and context
@ -156,7 +161,8 @@ newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringCo
type WithStringContext = WithStringContextT Identity
-- | Add 'StringContext's into the resulting set.
addStringContext :: Monad m => S.HashSet StringContext -> WithStringContextT m ()
addStringContext
:: Monad m => S.HashSet StringContext -> WithStringContextT m ()
addStringContext = WithStringContextT . tell
-- | Add a 'StringContext' into the resulting set.
@ -169,7 +175,8 @@ extractNixString (NixString s c) = WithStringContextT $ tell c >> return s
-- | Run an action producing a string with a context and put those into a 'NixString'.
runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString
runWithStringContextT (WithStringContextT m) = uncurry NixString <$> runWriterT m
runWithStringContextT (WithStringContextT m) =
uncurry NixString <$> runWriterT m
-- | Run an action producing a string with a context and put those into a 'NixString'.
runWithStringContext :: WithStringContextT Identity Text -> NixString

32
src/Nix/Strings.hs
View File

@ -4,7 +4,10 @@
-- | Functions for manipulating nix strings.
module Nix.Strings where
import Data.List (intercalate, dropWhileEnd, inits)
import Data.List ( intercalate
, dropWhileEnd
, inits
)
import Data.Monoid ( (<>) )
import Data.Text ( Text )
import qualified Data.Text as T
@ -62,10 +65,18 @@ stripIndent xs =
. mergePlain
. map snd
. dropWhileEnd cleanup
. (\ys -> zip (map (\case [] -> Nothing
x -> Just (last x))
(inits ys)) ys)
. unsplitLines $ ls'
. (\ys -> zip
(map
(\case
[] -> Nothing
x -> Just (last x)
)
(inits ys)
)
ys
)
. unsplitLines
$ ls'
where
ls = stripEmptyOpening $ splitLines xs
ls' = map (dropSpaces minIndent) ls
@ -91,19 +102,12 @@ stripIndent xs =
dropSpaces _ _ = error "stripIndent: impossible"
cleanup (Nothing, Plain y) = T.all (== ' ') y
cleanup (Just (Plain x), Plain y)
| "\n" `T.isSuffixOf` x = T.all (== ' ') y
cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y
cleanup _ = False
escapeCodes :: [(Char, Char)]
escapeCodes =
[ ('\n', 'n' )
, ('\r', 'r' )
, ('\t', 't' )
, ('\\', '\\')
, ('$' , '$' )
, ('"', '"')
]
[('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')]
fromEscapeCode :: Char -> Maybe Char
fromEscapeCode = (`lookup` map swap escapeCodes)

30
src/Nix/TH.hs
View File

@ -10,7 +10,9 @@ module Nix.TH where
import Data.Fix
import Data.Generics.Aliases
import Data.Set (Set, (\\))
import Data.Set ( Set
, (\\)
)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.List.NonEmpty ( NonEmpty(..) )
@ -47,16 +49,25 @@ freeVars e = case unFix e of
(NEnvPath _ ) -> Set.empty
(NUnary _ expr ) -> freeVars expr
(NBinary _ left right ) -> freeVars left `Set.union` freeVars right
(NSelect expr path orExpr) -> freeVars expr `Set.union` pathFree path `Set.union` maybe Set.empty freeVars orExpr
(NSelect expr path orExpr) ->
freeVars expr
`Set.union` pathFree path
`Set.union` maybe Set.empty freeVars orExpr
(NHasAttr expr path) -> freeVars expr `Set.union` pathFree path
(NAbs (Param varname) expr) -> Set.delete varname (freeVars expr)
(NAbs (ParamSet set _ varname) expr) ->
-- Include all free variables from the expression and the default arguments
freeVars expr `Set.union` Set.unions (mapMaybe (fmap freeVars . snd) set)
freeVars expr
`Set.union` Set.unions (mapMaybe (fmap freeVars . snd) set)
-- But remove the argument name if existing, and all arguments in the parameter set
\\ maybe Set.empty Set.singleton varname \\ Set.fromList (map fst set)
(NLet bindings expr) -> freeVars expr `Set.union` foldMap bindFree bindings \\ foldMap bindDefs bindings
(NIf cond th el) -> freeVars cond `Set.union` freeVars th `Set.union` freeVars el
\\ maybe Set.empty Set.singleton varname
\\ Set.fromList (map fst set)
(NLet bindings expr) ->
freeVars expr
`Set.union` foldMap bindFree bindings
\\ foldMap bindDefs bindings
(NIf cond th el) ->
freeVars cond `Set.union` freeVars th `Set.union` freeVars el
-- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it
-- This also makes sense because its value can be overridden by `x: with y; x`
(NWith set expr) -> freeVars set `Set.union` freeVars expr
@ -70,7 +81,7 @@ freeVars e = case unFix e of
staticKey (DynamicKey _ ) = Nothing
bindDefs :: Binding r -> Set VarName
bindDefs (Inherit Nothing _ _) = Set.empty;
bindDefs (Inherit Nothing _ _) = Set.empty
bindDefs (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys
bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname
bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty
@ -113,7 +124,4 @@ metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
metaPat _ _ = Nothing
nix :: QuasiQuoter
nix = QuasiQuoter
{ quoteExp = quoteExprExp
, quotePat = quoteExprPat
}
nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat }

15
src/Nix/Thunk/Basic.hs
View File

@ -85,13 +85,11 @@ queryThunk (Thunk _ active ref) n k = do
return res
forceThunk
:: forall m v a.
( MonadVar m
, MonadThrow m
, MonadCatch m
, Show (ThunkId m)
)
=> NThunkF m v -> (v -> m a) -> m a
:: forall m v a
. (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m))
=> NThunkF m v
-> (v -> m a)
-> m a
forceThunk (Value v ) k = k v
forceThunk (Thunk n active ref) k = do
eres <- readVar ref
@ -100,8 +98,7 @@ forceThunk (Thunk n active ref) k = do
Deferred action -> do
nowActive <- atomicModifyVar active (True, )
if nowActive
then
throwM $ ThunkLoop $ show n
then throwM $ ThunkLoop $ show n
else do
traceM $ "Forcing " ++ show n
v <- catch action $ \(e :: SomeException) -> do

29
src/Nix/Thunk/Standard.hs
View File

@ -39,7 +39,9 @@ import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var (MonadVar, newVar)
import Nix.Var ( MonadVar
, newVar
)
newtype StdCited m a = StdCited
{ _stdCited :: NCited (StdThunk m) (StdCited m) (StdLazy m) a }
@ -64,12 +66,7 @@ type StdIdT m = FreshIdT Int m
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT m)
type MonadStdThunk m =
( MonadVar m
, MonadCatch m
, MonadThrow m
, Typeable m
)
type MonadStdThunk m = (MonadVar m, MonadCatch m, MonadThrow m, Typeable m)
instance MonadStdThunk m
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
@ -91,8 +88,7 @@ instance MonadStdThunk m
ps = concatMap (go . frame) frames
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
else
fmap (StdThunk . StdCited . NCited []) . thunk $ mv
else fmap (StdThunk . StdCited . NCited []) . thunk $ mv
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
@ -103,8 +99,8 @@ instance MonadStdThunk m
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
force (StdThunk (StdCited (NCited ps t))) f = catch go
(throwError @ThunkLoop)
where
go = case ps of
[] -> force t f
@ -113,11 +109,11 @@ instance MonadStdThunk m
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (force t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(force t f)
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
forceEff (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
forceEff (StdThunk (StdCited (NCited ps t))) f = catch
go
(throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
@ -126,8 +122,7 @@ instance MonadStdThunk m
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (forceEff t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(forceEff t f)
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
getValue (StdThunk (StdCited (NCited _ v))) = getValue v

23
src/Nix/Type/Assumption.hs
View File

@ -1,14 +1,15 @@
module Nix.Type.Assumption (
Assumption(..),
empty,
lookup,
remove,
extend,
keys,
merge,
mergeAssumptions,
singleton,
) where
module Nix.Type.Assumption
( Assumption(..)
, empty
, lookup
, remove
, extend
, keys
, merge
, mergeAssumptions
, singleton
)
where
import Prelude hiding ( lookup )

32
src/Nix/Type/Env.hs
View File

@ -1,17 +1,18 @@
module Nix.Type.Env (
Env(..),
empty,
lookup,
remove,
extend,
extends,
merge,
mergeEnvs,
singleton,
keys,
fromList,
toList,
) where
module Nix.Type.Env
( Env(..)
, empty
, lookup
, remove
, extend
, extends
, merge
, mergeEnvs
, singleton
, keys
, fromList
, toList
)
where
import Prelude hiding ( lookup )
@ -37,8 +38,7 @@ remove :: Env -> Name -> Env
remove (TypeEnv env) var = TypeEnv (Map.delete var env)
extends :: Env -> [(Name, [Scheme])] -> Env
extends env xs =
env { types = Map.union (Map.fromList xs) (types env) }
extends env xs = env { types = Map.union (Map.fromList xs) (types env) }
lookup :: Name -> Env -> Maybe [Scheme]
lookup key (TypeEnv tys) = Map.lookup key tys

192
src/Nix/Type/Infer.hs
View File

@ -17,13 +17,14 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Nix.Type.Infer (
Constraint(..),
TypeError(..),
InferError(..),
Subst(..),
inferTop
) where
module Nix.Type.Infer
( Constraint(..)
, TypeError(..)
, InferError(..)
, Subst(..)
, inferTop
)
where
import Control.Applicative
import Control.Arrow
@ -38,7 +39,12 @@ import Control.Monad.State.Strict
import Data.Fix
import Data.Foldable
import qualified Data.HashMap.Lazy as M
import Data.List (delete, find, nub, intersect, (\\))
import Data.List ( delete
, find
, nub
, intersect
, (\\)
)
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( fromJust )
@ -112,7 +118,8 @@ class Substitutable a where
instance Substitutable TVar where
apply (Subst s) a = tv
where t = TVar a
where
t = TVar a
(TVar tv) = Map.findWithDefault t a s
instance Substitutable Type where
@ -130,7 +137,8 @@ instance Substitutable Scheme where
instance Substitutable Constraint where
apply s (EqConst t1 t2) = EqConst (apply s t1) (apply s t2)
apply s (ExpInstConst t sc) = ExpInstConst (apply s t) (apply s sc)
apply s (ImpInstConst t1 ms t2) = ImpInstConst (apply s t1) (apply s ms) (apply s t2)
apply s (ImpInstConst t1 ms t2) =
ImpInstConst (apply s t1) (apply s ms) (apply s t2)
instance Substitutable a => Substitutable [a] where
apply = map . apply
@ -168,7 +176,8 @@ class ActiveTypeVars a where
instance ActiveTypeVars Constraint where
atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2
atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2)
atv (ImpInstConst t1 ms t2) =
ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2)
atv (ExpInstConst t s) = ftv t `Set.union` ftv s
instance ActiveTypeVars a => ActiveTypeVars [a] where
@ -206,7 +215,8 @@ instance Monoid InferError where
-- | Run the inference monad
runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a)
runInfer' = runExceptT
runInfer' =
runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
. getInfer
@ -216,18 +226,20 @@ runInfer m = runST $ do
i <- newVar (1 :: Int)
runFreshIdT i (runInfer' m)
inferType :: forall s m. MonadInfer m
=> Env -> NExpr -> InferT s m [(Subst, Type)]
inferType
:: forall s m . MonadInfer m => Env -> NExpr -> InferT s m [(Subst, Type)]
inferType env ex = do
Judgment as cs t <- infer ex
let unbounds = Set.fromList (As.keys as) `Set.difference`
Set.fromList (Env.keys env)
unless (Set.null unbounds) $
typeError $ UnboundVariables (nub (Set.toList unbounds))
let cs' = [ ExpInstConst t s
let unbounds =
Set.fromList (As.keys as) `Set.difference` Set.fromList (Env.keys env)
unless (Set.null unbounds) $ typeError $ UnboundVariables
(nub (Set.toList unbounds))
let cs' =
[ ExpInstConst t s
| (x, ss) <- Env.toList env
, s <- ss
, t <- As.lookup x as]
, t <- As.lookup x as
]
inferState <- get
let eres = (`evalState` inferState) $ runSolver $ do
subst <- solve (cs ++ cs')
@ -274,8 +286,11 @@ generalize free t = Forall as t
unops :: Type -> NUnaryOp -> [Constraint]
unops u1 = \case
NNot -> [EqConst u1 (typeFun [typeBool, typeBool])]
NNeg -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt]
, typeFun [typeFloat, typeFloat] ]) ]
NNeg ->
[ EqConst
u1
(TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]])
]
binops :: Type -> NBinaryOp -> [Constraint]
binops u1 = \case
@ -295,41 +310,69 @@ binops u1 = \case
NOr -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])]
NImpl -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])]
NConcat -> [ EqConst u1 (TMany [ typeFun [typeList, typeList, typeList]
NConcat ->
[ EqConst
u1
(TMany
[ typeFun [typeList, typeList, typeList]
, typeFun [typeList, typeNull, typeList]
, typeFun [typeNull, typeList, typeList]
]) ]
]
)
]
NUpdate -> [ EqConst u1 (TMany [ typeFun [typeSet, typeSet, typeSet]
NUpdate ->
[ EqConst
u1
(TMany
[ typeFun [typeSet, typeSet, typeSet]
, typeFun [typeSet, typeNull, typeSet]
, typeFun [typeNull, typeSet, typeSet]
]) ]
]
)
]
NPlus -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
NPlus ->
[ EqConst
u1
(TMany
[ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
, typeFun [typeString, typeString, typeString]
, typeFun [typePath, typePath, typePath]
, typeFun [typeString, typeString, typePath]
]) ]
]
)
]
NMinus -> arithmetic
NMult -> arithmetic
NDiv -> arithmetic
where
inequality =
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeBool]
[ EqConst
u1
(TMany
[ typeFun [typeInt, typeInt, typeBool]
, typeFun [typeFloat, typeFloat, typeBool]
, typeFun [typeInt, typeFloat, typeBool]
, typeFun [typeFloat, typeInt, typeBool]
]) ]
]
)
]
arithmetic =
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
[ EqConst
u1
(TMany
[ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
]) ]
]
)
]
liftInfer :: Monad m => m a -> InferT s m a
liftInfer = InferT . lift . lift . lift
@ -353,16 +396,13 @@ instance Monad m => MonadThrow (InferT s m) where
instance Monad m => MonadCatch (InferT s m) where
catch m h = catchError m $ \case
EvaluationError e ->
maybe (error $ "Exception was not an exception: " ++ show e) h
EvaluationError e -> maybe
(error $ "Exception was not an exception: " ++ show e)
h
(fromException (toException e))
err -> error $ "Unexpected error: " ++ show err
type MonadInfer m
= ( MonadThunkId m
, MonadVar m
, MonadFix m
)
type MonadInfer m = (MonadThunkId m, MonadVar m, MonadFix m)
instance MonadInfer m
=> MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
@ -372,10 +412,12 @@ instance MonadInfer m
query (JThunk x) b f = query x b f
queryM (JThunk x) b f = queryM x b f
force (JThunk t) f = catch (force t f) $ \(_ :: ThunkLoop) ->
force (JThunk t) f = catch (force t f)
$ \(_ :: ThunkLoop) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
forceEff (JThunk t) f = catch (forceEff t f) $ \(_ :: ThunkLoop) ->
forceEff (JThunk t) f = catch (forceEff t f)
$ \(_ :: ThunkLoop) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
@ -396,11 +438,8 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
evaledSym _ = pure
evalCurPos =
return $ Judgment As.empty [] $ TSet False $ M.fromList
[ ("file", typePath)
, ("line", typeInt)
, ("col", typeInt) ]
evalCurPos = return $ Judgment As.empty [] $ TSet False $ M.fromList
[("file", typePath), ("line", typeInt), ("col", typeInt)]
evalConstant c = return $ Judgment As.empty [] (go c)
where
@ -421,8 +460,7 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
evalBinary op (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
return $ Judgment
(as1 `As.merge` as2)
return $ Judgment (as1 `As.merge` as2)
(cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op)
tv
@ -438,27 +476,23 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
evalAssert (Judgment as1 cs1 t1) body = do
Judgment as2 cs2 t2 <- body
return $ Judgment
(as1 `As.merge` as2)
(cs1 ++ cs2 ++ [EqConst t1 typeBool])
t2
return
$ Judgment (as1 `As.merge` as2) (cs1 ++ cs2 ++ [EqConst t1 typeBool]) t2
evalApp (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
return $ Judgment
(as1 `As.merge` as2)
return $ Judgment (as1 `As.merge` as2)
(cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)])
tv
evalAbs (Param x) k = do
a <- freshTVar
let tv = TVar a
((), Judgment as cs t) <-
extendMSet a (k (pure (Judgment (As.singleton x tv) [] tv))
(\_ b -> ((),) <$> b))
return $ Judgment
(as `As.remove` x)
((), Judgment as cs t) <- extendMSet
a
(k (pure (Judgment (As.singleton x tv) [] tv)) (\_ b -> ((), ) <$> b))
return $ Judgment (as `As.remove` x)
(cs ++ [ EqConst t' tv | t' <- As.lookup x as ])
(tv :~> t)
@ -467,23 +501,20 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
tv <- fresh
pure [(name, tv)]
let (env, tys) = (\f -> foldl' f (As.empty, M.empty) js)
$ \(as1, t1) (k, t) ->
let (env, tys) =
(\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) ->
(as1 `As.merge` As.singleton k t, M.insert k t t1)
arg = pure $ Judgment env [] (TSet True tys)
call = k arg $ \args b -> (args, ) <$> b
names = map fst js
(args, Judgment as cs t) <-
foldr (\(_, TVar a) -> extendMSet a) call js
(args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js
ty <- TSet variadic <$> traverse (inferredType <$>) args
return $ Judgment
(foldl' As.remove as names)
(cs ++ [ EqConst t' (tys M.! x)
| x <- names
, t' <- As.lookup x as])
(cs ++ [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ])
(ty :~> t)
evalError = throwError . EvaluationError
@ -513,20 +544,20 @@ instance MonadInfer m
instance MonadInfer m
=> ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
toValue (xs, _) = Judgment
toValue (xs, _) =
Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
<*> (TSet True <$> traverse (`force` (pure . inferredType)) xs)
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
toValue xs = Judgment
toValue xs =
Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
<*> (TList <$> traverse (`force` (pure . inferredType)) xs)
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where
toValue _ = pure $ Judgment As.empty [] typeBool
@ -557,8 +588,7 @@ normalize (Forall _ body) = Forall (map snd ord) (normtype body)
normtype (TSet b a) = TSet b (M.map normtype a)
normtype (TList a ) = TList (map normtype a)
normtype (TMany ts) = TMany (map normtype ts)
normtype (TVar a) =
case Prelude.lookup a ord of
normtype (TVar a ) = case Prelude.lookup a ord of
Just x -> TVar x
Nothing -> error "type variable not in signature"
@ -595,8 +625,8 @@ Subst s1 `compose` Subst s2 =
unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst
unifyMany [] [] = return emptySubst
unifyMany (t1 : ts1) (t2 : ts2) =
do su1 <- unifies t1 t2
unifyMany (t1 : ts1) (t2 : ts2) = do
su1 <- unifies t1 t2
su2 <- unifyMany (apply su1 ts1) (apply su1 ts2)
return (su2 `compose` su1)
unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2
@ -623,8 +653,8 @@ unifies (TSet False b) (TSet True s)
| M.keys b `intersect` M.keys s == M.keys s = return emptySubst
unifies (TSet True s) (TSet False b)
| M.keys b `intersect` M.keys s == M.keys b = return emptySubst
unifies (TSet False s) (TSet False b)
| null (M.keys b \\ M.keys s) = return emptySubst
unifies (TSet False s) (TSet False b) | null (M.keys b \\ M.keys s) =
return emptySubst
unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4]
unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2
unifies t1 (TMany t2s) = considering t2s >>- unifies t1
@ -655,10 +685,8 @@ solve :: MonadState InferState m => [Constraint] -> Solver m Subst
solve [] = return emptySubst
solve cs = solve' (nextSolvable cs)
where
solve' (EqConst t1 t2, cs) =
unifies t1 t2 >>- \su1 ->
solve (apply su1 cs) >>- \su2 ->
return (su2 `compose` su1)
solve' (EqConst t1 t2, cs) = unifies t1 t2
>>- \su1 -> solve (apply su1 cs) >>- \su2 -> return (su2 `compose` su1)
solve' (ImpInstConst t1 ms t2, cs) =
solve (ExpInstConst t1 (generalize ms t2) : cs)

51
src/Nix/Utils.hs
View File

@ -22,18 +22,26 @@ import Data.Hashable
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
import Data.List ( sortOn )
import Data.Monoid (Endo, (<>))
import Data.Monoid ( Endo
, (<>)
)
import Data.Text ( Text )
import qualified Data.Text as Text
import qualified Data.Vector as V
import Lens.Family2 as X
import Lens.Family2.Stock (_1, _2)
import Lens.Family2.Stock ( _1
, _2
)
import Lens.Family2.TH
#if ENABLE_TRACING
import Debug.Trace as X
#else
import Prelude as X hiding (putStr, putStrLn, print)
import Prelude as X
hiding ( putStr
, putStrLn
, print
)
trace :: String -> a -> a
trace = const id
traceM :: Monad m => String -> m ()
@ -92,8 +100,12 @@ transport f (Fix x) = Fix $ fmap (transport f) (f x)
adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi f g = g (f . fmap (adi f g) . unFix)
adiM :: (Traversable t, Monad m)
=> (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
adiM
:: (Traversable t, Monad m)
=> (t a -> m a)
-> ((Fix t -> m a) -> Fix t -> m a)
-> Fix t
-> m a
adiM f g = g ((f <=< traverse (adiM f g)) . unFix)
class Has a b where
@ -111,7 +123,8 @@ instance Has (a, b) b where
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted = \case
A.Object m ->
A.pairs . mconcat
A.pairs
. mconcat
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
. sortOn fst
$ M.toList m
@ -126,14 +139,28 @@ uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit = go where
go str = case Text.break (== ':') str of
(e1, e2)
| Text.null e2 -> [(e1, PathEntryPath)]
| Text.pack "://" `Text.isPrefixOf` e2 ->
let ((suffix, _):path) = go (Text.drop 3 e2)
| Text.null e2
-> [(e1, PathEntryPath)]
| Text.pack "://" `Text.isPrefixOf` e2
-> let ((suffix, _) : path) = go (Text.drop 3 e2)
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
| otherwise
-> (e1, PathEntryPath) : go (Text.drop 1 e2)
alterF :: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
alterF
:: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v))
-> k
-> HashMap k v
-> f (HashMap k v)
alterF f k m = f (M.lookup k m) <&> \case
Nothing -> M.delete k m
Just v -> M.insert k v m

168
src/Nix/Value.hs
View File

@ -99,8 +99,11 @@ instance Foldable (NValueF p m) where
NVClosureF _ _ -> mempty
NVBuiltinF _ _ -> mempty
bindNValueF :: (Monad m, Monad n)
=> (forall x. n x -> m x) -> (a -> n b) -> NValueF p m a
bindNValueF
:: (Monad m, Monad n)
=> (forall x . n x -> m x)
-> (a -> n b)
-> NValueF p m a
-> n (NValueF p m b)
bindNValueF transform f = \case
NVConstantF a -> pure $ NVConstantF a
@ -121,7 +124,8 @@ lmapNValueF f = \case
NVClosureF p g -> NVClosureF p (g . fmap f)
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
liftNValueF :: (MonadTrans u, Monad m)
liftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p m a
-> NValueF p (u m) a
@ -134,7 +138,8 @@ liftNValueF run = \case
NVClosureF p g -> NVClosureF p $ lift . g . run
NVBuiltinF s g -> NVBuiltinF s $ lift . g . run
unliftNValueF :: (MonadTrans u, Monad m)
unliftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p (u m) a
-> NValueF p m a
@ -147,8 +152,8 @@ unliftNValueF run = \case
NVClosureF p g -> NVClosureF p $ run . g . lift
NVBuiltinF s g -> NVBuiltinF s $ run . g . lift
type MonadDataContext f (m :: * -> *) =
(Comonad f, Applicative f, Traversable f, Monad m)
type MonadDataContext f (m :: * -> *)
= (Comonad f, Applicative f, Traversable f, Monad m)
-- | At the time of constructor, the expected arguments to closures are values
-- that may contain thunks. The type of such thunks are fixed at that time.
@ -174,20 +179,25 @@ instance (Comonad f, Show a) => Show (NValue' t f m a) where
type NValue t f m = NValue' t f m t
bindNValue :: (Traversable f, Monad m, Monad n)
=> (forall x. n x -> m x) -> (a -> n b) -> NValue' t f m a
bindNValue
:: (Traversable f, Monad m, Monad n)
=> (forall x . n x -> m x)
-> (a -> n b)
-> NValue' t f m a
-> n (NValue' t f m b)
bindNValue transform f (NValue v) =
NValue <$> traverse (bindNValueF transform f) v
liftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
liftNValue
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue' t f m a
-> NValue' t f (u m) a
liftNValue run (NValue v) =
NValue (fmap (lmapNValueF (unliftNValue run) . liftNValueF run) v)
unliftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
unliftNValue
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
=> (forall x . u m x -> m x)
-> NValue' t f (u m) a
-> NValue' t f m a
@ -207,10 +217,12 @@ unliftNValue run (NValue v) =
type NValueNF t f m = Free (NValue' t f m) t
iterNValue
:: forall t f m a r. MonadDataContext f m
:: forall t f m a r
. MonadDataContext f m
=> (a -> (NValue' t f m a -> r) -> r)
-> (NValue' t f m r -> r)
-> NValue' t f m a -> r
-> NValue' t f m a
-> r
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
iterNValueM
@ -218,7 +230,8 @@ iterNValueM
=> (forall x . n x -> m x)
-> (a -> (NValue' t f m a -> n r) -> n r)
-> (NValue' t f m r -> n r)
-> NValue' t f m a -> n r
-> NValue' t f m a
-> n r
iterNValueM transform k f =
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
@ -226,11 +239,14 @@ iterNValueNF
:: MonadDataContext f m
=> (t -> r)
-> (NValue' t f m r -> r)
-> NValueNF t f m -> r
-> NValueNF t f m
-> r
iterNValueNF k f = iter f . fmap k
sequenceNValueNF :: (Functor n, Traversable f, Monad m, Monad n)
=> (forall x. n x -> m x) -> Free (NValue' t f m) (n a)
sequenceNValueNF
:: (Functor n, Traversable f, Monad m, Monad n)
=> (forall x . n x -> m x)
-> Free (NValue' t f m) (n a)
-> n (Free (NValue' t f m) a)
sequenceNValueNF transform = go
where
@ -238,22 +254,27 @@ sequenceNValueNF transform = go
go (Free fa) = Free <$> bindNValue transform go fa
iterNValueNFM
:: forall f m n t r. (MonadDataContext f m, Monad n)
:: forall f m n t r
. (MonadDataContext f m, Monad n)
=> (forall x . n x -> m x)
-> (t -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValueNF t f m -> n r
-> NValueNF t f m
-> n r
iterNValueNFM transform k f v =
iterM f =<< sequenceNValueNF transform (fmap k v)
nValueFromNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m -> NValue t f m
nValueFromNF
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValueNF t f m
-> NValue t f m
nValueFromNF = iterNValueNF f (fmap wrapValue)
where
f t = query t cyc id
cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")
nValueToNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
nValueToNF
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
-> NValue t f m
-> NValueNF t f m
@ -329,8 +350,11 @@ nvBuiltinNF :: Applicative f
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
checkComparable :: (Framed e m, MonadDataErrorContext t f m)
=> NValue t f m -> NValue t f m -> m ()
checkComparable
:: (Framed e m, MonadDataErrorContext t f m)
=> NValue t f m
-> NValue t f m
-> m ()
checkComparable x y = case (x, y) of
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
@ -340,12 +364,10 @@ checkComparable x y = case (x, y) of
(NVPath _, NVPath _) -> pure ()
_ -> throwError $ Comparison x y
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f)
=> t -> t -> m Bool
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
let unsafePtrEq = case (lt, rt) of
(thunkId -> lid, thunkId -> rid)
| lid == rid -> return True
(thunkId -> lid, thunkId -> rid) | lid == rid -> return True
_ -> valueEqM lv rv
in case (lv, rv) of
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
@ -353,18 +375,29 @@ thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
(NVSet _ _ , NVSet _ _ ) -> unsafePtrEq
_ -> valueEqM lv rv
builtin :: forall m f t. (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String -> (m (NValue t f m) -> m (NValue t f m)) -> m (NValue t f m)
builtin
:: forall m f t
. (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue t f m) -> m (NValue t f m))
-> m (NValue t f m)
builtin name f = return $ nvBuiltin name $ thunk . f
builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
builtin2
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
-> m (NValue t f m)
builtin2 name f = builtin name (builtin name . f)
builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
builtin3
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> String
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
-> ( m (NValue t f m)
-> m (NValue t f m)
-> m (NValue t f m)
-> m (NValue t f m)
)
-> m (NValue t f m)
builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
@ -405,7 +438,8 @@ isDerivationM f m = case M.lookup "type" m of
isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool
isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x))
valueFEqM :: Monad n
valueFEqM
:: Monad n
=> (AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool)
-> NValueF p m a
@ -416,24 +450,26 @@ valueFEqM attrsEq eq = curry $ \case
(NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y
(NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc
(NVStrF ls, NVStrF rs) ->
pure $ principledStringIgnoreContext ls
== principledStringIgnoreContext rs
pure $ principledStringIgnoreContext ls == principledStringIgnoreContext rs
(NVListF ls , NVListF rs ) -> alignEqM eq ls rs
(NVSetF lm _, NVSetF rm _) -> attrsEq lm rm
(NVPathF lp , NVPathF rp ) -> pure $ lp == rp
_ -> pure False
valueFEq :: (AttrSet a -> AttrSet a -> Bool)
valueFEq
:: (AttrSet a -> AttrSet a -> Bool)
-> (a -> a -> Bool)
-> NValueF p m a
-> NValueF p m a
-> Bool
valueFEq attrsEq eq x y =
runIdentity $ valueFEqM
valueFEq attrsEq eq x y = runIdentity $ valueFEqM
(\x' y' -> Identity (attrsEq x' y'))
(\x' y' -> Identity (eq x' y')) x y
(\x' y' -> Identity (eq x' y'))
x
y
compareAttrSetsM :: Monad m
compareAttrSetsM
:: Monad m
=> (t -> m (Maybe NixString))
-> (t -> t -> m Bool)
-> AttrSet t
@ -442,35 +478,39 @@ compareAttrSetsM :: Monad m
compareAttrSetsM f eq lm rm = do
isDerivationM f lm >>= \case
True -> isDerivationM f rm >>= \case
True | Just lp <- M.lookup "outPath" lm
, Just rp <- M.lookup "outPath" rm
-> eq lp rp
True
| Just lp <- M.lookup "outPath" lm, Just rp <- M.lookup "outPath" rm -> eq
lp
rp
_ -> compareAttrs
_ -> compareAttrs
where
compareAttrs = alignEqM eq lm rm
where compareAttrs = alignEqM eq lm rm
compareAttrSets :: (t -> Maybe NixString)
compareAttrSets
:: (t -> Maybe NixString)
-> (t -> t -> Bool)
-> AttrSet t
-> AttrSet t
-> Bool
compareAttrSets f eq lm rm =
runIdentity $ compareAttrSetsM
(\t -> Identity (f t))
(\x y -> Identity (eq x y)) lm rm
compareAttrSets f eq lm rm = runIdentity
$ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm
valueEqM :: (MonadThunk t m (NValue t f m), Comonad f)
=> NValue t f m -> NValue t f m -> m Bool
valueEqM (NValue (extract -> x)) (NValue (extract -> y)) =
valueFEqM (compareAttrSetsM f thunkEqM) thunkEqM x y
valueEqM
:: (MonadThunk t m (NValue t f m), Comonad f)
=> NValue t f m
-> NValue t f m
-> m Bool
valueEqM (NValue (extract -> x)) (NValue (extract -> y)) = valueFEqM
(compareAttrSetsM f thunkEqM)
thunkEqM
x
y
where
f t = force t $ \case
NVStr s -> pure $ Just s
_ -> pure Nothing
valueNFEq :: Comonad f
=> NValueNF t f m -> NValueNF t f m -> Bool
valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool
valueNFEq (Pure _) (Pure _) = False
valueNFEq (Pure _) (Free _) = False
valueNFEq (Free _) (Pure _) = False
@ -537,8 +577,8 @@ instance Eq1 (NValueF p m) where
instance Comonad f => Show1 (NValue' t f m) where
liftShowsPrec sp sl p = \case
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStr ns -> showsUnaryWith showsPrec "NVStrF" p
(hackyStringIgnoreContext ns)
NVStr ns ->
showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
NVList lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSet attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVPath path -> showsUnaryWith showsPrec "NVPathF" p path
@ -560,16 +600,18 @@ data ValueFrame t f m
| Expectation ValueType (NValue t f m)
deriving (Show, Typeable)
type MonadDataErrorContext t f m =
(Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
type MonadDataErrorContext t f m
= (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)
$(makeTraversals ''NValueF)
$(makeLenses ''NValue')
key :: (Traversable f, Applicative g)
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
key
:: (Traversable f, Applicative g)
=> VarName
-> LensLike' g (NValue' t f m a) (Maybe a)
key k = nValue . traverse . _NVSetF . _1 . hashAt k
$(deriveEq1 ''NValue')

8
src/Nix/Var.hs
View File

@ -39,11 +39,7 @@ atomicModifyVar = atomicModifyRef
--TODO: Upstream GEq instances
instance GEq IORef where
a `geq` b = if a == unsafeCoerce b
then Just $ unsafeCoerce Refl
else Nothing
a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing
instance GEq (STRef s) where
a `geq` b = if a == unsafeCoerce b
then Just $ unsafeCoerce Refl
else Nothing
a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing

35
src/Nix/XML.hs
View File

@ -16,11 +16,13 @@ import Nix.Value
import Text.XML.Light
toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString
toXML = runWithStringContext
toXML =
runWithStringContext
. fmap pp
. iterNValueNF (const (pure (mkElem "cycle" "value" ""))) phi
where
pp = ("<?xml version='1.0' encoding='utf-8'?>\n" <>)
pp =
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
. (<> "\n")
. Text.pack
. ppElement
@ -35,18 +37,26 @@ toXML = runWithStringContext
NNull -> return $ Element (unqual "null") [] [] Nothing
NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
NVList l -> sequence l >>= \els ->
return $ Element (unqual "list") [] (Elem <$> els) Nothing
NVList l -> sequence l
>>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing
NVSet s _ -> sequence s >>= \kvs ->
return $ Element (unqual "attrs") []
(map (\(k, v) ->
Elem (Element (unqual "attr")
NVSet s _ -> sequence s >>= \kvs -> return $ Element
(unqual "attrs")
[]
(map
(\(k, v) -> Elem
(Element (unqual "attr")
[Attr (unqual "name") (Text.unpack k)]
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList kvs)) Nothing
[Elem v]
Nothing
)
)
(sortBy (comparing fst) $ M.toList kvs)
)
Nothing
NVClosure p _ -> return $ Element (unqual "function") [] (paramsXML p) Nothing
NVClosure p _ ->
return $ Element (unqual "function") [] (paramsXML p) Nothing
NVPath fp -> return $ mkElem "path" "value" fp
NVBuiltin name _ -> return $ mkElem "function" "name" name
_ -> error "Pattern synonyms mask coverage"
@ -55,8 +65,7 @@ mkElem :: String -> String -> String -> Element
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing
paramsXML :: Params r -> [Content]
paramsXML (Param name) =
[Elem $ mkElem "varpat" "name" (Text.unpack name)]
paramsXML (Param name) = [Elem $ mkElem "varpat" "name" (Text.unpack name)]
paramsXML (ParamSet s b mname) =
[Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing]
where

82
tests/NixLanguageTests.hs
View File

@ -9,7 +9,9 @@ import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.ST
import Data.List (delete, sort)
import Data.List ( delete
, sort
)
import Data.List.Split ( splitOn )
import Data.Map ( Map )
import qualified Data.Map as Map
@ -30,7 +32,9 @@ import Nix.XML
import qualified Options.Applicative as Opts
import System.Environment
import System.FilePath
import System.FilePath.Glob (compile, globDir1)
import System.FilePath.Glob ( compile
, globDir1
)
import Test.Tasty
import Test.Tasty.HUnit
import TestCommon
@ -72,7 +76,8 @@ newFailingTests = Set.fromList
genTests :: IO TestTree
genTests = do
testFiles <- sort
testFiles <-
sort
-- jww (2018-05-07): Temporarily disable this test until #128 is fixed.
. filter ((`Set.notMember` newFailingTests) . takeBaseName)
. filter ((/= ".xml") . takeExtension)
@ -80,15 +85,14 @@ genTests = do
let testsByName = groupBy (takeFileName . dropExtensions) testFiles
let testsByType = groupBy testType (Map.toList testsByName)
let testGroups = map mkTestGroup (Map.toList testsByType)
return $ localOption (mkTimeout 2000000)
$ testGroup "Nix (upstream) language tests" testGroups
return $ localOption (mkTimeout 2000000) $ testGroup
"Nix (upstream) language tests"
testGroups
where
testType (fullpath, _files) =
take 2 $ splitOn "-" $ takeFileName fullpath
testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath
mkTestGroup (kind, tests) =
testGroup (unwords kind) $ map (mkTestCase kind) tests
mkTestCase kind (basename, files) =
testCase (takeFileName basename) $ do
mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do
time <- liftIO getCurrentTime
let opts = defaultOptions time
case kind of
@ -107,13 +111,18 @@ assertParse _opts file = parseNixFileLoc file >>= \case
assertParseFail :: Options -> FilePath -> Assertion
assertParseFail opts file = do
eres <- parseNixFileLoc file
catch (case eres of
catch
(case eres of
Success expr -> do
_ <- pure $! runST $ void $ lint opts expr
assertFailure $ "Unexpected success parsing `"
++ file ++ ":\nParsed value: " ++ show expr
Failure _ -> return ()) $ \(_ :: SomeException) ->
return ()
assertFailure
$ "Unexpected success parsing `"
++ file
++ ":\nParsed value: "
++ show expr
Failure _ -> return ()
)
$ \(_ :: SomeException) -> return ()
assertLangOk :: Options -> FilePath -> Assertion
assertLangOk opts file = do
@ -123,7 +132,9 @@ assertLangOk opts file = do
assertLangOkXml :: Options -> FilePath -> Assertion
assertLangOkXml opts file = do
actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile opts (file ++ ".nix")
actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile
opts
(file ++ ".nix")
expected <- Text.readFile $ file ++ ".exp.xml"
assertEqual "" expected actual
@ -142,23 +153,33 @@ assertEval _opts files = do
flags <- Text.readFile (name ++ ".flags")
let flags' | Text.last flags == '\n' = Text.init flags
| otherwise = flags
case Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time)
(fixup (map Text.unpack (Text.splitOn " " flags'))) of
Opts.Failure err -> errorWithoutStackTrace $
"Error parsing flags from " ++ name ++ ".flags: "
case
Opts.execParserPure
Opts.defaultPrefs
(nixOptionsInfo time)
(fixup (map Text.unpack (Text.splitOn " " flags')))
of
Opts.Failure err ->
errorWithoutStackTrace
$ "Error parsing flags from "
++ name
++ ".flags: "
++ show err
Opts.Success opts' ->
assertLangOk
(opts' { include = include opts' ++
[ "nix=../../../../data/nix/corepkgs"
Opts.Success opts' -> assertLangOk
(opts'
{ include = include opts'
++ [ "nix=../../../../data/nix/corepkgs"
, "lang/dir4"
, "lang/dir5" ] })
, "lang/dir5"
]
}
)
name
Opts.CompletionInvoked _ -> error "unused"
_ -> assertFailure $ "Unknown test type " ++ show files
where
name = "data/nix/tests/lang/"
++ the (map (takeFileName . dropExtensions) files)
name =
"data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files)
fixup ("--arg" : x : y : rest) = "--arg" : (x ++ "=" ++ y) : fixup rest
fixup ("--argstr" : x : y : rest) = "--argstr" : (x ++ "=" ++ y) : fixup rest
@ -169,6 +190,9 @@ assertEvalFail :: FilePath -> Assertion
assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do
time <- liftIO getCurrentTime
evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file
evalResult `seq` assertFailure $
file ++ " should not evaluate.\nThe evaluation result was `"
++ evalResult ++ "`."
evalResult
`seq` assertFailure
$ file
++ " should not evaluate.\nThe evaluation result was `"
++ evalResult
++ "`."

71
tests/PrettyParseTests.hs
View File

@ -16,7 +16,9 @@ import Data.Algorithm.DiffOutput
import Data.Char
import Data.Fix
import qualified Data.List.NonEmpty as NE
import Data.Text (Text, pack)
import Data.Text ( Text
, pack
)
import Data.Text.Prettyprint.Doc
import Hedgehog
import qualified Hedgehog.Gen as Gen
@ -27,7 +29,10 @@ import Nix.Parser
import Nix.Pretty
import Test.Tasty
import Test.Tasty.Hedgehog
import Text.Megaparsec (Pos, SourcePos, mkPos)
import Text.Megaparsec ( Pos
, SourcePos
, mkPos
)
import qualified Text.Show.Pretty as PS
asciiString :: MonadGen m => m String
@ -44,20 +49,18 @@ genSourcePos :: Gen SourcePos
genSourcePos = SourcePos <$> asciiString <*> genPos <*> genPos
genKeyName :: Gen (NKeyName NExpr)
genKeyName = Gen.choice [ DynamicKey <$> genAntiquoted genString
, StaticKey <$> asciiText ]
genKeyName =
Gen.choice [DynamicKey <$> genAntiquoted genString, StaticKey <$> asciiText]
genAntiquoted :: Gen a -> Gen (Antiquoted a NExpr)
genAntiquoted gen = Gen.choice
[ Plain <$> gen
, pure EscapedNewline
, Antiquoted <$> genExpr
]
genAntiquoted gen =
Gen.choice [Plain <$> gen, pure EscapedNewline, Antiquoted <$> genExpr]
genBinding :: Gen (Binding NExpr)
genBinding = Gen.choice
[ NamedVar <$> genAttrPath <*> genExpr <*> genSourcePos
, Inherit <$> Gen.maybe genExpr
, Inherit
<$> Gen.maybe genExpr
<*> Gen.list (Range.linear 0 5) genKeyName
<*> genSourcePos
]
@ -65,19 +68,19 @@ genBinding = Gen.choice
genString :: Gen (NString NExpr)
genString = Gen.choice
[ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
, Indented <$> Gen.int (Range.linear 0 10)
<*> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
, Indented <$> Gen.int (Range.linear 0 10) <*> Gen.list
(Range.linear 0 5)
(genAntiquoted asciiText)
]
genAttrPath :: Gen (NAttrPath NExpr)
genAttrPath = (NE.:|) <$> genKeyName
<*> Gen.list (Range.linear 0 4) genKeyName
genAttrPath = (NE.:|) <$> genKeyName <*> Gen.list (Range.linear 0 4) genKeyName
genParams :: Gen (Params NExpr)
genParams = Gen.choice
[ Param <$> asciiText
, ParamSet <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText
<*> Gen.maybe genExpr)
, ParamSet
<$> Gen.list (Range.linear 0 10) ((,) <$> asciiText <*> Gen.maybe genExpr)
<*> Gen.bool
<*> Gen.choice [pure Nothing, Just <$> asciiText]
]
@ -87,19 +90,16 @@ genAtom = Gen.choice
[ NInt <$> Gen.integral (Range.linear 0 1000)
, NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0)
, NBool <$> Gen.bool
, pure NNull ]
, pure NNull
]
-- This is written by hand so we can use `fairList` rather than the normal
-- list Arbitrary instance which makes the generator terminate. The
-- distribution is not scientifically chosen.
genExpr :: Gen NExpr
genExpr = Gen.sized $ \(Size n) ->
Fix <$>
if n < 2
then Gen.choice
[genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
else
Gen.frequency
genExpr = Gen.sized $ \(Size n) -> Fix <$> if n < 2
then Gen.choice [genConstant, genStr, genSym, genLiteralPath, genEnvPath]
else Gen.frequency
[ (1 , genConstant)
, (1 , genSym)
, (4 , Gen.resize (Size (n `div` 3)) genIf)
@ -147,8 +147,10 @@ equivUpToNormalization x y = normalize x == normalize y
normalize :: NExpr -> NExpr
normalize = cata $ \case
NConstant (NInt n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NInt (negate n)))))
NConstant (NFloat n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n)))))
NConstant (NInt n) | n < 0 ->
Fix (NUnary NNeg (Fix (NConstant (NInt (negate n)))))
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))
@ -165,10 +167,9 @@ normalize = cata $ \case
normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted)
normKey (StaticKey name ) = StaticKey name
normAntiquotedString :: Antiquoted (NString NExpr) NExpr
-> Antiquoted (NString NExpr) NExpr
normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) =
EscapedNewline
normAntiquotedString
:: Antiquoted (NString NExpr) NExpr -> Antiquoted (NString NExpr) NExpr
normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) = EscapedNewline
normAntiquotedString (Plain (DoubleQuoted strs)) =
let strs' = map normAntiquotedText strs
in if strs == strs'
@ -191,17 +192,17 @@ prop_prettyparse p = do
case parse (pack prog) of
Failure s -> do
footnote $ show $ vsep
[ fillSep ["Parse failed:", pretty (show s)]
, indent 2 (prettyNix p)
]
[fillSep ["Parse failed:", pretty (show s)], indent 2 (prettyNix p)]
discard
Success v
| equivUpToNormalization p v -> success
| otherwise -> do
let pp = normalise prog
pv = normalise (show (prettyNix v))
footnote $ show $ vsep $
[ "----------------------------------------"
footnote
$ show
$ vsep
$ [ "----------------------------------------"
, vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))]
, "----------------------------------------"
, vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))]

3
tests/PrettyTests.hs
View File

@ -34,4 +34,5 @@ tests = $testGroupGenerator
--------------------------------------------------------------------------------
assertPretty :: NExpr -> String -> Assertion
assertPretty e s = assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e
assertPretty e s =
assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e

19
tests/ReduceExprTests.hs
View File

@ -13,15 +13,16 @@ import Nix.Reduce (reduceExpr)
tests :: TestTree
tests = testGroup "Expr Reductions"
[ testCase "Non nested NSelect on set should be reduced" $
cmpReduceResult selectBasic selectBasicExpect,
testCase "Nested NSelect on set should be reduced" $
cmpReduceResult selectNested selectNestedExpect,
testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" $
shouldntReduce selectIncorrectAttrPath,
testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" $
shouldntReduce selectNestedIncorrectAttrPath
tests = testGroup
"Expr Reductions"
[ testCase "Non nested NSelect on set should be reduced"
$ cmpReduceResult selectBasic selectBasicExpect
, testCase "Nested NSelect on set should be reduced"
$ cmpReduceResult selectNested selectNestedExpect
, testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced"
$ shouldntReduce selectIncorrectAttrPath
, testCase "Nested NSelect with incorrect attrpath shouldn't be reduced"
$ shouldntReduce selectNestedIncorrectAttrPath
]
assertSucc :: Result a -> IO a

23
tests/TestCommon.hs
View File

@ -6,7 +6,9 @@ module TestCommon where
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Text (Text, unpack)
import Data.Text ( Text
, unpack
)
import Data.Time
import Nix
import Nix.Thunk.Standard
@ -25,18 +27,22 @@ hnixEvalFile opts file = do
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
Success expr -> do
setEnv "TEST_VAR" "foo"
runStdLazyM opts $
catch (evaluateExpression (Just file) nixEvalExprLoc
normalForm expr) $ \case
runStdLazyM opts
$ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr)
$ \case
NixException frames ->
errorWithoutStackTrace . show
errorWithoutStackTrace
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
hnixEvalText :: Options -> Text -> IO (StdValueNF IO)
hnixEvalText opts src = case parseNixText src of
Failure err ->
error $ "Parsing failed for expressien `"
++ unpack src ++ "`.\n" ++ show err
error
$ "Parsing failed for expressien `"
++ unpack src
++ "`.\n"
++ show err
Success expr ->
-- runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
@ -66,5 +72,4 @@ assertEvalMatchesNix expr = do
hnixVal <- (++ "\n") . printNix <$> hnixEvalText (defaultOptions time) expr
nixVal <- nixEvalString expr'
assertEqual expr' nixVal hnixVal
where
expr' = unpack expr
where expr' = unpack expr