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

6
benchmarks/Main.hs
View File

@ -1,10 +1,8 @@
module Main where
import Criterion.Main
import Criterion.Main
import qualified ParserBench
main :: IO ()
main = defaultMain
[ ParserBench.benchmarks
]
main = defaultMain [ParserBench.benchmarks]

9
benchmarks/ParserBench.hs
View File

@ -1,15 +1,16 @@
module ParserBench (benchmarks) where
import Nix.Parser
import Nix.Parser
import Control.Applicative
import Criterion
import Control.Applicative
import Criterion
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"

367
main/Main.hs
View File

@ -8,221 +8,218 @@
module Main where
import qualified Control.DeepSeq as Deep
import qualified Control.Exception as Exc
import qualified Control.DeepSeq as Deep
import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
-- import Control.Monad.ST
import qualified Data.Aeson.Text as A
import qualified Data.HashMap.Lazy as M
import qualified Data.Map as Map
import Data.List (sortOn)
import Data.Maybe (fromJust)
import qualified Data.Aeson.Text as A
import qualified Data.HashMap.Lazy as M
import qualified Data.Map as Map
import Data.List ( sortOn )
import Data.Maybe ( fromJust )
import Data.Time
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.IO as TL
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text
import Nix
import Nix.Cited
import Nix.Convert
import qualified Nix.Eval as Eval
import qualified Nix.Eval as Eval
import Nix.Json
-- import Nix.Lint
import Nix.Options.Parser
import Nix.Thunk.Basic
import Nix.Thunk.Standard
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import Nix.Utils
import Nix.Var
import Options.Applicative hiding (ParserResult(..))
import Options.Applicative hiding ( ParserResult(..) )
import qualified Repl
import System.FilePath
import System.IO
import qualified Text.Show.Pretty as PS
import qualified Text.Show.Pretty as PS
main :: IO ()
main = do
time <- liftIO getCurrentTime
opts <- execParser (nixOptionsInfo time)
runStdLazyM opts $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
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 path ->
mapM_ (processFile opts)
=<< (lines <$> liftIO (readFile path))
Nothing -> case filePaths opts of
[] -> withNixContext Nothing $ Repl.main
["-"] ->
handleResult opts Nothing . parseNixTextLoc
=<< liftIO Text.getContents
paths ->
mapM_ (processFile opts) paths
where
processFile opts path = do
eres <- parseNixFileLoc path
handleResult opts (Just path) eres
time <- liftIO getCurrentTime
opts <- execParser (nixOptionsInfo time)
runStdLazyM opts $ case readFrom opts of
Just path -> do
let file = addExtension (dropExtension path) "nixc"
process opts (Just file) =<< liftIO (readCache path)
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 path ->
mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path))
Nothing -> case filePaths opts of
[] -> withNixContext Nothing $ Repl.main
["-"] ->
handleResult opts Nothing
. parseNixTextLoc
=<< liftIO Text.getContents
paths -> mapM_ (processFile opts) paths
where
processFile opts path = do
eres <- parseNixFileLoc path
handleResult opts (Just path) eres
handleResult opts mpath = \case
Failure err ->
(if ignoreErrors opts
then liftIO . hPutStrLn stderr
else errorWithoutStackTrace) $ "Parse failed: " ++ show err
handleResult opts mpath = \case
Failure err ->
(if ignoreErrors opts
then liftIO . hPutStrLn stderr
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)))
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)))
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (process opts mpath expr) $ \case
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
catch (process opts mpath expr) $ \case
NixException frames ->
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
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
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
. prettyNix
. stripAnnotation
$ expr
where
printer
| finder opts
= fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
| xml opts
= liftIO
. putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts
= liftIO
. Text.putStrLn
. principledStringIgnoreContext
<=< nvalueToJSONNixString
| 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))
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar @(StdLazy IO) ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k, ) <$> forceEntry path nv
| otherwise -> pure (k, Nothing)
| evaluate opts, Just path <- reduce opts =
evaluateExpression mpath (reduction path) printer expr
forM_ xs $ \(k, mv) -> do
let path = prefix ++ Text.unpack k
(report, descend) = filterEntry path k
when report $ do
liftIO $ putStrLn path
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ -> go (path ++ ".") s'
_ -> return ()
where
filterEntry path k = case (path, k) of
("stdenv", "stdenv" ) -> (True, True)
(_ , "stdenv" ) -> (False, False)
(_ , "out" ) -> (True, False)
(_ , "src" ) -> (True, False)
(_ , "mirrorsFile" ) -> (True, False)
(_ , "buildPhase" ) -> (True, False)
(_ , "builder" ) -> (False, False)
(_ , "drvPath" ) -> (False, False)
(_ , "outPath" ) -> (False, False)
(_ , "__impureHostDeps") -> (False, False)
(_ , "__sandboxProfile") -> (False, False)
("pkgs" , "pkgs" ) -> (True, True)
(_ , "pkgs" ) -> (False, False)
(_ , "drvAttrs" ) -> (False, False)
_ -> (True, True)
| evaluate opts, not (null (arg opts) && null (argstr opts)) =
evaluateExpression mpath
Nix.nixEvalExprLoc printer expr
forceEntry k v =
catch (Just <$> force v pure) $ \(NixException frames) -> do
liftIO
. putStrLn
. ("Exception forcing " ++)
. (k ++)
. (": " ++)
. show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
return Nothing
| evaluate opts =
processResult printer =<< Nix.nixEvalExprLoc mpath expr
reduction path mp x = do
eres <- Nix.withNixContext mp
$ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
handleReduced path eres
| 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
where
printer
| finder opts =
fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
| xml opts =
liftIO . putStrLn
. Text.unpack
. principledStringIgnoreContext
. toXML
<=< normalForm
| json opts =
liftIO . Text.putStrLn
. principledStringIgnoreContext
<=< nvalueToJSONNixString
| 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))
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
Value v -> pure (k, Just v)
Thunk _ _ ref -> do
let path = prefix ++ Text.unpack k
(_, descend) = filterEntry path k
val <- readVar @(StdLazy IO) ref
case val of
Computed _ -> pure (k, Nothing)
_ | descend -> (k,) <$> forceEntry path nv
| otherwise -> pure (k, Nothing)
forM_ xs $ \(k, mv) -> do
let path = prefix ++ Text.unpack k
(report, descend) = filterEntry path k
when report $ do
liftIO $ putStrLn path
when descend $ case mv of
Nothing -> return ()
Just v -> case v of
NVSet s' _ ->
go (path ++ ".") s'
_ -> return ()
where
filterEntry path k = case (path, k) of
("stdenv", "stdenv") -> (True, True)
(_, "stdenv") -> (False, False)
(_, "out") -> (True, False)
(_, "src") -> (True, False)
(_, "mirrorsFile") -> (True, False)
(_, "buildPhase") -> (True, False)
(_, "builder") -> (False, False)
(_, "drvPath") -> (False, False)
(_, "outPath") -> (False, False)
(_, "__impureHostDeps") -> (False, False)
(_, "__sandboxProfile") -> (False, False)
("pkgs", "pkgs") -> (True, True)
(_, "pkgs") -> (False, False)
(_, "drvAttrs") -> (False, False)
_ -> (True, True)
forceEntry k v = catch (Just <$> force v pure)
$ \(NixException frames) -> do
liftIO . putStrLn
. ("Exception forcing " ++)
. (k ++)
. (": " ++) . 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
handleReduced path eres
handleReduced :: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path
writeFile path $ show $ prettyNix (stripAnnotation expr')
case eres of
Left err -> throwM err
Right v -> return v
handleReduced
:: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue t f m))
-> m (NValue t f m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path
writeFile path $ show $ prettyNix (stripAnnotation expr')
case eres of
Left err -> throwM err
Right v -> return v

134
main/Repl.hs
View File

@ -22,26 +22,32 @@
module Repl where
import Nix hiding (exec, try)
import Nix.Builtins (MonadBuiltins)
import Nix hiding ( exec
, try
)
import Nix.Builtins ( MonadBuiltins )
import Nix.Cited
import Nix.Convert
import Nix.Eval
import Nix.Scope
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Env as Env
import Nix.Type.Infer
import Nix.Utils
import Control.Comonad
import qualified Data.HashMap.Lazy as M
import Data.List (isPrefixOf, foldl')
import qualified Data.Map as Map
import qualified Data.HashMap.Lazy as M
import Data.List ( isPrefixOf
, foldl'
)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (unpack, pack)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Version (showVersion)
import Paths_hnix (version)
import Data.Text ( unpack
, pack
)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Version ( showVersion )
import Paths_hnix ( version )
import Control.Monad.Catch
import Control.Monad.Identity
@ -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"
where
prefix = "hnix> "
welcomeText =
liftIO
$ putStrLn
$ "Welcome to hnix "
<> showVersion version
<> ". For help type :help\n"
-------------------------------------------------------------------------------
-- Types
@ -87,11 +98,15 @@ 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
st <- get
-- Parser ( returns AST )
-- TODO: parse <var> = <expr>
@ -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
st <- get
val <- case M.lookup line (tmctx st) of
Just val -> return val
Nothing -> exec False line
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,10 +185,10 @@ quit _ = liftIO exitSuccess
-- Prefix tab completer
defaultMatcher :: MonadIO m => [(String, CompletionFunc m)]
defaultMatcher = [
(":load" , fileCompleter)
defaultMatcher =
[(":load", fileCompleter)
--, (":type" , values)
]
]
-- Default tab completer
comp :: Monad m => WordCompleter m
@ -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)
=> [(String, [String] -> Repl e t f m ())]
options = [
("load" , load)
options
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
=> [(String, [String] -> Repl e t f m ())]
options =
[ ( "load"
, load
)
--, ("browse" , browse)
, ("quit" , quit)
, ("type" , typeof)
, ("help" , help)
, ("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)
=> CompleterStyle (StateT (IState t f m) m)
completer
:: (MonadBuiltins e t f m, MonadIO m)
=> CompleterStyle (StateT (IState t f m) m)
completer = Prefix (wordCompleter comp) defaultMatcher

201
src/Nix.hs
View File

@ -4,34 +4,40 @@
{-# 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)
import Control.Arrow ( second )
import Control.Monad.Reader
import Data.Fix
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Nix.Builtins
import Nix.Cache
import qualified Nix.Eval as Eval
import qualified Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
@ -50,21 +56,34 @@ 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)
(Eval.eval . annotated . getCompose)
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
-- this function doesn't do any tracing itself, but 'evalExprLoc' will be
@ -72,66 +91,78 @@ nixEvalExprLoc mpath =
-- 'MonadNix'). All this function does is provide the right type class
-- context.
nixTracingEvalExprLoc
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath
-> NExprLoc
-> m (NValue t f m)
nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
evaluateExpression
:: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue t f m))
-> (NValue t f m -> m a)
-> NExprLoc
-> m a
:: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue t f m))
-> (NValue t f m -> m a)
-> NExprLoc
-> 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)
compute evaluator expr (argmap args) handler
where
parseArg s = case parseNixText s of
Success x -> x
Failure err -> errorWithoutStackTrace (show err)
opts :: Options <- asks (view hasLens)
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
Success x -> x
Failure err -> errorWithoutStackTrace (show err)
eval' = (normalForm =<<) . nixEvalExpr mpath
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = pure $ nvSet (M.fromList args') mempty
where
args' = map (fmap (wrapValue . nValueFromNF)) args
argmap args = pure $ nvSet (M.fromList args') mempty
where args' = map (fmap (wrapValue . nValueFromNF)) args
compute ev x args p = do
f :: NValue t f m <- ev mpath x
processResult p =<< case f of
NVClosure _ g -> force ?? pure =<< g args
_ -> pure f
compute ev x args p = do
f :: NValue t f m <- ev mpath x
processResult p =<< case f of
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
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue t f m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")):ks) v = case v of
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
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 ++ "'"
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
opts :: Options <- asks (view hasLens)
case attr opts of
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue t f m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")) : ks) v = case v of
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
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
++ "'"
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

24
src/Nix/Atoms.hs
View File

@ -9,11 +9,13 @@ module Nix.Atoms where
#ifdef MIN_VERSION_serialise
import Codec.Serialise
#endif
import Control.DeepSeq
import Data.Data
import Data.Hashable
import Data.Text (Text, pack)
import GHC.Generics
import Control.DeepSeq
import Data.Data
import Data.Hashable
import Data.Text ( Text
, pack
)
import GHC.Generics
-- | Atoms are values that evaluate to themselves. This means that
-- they appear in both the parsed AST (in the form of literals) and
@ -37,7 +39,15 @@ instance Serialise NAtom
-- | Translate an atom into its nix representation.
atomText :: NAtom -> Text
atomText (NInt i) = pack (show i)
atomText (NInt i) = pack (show i)
atomText (NFloat f) = pack (show f)
atomText (NBool b) = if b then "true" else "false"
atomText (NBool b) = if b then "true" else "false"
atomText NNull = "null"

1975
src/Nix/Builtins.hs
View File

File diff suppressed because it is too large Load Diff

14
src/Nix/Cache.hs
View File

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

21
src/Nix/Cited.hs
View File

@ -12,15 +12,15 @@
module Nix.Cited where
import Control.Comonad
import Control.Comonad.Env
import Data.Typeable (Typeable)
import GHC.Generics
import Lens.Family2.TH
import Control.Comonad
import Control.Comonad.Env
import Data.Typeable ( Typeable )
import GHC.Generics
import Lens.Family2.TH
import Nix.Expr.Types.Annotated
import Nix.Scope
import Nix.Value
import Nix.Expr.Types.Annotated
import Nix.Scope
import Nix.Value
data Provenance t f m = Provenance
{ _lexicalScope :: Scopes m t
@ -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
@ -58,8 +57,8 @@ class HasCitations t f m a where
addProvenance :: Provenance t f m -> a -> a
instance HasCitations t f m (NCited t f m a) where
citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v)
citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v)
class HasCitations1 t f m where
citations1 :: f a -> [Provenance t f m]

20
src/Nix/Context.hs
View File

@ -4,11 +4,13 @@
module Nix.Context where
import Nix.Options
import Nix.Scope
import Nix.Frames
import Nix.Utils
import Nix.Expr.Types.Annotated (SrcSpan, nullSpan)
import Nix.Options
import Nix.Scope
import Nix.Frames
import Nix.Utils
import Nix.Expr.Types.Annotated ( SrcSpan
, nullSpan
)
data Context m t = Context
{ scopes :: Scopes m t
@ -18,16 +20,16 @@ data Context m t = Context
}
instance Has (Context m t) (Scopes m t) where
hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x
hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x
instance Has (Context m t) SrcSpan where
hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y
hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y
instance Has (Context m t) Frames where
hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z
hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z
instance Has (Context m t) Options where
hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w
hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w
newContext :: Options -> Context m t
newContext = Context emptyScopes nullSpan []

463
src/Nix/Convert.hs
View File

@ -29,11 +29,13 @@ module Nix.Convert where
import Control.Monad
import Data.ByteString
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.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 Nix.Atoms
import Nix.Effects
import Nix.Expr.Types
@ -60,326 +62,333 @@ 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
NVConstantNF NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TNull v
fromValueMay = \case
NVConstantNF NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TNull v
instance Convertible e t f m => FromValue () m (NValue t f m) where
fromValueMay = \case
NVConstant NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TNull v
fromValueMay = \case
NVConstant NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TNull v
instance Convertible e t f m => FromValue Bool m (NValueNF t f m) where
fromValueMay = \case
NVConstantNF (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TBool v
fromValueMay = \case
NVConstantNF (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TBool v
instance Convertible e t f m => FromValue Bool m (NValue t f m) where
fromValueMay = \case
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TBool v
fromValueMay = \case
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TBool v
instance Convertible e t f m => FromValue Int m (NValueNF t f m) where
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e t f m => FromValue Int m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e t f m => FromValue Integer m (NValueNF t f m) where
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
fromValueMay = \case
NVConstantNF (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TInt v
instance Convertible e t f m => FromValue Integer m (NValue t f m) where
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
fromValueMay = \case
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TInt v
instance Convertible e t f m => FromValue Float m (NValueNF t f m) where
fromValueMay = \case
NVConstantNF (NFloat b) -> pure $ Just b
NVConstantNF (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TFloat v
fromValueMay = \case
NVConstantNF (NFloat b) -> pure $ Just b
NVConstantNF (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TFloat v
instance Convertible e t f m => FromValue Float m (NValue t f m) where
fromValueMay = \case
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TFloat v
fromValueMay = \case
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TFloat v
instance (Convertible e t f m, MonadEffects t f m)
=> FromValue NixString m (NValueNF t f m) where
fromValueMay = \case
NVStrNF ns -> pure $ Just ns
NVPathNF p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
fromValueMay = \case
NVStrNF ns -> pure $ Just ns
NVPathNF p ->
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
=> FromValue NixString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ Just ns
NVPath p ->
Just . hackyMakeNixStringWithoutContext
. Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
fromValueMay = \case
NVStr ns -> pure $ Just ns
NVPath p ->
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
instance Convertible e t f m
=> FromValue ByteString m (NValueNF t f m) where
fromValueMay = \case
NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
fromValueMay = \case
NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF (TString NoContext) v
instance Convertible e t f m
=> FromValue ByteString m (NValue t f m) where
fromValueMay = \case
NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
fromValueMay = \case
NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation (TString NoContext) v
newtype Path = Path { getPath :: FilePath }
deriving Show
instance Convertible e t f m => FromValue Path m (NValueNF t f m) where
fromValueMay = \case
NVPathNF p -> pure $ Just (Path p)
NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TPath v
fromValueMay = \case
NVPathNF p -> pure $ Just (Path p)
NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSetNF s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TPath v
instance (Convertible e t f m, FromValue Path m t)
=> FromValue Path m (NValue t f m) where
fromValueMay = \case
NVPath p -> pure $ Just (Path p)
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TPath v
fromValueMay = \case
NVPath p -> pure $ Just (Path p)
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TPath v
instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a)
=> FromValue [a] m (NValueNF t f m) where
fromValueMay = \case
NVListNF l -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TList v
fromValueMay = \case
NVListNF l -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TList v
instance Convertible e t f m => FromValue [t] m (NValue t f m) where
fromValueMay = \case
NVList l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
fromValueMay = \case
NVList l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
fromValueMay = \case
NVSetNF s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
fromValueMay = \case
NVSetNF s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e t f m
=> FromValue (HashMap Text t) m (NValue t f m) where
fromValueMay = \case
NVSet s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
fromValueMay = \case
NVSet s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e t f m
=> FromValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
fromValueMay = \case
NVSetNF s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
fromValueMay = \case
NVSetNF s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ ExpectationNF TSet v
instance Convertible e t f m
=> FromValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
fromValueMay = \case
NVSet s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
fromValueMay = \case
NVSet s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
class ToValue a m v where
toValue :: a -> m v
instance Convertible e t f m => ToValue () m (NValueNF t f m) where
toValue _ = pure . nvConstantNF $ NNull
toValue _ = pure . nvConstantNF $ NNull
instance Convertible e t f m => ToValue () m (NValue t f m) where
toValue _ = pure . nvConstant $ NNull
toValue _ = pure . nvConstant $ NNull
instance Convertible e t f m => ToValue Bool m (NValueNF t f m) where
toValue = pure . nvConstantNF . NBool
toValue = pure . nvConstantNF . NBool
instance Convertible e t f m => ToValue Bool m (NValue t f m) where
toValue = pure . nvConstant . NBool
toValue = pure . nvConstant . NBool
instance Convertible e t f m => ToValue Int m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt . toInteger
toValue = pure . nvConstantNF . NInt . toInteger
instance Convertible e t f m => ToValue Int m (NValue t f m) where
toValue = pure . nvConstant . NInt . toInteger
toValue = pure . nvConstant . NInt . toInteger
instance Convertible e t f m => ToValue Integer m (NValueNF t f m) where
toValue = pure . nvConstantNF . NInt
toValue = pure . nvConstantNF . NInt
instance Convertible e t f m => ToValue Integer m (NValue t f m) where
toValue = pure . nvConstant . NInt
toValue = pure . nvConstant . NInt
instance Convertible e t f m => ToValue Float m (NValueNF t f m) where
toValue = pure . nvConstantNF . NFloat
toValue = pure . nvConstantNF . NFloat
instance Convertible e t f m => ToValue Float m (NValue t f m) where
toValue = pure . nvConstant . NFloat
toValue = pure . nvConstant . NFloat
instance Convertible e t f m => ToValue NixString m (NValueNF t f m) where
toValue = pure . nvStrNF
toValue = pure . nvStrNF
instance Convertible e t f m => ToValue NixString m (NValue t f m) where
toValue = pure . nvStr
toValue = pure . nvStr
instance Convertible e t f m => ToValue ByteString m (NValueNF t f m) where
toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8
toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue ByteString m (NValue t f m) where
toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8
toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m => ToValue Path m (NValueNF t f m) where
toValue = pure . nvPathNF . getPath
toValue = pure . nvPathNF . getPath
instance Convertible e t f m => ToValue Path m (NValue t f m) where
toValue = pure . nvPath . getPath
toValue = pure . nvPath . getPath
instance Convertible e t f m => ToValue StorePath m (NValueNF t f m) where
toValue = toValue . Path . unStorePath
toValue = toValue . Path . unStorePath
instance Convertible e t f m => ToValue StorePath m (NValue t f m) where
toValue = toValue . Path . unStorePath
toValue = toValue . Path . unStorePath
instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
toValue (SourcePos f l c) = do
f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f)
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, wrapValue f')
, ("line", wrapValue l')
, ("column", wrapValue c') ]
pure $ nvSet pos mempty
toValue (SourcePos f l c) = do
f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f)
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, wrapValue f')
, ("line" , wrapValue l')
, ("column" , wrapValue c')
]
pure $ nvSet pos mempty
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
=> ToValue [a] m (NValueNF t f m) where
toValue = fmap nvListNF . traverse toValue
toValue = fmap nvListNF . traverse toValue
instance Convertible e t f m => ToValue [t] m (NValue t f m) where
toValue = pure . nvList
toValue = pure . nvList
instance Convertible e t f m
=> ToValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where
toValue = pure . flip nvSetNF M.empty
toValue = pure . flip nvSetNF M.empty
instance Convertible e t f m => ToValue (HashMap Text t) m (NValue t f m) where
toValue = pure . flip nvSet M.empty
toValue = pure . flip nvSet M.empty
instance Convertible e t f m => ToValue (HashMap Text (NValueNF t f m),
HashMap Text SourcePos) m (NValueNF t f m) where
toValue (s, p) = pure $ nvSetNF s p
toValue (s, p) = pure $ nvSetNF s p
instance Convertible e t f m => ToValue (HashMap Text t,
HashMap Text SourcePos) m (NValue t f m) where
toValue (s, p) = pure $ nvSet s p
toValue (s, p) = pure $ nvSet s p
instance Convertible e t f m => ToValue Bool m (NExprF r) where
toValue = pure . NConstant . NBool
toValue = pure . NConstant . NBool
instance Convertible e t f m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
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
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
class FromNix a m v where
fromNix :: v -> m a
@ -392,21 +401,21 @@ class FromNix a m v where
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix [a] m (NValue t f m) where
fromNixMay = \case
NVList l -> sequence <$> traverse (`force` fromNixMay) l
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
fromNixMay = \case
NVList l -> sequence <$> traverse (`force` fromNixMay) l
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TList v
instance (Convertible e t f m, FromNix a m (NValue t f m))
=> FromNix (HashMap Text a) m (NValue t f m) where
fromNixMay = \case
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
fromNixMay = \case
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation TSet v
instance Convertible e t f m => FromNix () m (NValueNF t f m) where
instance Convertible e t f m => FromNix () m (NValue t f m) where
@ -438,8 +447,8 @@ instance Convertible e t f m
=> FromNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
fromNix = (>>= fromNix)
fromNixMay = (>>= fromNixMay)
fromNix = (>>= fromNix)
class ToNix a m v where
toNix :: a -> m v
@ -448,17 +457,17 @@ class ToNix a m v where
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
toNix = fmap nvList . traverse (thunk . go)
where
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
toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)
where
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
@ -485,14 +494,14 @@ instance Convertible e t f m
=> ToNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where
instance Convertible e t f m => ToNix Bool m (NExprF r) where
toNix = pure . NConstant . NBool
toNix = pure . NConstant . NBool
instance Convertible e t f m => ToNix () m (NExprF r) where
toNix _ = pure $ NConstant NNull
toNix _ = pure $ NConstant NNull
instance (Convertible e t f m, ToNix a m (NValueNF t f m))
=> ToNix [a] m (NValueNF t f m) where
toNix = fmap nvListNF . traverse toNix
toNix = fmap nvListNF . traverse toNix
convertNix :: forall a t m v. (FromNix a m t, ToNix a m v, Monad m) => t -> m v
convertNix :: forall a t m v . (FromNix a m t, ToNix a m v, Monad m) => t -> m v
convertNix = fromNix @a >=> toNix

204
src/Nix/Effects.hs
View File

@ -10,13 +10,16 @@
module Nix.Effects where
import Prelude hiding (putStr, putStrLn, print)
import Prelude hiding ( putStr
, putStrLn
, print
)
import qualified Prelude
import Control.Monad.Trans
import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Client hiding (path)
import Data.Text ( Text )
import qualified Data.Text as T
import Network.HTTP.Client hiding ( path )
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import Nix.Expr
@ -25,7 +28,7 @@ import Nix.Parser
import Nix.Render
import Nix.Utils
import Nix.Value
import qualified System.Directory as S
import qualified System.Directory as S
import System.Environment
import System.Exit
import qualified System.Info
@ -63,15 +66,15 @@ class Monad m => MonadIntrospect m where
recursiveSize = lift . recursiveSize
instance MonadIntrospect IO where
recursiveSize =
recursiveSize =
#ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
recursiveSize
recursiveSize
#else
\_ -> return 0
\_ -> return 0
#endif
#else
\_ -> return 0
\_ -> return 0
#endif
class Monad m => MonadExec m where
@ -80,24 +83,33 @@ class Monad m => MonadExec m where
exec' = lift . exec'
instance MonadExec IO where
exec' = \case
[] -> return $ Left $ ErrorCall "exec: missing program"
(prog:args) -> do
(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
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
Success v -> return $ Right v
err -> return $ Left $ ErrorCall $
"exec failed: " ++ show err ++ " " ++ emsg
exec' = \case
[] -> return $ Left $ ErrorCall "exec: missing program"
(prog : args) -> do
(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
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
Success v -> return $ Right v
err ->
return
$ Left
$ ErrorCall
$ "exec failed: "
++ show err
++ " "
++ emsg
class Monad m => MonadInstantiate m where
instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
@ -105,21 +117,29 @@ class Monad m => MonadInstantiate m where
instantiateExpr = lift . instantiateExpr
instance MonadInstantiate IO where
instantiateExpr expr = do
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
Success v -> return $ Right v
status ->
return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
instantiateExpr expr = do
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
Success v -> return $ Right v
status ->
return
$ Left
$ ErrorCall
$ "nix-instantiate failed: "
++ show status
++ ": "
++ err
pathExists :: MonadFile m => FilePath -> m Bool
pathExists = doesFileExist
@ -136,14 +156,14 @@ class Monad m => MonadEnv m where
getCurrentSystemArch = lift getCurrentSystemArch
instance MonadEnv IO where
getEnvVar = lookupEnv
getEnvVar = lookupEnv
getCurrentSystemOS = return $ T.pack System.Info.os
getCurrentSystemOS = return $ T.pack System.Info.os
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
getCurrentSystemArch = return $ T.pack $ case System.Info.arch of
"i386" -> "i686"
arch -> arch
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
getCurrentSystemArch = return $ T.pack $ case System.Info.arch of
"i386" -> "i686"
arch -> arch
class Monad m => MonadHttp m where
getURL :: Text -> m (Either ErrorCall StorePath)
@ -151,24 +171,32 @@ class Monad m => MonadHttp m where
getURL = lift . getURL
instance MonadHttp IO where
getURL url = do
let urlstr = T.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr
req <- parseRequest urlstr
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
else -- do
-- let bstr = responseBody response
return $ Left $ ErrorCall $
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
getURL url = do
let urlstr = T.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr
req <- parseRequest urlstr
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
else -- do
-- let bstr = responseBody response
return
$ Left
$ ErrorCall
$ "success in downloading but hnix-store is not yet ready; url = "
++ urlstr
class Monad m => MonadPutStr m where
@ -179,13 +207,13 @@ class Monad m => MonadPutStr m where
putStr = lift . putStr
putStrLn :: MonadPutStr m => String -> m ()
putStrLn = putStr . (++"\n")
putStrLn = putStr . (++ "\n")
print :: (MonadPutStr m, Show a) => a -> m ()
print = putStrLn . show
instance MonadPutStr IO where
putStr = Prelude.putStr
putStr = Prelude.putStr
class Monad m => MonadStore m where
-- | Import a path into the nix store, and return the resulting path
@ -195,25 +223,35 @@ class Monad m => MonadStore m where
toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath)
instance MonadStore IO where
addPath' path = do
(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
addPath' path = do
(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
--TODO: Use a temp directory so we don't overwrite anything important
toFile_' filepath content = do
writeFile filepath content
storepath <- addPath' filepath
S.removeFile filepath
return storepath
--TODO: Use a temp directory so we don't overwrite anything important
toFile_' filepath content = do
writeFile filepath content
storepath <- addPath' filepath
S.removeFile filepath
return storepath
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
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

525
src/Nix/Eval.hs
View File

@ -18,24 +18,26 @@ import Control.Monad
import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Align.Key (alignWithKey)
import Data.Either (isRight)
import Data.Fix (Fix(Fix))
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.Text (Text)
import Data.These (These(..))
import Data.Traversable (for)
import Data.Align.Key ( alignWithKey )
import Data.Either ( isRight )
import Data.Fix ( Fix(Fix) )
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.Text ( Text )
import Data.These ( These(..) )
import Data.Traversable ( for )
import Nix.Atoms
import Nix.Convert
import Nix.Expr
import Nix.Frames
import Nix.String
import Nix.Scope
import Nix.Strings (runAntiquoted)
import Nix.Strings ( runAntiquoted )
import Nix.Thunk
import Nix.Utils
@ -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
@ -104,290 +107,336 @@ data SynHoleInfo m t = SynHoleInfo
instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t)
eval :: forall v t m. MonadNixEval v t m => NExprF (m v) -> m v
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
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NConstant x ) = evalConstant x
eval (NStr str ) = evalString str
eval (NLiteralPath p ) = evalLiteralPath p
eval (NEnvPath p ) = evalEnvPath p
eval (NUnary op arg ) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes :: m (Scopes m t)
fun >>= (`evalApp` withScopes scope arg)
scope <- currentScopes :: m (Scopes m t)
fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
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
eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id
where go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l) = do
scope <- currentScopes
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
eval (NList l ) = do
scope <- currentScopes
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
eval (NRecSet binds) =
evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue
evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue
eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst
eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
eval (NIf cond t f ) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = evalWith scope body
eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= evalAssert ?? body
eval (NAssert cond body) = cond >>= evalAssert ?? body
eval (NAbs params body) = do
eval (NAbs params body) = do
-- It is the environment at the definition site, not the call site, that
-- needs to be used when evaluating the body and default arguments, hence
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes :: m (Scopes m t)
evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
scope <- currentScopes :: m (Scopes m t)
evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
eval (NSynHole name) = synHole name
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- this implementation may be used as an implementation for 'evalWith'.
evalWithAttrSet :: forall v t m. MonadNixEval v t m => m v -> m v -> m v
evalWithAttrSet :: forall v t m . MonadNixEval v t m => m v -> m v -> m v
evalWithAttrSet aset 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.
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)
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)
attrSetAlter :: forall v t m. MonadNixEval v t m
=> [Text]
-> SourcePos
-> AttrSet (m v)
-> AttrSet SourcePos
-> m v
-> m (AttrSet (m v), AttrSet SourcePos)
attrSetAlter
:: forall v t m
. MonadNixEval v t m
=> [Text]
-> SourcePos
-> AttrSet (m v)
-> AttrSet SourcePos
-> m v
-> m (AttrSet (m v), AttrSet SourcePos)
attrSetAlter [] _ _ _ _ =
evalError @v $ ErrorCall "invalid selector with no components"
evalError @v $ ErrorCall "invalid selector with no components"
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
where
go = return (M.insert k val m, M.insert k pos p)
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
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 )
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
)
desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r]
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]))
(Either VarName (Binding r))
collect (NamedVar (StaticKey x :| y:ys) val p) = do
m <- get
put $ M.insert x ?? m $ case M.lookup x m of
Nothing -> (p, [NamedVar (y:|ys) val p])
Just (q, v) -> (q, NamedVar (y:|ys) val q : v)
pure $ Left x
collect x = pure $ Right x
where
collect
:: Binding r
-> State
(HashMap VarName (SourcePos, [Binding r]))
(Either VarName (Binding r))
collect (NamedVar (StaticKey x :| y : ys) val p) = do
m <- get
put $ M.insert x ?? m $ case M.lookup x m of
Nothing -> (p, [NamedVar (y :| ys) val p])
Just (q, v) -> (q, NamedVar (y :| ys) val q : v)
pure $ Left x
collect x = pure $ Right x
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
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
evalBinds :: forall v t m. MonadNixEval v t m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds
:: forall v t m
. MonadNixEval v t m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds recursive binds = do
scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) .
partition (\case
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
_ -> True)
scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) . partition
(\case
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
_ -> 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))
(M.toList o')
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))
(M.toList o')
go _ (NamedVar pathExpr finalValue pos) = do
let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
go = \case
h :| t -> evalSetterKeyName h >>= \case
Nothing ->
pure ([], nullPos,
toValue @(AttrSet t, AttrSet SourcePos)
(mempty, mempty))
Just k -> case t of
[] -> pure ([k], pos, finalValue)
x:xs -> do
(restOfPath, _, v) <- go (x:|xs)
pure (k : restOfPath, pos, v)
go pathExpr <&> \case
-- When there are no path segments, e.g. `${null} = 5;`, we don't
-- bind anything
([], _, _) -> []
result -> [result]
go _ (NamedVar pathExpr finalValue pos) = do
let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
go = \case
h :| t -> evalSetterKeyName h >>= \case
Nothing ->
pure
( []
, nullPos
, toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)
)
Just k -> case t of
[] -> pure ([k], pos, finalValue)
x : xs -> do
(restOfPath, _, v) <- go (x :| xs)
pure (k : restOfPath, pos, v)
go pathExpr <&> \case
-- When there are no path segments, e.g. `${null} = 5;`, we don't
-- bind anything
([], _, _) -> []
result -> [result]
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
evalSetterKeyName >=> \case
Nothing -> pure Nothing
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, _) ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> attrMissing (key :| []) Nothing
Just v -> force v pure)
go scope (Inherit ms names pos) =
fmap catMaybes $ forM names $ evalSetterKeyName >=> \case
Nothing -> pure Nothing
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, _) ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> attrMissing (key :| []) Nothing
Just v -> force v pure
)
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
return (res, p)
where
mkThunk = thunk . withScopes scope
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
return (res, p)
where
mkThunk = thunk . withScopes scope
encapsulate f attrs = mkThunk . pushScope attrs $ f
encapsulate f attrs = mkThunk . pushScope attrs $ f
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall v t m. MonadNixEval v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
evalSelect
:: forall v t m
. MonadNixEval v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
evalSelect aset attr = do
s <- aset
path <- traverse evalGetterKeyName attr
extract s path
where
extract x path@(k:|ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos)
| Just t <- M.lookup k s -> case ks of
[] -> pure $ Right $ force t pure
y:ys -> force t $ extract ?? (y:|ys)
| otherwise -> Left . (, path) <$> toValue (s, p)
Nothing -> return $ Left (x, path)
s <- aset
path <- traverse evalGetterKeyName attr
extract s path
where
extract x path@(k :| ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos)
| Just t <- M.lookup k s -> case ks of
[] -> pure $ Right $ force t pure
y : ys -> force t $ extract ?? (y :| ys)
| otherwise -> Left . (, path) <$> toValue (s, p)
Nothing -> return $ Left (x, path)
-- | 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"
Just k -> pure k
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)
_ -> Nothing
StaticKey k -> pure (Just k)
DynamicKey k ->
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
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
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))
where
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
These x _ -> Just (const (pure x))
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
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)
)
where
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
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)
local (set hasLens ann) (f v)
addStackFrames
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m)
=> Transform NExprLocF (m a)
:: 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)
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)

1258
src/Nix/Exec.hs
View File

File diff suppressed because it is too large Load Diff

17
src/Nix/Expr.hs
View File

@ -1,10 +1,11 @@
-- | 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
import Nix.Expr.Types.Annotated
import Nix.Expr.Types
import Nix.Expr.Shorthands
import Nix.Expr.Types.Annotated

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

@ -7,12 +7,12 @@
-- 'Fix' wrapper.
module Nix.Expr.Shorthands where
import Data.Fix
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Nix.Atoms
import Nix.Expr.Types
import Text.Megaparsec.Pos (SourcePos)
import Data.Fix
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Text ( Text )
import Nix.Atoms
import Nix.Expr.Types
import Text.Megaparsec.Pos ( SourcePos )
-- | Make an integer literal expression.
mkInt :: Integer -> NExpr
@ -32,13 +32,13 @@ mkFloatF = NConstant . NFloat
mkStr :: Text -> NExpr
mkStr = Fix . NStr . DoubleQuoted . \case
"" -> []
x -> [Plain x]
x -> [Plain x]
-- | Make an indented string.
mkIndentedStr :: Int -> Text -> NExpr
mkIndentedStr w = Fix . NStr . Indented w . \case
"" -> []
x -> [Plain x]
x -> [Plain x]
-- | Make a path. Use 'True' if the path should be read from the
-- environment, else 'False'.
@ -47,7 +47,7 @@ mkPath b = Fix . mkPathF b
mkPathF :: Bool -> FilePath -> NExprF a
mkPathF False = NLiteralPath
mkPathF True = NEnvPath
mkPathF True = NEnvPath
-- | Make a path expression which pulls from the NIX_PATH env variable.
mkEnvPath :: FilePath -> NExpr
@ -162,15 +162,15 @@ infixr 2 $=
appendBindings :: [Binding NExpr] -> NExpr -> NExpr
appendBindings newBindings (Fix e) = case e of
NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e'
NSet bindings -> Fix $ NSet (bindings <> newBindings)
NSet bindings -> Fix $ NSet (bindings <> newBindings)
NRecSet bindings -> Fix $ NRecSet (bindings <> newBindings)
_ -> error "Can only append bindings to a set or a let"
_ -> error "Can only append bindings to a set or a let"
-- | Applies a transformation to the body of a nix function.
modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr
modifyFunctionBody f (Fix e) = case e of
NAbs params body -> Fix $ NAbs params (f body)
_ -> error "Not a function"
_ -> error "Not a function"
-- | A let statement with multiple assignments.
letsE :: [(Text, NExpr)] -> NExpr -> NExpr
@ -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

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

@ -28,16 +28,16 @@
module Nix.Expr.Types where
#ifdef MIN_VERSION_serialise
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as Ser
import Codec.Serialise ( Serialise )
import qualified Codec.Serialise as Ser
#endif
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.Aeson
import Data.Aeson.TH
import Data.Binary (Binary)
import qualified Data.Binary as Bin
import Data.Binary ( Binary )
import qualified Data.Binary as Bin
import Data.Data
import Data.Eq.Deriving
import Data.Fix
@ -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.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
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
@ -64,8 +69,8 @@ import Text.Megaparsec.Pos
import Text.Read.Deriving
import Text.Show.Deriving
#if MIN_VERSION_base(4, 10, 0)
import Type.Reflection (eqTypeRep)
import qualified Type.Reflection as Reflection
import Type.Reflection ( eqTypeRep )
import qualified Type.Reflection as Reflection
#endif
type VarName = Text
@ -161,10 +166,10 @@ instance IsString NExpr where
#if MIN_VERSION_base(4, 10, 0)
instance Lift (Fix NExprF) where
lift = dataToExpQ $ \b ->
case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of
Just HRefl -> Just [| pack $(liftString $ unpack b) |]
Nothing -> Nothing
lift = dataToExpQ $ \b ->
case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of
Just HRefl -> Just [| pack $(liftString $ unpack b) |]
Nothing -> Nothing
#else
instance Lift (Fix NExprF) where
lift = dataToExpQ $ \b -> case cast b of
@ -245,12 +250,10 @@ 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 _ hb salt (Antiquoted b) =
hb (salt `hashWithSalt` (2 :: Int)) b
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
#if MIN_VERSION_deepseq(1, 4, 3)
@ -289,7 +292,7 @@ instance Serialise r => Serialise (NString r)
-- | For the the 'IsString' instance, we use a plain doublequoted string.
instance IsString (NString r) where
fromString "" = DoubleQuoted []
fromString "" = DoubleQuoted []
fromString string = DoubleQuoted [Plain $ pack string]
-- | A 'KeyName' is something that can appear on the left side of an
@ -320,20 +323,20 @@ data NKeyName r
instance Serialise r => Serialise (NKeyName r)
instance Serialise Pos where
encode x = Ser.encode (unPos x)
decode = mkPos <$> Ser.decode
encode x = Ser.encode (unPos x)
decode = mkPos <$> Ser.decode
instance Serialise SourcePos where
encode (SourcePos f l c) = Ser.encode f <> Ser.encode l <> Ser.encode c
decode = SourcePos <$> Ser.decode <*> Ser.decode <*> Ser.decode
encode (SourcePos f l c) = Ser.encode f <> Ser.encode l <> Ser.encode c
decode = SourcePos <$> Ser.decode <*> Ser.decode <*> Ser.decode
#endif
instance Hashable Pos where
hashWithSalt salt x = hashWithSalt salt (unPos x)
hashWithSalt salt x = hashWithSalt salt (unPos x)
instance Hashable SourcePos where
hashWithSalt salt (SourcePos f l c) =
salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c
hashWithSalt salt (SourcePos f l c) =
salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c
instance Generic1 NKeyName where
type Rep1 NKeyName = NKeyName
@ -342,10 +345,10 @@ instance Generic1 NKeyName where
#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 NKeyName where
liftRnf _ (StaticKey !_) = ()
liftRnf _ (DynamicKey (Plain !_)) = ()
liftRnf _ (DynamicKey EscapedNewline) = ()
liftRnf k (DynamicKey (Antiquoted r)) = k r
liftRnf _ (StaticKey !_ ) = ()
liftRnf _ (DynamicKey (Plain !_) ) = ()
liftRnf _ (DynamicKey EscapedNewline) = ()
liftRnf k (DynamicKey (Antiquoted r)) = k r
#endif
-- | Most key names are just static text, so this instance is convenient.
@ -354,22 +357,26 @@ instance IsString (NKeyName r) where
instance Eq1 NKeyName where
liftEq eq (DynamicKey a) (DynamicKey b) = liftEq2 (liftEq eq) eq a b
liftEq _ (StaticKey a) (StaticKey b) = a == b
liftEq _ _ _ = False
liftEq _ (StaticKey a) (StaticKey b) = a == b
liftEq _ _ _ = False
#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NKeyName where
liftHashWithSalt h salt (DynamicKey a) =
liftHashWithSalt2 (liftHashWithSalt h) h (salt `hashWithSalt` (0 :: Int)) a
liftHashWithSalt2 (liftHashWithSalt h) h (salt `hashWithSalt` (0 :: Int)) a
liftHashWithSalt _ salt (StaticKey n) =
salt `hashWithSalt` (1 :: Int) `hashWithSalt` n
salt `hashWithSalt` (1 :: Int) `hashWithSalt` n
#endif
-- Deriving this instance automatically is not possible because @r@
-- 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@
@ -386,10 +393,10 @@ instance Foldable NKeyName where
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Traversable NKeyName where
traverse f = \case
DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str
DynamicKey (Antiquoted e) -> DynamicKey . Antiquoted <$> f e
DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline
StaticKey key -> pure (StaticKey key)
DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str
DynamicKey (Antiquoted e ) -> DynamicKey . Antiquoted <$> f e
DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline
StaticKey key -> pure (StaticKey key)
-- | A selector (for example in a @let@ or an attribute set) is made up
-- of strung-together key names.
@ -431,7 +438,7 @@ instance Serialise NBinaryOp
-- | Get the name out of the parameter (there might be none).
paramName :: Params r -> Maybe VarName
paramName (Param n) = Just n
paramName (Param n ) = Just n
paramName (ParamSet _ _ n) = n
#if !MIN_VERSION_deepseq(1, 4, 3)
@ -473,8 +480,8 @@ instance (Binary v, Binary a) => Binary (Antiquoted v a)
instance Binary a => Binary (NString a)
instance Binary a => Binary (Binding a)
instance Binary Pos where
put x = Bin.put (unPos x)
get = mkPos <$> Bin.get
put x = Bin.put (unPos x)
get = mkPos <$> Bin.get
instance Binary SourcePos
instance Binary a => Binary (NKeyName a)
instance Binary a => Binary (Params a)
@ -487,7 +494,7 @@ instance (ToJSON v, ToJSON a) => ToJSON (Antiquoted v a)
instance ToJSON a => ToJSON (NString a)
instance ToJSON a => ToJSON (Binding a)
instance ToJSON Pos where
toJSON x = toJSON (unPos x)
toJSON x = toJSON (unPos x)
instance ToJSON SourcePos
instance ToJSON a => ToJSON (NKeyName a)
instance ToJSON a => ToJSON (Params a)
@ -501,7 +508,7 @@ instance (FromJSON v, FromJSON a) => FromJSON (Antiquoted v a)
instance FromJSON a => FromJSON (NString a)
instance FromJSON a => FromJSON (Binding a)
instance FromJSON Pos where
parseJSON = fmap mkPos . parseJSON
parseJSON = fmap mkPos . parseJSON
instance FromJSON SourcePos
instance FromJSON a => FromJSON (NKeyName a)
instance FromJSON a => FromJSON (Params a)
@ -526,43 +533,46 @@ class NExprAnn ann g | g -> ann where
fromNExpr :: g r -> (NExprF r, ann)
toNExpr :: (NExprF r, ann) -> g r
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
((v, []):_) -> fromMaybe e <$> f (Just v)
((v, r:rest):_) -> ekey (r :| rest) pos f v
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
((v, [] ) : _) -> fromMaybe e <$> f (Just v)
((v, r : rest) : _) -> ekey (r :| rest) pos f v
_ -> f Nothing <&> \case
Nothing -> e
Just v ->
let entry = NamedVar (NE.map StaticKey keys) v pos
in Fix (toNExpr (NSet (entry : xs), ann))
where
go xs = do
let keys' = NE.toList keys
(ks, rest) <- zip (inits keys') (tails keys')
case ks of
[] -> empty
j:js -> do
NamedVar ns v _p <- xs
guard $ (j:js) == (NE.toList ns ^.. traverse._StaticKey)
return (v, rest)
_ -> f Nothing <&> \case
Nothing -> e
Just v ->
let entry = NamedVar (NE.map StaticKey keys) v pos
in Fix (toNExpr (NSet (entry : xs), ann))
where
go xs = do
let keys' = NE.toList keys
(ks, rest) <- zip (inits keys') (tails keys')
case ks of
[] -> empty
j : js -> do
NamedVar ns v _p <- xs
guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
return (v, rest)
ekey _ _ f e = fromMaybe e <$> f Nothing
stripPositionInfo :: NExpr -> NExpr
stripPositionInfo = transport phi
where
phi (NSet binds) = NSet (map go binds)
phi (NRecSet binds) = NRecSet (map go binds)
phi (NLet binds body) = NLet (map go binds) body
phi x = x
where
phi (NSet binds ) = NSet (map go binds)
phi (NRecSet binds ) = NRecSet (map go binds)
phi (NLet binds body) = NLet (map go binds) body
phi x = x
go (NamedVar path r _pos) = NamedVar path r nullPos
go (Inherit ms names _pos) = Inherit ms names nullPos
go (NamedVar path r _pos) = NamedVar path r nullPos
go (Inherit ms names _pos) = Inherit ms names nullPos
nullPos :: SourcePos
nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)

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

@ -18,34 +18,43 @@
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
import Codec.Serialise
#endif
import Control.DeepSeq
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Aeson.TH
import Data.Binary (Binary(..))
import Data.Data
import Data.Eq.Deriving
import Data.Fix
import Data.Function (on)
import Data.Functor.Compose
import Data.Hashable
import Control.DeepSeq
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
)
import Data.Aeson.TH
import Data.Binary ( Binary(..) )
import Data.Data
import Data.Eq.Deriving
import Data.Fix
import Data.Function ( on )
import Data.Functor.Compose
import Data.Hashable
#if MIN_VERSION_hashable(1, 2, 5)
import Data.Hashable.Lifted
import Data.Hashable.Lifted
#endif
import Data.Ord.Deriving
import Data.Text (Text, pack)
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Text.Megaparsec (unPos, mkPos)
import Text.Megaparsec.Pos (SourcePos(..))
import Text.Read.Deriving
import Text.Show.Deriving
import Data.Ord.Deriving
import Data.Text ( Text
, pack
)
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Text.Megaparsec ( unPos
, mkPos
)
import Text.Megaparsec.Pos ( SourcePos(..) )
import Text.Read.Deriving
import Text.Show.Deriving
-- | A location in a source file
data SrcSpan = SrcSpan
@ -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
@ -130,8 +138,8 @@ instance FromJSON SrcSpan
#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where
encode (Compose (Ann ann a)) = encode ann <> encode a
decode = (Compose .) . Ann <$> decode <*> decode
encode (Compose (Ann ann a)) = encode ann <> encode a
decode = (Compose .) . Ann <$> decode <*> decode
#endif
pattern AnnE :: forall ann (g :: * -> *). ann
@ -146,32 +154,32 @@ stripAnn = annotated . getCompose
nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc
nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NUnary u e1)
nUnary _ _ = error "nUnary: unexpected"
nUnary _ _ = error "nUnary: unexpected"
nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
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))
_ -> error "nSelectLoc: unexpected"
_ -> error "nSelectLoc: unexpected"
nSelectLoc _ _ _ = error "nSelectLoc: unexpected"
nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc
nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) (NHasAttr e1 ats)
nHasAttr _ _ = error "nHasAttr: unexpected"
nHasAttr _ _ = error "nHasAttr: unexpected"
nApp :: NExprLoc -> NExprLoc -> NExprLoc
nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) (NBinary NApp e1 e2)
nApp _ _ = error "nApp: unexpected"
nApp _ _ = error "nApp: unexpected"
nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc
nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NAbs ps e1)
nAbs _ _ = error "nAbs: unexpected"
nAbs _ _ = error "nAbs: unexpected"
nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc
nStr (Ann s1 s) = AnnE s1 (NStr s)

44
src/Nix/Frames.hs
View File

@ -4,16 +4,26 @@
{-# 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.Monad.Catch
import Control.Monad.Reader
import Data.Typeable hiding (typeOf)
import Nix.Utils
import Control.Exception hiding ( catch
, evaluate
)
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Typeable hiding ( typeOf )
import Nix.Utils
data NixLevel = Fatal | Error | Warning | Info | Debug
deriving (Ord, Eq, Bounded, Enum, Show)
@ -24,8 +34,8 @@ data NixFrame = NixFrame
}
instance Show NixFrame where
show (NixFrame level f) =
"Nix frame at level " ++ show level ++ ": "++ show f
show (NixFrame level f) =
"Nix frame at level " ++ show level ++ ": " ++ show f
type Frames = [NixFrame]
@ -36,11 +46,13 @@ 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..."
throwM $ NixException (NixFrame Error (toException err):context)
context <- asks (view hasLens)
traceM "Throwing error..."
throwM $ NixException (NixFrame Error (toException err) : context)

49
src/Nix/Fresh.hs
View File

@ -14,22 +14,22 @@
module Nix.Fresh where
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Writer
import Data.Typeable
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Writer
import Data.Typeable
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
import System.Console.Haskeline.MonadException hiding(catch)
#endif
import Nix.Var
import Nix.Thunk
import Nix.Var
import Nix.Thunk
newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a }
deriving
@ -50,10 +50,10 @@ newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a }
)
instance MonadTrans (FreshIdT i) where
lift = FreshIdT . lift
lift = FreshIdT . lift
instance MonadBase b m => MonadBase b (FreshIdT i m) where
liftBase = FreshIdT . liftBase
liftBase = FreshIdT . liftBase
-- instance MonadTransControl (FreshIdT i) where
-- type StT (FreshIdT i) a = StT (ReaderT (Var m i)) a
@ -75,20 +75,20 @@ instance ( MonadVar m
=> MonadThunkId (FreshIdT i m) where
type ThunkId (FreshIdT i m) = i
freshId = FreshIdT $ do
v <- ask
atomicModifyVar v (\i -> (succ i, i))
v <- ask
atomicModifyVar v (\i -> (succ i, i))
runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a
runFreshIdT i m = runReaderT (unFreshIdT m) i
instance MonadThunkId m => MonadThunkId (ReaderT r m) where
type ThunkId (ReaderT r m) = ThunkId m
type ThunkId (ReaderT r m) = ThunkId m
instance (Monoid w, MonadThunkId m) => MonadThunkId (WriterT w m) where
type ThunkId (WriterT w m) = ThunkId m
type ThunkId (WriterT w m) = ThunkId m
instance MonadThunkId m => MonadThunkId (ExceptT e m) where
type ThunkId (ExceptT e m) = ThunkId m
type ThunkId (ExceptT e m) = ThunkId m
instance MonadThunkId m => MonadThunkId (StateT s m) where
type ThunkId (StateT s m) = ThunkId m
type ThunkId (StateT s m) = ThunkId m
-- Orphan instance needed by Infer.hs and Lint.hs
@ -104,3 +104,10 @@ instance MonadAtomicRef (ST s) where
let (a, b) = f v
writeRef r $! a
return b

49
src/Nix/Json.hs
View File

@ -6,13 +6,13 @@ module Nix.Json where
import Control.Monad
import Control.Monad.Trans
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import qualified Data.HashMap.Lazy as HM
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Vector as V
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import qualified Data.HashMap.Lazy as HM
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Vector as V
import Nix.Atoms
import Nix.Effects
import Nix.Exec
@ -23,27 +23,32 @@ 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
. A.encodingToLazyByteString
. toEncodingSorted)
. nvalueToJSON
nvalueToJSONNixString =
runWithStringContextT
. fmap
( TL.toStrict
. TL.decodeUtf8
. A.encodingToLazyByteString
. toEncodingSorted
)
. nvalueToJSON
nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
nvalueToJSON = \case
NVConstant (NInt n) -> pure $ A.toJSON n
NVConstant (NInt n) -> pure $ A.toJSON n
NVConstant (NFloat n) -> pure $ A.toJSON n
NVConstant (NBool b) -> pure $ A.toJSON b
NVConstant NNull -> pure $ A.Null
NVStr ns -> A.toJSON <$> extractNixString ns
NVList l ->
A.Array . V.fromList
<$> traverse (join . lift . flip force (return . nvalueToJSON)) l
NVConstant (NBool b) -> pure $ A.toJSON b
NVConstant NNull -> pure $ A.Null
NVStr ns -> A.toJSON <$> extractNixString ns
NVList l ->
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
NVPath p -> do
fp <- lift $ unStorePath <$> addPath p
addSingletonStringContext $ StringContext (Text.pack fp) DirectPath
return $ A.toJSON fp

507
src/Nix/Lint.hs
View File

@ -27,22 +27,22 @@ module Nix.Lint where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.Reader (MonadReader)
import Control.Monad.Reader ( MonadReader )
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.Trans.Reader
import Data.Coerce
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.List.NonEmpty as NE
import Data.Text ( Text )
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval
import Nix.Eval ( MonadEval(..) )
import qualified Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Fresh
@ -72,25 +72,25 @@ data NTypeF (m :: * -> *) r
deriving Functor
compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes (TConstant _) (TConstant _) = EQ
compareTypes (TConstant _) _ = LT
compareTypes _ (TConstant _) = GT
compareTypes TStr TStr = EQ
compareTypes TStr _ = LT
compareTypes _ TStr = GT
compareTypes (TList _) (TList _) = EQ
compareTypes (TList _) _ = LT
compareTypes _ (TList _) = GT
compareTypes (TSet _) (TSet _) = EQ
compareTypes (TSet _) _ = LT
compareTypes _ (TSet _) = GT
compareTypes TClosure {} TClosure {} = EQ
compareTypes TClosure {} _ = LT
compareTypes _ TClosure {} = GT
compareTypes TPath TPath = EQ
compareTypes TPath _ = LT
compareTypes _ TPath = GT
compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ
compareTypes (TConstant _) (TConstant _) = EQ
compareTypes (TConstant _) _ = LT
compareTypes _ (TConstant _) = GT
compareTypes TStr TStr = EQ
compareTypes TStr _ = LT
compareTypes _ TStr = GT
compareTypes (TList _) (TList _) = EQ
compareTypes (TList _) _ = LT
compareTypes _ (TList _) = GT
compareTypes (TSet _) (TSet _) = EQ
compareTypes (TSet _) _ = LT
compareTypes _ (TSet _) = GT
compareTypes TClosure{} TClosure{} = EQ
compareTypes TClosure{} _ = LT
compareTypes _ TClosure{} = GT
compareTypes TPath TPath = EQ
compareTypes TPath _ = LT
compareTypes _ TPath = GT
compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ
data NSymbolicF r
= NAny
@ -103,7 +103,7 @@ newtype Symbolic m =
Symbolic { getSymbolic :: Var m (NSymbolicF (NTypeF m (SThunk m))) }
instance Show (Symbolic m) where
show _ = "<symbolic>"
show _ = "<symbolic>"
everyPossible :: MonadVar m => m (Symbolic m)
everyPossible = packSymbolic NAny
@ -111,83 +111,87 @@ 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 :: forall e m a . MonadLint e m => String -> m a
symerr = evalError @(Symbolic m) . ErrorCall
renderSymbolic :: MonadLint e m => Symbolic m -> m String
renderSymbolic = unpackSymbolic >=> \case
NAny -> return "<any>"
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case
TInt -> return "int"
TFloat -> return "float"
TBool -> return "bool"
TNull -> return "null"
TStr -> return "string"
TList r -> do
x <- force r renderSymbolic
return $ "[" ++ x ++ "]"
TSet Nothing -> return "<any set>"
TSet (Just s) -> do
x <- traverse (`force` renderSymbolic) s
return $ "{" ++ show x ++ "}"
f@(TClosure p) -> do
(args, sym) <- do
f' <- mkSymbolic [f]
lintApp (NAbs (void p) ()) f' everyPossible
args' <- traverse renderSymbolic args
sym' <- renderSymbolic sym
return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
TPath -> return "path"
TBuiltin _n _f -> return "<builtin function>"
NAny -> return "<any>"
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case
TInt -> return "int"
TFloat -> return "float"
TBool -> return "bool"
TNull -> return "null"
TStr -> return "string"
TList r -> do
x <- force r renderSymbolic
return $ "[" ++ x ++ "]"
TSet Nothing -> return "<any set>"
TSet (Just s) -> do
x <- traverse (`force` renderSymbolic) s
return $ "{" ++ show x ++ "}"
f@(TClosure p) -> do
(args, sym) <- do
f' <- mkSymbolic [f]
lintApp (NAbs (void p) ()) f' everyPossible
args' <- traverse renderSymbolic args
sym' <- renderSymbolic sym
return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")"
TPath -> return "path"
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)]
-> 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 [] _ = return []
go _ [] = return []
go (x:xs) (y:ys) = case (x, y) of
(TStr, TStr) -> (TStr :) <$> go xs ys
(TPath, TPath) -> (TPath :) <$> go xs ys
(TConstant ls, TConstant rs) ->
(TConstant (ls `intersect` rs) :) <$> go xs ys
(TList l, TList r) -> force l $ \l' -> force r $ \r' -> do
m <- thunk $ unify context l' r'
(TList m :) <$> go xs ys
(TSet x, TSet Nothing) -> (TSet x :) <$> go xs ys
(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
(TClosure {}, TClosure {}) ->
throwError $ ErrorCall "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
throwError $ ErrorCall "Cannot unify builtin functions"
_ | compareTypes x y == LT -> go xs (y:ys)
| compareTypes x y == GT -> go (x:xs) ys
| otherwise -> error "impossible"
where
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
(TStr , TStr ) -> (TStr :) <$> go xs ys
(TPath, TPath) -> (TPath :) <$> go xs ys
(TConstant ls, TConstant rs) ->
(TConstant (ls `intersect` rs) :) <$> go xs ys
(TList l, TList r) -> force l $ \l' -> force r $ \r' -> do
m <- thunk $ unify context l' r'
(TList m :) <$> go xs ys
(TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys
(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
(TClosure{}, TClosure{}) ->
throwError $ ErrorCall "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
throwError $ ErrorCall "Cannot unify builtin functions"
_ | compareTypes x y == LT -> go xs (y : ys)
| compareTypes x y == GT -> go (x : xs) ys
| otherwise -> error "impossible"
{-
mergeFunctions pl nl fl pr fr xs ys = do
@ -209,31 +213,36 @@ 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
case (x', y') of
(NAny, _) -> do
writeVar x y'
return $ Symbolic y
(_, NAny) -> do
writeVar y x'
return $ Symbolic x
(NMany xs, NMany ys) -> do
m <- merge context xs ys
if null m
then do
-- x' <- renderSymbolic (Symbolic x)
-- y' <- renderSymbolic (Symbolic y)
throwError $ ErrorCall "Cannot unify "
-- ++ show x' ++ " with " ++ show y'
-- ++ " in context: " ++ show context
else do
writeVar x (NMany m)
writeVar y (NMany m)
packSymbolic (NMany m)
x' <- readVar x
y' <- readVar y
case (x', y') of
(NAny, _) -> do
writeVar x y'
return $ Symbolic y
(_, NAny) -> do
writeVar y x'
return $ Symbolic x
(NMany xs, NMany ys) -> do
m <- merge context xs ys
if null m
then do
-- x' <- renderSymbolic (Symbolic x)
-- y' <- renderSymbolic (Symbolic y)
throwError $ ErrorCall "Cannot unify "
-- ++ show x' ++ " with " ++ show y'
-- ++ " in context: " ++ show context
else do
writeVar x (NMany m)
writeVar y (NMany m)
packSymbolic (NMany m)
-- These aren't worth defining yet, because once we move to Hindley-Milner,
-- we're not going to be managing Symbolic values this way anymore.
@ -249,151 +258,155 @@ instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
instance ToValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where
thunk = fmap SThunk . thunk
thunkId = thunkId . getSThunk
query x b f = query (getSThunk x) b f
queryM x b f = queryM (getSThunk x) b f
force = force . getSThunk
forceEff = forceEff . getSThunk
wrapValue = SThunk . wrapValue
getValue = getValue . getSThunk
thunk = fmap SThunk . thunk
thunkId = thunkId . getSThunk
query x b f = query (getSThunk x) b f
queryM x b f = queryM (getSThunk x) b f
force = force . getSThunk
forceEff = forceEff . getSThunk
wrapValue = SThunk . wrapValue
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: "
++ intercalate "." (map Text.unpack (NE.toList ks))
attrMissing ks Nothing =
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 "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show s
attrMissing ks (Just s) =
evalError @(Symbolic m)
$ ErrorCall
$ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in "
++ show s
evalCurPos = do
f <- wrapValue <$> mkSymbolic [TPath]
l <- wrapValue <$> mkSymbolic [TConstant [TInt]]
c <- wrapValue <$> mkSymbolic [TConstant [TInt]]
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) ]
evalCurPos = do
f <- wrapValue <$> mkSymbolic [TPath]
l <- wrapValue <$> mkSymbolic [TConstant [TInt]]
c <- wrapValue <$> mkSymbolic [TConstant [TInt]]
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)]
evalConstant c = mkSymbolic [TConstant [go c]]
where
go = \case
NInt _ -> TInt
NFloat _ -> TFloat
NBool _ -> TBool
NNull -> TNull
evalConstant c = mkSymbolic [TConstant [go c]]
where
go = \case
NInt _ -> TInt
NFloat _ -> TFloat
NBool _ -> TBool
NNull -> TNull
evalString = const $ mkSymbolic [TStr]
evalLiteralPath = const $ mkSymbolic [TPath]
evalEnvPath = const $ mkSymbolic [TPath]
evalString = const $ mkSymbolic [TStr]
evalLiteralPath = const $ mkSymbolic [TPath]
evalEnvPath = const $ mkSymbolic [TPath]
evalUnary op arg =
unify (void (NUnary op arg)) arg
=<< mkSymbolic [TConstant [TInt, TBool]]
evalUnary op arg =
unify (void (NUnary op arg)) arg =<< mkSymbolic [TConstant [TInt, TBool]]
evalBinary = lintBinaryOp
evalBinary = lintBinaryOp
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'
NMany [TSet Nothing] -> error "NYI: with unknown"
_ -> throwError $ ErrorCall "scope must be a set in with statement"
-- 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
s <- thunk @(SThunk m) @m @(Symbolic m) scope
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
NMany [TSet (Just s')] -> return s'
NMany [TSet Nothing] -> error "NYI: with unknown"
_ -> throwError $ ErrorCall "scope must be a set in with statement"
evalIf cond t f = do
t' <- t
f' <- f
let e = NIf cond t' f'
_ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]]
unify (void e) t' f'
evalIf cond t f = do
t' <- t
f' <- f
let e = NIf cond t' f'
_ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]]
unify (void e) t' f'
evalAssert cond body = do
body' <- body
let e = NAssert cond body'
_ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]]
pure body'
evalAssert cond body = do
body' <- body
let e = NAssert cond body'
_ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]]
pure body'
evalApp = (fmap snd .) . lintApp (NBinary NApp () ())
evalAbs params _ = mkSymbolic [TClosure (void params)]
evalApp = (fmap snd .) . lintApp (NBinary NApp () ())
evalAbs params _ = mkSymbolic [TClosure (void params)]
evalError = throwError
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 ]
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]
NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NGt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NGte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
NLt -> check lsym rsym [TConstant [TInt, TBool, TNull]]
NLte -> check lsym rsym [TConstant [TInt, TBool, TNull]]
NGt -> check lsym rsym [TConstant [TInt, TBool, TNull]]
NGte -> check lsym rsym [TConstant [TInt, TBool, TNull]]
NAnd -> check lsym rsym [ TConstant [TBool] ]
NOr -> check lsym rsym [ TConstant [TBool] ]
NImpl -> check lsym rsym [ TConstant [TBool] ]
NAnd -> check lsym rsym [TConstant [TBool]]
NOr -> check lsym rsym [TConstant [TBool]]
NImpl -> check lsym rsym [TConstant [TBool]]
-- jww (2018-04-01): NYI: Allow Path + Str
NPlus -> check lsym rsym [ TConstant [TInt], TStr, TPath ]
NMinus -> check lsym rsym [ TConstant [TInt] ]
NMult -> check lsym rsym [ TConstant [TInt] ]
NDiv -> check lsym rsym [ TConstant [TInt] ]
-- jww (2018-04-01): NYI: Allow Path + Str
NPlus -> check lsym rsym [TConstant [TInt], TStr, TPath]
NMinus -> check lsym rsym [TConstant [TInt]]
NMult -> check lsym rsym [TConstant [TInt]]
NDiv -> check lsym rsym [TConstant [TInt]]
NUpdate -> check lsym rsym [ TSet Nothing ]
NUpdate -> check lsym rsym [TSet Nothing]
NConcat -> check lsym rsym [ TList y ]
where
check lsym rsym xs = do
let e = NBinary op lsym rsym
m <- mkSymbolic xs
_ <- unify (void e) lsym m
_ <- unify (void e) rsym m
unify (void e) lsym rsym
NConcat -> check lsym rsym [TList y]
where
check lsym rsym xs = do
let e = NBinary op lsym rsym
m <- mkSymbolic xs
_ <- unify (void e) lsym m
_ <- unify (void e) rsym m
unify (void e) lsym rsym
infixl 1 `lintApp`
lintApp :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> m (Symbolic m)
-> m (HashMap VarName (Symbolic 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"
NMany xs -> do
(args, ys) <- fmap unzip $ forM xs $ \case
TClosure _params -> arg >>= unpackSymbolic >>= \case
NAny -> do
error "NYI"
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
NAny -> do
error "NYI"
NMany [TSet (Just _)] -> do
error "NYI"
NMany [TSet (Just _)] -> do
error "NYI"
NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin"
TSet _m -> throwError $ ErrorCall "NYI: lintApp Set"
_x -> throwError $ ErrorCall "Attempt to call non-function"
NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin"
TSet _m -> throwError $ ErrorCall "NYI: lintApp Set"
_x -> throwError $ ErrorCall "Attempt to call non-function"
y <- everyPossible
(head args,) <$> foldM (unify context) y ys
y <- everyPossible
(head args, ) <$> foldM (unify context) y ys
newtype Lint s a = Lint
{ runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (FreshIdT Int (ST s)) a }
@ -409,28 +422,30 @@ newtype Lint s a = Lint
)
instance MonadThrow (Lint s) where
throwM e = Lint $ ReaderT $ \_ -> throw e
throwM e = Lint $ ReaderT $ \_ -> throw e
instance MonadCatch (Lint s) where
catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'"
catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'"
runLintM :: Options -> Lint s a -> ST s a
runLintM opts action = do
i <- newVar (1 :: Int)
runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action
i <- newVar (1 :: Int)
runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action
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
clearScopes = clearScopesReader @(Lint s) @(SThunk (Lint s))
pushScopes = pushScopesReader
lookupVar = lookupVarReader
clearScopes = clearScopesReader @(Lint s) @(SThunk (Lint s))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

141
src/Nix/Normal.hs
View File

@ -12,15 +12,15 @@
module Nix.Normal where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Set
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Set
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
newtype NormalLoop t f m = NormalLoop (NValue t f m)
deriving Show
@ -28,79 +28,88 @@ 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
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> (forall r. t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValueNF t f m)
:: forall e t m f
. ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> (forall r . t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValueNF t f m)
normalForm' f = run . nValueToNFM run go
where
start = 0 :: Int
table = mempty
where
start = 0 :: Int
table = mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start)
go :: t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m))
go
:: t
-> ( NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
go t k = do
b <- seen t
if b
then return $ pure t
else do
i <- ask
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
lift $ put s'
return res
)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
go t k = do
b <- seen t
if b
then return $ pure t
else do
i <- ask
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
lift $ put s'
return res
seen t = case thunkId t of
Just tid -> lift $ do
res <- gets (member tid)
unless res $ modify (insert tid)
return res
Nothing ->
return False
seen t = case thunkId t of
Just tid -> lift $ do
res <- gets (member tid)
unless res $ modify (insert tid)
return res
Nothing -> return False
normalForm
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m (NValueNF t f m)
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m
-> m (NValueNF t f m)
normalForm = normalForm' force
normalForm_
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m -> m ()
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId 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

63
src/Nix/Options.hs
View File

@ -1,6 +1,6 @@
module Nix.Options where
import Data.Text (Text)
import Data.Text ( Text )
import Data.Time
data Options = Options
@ -37,37 +37,36 @@ data Options = Options
deriving Show
defaultOptions :: UTCTime -> Options
defaultOptions current = Options
{ verbose = ErrorsOnly
, tracing = False
, thunks = False
, values = False
, scopes = False
, reduce = Nothing
, reduceSets = False
, reduceLists = False
, parse = False
, parseOnly = False
, finder = False
, findFile = Nothing
, strict = False
, evaluate = False
, json = False
, xml = False
, attr = Nothing
, include = []
, check = False
, readFrom = Nothing
, cache = False
, repl = False
, ignoreErrors = False
, expression = Nothing
, arg = []
, argstr = []
, fromFile = Nothing
, currentTime = current
, filePaths = []
}
defaultOptions current = Options { verbose = ErrorsOnly
, tracing = False
, thunks = False
, values = False
, scopes = False
, reduce = Nothing
, reduceSets = False
, reduceLists = False
, parse = False
, parseOnly = False
, finder = False
, findFile = Nothing
, strict = False
, evaluate = False
, json = False
, xml = False
, attr = Nothing
, include = []
, check = False
, readFrom = Nothing
, cache = False
, repl = False
, ignoreErrors = False
, expression = Nothing
, arg = []
, argstr = []
, fromFile = Nothing
, currentTime = current
, filePaths = []
}
data Verbosity
= ErrorsOnly

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

@ -1,13 +1,13 @@
module Nix.Options.Parser where
import Control.Arrow (second)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Arrow ( second )
import Data.Char ( isDigit )
import Data.Maybe ( fromMaybe )
import Data.Text ( Text )
import qualified Data.Text as Text
import Data.Time
import Nix.Options
import Options.Applicative hiding (ParserResult(..))
import Options.Applicative hiding ( ParserResult(..) )
decodeVerbosity :: Int -> Verbosity
decodeVerbosity 0 = ErrorsOnly
@ -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"
Just i -> return $ second Text.tail $ Text.splitAt i s
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
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")))
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")
)
)
<*> switch
( long "trace"
<> help "Enable tracing code (even more can be seen if built with --flags=tracing)")
( long "trace"
<> help
"Enable tracing code (even more can be seen if built with --flags=tracing)"
)
<*> switch
( long "thunks"
<> help "Enable reporting of thunk tracing as well as regular evaluation")
(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")
( long "values"
<> help "Enable reporting of value provenance in error messages"
)
<*> switch
( long "scopes"
<> 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"))
( long "scopes"
<> 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"
)
)
<*> 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)")
( long "parse"
<> help "Whether to parse the file (also the default right now)"
)
<*> switch
( long "parse-only"
<> help "Whether to parse only, no pretty printing or checking")
( long "parse-only"
<> help "Whether to parse only, no pretty printing or checking"
)
<*> switch (long "find" <> help "If selected, find paths within attr trees")
<*> optional
(strOption
( long "find-file"
<> help "Look up the given files in Nix's search path"
)
)
<*> switch
( long "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"))
( long "strict"
<> help
"When used with --eval, recursively evaluate list elements and attributes"
)
<*> switch (long "eval" <> help "Whether to evaluate, or just pretty-print")
<*> switch
( long "strict"
<> help "When used with --eval, recursively evaluate list elements and attributes")
( long "json"
<> help "Print the resulting value as an JSON representation"
)
<*> switch
( long "eval"
<> help "Whether to evaluate, or just pretty-print")
( long "xml"
<> help "Print the resulting value as an XML representation"
)
<*> optional
(strOption
( short 'A'
<> long "attr"
<> help
"Select an attribute from the top-level Nix expression being evaluated"
)
)
<*> many
(strOption
(short 'I' <> long "include" <> help
"Add a path to the Nix expression search path"
)
)
<*> switch
( long "json"
<> help "Print the resulting value as an JSON representation")
( long "check"
<> help "Whether to check for syntax errors after parsing"
)
<*> optional
(strOption
( long "read"
<> help "Read in an expression tree from a binary cache"
)
)
<*> switch
( long "xml"
<> help "Print the resulting value as an XML representation")
<*> optional (strOption
( short 'A'
<> long "attr"
<> help "Select an attribute from the top-level Nix expression being evaluated"))
<*> many (strOption
( short 'I'
<> long "include"
<> help "Add a path to the Nix expression search path"))
( long "cache"
<> help "Write out the parsed expression tree to a binary cache"
)
<*> switch
( long "check"
<> help "Whether to check for syntax errors after parsing")
<*> optional (strOption
( long "read"
<> help "Read in an expression tree from a binary cache"))
( long "repl"
<> help "After performing any indicated actions, enter the REPL"
)
<*> switch
( long "cache"
<> help "Write out the parsed expression tree to a binary cache")
<*> switch
( long "repl"
<> help "After performing any indicated actions, enter the REPL")
<*> switch
( long "ignore-errors"
<> help "Continue parsing files, even if there are errors")
<*> optional (strOption
( short 'E'
<> long "expr"
<> help "Expression to parse or evaluate"))
<*> many (argPair
( long "arg"
<> help "Argument to pass to an evaluated lambda"))
<*> many (argPair
( long "argstr"
<> help "Argument string to pass to an evaluated lambda"))
<*> optional (strOption
( short 'f'
<> long "file"
<> help "Parse all of the files given in FILE; - means stdin"))
<*> option (parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str)
( long "now"
<> value current
<> help "Set current time for testing purposes")
( long "ignore-errors"
<> help "Continue parsing files, even if there are errors"
)
<*> optional
(strOption
(short 'E' <> long "expr" <> help "Expression to parse or evaluate")
)
<*> many
(argPair
(long "arg" <> help "Argument to pass to an evaluated lambda")
)
<*> many
(argPair
( long "argstr"
<> help "Argument string to pass to an evaluated lambda"
)
)
<*> optional
(strOption
(short 'f' <> long "file" <> help
"Parse all of the files given in FILE; - means stdin"
)
)
<*> option
(parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str)
(long "now" <> value current <> help
"Set current time for testing purposes"
)
<*> many (strArgument (metavar "FILE" <> help "Path of file to parse"))
nixOptionsInfo :: UTCTime -> ParserInfo Options
nixOptionsInfo current =
info (helper <*> nixOptions current)
(fullDesc <> progDesc "" <> header "hnix")
nixOptionsInfo current = info (helper <*> nixOptions current)
(fullDesc <> progDesc "" <> header "hnix")

647
src/Nix/Parser.hs
View File

@ -10,71 +10,82 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Nix.Parser
( parseNixFile
, parseNixFileLoc
, parseNixText
, parseNixTextLoc
, parseFromFileEx
, Parser
, parseFromText
, Result(..)
, reservedNames
, OperatorInfo(..)
, NSpecialOp(..)
, NAssoc(..)
, NOperatorDef
, getUnaryOperator
, getBinaryOperator
, getSpecialOperator
( parseNixFile
, parseNixFileLoc
, parseNixText
, parseNixTextLoc
, parseFromFileEx
, Parser
, parseFromText
, Result(..)
, reservedNames
, OperatorInfo(..)
, NSpecialOp(..)
, NAssoc(..)
, NOperatorDef
, getUnaryOperator
, getBinaryOperator
, getSpecialOperator
, nixToplevelForm
, nixExpr
, nixSet
, nixBinders
, nixSelector
, nixSym
, nixPath
, nixString
, nixUri
, nixSearchPath
, nixFloat
, nixInt
, nixBool
, nixNull
, symbol
, whiteSpace
)
where
, nixToplevelForm
, nixExpr
, nixSet
, nixBinders
, nixSelector
import Prelude hiding ( readFile )
, nixSym
, nixPath
, nixString
, nixUri
, nixSearchPath
, nixFloat
, nixInt
, nixBool
, nixNull
, symbol
, whiteSpace
) 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.Data (Data(..))
import Data.Foldable (concat)
import Data.Char ( isAlpha
, isDigit
, isSpace
)
import Data.Data ( Data(..) )
import Data.Foldable ( concat )
import Data.Functor
import Data.Functor.Identity
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
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.HashSet ( HashSet )
import qualified Data.HashSet as HashSet
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.Encoding
import Data.Typeable (Typeable)
import Data.Typeable ( Typeable )
import Data.Void
import GHC.Generics hiding (Prefix)
import Nix.Expr hiding (($>))
import GHC.Generics hiding ( Prefix )
import Nix.Expr hiding ( ($>) )
import Nix.Render
import Nix.Strings
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Text.Megaparsec.Char.Lexer as L
infixl 3 <+>
(<+>) :: MonadPlus m => m a -> m a -> m a
@ -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,62 +112,69 @@ selDot = try (symbol "." *> notFollowedBy nixPath) <?> "."
nixSelect :: Parser NExprLoc -> Parser NExprLoc
nixSelect term = do
res <- build
<$> term
<*> optional ((,) <$> (selDot *> nixSelector)
<*> optional (reserved "or" *> nixTerm))
continues <- optional $ lookAhead selDot
case continues of
Nothing -> pure res
Just _ -> nixSelect (pure res)
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
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
-> NExprLoc
build t Nothing = t
build t (Just (s,o)) = nSelectLoc t s o
build
:: NExprLoc
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
-> NExprLoc
build t Nothing = t
build t (Just (s, o)) = nSelectLoc t s o
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
nixSelector = annotateLocation $ do
(x:xs) <- keyName `sepBy1` selDot
return $ x :| xs
(x : xs) <- keyName `sepBy1` selDot
return $ x :| xs
nixTerm :: Parser NExprLoc
nixTerm = do
c <- try $ lookAhead $ satisfy $ \x ->
pathChar x ||
x == '(' ||
x == '{' ||
x == '[' ||
x == '<' ||
x == '/' ||
x == '"' ||
x == '\''||
x == '^'
case c of
'(' -> nixSelect nixParens
'{' -> nixSelect nixSet
'[' -> nixList
'<' -> nixSearchPath
'/' -> nixPath
'"' -> 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 ]
c <- try $ lookAhead $ satisfy $ \x ->
pathChar x
|| x
== '('
|| x
== '{'
|| x
== '['
|| x
== '<'
|| x
== '/'
|| x
== '"'
|| x
== '\''
|| x
== '^'
case c of
'(' -> nixSelect nixParens
'{' -> nixSelect nixSet
'[' -> nixList
'<' -> nixSearchPath
'/' -> nixPath
'"' -> 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]
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))
(Prelude.concat <$> some (liftM2 (:) slash (some (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")
where
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
nixLet = annotateLocation1
(reserved "let" *> (letBody <+> letBinders) <?> "let block")
where
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
<$> (reserved "if" *> nixExpr)
<*> (reserved "then" *> nixToplevelForm)
<*> (reserved "else" *> nixToplevelForm)
<?> "if")
nixIf = annotateLocation1
( NIf
<$> (reserved "if" *> nixExpr)
<*> (reserved "then" *> nixToplevelForm)
<*> (reserved "else" *> nixToplevelForm)
<?> "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
@ -243,55 +287,64 @@ nixString = nStr <$> annotateLocation nixString'
nixUri :: Parser NExprLoc
nixUri = annotateLocation1 $ lexeme $ try $ do
start <- letterChar
protocol <- many $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("+-." :: String)
_ <- string ":"
address <- some $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
return $ NStr $
DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address]
start <- letterChar
protocol <- many $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("+-." :: String)
_ <- string ":"
address <- some $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
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)
<?> "double quoted string"
where
doubleQuoted :: Parser (NString NExprLoc)
doubleQuoted =
DoubleQuoted
. removePlainEmpty
. mergePlain
<$> ( doubleQ
*> many (stringChar doubleQ (void $ char '\\') doubleEscape)
<* doubleQ
)
<?> "double quoted string"
doubleQ = void (char '"')
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
doubleQ = void (char '"')
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
indented :: Parser (NString NExprLoc)
indented = stripIndent
<$> (indentedQ *> many (stringChar indentedQ indentedQ
indentedEscape)
<* indentedQ)
<?> "indented string"
indented :: Parser (NString NExprLoc)
indented =
stripIndent
<$> ( indentedQ
*> many (stringChar indentedQ indentedQ indentedEscape)
<* indentedQ
)
<?> "indented string"
indentedQ = void (string "''" <?> "\"''\"")
indentedEscape = try $ do
indentedQ
(Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do
_ <- char '\\'
c <- escapeCode
pure $ if c == '\n'
then EscapedNewline
else Plain $ singleton c
indentedQ = void (string "''" <?> "\"''\"")
indentedEscape = try $ do
indentedQ
(Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do
_ <- char '\\'
c <- escapeCode
pure $ if c == '\n' then EscapedNewline else Plain $ singleton c
stringChar end escStart esc =
Antiquoted <$> (antiStart *> nixToplevelForm <* char '}')
<+> Plain . singleton <$> char '$'
<+> esc
<+> Plain . pack <$> some plainChar
where
plainChar =
notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle
stringChar end escStart esc =
Antiquoted
<$> (antiStart *> nixToplevelForm <* char '}')
<+> Plain
. singleton
<$> char '$'
<+> esc
<+> Plain
. pack
<$> some plainChar
where
plainChar =
notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle
escapeCode = msum [ c <$ char e | (c,e) <- escapeCodes ] <+> anySingle
escapeCode = msum [ c <$ char e | (c, e) <- escapeCodes ] <+> anySingle
-- | Gets all of the arguments for a function.
argExpr :: Parser (Params NExprLoc)
@ -300,19 +353,22 @@ 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
name <- identifier <* symbol "@"
name <- identifier <* symbol "@"
(variadic, params) <- params
return $ ParamSet params variadic (Just name)
-- Parameters named by an identifier on the right, or none (`{x, y} @ args`)
atRight = do
(variadic, params) <- params
name <- optional $ symbol "@" *> identifier
name <- optional $ symbol "@" *> identifier
return $ ParamSet params variadic name
-- Return the parameters set.
@ -323,7 +379,7 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
-- Collects the parameters within curly braces. Returns the parameters and
-- a boolean indicating if the parameters are variadic.
getParams :: Parser ([(Text, Maybe NExprLoc)], Bool)
getParams = go [] where
getParams = go [] where
-- Attempt to parse `...`. If this succeeds, stop and return True.
-- Otherwise, attempt to parse an argument, optionally with a
-- default. If this fails, then return what has been accumulated
@ -331,49 +387,49 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
go acc = ((acc, True) <$ symbol "...") <+> getMore acc
getMore acc =
-- Could be nothing, in which just return what we have so far.
option (acc, False) $ do
option (acc, False) $ do
-- Get an argument name and an optional default.
pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm)
-- Either return this, or attempt to get a comma and restart.
option (acc ++ [pair], False) $ comma >> go (acc ++ [pair])
pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm)
-- Either return this, or attempt to get a comma and restart.
option (acc ++ [pair], False) $ comma >> go (acc ++ [pair])
nixBinders :: Parser [Binding NExprLoc]
nixBinders = (inherit <+> namedVar) `endBy` semi where
inherit = do
-- We can't use 'reserved' here because it would consume the whitespace
-- after the keyword, which is not exactly the semantics of C++ Nix.
try $ string "inherit" *> lookAhead (void (satisfy reservedEnd))
p <- getSourcePos
x <- whiteSpace *> optional scope
Inherit x <$> many keyName <*> pure p <?> "inherited binding"
try $ string "inherit" *> lookAhead (void (satisfy reservedEnd))
p <- getSourcePos
x <- whiteSpace *> optional scope
Inherit x <$> many keyName <*> pure p <?> "inherited binding"
namedVar = do
p <- getSourcePos
NamedVar <$> (annotated <$> nixSelector)
<*> (equals *> nixToplevelForm)
<*> pure p
<?> "variable binding"
p <- getSourcePos
NamedVar
<$> (annotated <$> nixSelector)
<*> (equals *> nixToplevelForm)
<*> pure p
<?> "variable binding"
scope = parens nixToplevelForm <?> "inherit scope"
keyName :: Parser (NKeyName NExprLoc)
keyName = dynamicKey <+> staticKey where
staticKey = StaticKey <$> identifier
staticKey = StaticKey <$> identifier
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 =
parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc)
parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof)
parseNixText :: Text -> Result NExpr
parseNixText =
parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseNixTextLoc :: Text -> Result NExprLoc
parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
@ -381,15 +437,14 @@ parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
{- Parser.Library -}
skipLineComment' :: Tokens Text -> Parser ()
skipLineComment' prefix =
string prefix
*> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
skipLineComment' prefix = string prefix
*> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
whiteSpace :: Parser ()
whiteSpace = L.space space1 lineCmnt blockCmnt
where
lineCmnt = skipLineComment' "#"
blockCmnt = L.skipBlockComment "/*" "*/"
where
lineCmnt = skipLineComment' "#"
blockCmnt = L.skipBlockComment "/*" "*/"
lexeme :: Parser a -> Parser a
lexeme p = p <* whiteSpace
@ -398,34 +453,57 @@ 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 == '_')
<*> takeWhileP Nothing identLetter
guard (not (ident `HashSet.member` reservedNames))
return ident
where
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-'
ident <-
cons
<$> satisfy (\x -> isAlpha x || x == '_')
<*> takeWhileP Nothing identLetter
guard (not (ident `HashSet.member` reservedNames))
return ident
where
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-'
parens = between (symbol "(") (symbol ")")
braces = between (symbol "{") (symbol "}")
parens = between (symbol "(") (symbol ")")
braces = between (symbol "{") (symbol "}")
-- angles = between (symbol "<") (symbol ">")
brackets = between (symbol "[") (symbol "]")
semi = symbol ";"
comma = symbol ","
brackets = between (symbol "[") (symbol "]")
semi = symbol ";"
comma = symbol ","
-- colon = symbol ":"
-- dot = symbol "."
equals = symbol "="
question = symbol "?"
equals = symbol "="
question = symbol "?"
integer :: Parser Integer
integer = lexeme L.decimal
@ -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
@ -448,14 +521,14 @@ 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
txt <- decodeUtf8 <$> readFile path
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,23 +564,24 @@ 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
return $ f (Ann ann op)
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))
nixOperators
:: Parser (Ann SrcSpan (NAttrPath NExprLoc))
-> [[(NOperatorDef, Operator Parser NExprLoc)]]
:: Parser (Ann SrcSpan (NAttrPath NExprLoc))
-> [[(NOperatorDef, Operator Parser NExprLoc)]]
nixOperators selector =
[ -- This is not parsed here, even though technically it's part of the
-- expression table. The problem is that in some cases, such as list
@ -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,25 +639,36 @@ data OperatorInfo = OperatorInfo
getUnaryOperator :: NUnaryOp -> OperatorInfo
getUnaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused"))
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)]
_ -> []
_ -> []
getBinaryOperator :: NBinaryOp -> OperatorInfo
getBinaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused"))
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> []
_ -> []
getSpecialOperator :: NSpecialOp -> OperatorInfo
getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "."
getSpecialOperator o = m Map.! o where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused"))
getSpecialOperator o = m Map.! o where
m = Map.fromList $ concat $ zipWith buildEntry
[1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> []
_ -> []

475
src/Nix/Pretty.hs
View File

@ -16,18 +16,26 @@
module Nix.Pretty where
import Control.Applicative ((<|>))
import Control.Applicative ( (<|>) )
import Control.Comonad
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.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust, fromMaybe)
import Data.Text (pack, unpack, replace, strip)
import qualified Data.Text as Text
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.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
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
import Nix.Cited
@ -40,11 +48,11 @@ import Nix.Thunk
#if ENABLE_TRACING
import Nix.Utils
#else
import Nix.Utils hiding ((<$>))
import Nix.Utils hiding ( (<$>) )
#endif
import Nix.Value
import Prelude hiding ((<$>))
import Text.Read (readMaybe)
import Prelude hiding ( (<$>) )
import Text.Read ( readMaybe )
-- | This type represents a pretty printed nix expression
-- together with some information about the expression.
@ -80,7 +88,7 @@ pathExpr d = (simpleExpr d) { wasPath = True }
-- binding).
leastPrecedence :: Doc ann -> NixDoc ann
leastPrecedence =
flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
appOp :: OperatorInfo
appOp = getBinaryOperator NApp
@ -96,72 +104,84 @@ 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 :: NString (NixDoc ann) -> Doc ann
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
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]
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]
where
dsquote = squote <> squote
content = vsep . map prettyLine . stripLastIfEmpty . splitLines $ parts
stripLastIfEmpty = reverse . f . reverse where
stripLastIfEmpty = reverse . f . reverse where
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)
prettyParams :: Params (NixDoc ann) -> Doc ann
prettyParams (Param n) = pretty $ unpack n
prettyParams (Param n ) = pretty $ unpack n
prettyParams (ParamSet s v mname) = prettyParamSet s v <> case mname of
Nothing -> mempty
Just name | Text.null name -> mempty
| otherwise -> "@" <> pretty (unpack name)
| 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)
where
prettySetArg (n, maybeDef) = case maybeDef of
Nothing -> pretty (unpack n)
Just v -> pretty (unpack n) <+> "?" <+> withoutParens v
prettyVariadic = ["..." | var]
sep = align (comma <> space)
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)
Just v -> pretty (unpack n) <+> "?" <+> withoutParens v
prettyVariadic = [ "..." | var ]
sep = align (comma <> space)
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
where scope = maybe mempty ((<> space) . parens . withoutParens) s
prettySelector n <+> equals <+> withoutParens v <> 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) = pretty . unpack $ key
prettyKeyName (DynamicKey key) =
runAntiquoted (DoubleQuoted [Plain "\n"])
prettyString (("$" <>) . braces . withoutParens) 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
prettySelector :: NAttrPath (NixDoc ann) -> Doc ann
prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList
@ -174,19 +194,22 @@ prettyNix = withoutParens . cata exprFNixDoc
instance HasCitations1 t f m
=> HasCitations t f m (NValue' t f m a) where
citations (NValue f) = citations1 f
addProvenance x (NValue f) = NValue (addProvenance1 x f)
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
where
go = exprFNixDoc . annotated . getCompose . fmap render
render :: Maybe (NValue t f m) -> NixDoc ann
render Nothing = simpleExpr $ "_"
render (Just (reverse . citations @t @f @m -> p:_)) = go (_originExpr p)
render _ = simpleExpr "?"
render :: Maybe (NValue t f m) -> NixDoc ann
render Nothing = simpleExpr $ "_"
render (Just (reverse . citations @t @f @m -> p:_)) = go (_originExpr p)
render _ = simpleExpr "?"
-- render (Just (NValue (citations -> ps))) =
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
-- . go . originExpr)
@ -194,169 +217,207 @@ prettyOriginExpr = withoutParens . go
exprFNixDoc :: NExprF (NixDoc ann) -> NixDoc ann
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]
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]]
NSet [] -> simpleExpr $ lbrace <> 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]
NBinary NApp fun arg ->
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
[ wrapParens (f NAssocLeft) r1
, pretty $ unpack $ operatorName opInfo
, wrapParens (f NAssocRight) r2
]
where
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
where opInfo = getUnaryOperator op
NSelect r' attr o ->
(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
NHasAttr r attr ->
mkNixDoc (wrapParens hasAttrOp r <+> "?" <+> prettySelector attr) hasAttrOp
NEnvPath p -> simpleExpr $ pretty ("<" ++ p ++ ">")
NLiteralPath p -> pathExpr $ pretty $ case p of
"./" -> "./."
"../" -> "../."
".." -> "../."
txt | "/" `isPrefixOf` txt -> txt
| "~/" `isPrefixOf` txt -> txt
| "./" `isPrefixOf` txt -> txt
| "../" `isPrefixOf` txt -> txt
| otherwise -> "./" ++ txt
NSym name -> simpleExpr $ pretty (unpack name)
NLet binds body ->
leastPrecedence
$ group
$ vsep
$ [ "let"
, indent 2 (vsep (map prettyBind binds))
, "in" <+> withoutParens body
]
NSet [] -> simpleExpr $ lbrace <> rbrace
NSet xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
[ [lbrace]
, map prettyBind xs
, [rbrace]
NIf cond trueBody falseBody ->
leastPrecedence
$ group
$ nest 2
$ vsep
$ [ "if" <+> withoutParens cond
, align ("then" <+> withoutParens trueBody)
, align ("else" <+> withoutParens falseBody)
]
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
]
NBinary NApp fun arg ->
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
[ wrapParens (f NAssocLeft) r1
, pretty $ unpack $ operatorName opInfo
, wrapParens (f NAssocRight) r2
]
where
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
where opInfo = getUnaryOperator op
NSelect r' attr o ->
(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
NHasAttr r attr ->
mkNixDoc (wrapParens hasAttrOp r <+> "?" <+> prettySelector attr) hasAttrOp
NEnvPath p -> simpleExpr $ pretty ("<" ++ p ++ ">")
NLiteralPath p -> pathExpr $ pretty $ case p of
"./" -> "./."
"../" -> "../."
".." -> "../."
txt | "/" `isPrefixOf` txt -> txt
| "~/" `isPrefixOf` txt -> txt
| "./" `isPrefixOf` txt -> txt
| "../" `isPrefixOf` txt -> txt
| otherwise -> "./" ++ txt
NSym name -> simpleExpr $ pretty (unpack name)
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
, 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
]
NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
where
recPrefix = "rec" <> space
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
valueToExpr :: forall t f m. MonadDataContext f m => NValueNF t f m -> NExpr
valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr
valueToExpr = iterNValueNF
(const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))
phi
where
phi :: NValue' t f m NExpr -> NExpr
phi (NVConstant a) = Fix $ NConstant a
phi (NVStr ns) = mkStr ns
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 ]
phi (NVClosure _ _) = Fix . NSym . pack $ "<closure>"
phi (NVPath p) = Fix $ NLiteralPath p
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
phi _ = error "Pattern synonyms foil completeness check"
(const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))
phi
where
phi :: NValue' t f m NExpr -> NExpr
phi (NVConstant a ) = Fix $ NConstant a
phi (NVStr ns) = mkStr ns
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
]
phi (NVClosure _ _ ) = Fix . NSym . pack $ "<closure>"
phi (NVPath p ) = Fix $ NLiteralPath p
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
phi _ = error "Pattern synonyms foil completeness check"
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann
prettyNValueNF = prettyNix . valueToExpr
printNix :: forall t f m. MonadDataContext f m => NValueNF t f m -> String
printNix :: forall t f m . MonadDataContext f m => NValueNF t f m -> String
printNix = iterNValueNF (const "<CYCLE>") phi
where
phi :: NValue' t f m String -> String
phi (NVConstant a) = unpack $ atomText a
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
phi (NVList l) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
"{ " ++ concat [ check (unpack k) ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
where
check v =
fromMaybe v
((fmap (surround . show) (readMaybe v :: Maybe Int))
<|> (fmap (surround . show) (readMaybe v :: Maybe Float)))
where
surround s = "\"" ++ s ++ "\""
phi NVClosure {} = "<<lambda>>"
phi (NVPath fp) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
phi _ = error "Pattern synonyms foil completeness check"
where
phi :: NValue' t f m String -> String
phi (NVConstant a ) = unpack $ atomText a
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
phi (NVList l ) = "[ " ++ unwords l ++ " ]"
phi (NVSet s _) =
"{ "
++ concat
[ check (unpack k) ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s
]
++ "}"
where
check v = fromMaybe
v
( (fmap (surround . show) (readMaybe v :: Maybe Int))
<|> (fmap (surround . show) (readMaybe v :: Maybe Float))
)
where surround s = "\"" ++ s ++ "\""
phi NVClosure{} = "<<lambda>>"
phi (NVPath fp ) = fp
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
phi _ = error "Pattern synonyms foil completeness check"
prettyNValue
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m -> m (Doc ann)
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> m (Doc ann)
prettyNValue = fmap prettyNValueNF . removeEffectsM
prettyNValueProv
:: 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)
:: 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)
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
$ "from: "
: map (prettyOriginExpr . _originExpr) ps
]
let ps = citations1 @t @f @m nv
case ps of
[] -> prettyNValue v
ps -> do
v' <- prettyNValue v
pure
$ fillSep
$ [ v'
, indent 2
$ parens
$ mconcat
$ "from: "
: map (prettyOriginExpr . _originExpr) ps
]
prettyNThunk
:: 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)
:: 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)
prettyNThunk t = do
let ps = citations @t @f @m @t t
v' <- prettyNValueNF <$> dethunk t
pure $ fillSep $
[ v'
, indent 2 $ parens $ mconcat
$ "thunk from: "
: map (prettyOriginExpr . _originExpr) ps
let ps = citations @t @f @m @t t
v' <- prettyNValueNF <$> dethunk t
pure
$ fillSep
$ [ v'
, indent 2
$ parens
$ mconcat
$ "thunk from: "
: map (prettyOriginExpr . _originExpr) ps
]

478
src/Nix/Reduce.hs
View File

@ -32,7 +32,7 @@
module Nix.Reduce (reduceExpr, reducingEvalExpr) where
import Control.Applicative
import Control.Arrow (second)
import Control.Arrow ( second )
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fail
@ -40,24 +40,31 @@ import Control.Monad.Fix
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.Reader ( ReaderT(..) )
import Control.Monad.Trans.State.Strict
( StateT(..) )
import Data.Fix
-- import Data.Foldable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
-- import Data.HashSet (HashSet)
-- import qualified Data.HashSet as S
import Data.IORef
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
import Data.Text (Text)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
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,72 +80,84 @@ 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
path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
(maybe path (\p -> takeDirectory p </> path) mfile)
mfile <- asks fst
path <- liftIO $ pathToDefaultNixFile path
path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
(maybe path (\p -> takeDirectory p </> path) mfile)
imports <- get
case M.lookup path' imports of
Just expr -> pure expr
Nothing -> go path'
where
go path = do
liftIO $ putStrLn $ "Importing file " ++ path
imports <- get
case M.lookup path' imports of
Just expr -> pure expr
Nothing -> go path'
where
go path = do
liftIO $ putStrLn $ "Importing file " ++ path
eres <- liftIO $ parseNixFileLoc path
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success x -> do
let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
span = SrcSpan pos pos
cur = NamedVar (StaticKey "__cur_file" :| [])
(Fix (NLiteralPath_ pann path)) pos
x' = Fix (NLet_ span [cur] x)
modify (M.insert path x')
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
x'' <- cata reduce x'
modify (M.insert path x'')
return x''
eres <- liftIO $ parseNixFileLoc path
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success x -> do
let
pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
span = SrcSpan pos pos
cur = NamedVar (StaticKey "__cur_file" :| [])
(Fix (NLiteralPath_ pann path))
pos
x' = Fix (NLet_ span [cur] x)
modify (M.insert path x')
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
x'' <- cata reduce x'
modify (M.insert path x'')
return x''
-- gatherNames :: NExprLoc -> HashSet VarName
-- gatherNames = cata $ \case
-- 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.
reduce (NSym_ ann var) = lookupVar var <&> \case
Nothing -> Fix (NSym_ ann var)
Just v -> v
Nothing -> Fix (NSym_ ann var)
Just v -> v
-- | Reduce binary and integer negation.
reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
(NNeg, Fix (NConstant_ cann (NInt n))) ->
return $ Fix $ NConstant_ cann (NInt (negate n))
(NNot, Fix (NConstant_ cann (NBool b))) ->
return $ Fix $ NConstant_ cann (NBool (not b))
_ -> return $ Fix $ NUnary_ uann op x
(NNeg, Fix (NConstant_ cann (NInt n))) ->
return $ Fix $ NConstant_ cann (NInt (negate n))
(NNot, Fix (NConstant_ cann (NBool b))) ->
return $ Fix $ NConstant_ cann (NBool (not b))
_ -> return $ Fix $ NUnary_ uann op x
-- | Reduce function applications.
--
@ -147,25 +166,25 @@ reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
-- * Reduce a lambda function by adding its name to the local
-- scope and recursively reducing its body.
reduce (NBinary_ bann NApp fun arg) = fun >>= \case
f@(Fix (NSym_ _ "import")) -> arg >>= \case
-- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath
Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath
v -> return $ Fix $ NBinary_ bann NApp f v
f@(Fix (NSym_ _ "import")) -> arg >>= \case
-- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath
Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath
v -> return $ Fix $ NBinary_ bann NApp f v
Fix (NAbs_ _ (Param name) body) -> do
x <- arg
pushScope (M.singleton name x) (cata reduce body)
Fix (NAbs_ _ (Param name) body) -> do
x <- arg
pushScope (M.singleton name x) (cata reduce body)
f -> Fix . NBinary_ bann NApp f <$> arg
f -> Fix . NBinary_ bann NApp f <$> arg
-- | Reduce an integer addition to its result.
reduce (NBinary_ bann op larg rarg) = do
lval <- larg
rval <- rarg
case (op, lval, rval) of
(NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) ->
return $ Fix (NConstant_ ann (NInt (x + y)))
_ -> pure $ Fix $ NBinary_ bann op lval rval
lval <- larg
rval <- rarg
case (op, lval, rval) of
(NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) ->
return $ Fix (NConstant_ ann (NInt (x + y)))
_ -> pure $ Fix $ NBinary_ bann op lval rval
-- | Reduce a select on a Set by substituing the set to the selected value.
--
@ -175,70 +194,69 @@ reduce (NBinary_ bann op larg rarg) = do
-- 2. The selection AttrPath is a list of StaticKeys.
-- 3. The selected AttrPath exists in the set.
reduce base@(NSelect_ _ _ attrs _)
| sAttrPath $ NE.toList attrs = do
(NSelect_ _ aset attrs _) <- sequence base
inspectSet (unFix aset) attrs
| otherwise = sId
where
sId = Fix <$> sequence base
-- The selection AttrPath is composed of StaticKeys.
sAttrPath (StaticKey _:xs) = sAttrPath xs
sAttrPath [] = True
sAttrPath _ = False
-- Find appropriate bind in set's binds.
findBind [] _ = Nothing
findBind (x:xs) attrs@(a:|_) = case x of
n@(NamedVar (a':|_) _ _) | a' == a -> Just n
_ -> findBind xs attrs
-- Follow the attrpath recursively in sets.
inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
Just (NamedVar _ e _) -> case NE.uncons attrs of
(_,Just attrs) -> inspectSet (unFix e) attrs
_ -> pure e
_ -> sId
inspectSet _ _ = sId
| sAttrPath $ NE.toList attrs = do
(NSelect_ _ aset attrs _) <- sequence base
inspectSet (unFix aset) attrs
| otherwise = sId
where
sId = Fix <$> sequence base
-- The selection AttrPath is composed of StaticKeys.
sAttrPath (StaticKey _ : xs) = sAttrPath xs
sAttrPath [] = True
sAttrPath _ = False
-- Find appropriate bind in set's binds.
findBind [] _ = Nothing
findBind (x : xs) attrs@(a :| _) = case x of
n@(NamedVar (a' :| _) _ _) | a' == a -> Just n
_ -> findBind xs attrs
-- Follow the attrpath recursively in sets.
inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
Just (NamedVar _ e _) -> case NE.uncons attrs of
(_, Just attrs) -> inspectSet (unFix e) attrs
_ -> pure e
_ -> sId
inspectSet _ _ = sId
-- reduce (NHasAttr aset attr) =
-- | Reduce a set by inlining its binds outside of the set
-- if none of the binds inherit the super set.
reduce e@(NSet_ ann binds) = do
let usesInherit = flip any binds $ \case
Inherit {} -> True
_ -> False
if usesInherit
then clearScopes @NExprLoc $
Fix . NSet_ ann <$> traverse sequence binds
else Fix <$> sequence e
let usesInherit = flip any binds $ \case
Inherit{} -> True
_ -> False
if usesInherit
then clearScopes @NExprLoc $ Fix . NSet_ ann <$> traverse sequence binds
else Fix <$> sequence e
-- Encountering a 'rec set' construction eliminates any hope of inlining
-- definitions.
reduce (NRecSet_ ann binds) =
clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds
clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds
-- Encountering a 'with' construction eliminates any hope of inlining
-- definitions.
reduce (NWith_ ann scope body) =
clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body
clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body
-- | Reduce a let binds section by pushing lambdas,
-- constants and strings to the body scope.
reduce (NLet_ ann binds body) = do
s <- fmap (M.fromList . catMaybes) $ forM binds $ \case
NamedVar (StaticKey name :| []) def _pos -> def >>= \case
d@(Fix NAbs_ {}) -> pure $ Just (name, d)
d@(Fix NConstant_ {}) -> pure $ Just (name, d)
d@(Fix NStr_ {}) -> pure $ Just (name, d)
_ -> pure Nothing
_ -> pure Nothing
body' <- pushScope s body
binds' <- traverse sequence binds
-- let names = gatherNames body'
-- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case
-- NamedVar (StaticKey name _ :| []) _ ->
-- name `S.member` names
-- _ -> True
pure $ Fix $ NLet_ ann binds' body'
s <- fmap (M.fromList . catMaybes) $ forM binds $ \case
NamedVar (StaticKey name :| []) def _pos -> def >>= \case
d@(Fix NAbs_{} ) -> pure $ Just (name, d)
d@(Fix NConstant_{}) -> pure $ Just (name, d)
d@(Fix NStr_{} ) -> pure $ Just (name, d)
_ -> pure Nothing
_ -> pure Nothing
body' <- pushScope s body
binds' <- traverse sequence binds
-- let names = gatherNames body'
-- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case
-- NamedVar (StaticKey name _ :| []) _ ->
-- name `S.member` names
-- _ -> True
pure $ Fix $ NLet_ ann binds' body'
-- where
-- go m [] = pure m
-- go m (x:xs) = case x of
@ -250,24 +268,24 @@ reduce (NLet_ ann binds body) = do
-- | Reduce an if to the relevant path if
-- the condition is a boolean constant.
reduce e@(NIf_ _ b t f) = b >>= \case
Fix (NConstant_ _ (NBool b')) -> if b' then t else f
_ -> Fix <$> sequence e
Fix (NConstant_ _ (NBool b')) -> if b' then t else f
_ -> Fix <$> sequence e
-- | Reduce an assert atom to its encapsulated
-- symbol if the assertion is a boolean constant.
reduce e@(NAssert_ _ b body) = b >>= \case
Fix (NConstant_ _ (NBool b')) | b' -> body
_ -> Fix <$> sequence e
Fix (NConstant_ _ (NBool b')) | b' -> body
_ -> Fix <$> sequence e
reduce (NAbs_ ann params body) = do
params' <- sequence params
-- Make sure that variable definitions in scope do not override function
-- arguments.
let args = case params' of
Param name -> M.singleton name (Fix (NSym_ ann name))
ParamSet pset _ _ ->
M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset
Fix . NAbs_ ann params' <$> pushScope args body
params' <- sequence params
-- Make sure that variable definitions in scope do not override function
-- arguments.
let args = case params' of
Param name -> M.singleton name (Fix (NSym_ ann name))
ParamSet pset _ _ ->
M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset
Fix . NAbs_ ann params' <$> pushScope args body
reduce v = Fix <$> sequence v
@ -276,142 +294,136 @@ newtype FlaggedF f r = FlaggedF (IORef Bool, f r)
deriving (Functor, Foldable, Traversable)
instance Show (f r) => Show (FlaggedF f r) where
show (FlaggedF (_, x)) = show x
show (FlaggedF (_, x)) = show x
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)
flag <- liftIO $ newIORef False
pure $ Fix $ FlaggedF (flag, x)
-- stripFlags :: Functor f => Flagged f -> Fix f
-- stripFlags = cata $ Fix . snd . flagged
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
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)
NAbs params (Just body) -> Just $ NAbs (pruneParams params) body
used <- liftIO $ readIORef b
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)
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)
| otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds)
NList l | reduceLists opts -> Just $ NList (catMaybes l)
| otherwise -> Just $ NList (map (fromMaybe nNull) l)
NSet binds | reduceSets opts -> Just $ NSet (mapMaybe sequence binds)
| otherwise -> Just $ NSet (map (fmap (fromMaybe nNull)) binds)
NRecSet binds
| reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds)
| otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds)
NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
Just $ case mapMaybe pruneBinding binds of
[] -> x
xs -> NLet xs body
NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
Just $ case mapMaybe pruneBinding binds of
[] -> x
xs -> NLet xs body
NSelect (Just aset) attr alt ->
Just $ NSelect aset (NE.map pruneKeyName attr) (join alt)
NSelect (Just aset) attr alt ->
Just $ NSelect aset (NE.map pruneKeyName attr) (join alt)
-- These are the only short-circuiting binary operators
NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg
NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg
-- These are the only short-circuiting binary operators
NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg
NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg
-- If the function was never called, it means its argument was in a
-- thunk that was forced elsewhere.
NBinary NApp Nothing (Just _) -> Nothing
-- If the function was never called, it means its argument was in a
-- thunk that was forced elsewhere.
NBinary NApp Nothing (Just _) -> Nothing
-- The idea behind emitted a binary operator where one side may be
-- invalid is that we're trying to emit what will reproduce whatever
-- error the user encountered, which means providing all aspects of
-- the evaluation path they ultimately followed.
NBinary op Nothing (Just rarg) -> Just $ NBinary op nNull rarg
NBinary op (Just larg) Nothing -> Just $ NBinary op larg nNull
-- The idea behind emitted a binary operator where one side may be
-- invalid is that we're trying to emit what will reproduce whatever
-- error the user encountered, which means providing all aspects of
-- the evaluation path they ultimately followed.
NBinary op Nothing (Just rarg) -> Just $ NBinary op nNull rarg
NBinary op (Just larg) Nothing -> Just $ NBinary op larg nNull
-- If the scope of a with was never referenced, it's not needed
NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> Just body
-- If the scope of a with was never referenced, it's not needed
NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> Just body
NAssert Nothing _ ->
error "How can an assert be used, but its condition not?"
NAssert Nothing _ ->
error "How can an assert be used, but its condition not?"
NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body
NAssert (Just cond) _ -> Just $ NAssert cond nNull
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
NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f
NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t
x -> sequence x
x -> sequence x
pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
pruneString (DoubleQuoted xs) =
DoubleQuoted (mapMaybe pruneAntiquotedText xs)
pruneString (Indented n xs) =
Indented n (mapMaybe pruneAntiquotedText xs)
pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
pruneString (DoubleQuoted xs) =
DoubleQuoted (mapMaybe pruneAntiquotedText xs)
pruneString (Indented n xs) = Indented n (mapMaybe pruneAntiquotedText xs)
pruneAntiquotedText
:: Antiquoted Text (Maybe NExprLoc)
-> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText (Plain v) = Just (Plain v)
pruneAntiquotedText EscapedNewline = Just EscapedNewline
pruneAntiquotedText (Antiquoted Nothing) = Nothing
pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k)
pruneAntiquotedText
:: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText (Plain v) = Just (Plain v)
pruneAntiquotedText EscapedNewline = Just EscapedNewline
pruneAntiquotedText (Antiquoted Nothing ) = Nothing
pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k)
pruneAntiquoted
:: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
pruneAntiquoted (Plain v) = Just (Plain (pruneString v))
pruneAntiquoted EscapedNewline = Just EscapedNewline
pruneAntiquoted (Antiquoted Nothing) = Nothing
pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k)
pruneAntiquoted
:: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
pruneAntiquoted (Plain v) = Just (Plain (pruneString v))
pruneAntiquoted EscapedNewline = Just EscapedNewline
pruneAntiquoted (Antiquoted Nothing ) = Nothing
pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k)
pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (StaticKey n) = StaticKey n
pruneKeyName (DynamicKey k)
| Just k' <- pruneAntiquoted k = DynamicKey k'
| otherwise = StaticKey "<unused?>"
pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (StaticKey n) = StaticKey n
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
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
pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar _ Nothing _) = Nothing
pruneBinding (NamedVar xs (Just x) pos) =
Just (NamedVar (NE.map pruneKeyName xs) x pos)
pruneBinding (Inherit _ [] _) = Nothing
pruneBinding (Inherit (join -> Nothing) _ _) = Nothing
pruneBinding (Inherit (join -> m) xs pos) =
Just (Inherit m (map pruneKeyName xs) pos)
pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar _ Nothing _) = Nothing
pruneBinding (NamedVar xs (Just x) pos) =
Just (NamedVar (NE.map pruneKeyName xs) x pos)
pruneBinding (Inherit _ [] _) = Nothing
pruneBinding (Inherit (join -> Nothing) _ _) = Nothing
pruneBinding (Inherit (join -> m) xs pos) =
Just (Inherit m (map pruneKeyName xs) pos)
reducingEvalExpr
:: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)
=> (NExprLocF (m a) -> m a)
-> Maybe FilePath
-> NExprLoc
-> m (NExprLoc, Either r a)
:: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)
=> (NExprLocF (m a) -> m a)
-> Maybe FilePath
-> NExprLoc
-> m (NExprLoc, Either r a)
reducingEvalExpr eval mpath expr = do
expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)
eres <- catch (Right <$> cata (addEvalFlags eval) expr') (pure . Left)
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
expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)
eres <- catch (Right <$> cata (addEvalFlags eval) expr') (pure . Left)
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
instance Monad m => Scoped NExprLoc (Reducer m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Reducer m) @NExprLoc
pushScopes = pushScopesReader
lookupVar = lookupVarReader
clearScopes = clearScopesReader @(Reducer m) @NExprLoc
pushScopes = pushScopesReader
lookupVar = lookupVarReader

107
src/Nix/Render.hs
View File

@ -11,19 +11,19 @@
module Nix.Render where
import Prelude hiding (readFile)
import Prelude hiding ( readFile )
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Prettyprint.Doc
import Data.Void
import Nix.Expr.Types.Annotated
import qualified System.Directory as S
import qualified System.Posix.Files as S
import qualified System.Directory as S
import qualified System.Posix.Files as S
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
@ -57,59 +57,70 @@ class Monad m => MonadFile m where
getSymbolicLinkStatus = lift . getSymbolicLinkStatus
instance MonadFile IO where
readFile = BS.readFile
listDirectory = S.listDirectory
getCurrentDirectory = S.getCurrentDirectory
canonicalizePath = S.canonicalizePath
getHomeDirectory = S.getHomeDirectory
doesPathExist = S.doesPathExist
doesFileExist = S.doesFileExist
doesDirectoryExist = S.doesDirectoryExist
getSymbolicLinkStatus = S.getSymbolicLinkStatus
readFile = BS.readFile
listDirectory = S.listDirectory
getCurrentDirectory = S.getCurrentDirectory
canonicalizePath = S.canonicalizePath
getHomeDirectory = S.getHomeDirectory
doesPathExist = S.doesPathExist
doesFileExist = S.doesFileExist
doesDirectoryExist = S.doesDirectoryExist
getSymbolicLinkStatus = S.getSymbolicLinkStatus
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg (SourcePos _ lineNo _) msg =
FancyError (unPos lineNo)
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
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 <> ":"
then do
txt <- sourceContext file begLine begCol endLine endCol msg
return
$ vsep
[ "In file "
<> errorContext file begLine begCol endLine endCol
<> ":"
, txt
]
else return msg
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)
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
. take (end' - beg')
. drop (pred beg')
. T.lines
. T.decodeUtf8
<$> readFile path
let nums = map (show . fst) $ zip [beg'..] ls
longest = maximum (map length nums)
nums' = flip map nums $ \n ->
replicate (longest - length n) ' ' ++ n
pad n | read n == begLine = "==> " ++ n
| otherwise = " " ++ n
ls' = zipWith (<+>) (map (pretty . pad) nums')
(zipWith (<+>) (repeat "| ") ls)
ls <-
map pretty
. take (end' - beg')
. drop (pred beg')
. T.lines
. T.decodeUtf8
<$> readFile path
let
nums = map (show . fst) $ zip [beg' ..] ls
longest = maximum (map length nums)
nums' = flip map nums $ \n -> replicate (longest - length n) ' ' ++ n
pad n | read n == begLine = "==> " ++ n
| otherwise = " " ++ n
ls' = zipWith (<+>)
(map (pretty . pad) nums')
(zipWith (<+>) (repeat "| ") ls)
pure $ vsep $ ls' ++ [msg]

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

@ -35,196 +35,202 @@ import qualified Text.Show.Pretty as PS
renderFrames
:: forall v t f e m ann
. ( MonadReader e m
. ( MonadReader e m
, Has e Options
, MonadFile m
, MonadCitedThunks t f m
, Typeable v
)
=> 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
| 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))
pure $ case frames of
[] -> mempty
_ -> vsep frames
where
go :: NixFrame -> [Doc ann]
go f = case framePos @v @m f of
Just pos ->
["While evaluating at "
<> pretty (sourcePosPretty pos)
<> colon]
Nothing -> []
=> 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
| 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))
pure $ case frames of
[] -> mempty
_ -> vsep frames
where
go :: NixFrame -> [Doc ann]
go f = case framePos @v @m f of
Just pos ->
["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
_ -> Nothing
| otherwise = Nothing
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg
_ -> Nothing
| otherwise = Nothing
renderFrame
:: 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]
:: 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]
renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
| Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show f
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
| Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show 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
=<< renderExpr level "While evaluating" "Expression" e
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
=<< 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
Calling name ann ->
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
, pure $ pretty $ show (_synHoleInfo_scope synfo)
]
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 []
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
| verbose opts >= DebugInfo =
opts :: Options <- asks (view hasLens)
let rendered
| verbose opts >= DebugInfo =
#ifdef MIN_VERSION_pretty_show
pretty (PS.ppShow (stripAnnotation e))
#else
pretty (show (stripAnnotation e))
#endif
| 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
, "<<<<<<<<"
]
else pretty shortLabel <> fillSep [": ", rendered]
| 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, "<<<<<<<<"]
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]
renderValueFrame level = fmap (:[]) . \case
ForcingThunk -> pure "ForcingThunk"
ConcerningValue _v -> pure "ConcerningValue"
Comparison _ _ -> pure "Comparing"
Addition _ _ -> pure "Adding"
Division _ _ -> pure "Dividing"
Multiplication _ _ -> pure "Multiplying"
:: (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"
Comparison _ _ -> pure "Comparing"
Addition _ _ -> pure "Adding"
Division _ _ -> pure "Dividing"
Multiplication _ _ -> pure "Multiplying"
Coercion x y -> pure $ mconcat
[ desc
, pretty (describeValue x)
, " to "
, pretty (describeValue y)
]
where
desc | level <= Error = "Cannot coerce "
| otherwise = "While coercing "
Coercion x y -> pure
$ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)]
where
desc | level <= Error = "Cannot coerce "
| otherwise = "While coercing "
CoercionToJson v -> do
v' <- renderValue level "" "" v
pure $ "CoercionToJson " <> v'
CoercionFromJson _j -> pure "CoercionFromJson"
ExpectationNF _t _v -> pure "ExpectationNF"
Expectation t v -> do
v' <- renderValue level "" "" v
pure $ "Saw " <> v'
<> " but expected " <> pretty (describeValue t)
CoercionToJson v -> do
v' <- renderValue level "" "" v
pure $ "CoercionToJson " <> v'
CoercionFromJson _j -> pure "CoercionFromJson"
ExpectationNF _t _v -> pure "ExpectationNF"
Expectation t v -> do
v' <- renderValue level "" "" v
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
opts :: Options <- asks (view hasLens)
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
=<< ((\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v)
Assertion ann v ->
fmap (: [])
$ renderLocation ann
=<< ( (\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v
)
renderThunkLoop
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop _level = pure . (:[]) . \case
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> 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]
renderNormalLoop level = fmap (:[]) . \case
NormalLoop v -> do
v' <- renderValue level "" "" v
pure $ "Infinite recursion during normalization forcing " <> v'
:: (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'

59
src/Nix/Scope.hs
View File

@ -15,8 +15,8 @@ module Nix.Scope where
import Control.Applicative
import Control.Monad.Reader
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import qualified Data.HashMap.Lazy as M
import Data.Text ( Text )
import Lens.Family2
import Nix.Utils
@ -24,15 +24,14 @@ newtype Scope t = Scope { getScope :: AttrSet t }
deriving (Functor, Foldable, Traversable, Eq)
instance Show (Scope t) where
show (Scope m) = show (M.keys m)
show (Scope m) = show (M.keys m)
newScope :: AttrSet t -> Scope t
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]
@ -40,18 +39,17 @@ data Scopes m t = Scopes
}
instance Show (Scopes m t) where
show (Scopes m t) =
"Scopes: " ++ show m ++ ", and "
++ show (length t) ++ " with-scopes"
show (Scopes m t) =
"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)
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
instance Monoid (Scopes m t) where
mempty = emptyScopes
mappend = (<>)
mempty = emptyScopes
mappend = (<>)
emptyScopes :: forall m t. Scopes m t
emptyScopes :: forall m t . Scopes m t
emptyScopes = Scopes [] []
class Scoped t m | m -> t where
@ -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
mres' <- M.lookup k . getScope <$> x
case mres' of
Just sym -> return $ Just sym
Nothing -> rest)
(return Nothing) ws
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
mres' <- M.lookup k . getScope <$> x
case mres' of
Just sym -> return $ Just sym
Nothing -> rest
)
(return Nothing)
ws
withScopes :: Scoped t m => Scopes m t -> m a -> m a
withScopes scope = clearScopes . pushScopes scope

51
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,14 +29,15 @@ module Nix.String (
, addSingletonStringContext
, runWithStringContextT
, runWithStringContext
) where
)
where
import Control.Monad.Writer
import Data.Functor.Identity
import qualified Data.HashSet as S
import qualified Data.HashSet as S
import Data.Hashable
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text ( Text )
import qualified Data.Text as Text
import GHC.Generics
-- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-}
@ -73,20 +74,22 @@ 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
principledIntercalateNixString _ [] = principledMempty
principledIntercalateNixString _ [ns] = ns
principledIntercalateNixString sep nss = NixString contents ctx
where
contents = Text.intercalate (nsContents sep) (map nsContents nss)
ctx = S.unions (nsContext sep : map nsContext nss)
principledIntercalateNixString _ [] = principledMempty
principledIntercalateNixString _ [ns] = ns
principledIntercalateNixString sep nss = NixString contents ctx
where
contents = Text.intercalate (nsContents sep) (map nsContents nss)
ctx = S.unions (nsContext sep : map nsContext nss)
-- | Combine NixStrings using mconcat
hackyStringMConcat :: [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)
@ -109,13 +113,13 @@ principledStringMConcat = foldr principledStringMappend (NixString mempty mempty
-- | Extract the string contents from a NixString that has no context
hackyGetStringNoContext :: NixString -> Maybe Text
hackyGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
hackyGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString that has no context
principledGetStringNoContext :: NixString -> Maybe Text
principledGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
principledGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString even if the NixString has an associated context
principledStringIgnoreContext :: NixString -> Text
@ -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

106
src/Nix/Strings.hs
View File

@ -4,27 +4,30 @@
-- | Functions for manipulating nix strings.
module Nix.Strings where
import Data.List (intercalate, dropWhileEnd, inits)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Tuple (swap)
import Data.List ( intercalate
, dropWhileEnd
, inits
)
import Data.Monoid ( (<>) )
import Data.Text ( Text )
import qualified Data.Text as T
import Data.Tuple ( swap )
import Nix.Expr
-- | Merge adjacent 'Plain' values with 'mappend'.
mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r]
mergePlain [] = []
mergePlain (Plain a: EscapedNewline : Plain b: xs) =
mergePlain (Plain (a <> "\n" <> b) : xs)
mergePlain (Plain a: Plain b: xs) = mergePlain (Plain (a <> b) : xs)
mergePlain (x:xs) = x : mergePlain xs
mergePlain (Plain a : EscapedNewline : Plain b : xs) =
mergePlain (Plain (a <> "\n" <> b) : xs)
mergePlain (Plain a : Plain b : xs) = mergePlain (Plain (a <> b) : xs)
mergePlain (x : xs) = x : mergePlain xs
-- | Remove 'Plain' values equal to 'mempty', as they don't have any
-- informational content.
removePlainEmpty :: [Antiquoted Text r] -> [Antiquoted Text r]
removePlainEmpty = filter f where
f (Plain x) = x /= mempty
f _ = True
f _ = True
-- trimEnd xs
-- | null xs = xs
@ -41,12 +44,12 @@ runAntiquoted _ _ k (Antiquoted r) = k r
-- | Split a stream representing a string with antiquotes on line breaks.
splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]]
splitLines = uncurry (flip (:)) . go where
go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls where
(l : ls) = T.split (=='\n') t
go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls where
(l : ls) = T.split (== '\n') t
f prefix (finished, current) = ((Plain prefix : current) : finished, [])
go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs
go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs
go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs
go [] = ([],[])
go [] = ([], [])
-- | Join a stream of strings containing antiquotes again. This is the inverse
-- of 'splitLines'.
@ -58,52 +61,53 @@ stripIndent :: [Antiquoted Text r] -> NString r
stripIndent [] = Indented 0 []
stripIndent xs =
Indented minIndent
. removePlainEmpty
. mergePlain
. map snd
. dropWhileEnd cleanup
. (\ys -> zip (map (\case [] -> Nothing
x -> Just (last x))
(inits ys)) ys)
. unsplitLines $ ls'
where
ls = stripEmptyOpening $ splitLines xs
ls' = map (dropSpaces minIndent) ls
. removePlainEmpty
. mergePlain
. map snd
. dropWhileEnd cleanup
. (\ys -> zip
(map
(\case
[] -> Nothing
x -> Just (last x)
)
(inits ys)
)
ys
)
. unsplitLines
$ ls'
where
ls = stripEmptyOpening $ splitLines xs
ls' = map (dropSpaces minIndent) ls
minIndent = case stripEmptyLines ls of
[] -> 0
nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs
minIndent = case stripEmptyLines ls of
[] -> 0
nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs
stripEmptyLines = filter $ \case
[Plain t] -> not $ T.null $ T.strip t
_ -> True
stripEmptyLines = filter $ \case
[Plain t] -> not $ T.null $ T.strip t
_ -> True
stripEmptyOpening ([Plain t]:ts) | T.null (T.strip t) = ts
stripEmptyOpening ts = ts
stripEmptyOpening ([Plain t] : ts) | T.null (T.strip t) = ts
stripEmptyOpening ts = ts
countSpaces (Antiquoted _:_) = 0
countSpaces (EscapedNewline:_) = 0
countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t
countSpaces [] = 0
countSpaces (Antiquoted _ : _) = 0
countSpaces (EscapedNewline : _) = 0
countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t
countSpaces [] = 0
dropSpaces 0 x = x
dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs
dropSpaces _ _ = error "stripIndent: impossible"
dropSpaces 0 x = x
dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs
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 _ = False
cleanup (Nothing, Plain y) = 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)

122
src/Nix/TH.hs
View File

@ -10,11 +10,13 @@ module Nix.TH where
import Data.Fix
import Data.Generics.Aliases
import Data.Set (Set, (\\))
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (mapMaybe)
import Data.Set ( Set
, (\\)
)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( mapMaybe )
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Nix.Atoms
@ -23,97 +25,103 @@ import Nix.Parser
quoteExprExp :: String -> ExpQ
quoteExprExp s = do
expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
quoteExprPat :: String -> PatQ
quoteExprPat s = do
expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
freeVars :: NExpr -> Set VarName
freeVars e = case unFix e of
(NConstant _) -> Set.empty
(NStr string) -> foldMap freeVars string
(NSym var) -> Set.singleton var
(NList list) -> foldMap freeVars list
(NSet bindings) -> foldMap bindFree bindings
(NConstant _ ) -> Set.empty
(NStr string ) -> foldMap freeVars string
(NSym var ) -> Set.singleton var
(NList list ) -> foldMap freeVars list
(NSet bindings) -> foldMap bindFree bindings
(NRecSet bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings
(NLiteralPath _) -> Set.empty
(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
(NHasAttr expr path) -> freeVars expr `Set.union` pathFree path
(NAbs (Param varname) expr) -> Set.delete varname (freeVars expr)
(NLiteralPath _ ) -> Set.empty
(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
(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
(NWith set expr) -> freeVars set `Set.union` freeVars expr
(NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr
(NSynHole _) -> Set.empty
(NSynHole _ ) -> Set.empty
where
where
staticKey :: NKeyName r -> Maybe VarName
staticKey (StaticKey varname) = Just varname
staticKey (DynamicKey _) = Nothing
staticKey :: NKeyName r -> Maybe VarName
staticKey (StaticKey varname) = Just varname
staticKey (DynamicKey _ ) = Nothing
bindDefs :: Binding r -> Set VarName
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
bindDefs :: Binding r -> Set VarName
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
bindFree :: Binding NExpr -> Set VarName
bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys
bindFree (Inherit (Just scope) _ _) = freeVars scope
bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr
bindFree :: Binding NExpr -> Set VarName
bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys
bindFree (Inherit (Just scope) _ _) = freeVars scope
bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr
pathFree :: NAttrPath NExpr -> Set VarName
pathFree = foldMap (foldMap freeVars)
pathFree :: NAttrPath NExpr -> Set VarName
pathFree = foldMap (foldMap freeVars)
class ToExpr a where
toExpr :: a -> NExprLoc
instance ToExpr NExprLoc where
toExpr = id
toExpr = id
instance ToExpr VarName where
toExpr = Fix . NSym_ nullSpan
toExpr = Fix . NSym_ nullSpan
instance ToExpr Int where
toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
instance ToExpr Integer where
toExpr = Fix . NConstant_ nullSpan . NInt
toExpr = Fix . NConstant_ nullSpan . NInt
instance ToExpr Float where
toExpr = Fix . NConstant_ nullSpan . NFloat
toExpr = Fix . NConstant_ nullSpan . NFloat
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
metaExp _ _ = Nothing
metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just (varP (mkName (Text.unpack x)))
Just (varP (mkName (Text.unpack x)))
metaPat _ _ = Nothing
nix :: QuasiQuoter
nix = QuasiQuoter
{ quoteExp = quoteExprExp
, quotePat = quoteExprPat
}
nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat }

8
src/Nix/Thunk.hs
View File

@ -7,9 +7,9 @@
module Nix.Thunk where
import Control.Exception (Exception)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Typeable (Typeable)
import Control.Exception ( Exception )
import Control.Monad.Trans.Class ( MonadTrans(..) )
import Data.Typeable ( Typeable )
class ( Monad m
, Eq (ThunkId m)
@ -46,6 +46,6 @@ newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
deriving Typeable
instance Show ThunkLoop where
show (ThunkLoop i) = "ThunkLoop " ++ i
show (ThunkLoop i) = "ThunkLoop " ++ i
instance Exception ThunkLoop

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

@ -15,12 +15,12 @@
module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Control.Exception hiding ( catch )
import Control.Monad.Catch
import Nix.Thunk
import Nix.Utils
import Nix.Var
import Nix.Thunk
import Nix.Utils
import Nix.Var
data Deferred m v = Deferred (m v) | Computed v
deriving (Functor, Foldable, Traversable)
@ -31,98 +31,95 @@ data NThunkF m v
| Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))
instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where
Value x == Value y = x == y
Thunk x _ _ == Thunk y _ _ = x == y
_ == _ = False -- jww (2019-03-16): not accurate...
Value x == Value y = x == y
Thunk x _ _ == Thunk y _ _ = x == y
_ == _ = False -- jww (2019-03-16): not accurate...
instance Show v => Show (NThunkF m v) where
show (Value v) = show v
show (Thunk _ _ _) = "<thunk>"
show (Value v ) = show v
show (Thunk _ _ _) = "<thunk>"
type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
instance (MonadBasicThunk m, MonadCatch m)
=> MonadThunk (NThunkF m v) m v where
thunk = buildThunk
thunkId = \case
Value _ -> Nothing
Thunk n _ _ -> Just n
query = queryValue
queryM = queryThunk
force = forceThunk
forceEff = forceEffects
wrapValue = valueRef
getValue = thunkValue
thunk = buildThunk
thunkId = \case
Value _ -> Nothing
Thunk n _ _ -> Just n
query = queryValue
queryM = queryThunk
force = forceThunk
forceEff = forceEffects
wrapValue = valueRef
getValue = thunkValue
valueRef :: v -> NThunkF m v
valueRef = Value
thunkValue :: NThunkF m v -> Maybe v
thunkValue (Value v) = Just v
thunkValue _ = Nothing
thunkValue _ = Nothing
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk action =do
freshThunkId <- freshId
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
buildThunk action = do
freshThunkId <- freshId
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a
queryValue (Value v) _ k = k v
queryValue _ n _ = n
queryValue _ n _ = n
queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk (Value v) _ k = k v
queryThunk (Value v ) _ k = k v
queryThunk (Thunk _ active ref) n k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then n
else do
eres <- readVar ref
res <- case eres of
Computed v -> k v
_ -> n
_ <- atomicModifyVar active (False,)
return res
nowActive <- atomicModifyVar active (True, )
if nowActive
then n
else do
eres <- readVar ref
res <- case eres of
Computed v -> k v
_ -> n
_ <- atomicModifyVar active (False, )
return res
forceThunk
:: 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
:: 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
case eres of
Computed v -> k v
Deferred action -> do
nowActive <- atomicModifyVar active (True,)
if nowActive
then
throwM $ ThunkLoop $ show n
else do
traceM $ "Forcing " ++ show n
v <- catch action $ \(e :: SomeException) -> do
_ <- atomicModifyVar active (False,)
throwM e
_ <- atomicModifyVar active (False,)
writeVar ref (Computed v)
k v
eres <- readVar ref
case eres of
Computed v -> k v
Deferred action -> do
nowActive <- atomicModifyVar active (True, )
if nowActive
then throwM $ ThunkLoop $ show n
else do
traceM $ "Forcing " ++ show n
v <- catch action $ \(e :: SomeException) -> do
_ <- atomicModifyVar active (False, )
throwM e
_ <- atomicModifyVar active (False, )
writeVar ref (Computed v)
k v
forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
forceEffects (Value v) k = k v
forceEffects (Value v ) k = k v
forceEffects (Thunk _ active ref) k = do
nowActive <- atomicModifyVar active (True,)
if nowActive
then return $ error "Loop detected"
else do
eres <- readVar ref
case eres of
Computed v -> k v
Deferred action -> do
v <- action
writeVar ref (Computed v)
_ <- atomicModifyVar active (False,)
k v
nowActive <- atomicModifyVar active (True, )
if nowActive
then return $ error "Loop detected"
else do
eres <- readVar ref
case eres of
Computed v -> k v
Deferred action -> do
v <- action
writeVar ref (Computed v)
_ <- atomicModifyVar active (False, )
k v

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

@ -19,27 +19,29 @@
module Nix.Thunk.Standard where
import Control.Comonad (Comonad)
import Control.Comonad.Env (ComonadEnv)
import Control.Monad.Catch hiding (catchJust)
import Control.Monad.Reader
import Data.Fix
import GHC.Generics
import Nix.Cited
import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.Options
import Nix.Render
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var (MonadVar, newVar)
import Control.Comonad ( Comonad )
import Control.Comonad.Env ( ComonadEnv )
import Control.Monad.Catch hiding ( catchJust )
import Control.Monad.Reader
import Data.Fix
import GHC.Generics
import Nix.Cited
import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.Options
import Nix.Render
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Value
import Nix.Var ( MonadVar
, newVar
)
newtype StdCited m a = StdCited
{ _stdCited :: NCited (StdThunk m) (StdCited m) (StdLazy m) a }
@ -57,133 +59,126 @@ newtype StdCited m a = StdCited
newtype StdThunk m = StdThunk
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy m)
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy m)
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) (StdLazy m)
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
thunk mv = do
opts :: Options <- asks (view hasLens)
thunk mv = do
opts :: Options <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
if thunks opts
then do
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann s e))))) =
let e' = Compose (Ann s (Nothing <$ e))
in [Provenance scope e']
go _ = []
ps = concatMap (go . frame) frames
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
else
fmap (StdThunk . StdCited . NCited []) . thunk $ mv
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
else fmap (StdThunk . StdCited . NCited []) . thunk $ mv
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
query (StdThunk (StdCited (NCited _ t))) = query t
queryM (StdThunk (StdCited (NCited _ t))) = queryM t
query (StdThunk (StdCited (NCited _ t))) = query t
queryM (StdThunk (StdCited (NCited _ t))) = queryM t
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- 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)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann s _)):_ ->
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (force t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(force t f)
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- 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)
where
go = case ps of
[] -> force t f
Provenance scope e@(Compose (Ann s _)) : _ ->
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (force t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
forceEff (StdThunk (StdCited (NCited ps t))) f =
catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann s _)):_ -> do
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (forceEff t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
(forceEff t f)
forceEff (StdThunk (StdCited (NCited ps t))) f = catch
go
(throwError @ThunkLoop)
where
go = case ps of
[] -> forceEff t f
Provenance scope e@(Compose (Ann s _)) : _ -> do
-- r <- liftWith $ \run -> do
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
-- (run (forceEff t f))
-- restoreT $ return r
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
instance ( MonadStdThunk m
, ToValue a (StdLazy m) (StdValue m)
)
=> ToValue a (StdLazy m) (StdThunk m) where
toValue = fmap wrapValue . toValue
toValue = fmap wrapValue . toValue
instance MonadStdThunk m
=> ToValue (StdThunk m) (StdLazy m) (StdValue m) where
toValue = force ?? pure
toValue = force ?? pure
instance ( MonadStdThunk m
, FromValue a (StdLazy m) (StdValue m)
)
=> FromValue a (StdLazy m) (StdThunk m) where
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
instance MonadStdThunk m
=> FromValue (StdThunk m) (StdLazy m) (StdValue m) where
fromValueMay = pure . Just . wrapValue
fromValue = pure . wrapValue
fromValueMay = pure . Just . wrapValue
fromValue = pure . wrapValue
instance ( MonadStdThunk m
, ToNix a (StdLazy m) (StdValue m)
)
=> ToNix a (StdLazy m) (StdThunk m) where
toNix = fmap wrapValue . toNix
toNix = fmap wrapValue . toNix
instance MonadStdThunk m
=> ToNix (StdThunk m) (StdLazy m) (StdValue m) where
toNix = force ?? pure
toNix = force ?? pure
instance ( MonadStdThunk m
, FromNix a (StdLazy m) (StdValue m)
)
=> FromNix a (StdLazy m) (StdThunk m) where
fromNixMay = force ?? fromNixMay
fromNix = force ?? fromNix
fromNixMay = force ?? fromNixMay
fromNix = force ?? fromNix
instance MonadStdThunk m
=> FromNix (StdThunk m) (StdLazy m) (StdValue m) where
fromNixMay = pure . Just . wrapValue
fromNix = pure . wrapValue
fromNixMay = pure . Just . wrapValue
fromNix = pure . wrapValue
instance Show (StdThunk m) where
show _ = "<thunk>" -- jww (2019-03-15): NYI
show _ = "<thunk>" -- jww (2019-03-15): NYI
instance MonadFile m => MonadFile (StdIdT m)
instance MonadIntrospect m => MonadIntrospect (StdIdT m)
instance MonadStore m => MonadStore (StdIdT m) where
addPath' = lift . addPath'
toFile_' = (lift .) . toFile_'
addPath' = lift . addPath'
toFile_' = (lift .) . toFile_'
instance MonadPutStr m => MonadPutStr (StdIdT m)
instance MonadHttp m => MonadHttp (StdIdT m)
instance MonadEnv m => MonadEnv (StdIdT m)
@ -192,25 +187,25 @@ instance MonadExec m => MonadExec (StdIdT m)
instance (MonadEffects t f m, MonadDataContext f m)
=> MonadEffects t f (StdIdT m) where
makeAbsolutePath = lift . makeAbsolutePath @t @f @m
findEnvPath = lift . findEnvPath @t @f @m
findPath = (lift .) . findPath @t @f @m
importPath path = do
i <- FreshIdT ask
p <- lift $ importPath @t @f @m path
return $ liftNValue (runFreshIdT i) p
pathToDefaultNix = lift . pathToDefaultNix @t @f @m
derivationStrict v = do
i <- FreshIdT ask
p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v)
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m
makeAbsolutePath = lift . makeAbsolutePath @t @f @m
findEnvPath = lift . findEnvPath @t @f @m
findPath = (lift .) . findPath @t @f @m
importPath path = do
i <- FreshIdT ask
p <- lift $ importPath @t @f @m path
return $ liftNValue (runFreshIdT i) p
pathToDefaultNix = lift . pathToDefaultNix @t @f @m
derivationStrict v = do
i <- FreshIdT ask
p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v)
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m
instance HasCitations1 (StdThunk m) (StdCited m) (StdLazy m) where
citations1 (StdCited c) = citations c
addProvenance1 x (StdCited c) = StdCited (addProvenance x c)
citations1 (StdCited c) = citations c
addProvenance1 x (StdCited c) = StdCited (addProvenance x c)
runStdLazyM :: (MonadVar m, MonadIO m) => Options -> StdLazy m a -> m a
runStdLazyM opts action = do
i <- newVar (1 :: Int)
runFreshIdT i $ runLazyM opts action
i <- newVar (1 :: Int)
runFreshIdT i $ runLazyM opts action

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

@ -1,20 +1,21 @@
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)
import Prelude hiding ( lookup )
import Nix.Type.Type
import Nix.Type.Type
import Data.Foldable
import Data.Foldable
newtype Assumption = Assumption { assumptions :: [(Name, Type)] }
deriving (Eq, Show)

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

@ -1,24 +1,25 @@
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)
import Prelude hiding ( lookup )
import Nix.Type.Type
import Data.Foldable hiding (toList)
import qualified Data.Map as Map
import Data.Foldable hiding ( toList )
import qualified Data.Map as Map
-------------------------------------------------------------------------------
-- Typing Environment
@ -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
@ -65,5 +65,5 @@ instance Semigroup Env where
(<>) = merge
instance Monoid Env where
mempty = empty
mempty = empty
mappend = merge

694
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
@ -37,17 +38,22 @@ import Control.Monad.ST
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.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.HashMap.Lazy as M
import Data.List ( delete
, find
, nub
, intersect
, (\\)
)
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( fromJust )
import qualified Data.Set as Set
import Data.Text ( Text )
import Nix.Atoms
import Nix.Convert
import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval
import Nix.Eval ( MonadEval(..) )
import qualified Nix.Eval as Eval
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Fresh
@ -55,9 +61,9 @@ import Nix.String
import Nix.Scope
import Nix.Thunk
import Nix.Thunk.Basic
import qualified Nix.Type.Assumption as As
import qualified Nix.Type.Assumption as As
import Nix.Type.Env
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Env as Env
import Nix.Type.Type
import Nix.Utils
import Nix.Var
@ -86,10 +92,10 @@ newtype InferT s m a = InferT
)
instance MonadTrans (InferT s) where
lift = InferT . lift . lift . lift
lift = InferT . lift . lift . lift
instance MonadThunkId m => MonadThunkId (InferT s m) where
type ThunkId (InferT s m) = ThunkId m
type ThunkId (InferT s m) = ThunkId m
-- | Inference state
newtype InferState = InferState { count :: Int }
@ -112,25 +118,27 @@ class Substitutable a where
instance Substitutable TVar where
apply (Subst s) a = tv
where t = TVar a
(TVar tv) = Map.findWithDefault t a s
where
t = TVar a
(TVar tv) = Map.findWithDefault t a s
instance Substitutable Type where
apply _ (TCon a) = TCon a
apply s (TSet b a) = TSet b (M.map (apply s) a)
apply s (TList a) = TList (map (apply s) a)
apply (Subst s) t@(TVar a) = Map.findWithDefault t a s
apply s (t1 :~> t2) = apply s t1 :~> apply s t2
apply s (TMany ts) = TMany (map (apply s) ts)
apply _ ( TCon a ) = TCon a
apply s ( TSet b a ) = TSet b (M.map (apply s) a)
apply s ( TList a ) = TList (map (apply s) a)
apply (Subst s) t@(TVar a ) = Map.findWithDefault t a s
apply s ( t1 :~> t2) = apply s t1 :~> apply s t2
apply s ( TMany ts ) = TMany (map (apply s) ts)
instance Substitutable Scheme where
apply (Subst s) (Forall as t) = Forall as $ apply s' t
where s' = Subst $ foldr Map.delete s as
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 (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)
instance Substitutable a => Substitutable [a] where
apply = map . apply
@ -144,11 +152,11 @@ class FreeTypeVars a where
instance FreeTypeVars Type where
ftv TCon{} = Set.empty
ftv (TVar a) = Set.singleton a
ftv (TSet _ a) = Set.unions (map ftv (M.elems a))
ftv (TList a) = Set.unions (map ftv a)
ftv (TVar a ) = Set.singleton a
ftv (TSet _ a ) = Set.unions (map ftv (M.elems a))
ftv (TList a ) = Set.unions (map ftv a)
ftv (t1 :~> t2) = ftv t1 `Set.union` ftv t2
ftv (TMany ts) = Set.unions (map ftv ts)
ftv (TMany ts ) = Set.unions (map ftv ts)
instance FreeTypeVars TVar where
ftv = Set.singleton
@ -157,19 +165,20 @@ instance FreeTypeVars Scheme where
ftv (Forall as t) = ftv t `Set.difference` Set.fromList as
instance FreeTypeVars a => FreeTypeVars [a] where
ftv = foldr (Set.union . ftv) Set.empty
ftv = foldr (Set.union . ftv) Set.empty
instance (Ord a, FreeTypeVars a) => FreeTypeVars (Set.Set a) where
ftv = foldr (Set.union . ftv) Set.empty
ftv = foldr (Set.union . ftv) Set.empty
class ActiveTypeVars a where
atv :: a -> Set.Set TVar
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 (ExpInstConst t s) = ftv t `Set.union` ftv s
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 (ExpInstConst t s) = ftv t `Set.union` ftv s
instance ActiveTypeVars a => ActiveTypeVars [a] where
atv = foldr (Set.union . atv) Set.empty
@ -194,11 +203,11 @@ deriving instance Show InferError
instance Exception InferError
instance Semigroup InferError where
x <> _ = x
x <> _ = x
instance Monoid InferError where
mempty = TypeInferenceAborted
mappend = (<>)
mempty = TypeInferenceAborted
mappend = (<>)
-------------------------------------------------------------------------------
-- Inference
@ -206,41 +215,44 @@ instance Monoid InferError where
-- | Run the inference monad
runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a)
runInfer' = runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
. getInfer
runInfer' =
runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
. getInfer
runInfer :: (forall s. InferT s (FreshIdT Int (ST s)) a) -> Either InferError a
runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a
runInfer m = runST $ do
i <- newVar (1 :: Int)
runFreshIdT i (runInfer' m)
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
| (x, ss) <- Env.toList env
, s <- ss
, t <- As.lookup x as]
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
]
inferState <- get
let eres = (`evalState` inferState) $ runSolver $ do
subst <- solve (cs ++ cs')
return (subst, subst `apply` t)
subst <- solve (cs ++ cs')
return (subst, subst `apply` t)
case eres of
Left errs -> throwError $ TypeInferenceErrors errs
Right xs -> pure xs
Left errs -> throwError $ TypeInferenceErrors errs
Right xs -> pure xs
-- | Solve for the toplevel type of an expression in a given environment
inferExpr :: Env -> NExpr -> Either InferError [Scheme]
inferExpr env ex = case runInfer (inferType env ex) of
Left err -> Left err
Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs
Left err -> Left err
Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs
-- | Canonicalize and return the polymorphic toplevel type.
closeOver :: Type -> Scheme
@ -250,243 +262,262 @@ extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a
extendMSet x = InferT . local (first (Set.insert x)) . getInfer
letters :: [String]
letters = [1..] >>= flip replicateM ['a'..'z']
letters = [1 ..] >>= flip replicateM ['a' .. 'z']
freshTVar :: MonadState InferState m => m TVar
freshTVar = do
s <- get
put s{count = count s + 1}
return $ TV (letters !! count s)
s <- get
put s { count = count s + 1 }
return $ TV (letters !! count s)
fresh :: MonadState InferState m => m Type
fresh = TVar <$> freshTVar
instantiate :: MonadState InferState m => Scheme -> m Type
instantiate (Forall as t) = do
as' <- mapM (const fresh) as
let s = Subst $ Map.fromList $ zip as as'
return $ apply s t
as' <- mapM (const fresh) as
let s = Subst $ Map.fromList $ zip as as'
return $ apply s t
generalize :: Set.Set TVar -> Type -> Scheme
generalize free t = Forall as t
where as = Set.toList $ ftv t `Set.difference` free
generalize free t = Forall as t
where as = Set.toList $ ftv t `Set.difference` free
unops :: Type -> NUnaryOp -> [Constraint]
unops u1 = \case
NNot -> [ EqConst u1 (typeFun [typeBool, typeBool]) ]
NNeg -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt]
, typeFun [typeFloat, typeFloat] ]) ]
NNot -> [EqConst u1 (typeFun [typeBool, typeBool])]
NNeg ->
[ EqConst
u1
(TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]])
]
binops :: Type -> NBinaryOp -> [Constraint]
binops u1 = \case
NApp -> [] -- this is handled separately
NApp -> [] -- this is handled separately
-- Equality tells you nothing about the types, because any two types are
-- allowed.
NEq -> []
NNEq -> []
-- Equality tells you nothing about the types, because any two types are
-- allowed.
NEq -> []
NNEq -> []
NGt -> inequality
NGte -> inequality
NLt -> inequality
NLte -> inequality
NGt -> inequality
NGte -> inequality
NLt -> inequality
NLte -> inequality
NAnd -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NOr -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NImpl -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NAnd -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])]
NOr -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])]
NImpl -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])]
NConcat -> [ EqConst u1 (TMany [ typeFun [typeList, typeList, typeList]
, typeFun [typeList, typeNull, typeList]
, typeFun [typeNull, 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]
, typeFun [typeSet, typeNull, typeSet]
, typeFun [typeNull, 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]
, 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]
, typeFun [typeFloat, typeFloat, typeBool]
, typeFun [typeInt, typeFloat, typeBool]
, typeFun [typeFloat, typeInt, typeBool]
]) ]
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]
, typeFun [typeFloat, typeFloat, typeBool]
, typeFun [typeInt, typeFloat, typeBool]
, typeFun [typeFloat, typeInt, typeBool]
]
)
]
arithmetic =
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
]) ]
arithmetic =
[ 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
instance MonadRef m => MonadRef (InferT s m) where
type Ref (InferT s m) = Ref m
newRef x = liftInfer $ newRef x
readRef x = liftInfer $ readRef x
writeRef x y = liftInfer $ writeRef x y
type Ref (InferT s m) = Ref m
newRef x = liftInfer $ newRef x
readRef x = liftInfer $ readRef x
writeRef x y = liftInfer $ writeRef x y
instance MonadAtomicRef m => MonadAtomicRef (InferT s m) where
atomicModifyRef x f = liftInfer $ do
res <- snd . f <$> readRef x
_ <- modifyRef x (fst . f)
return res
atomicModifyRef x f = liftInfer $ do
res <- snd . f <$> readRef x
_ <- modifyRef x (fst . f)
return res
newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s))
instance Monad m => MonadThrow (InferT s m) where
throwM = throwError . EvaluationError
throwM = throwError . EvaluationError
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
(fromException (toException e))
err -> error $ "Unexpected error: " ++ show err
catch m h = catchError m $ \case
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
thunk = fmap JThunk . thunk
thunkId (JThunk x) = thunkId x
thunk = fmap JThunk . thunk
thunkId (JThunk x) = thunkId x
query (JThunk x) b f = query x b f
queryM (JThunk x) b f = queryM x b f
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) ->
-- 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) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
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) ->
-- If we have a thunk loop, we just don't know the type.
f =<< Judgment As.empty [] <$> fresh
wrapValue = JThunk . wrapValue
getValue (JThunk x) = getValue x
wrapValue = JThunk . wrapValue
getValue (JThunk x) = getValue x
instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
freeVariable var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
freeVariable var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
synHole var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
synHole var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
-- If we fail to look up an attribute, we just don't know the type.
attrMissing _ _ = Judgment As.empty [] <$> fresh
-- If we fail to look up an attribute, we just don't know the type.
attrMissing _ _ = Judgment As.empty [] <$> fresh
evaledSym _ = pure
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
go = \case
NInt _ -> typeInt
NFloat _ -> typeFloat
NBool _ -> typeBool
NNull -> typeNull
evalConstant c = return $ Judgment As.empty [] (go c)
where
go = \case
NInt _ -> typeInt
NFloat _ -> typeFloat
NBool _ -> typeBool
NNull -> typeNull
evalString = const $ return $ Judgment As.empty [] typeString
evalLiteralPath = const $ return $ Judgment As.empty [] typePath
evalEnvPath = const $ return $ Judgment As.empty [] typePath
evalString = const $ return $ Judgment As.empty [] typeString
evalLiteralPath = const $ return $ Judgment As.empty [] typePath
evalEnvPath = const $ return $ Judgment As.empty [] typePath
evalUnary op (Judgment as1 cs1 t1) = do
tv <- fresh
return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv
evalUnary op (Judgment as1 cs1 t1) = do
tv <- fresh
return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv
evalBinary op (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
return $ Judgment
(as1 `As.merge` as2)
(cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op)
tv
evalBinary op (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
return $ Judgment (as1 `As.merge` as2)
(cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op)
tv
evalWith = Eval.evalWithAttrSet
evalWith = Eval.evalWithAttrSet
evalIf (Judgment as1 cs1 t1) t f = do
Judgment as2 cs2 t2 <- t
Judgment as3 cs3 t3 <- f
return $ Judgment
(as1 `As.merge` as2 `As.merge` as3)
(cs1 ++ cs2 ++ cs3 ++ [EqConst t1 typeBool, EqConst t2 t3])
t2
evalIf (Judgment as1 cs1 t1) t f = do
Judgment as2 cs2 t2 <- t
Judgment as3 cs3 t3 <- f
return $ Judgment
(as1 `As.merge` as2 `As.merge` as3)
(cs1 ++ cs2 ++ cs3 ++ [EqConst t1 typeBool, EqConst t2 t3])
t2
evalAssert (Judgment as1 cs1 t1) body = do
Judgment as2 cs2 t2 <- body
return $ Judgment
(as1 `As.merge` as2)
(cs1 ++ cs2 ++ [EqConst t1 typeBool])
t2
evalAssert (Judgment as1 cs1 t1) body = do
Judgment as2 cs2 t2 <- body
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)
(cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)])
tv
evalApp (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
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)
(cs ++ [EqConst t' tv | t' <- As.lookup x as])
(tv :~> t)
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)
(cs ++ [ EqConst t' tv | t' <- As.lookup x as ])
(tv :~> t)
evalAbs (ParamSet ps variadic _mname) k = do
js <- fmap concat $ forM ps $ \(name, _) -> do
tv <- fresh
pure [(name, tv)]
evalAbs (ParamSet ps variadic _mname) k = do
js <- fmap concat $ forM ps $ \(name, _) -> do
tv <- fresh
pure [(name, tv)]
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
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
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])
(ty :~> t)
return $ Judgment
(foldl' As.remove as names)
(cs ++ [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ])
(ty :~> t)
evalError = throwError . EvaluationError
evalError = throwError . EvaluationError
data Judgment s = Judgment
{ assumptions :: As.Assumption
@ -496,71 +527,70 @@ data Judgment s = Judgment
deriving Show
instance Monad m => FromValue NixString (InferT s m) (Judgment s) where
fromValueMay _ = return Nothing
fromValue _ = error "Unused"
fromValueMay _ = return Nothing
fromValue _ = error "Unused"
instance MonadInfer m
=> FromValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
fromValueMay (Judgment _ _ (TSet _ xs)) = do
let sing _ = Judgment As.empty []
pure $ Just (M.mapWithKey (\k v -> wrapValue (sing k v)) xs, M.empty)
fromValueMay _ = pure Nothing
fromValue = fromValueMay >=> \case
Just v -> pure v
Nothing -> pure (M.empty, M.empty)
fromValueMay (Judgment _ _ (TSet _ xs)) = do
let sing _ = Judgment As.empty []
pure $ Just (M.mapWithKey (\k v -> wrapValue (sing k v)) xs, M.empty)
fromValueMay _ = pure Nothing
fromValue = fromValueMay >=> \case
Just v -> pure v
Nothing -> pure (M.empty, M.empty)
instance MonadInfer m
=> ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)
(InferT s m) (Judgment s) where
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
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
instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
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
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
instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where
toValue _ = pure $ Judgment As.empty [] typeBool
toValue _ = pure $ Judgment As.empty [] typeBool
infer :: MonadInfer m => NExpr -> InferT s m (Judgment s)
infer = cata Eval.eval
inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env
inferTop env [] = Right env
inferTop env ((name, ex):xs) = case inferExpr env ex of
Left err -> Left err
Right ty -> inferTop (extend env (name, ty)) xs
inferTop env [] = Right env
inferTop env ((name, ex) : xs) = case inferExpr env ex of
Left err -> Left err
Right ty -> inferTop (extend env (name, ty)) xs
normalize :: Scheme -> Scheme
normalize (Forall _ body) = Forall (map snd ord) (normtype body)
where
ord = zip (nub $ fv body) (map TV letters)
where
ord = zip (nub $ fv body) (map TV letters)
fv (TVar a) = [a]
fv (a :~> b) = fv a ++ fv b
fv (TCon _) = []
fv (TSet _ a) = concatMap fv (M.elems a)
fv (TList a) = concatMap fv a
fv (TMany ts) = concatMap fv ts
fv (TVar a ) = [a]
fv (a :~> b ) = fv a ++ fv b
fv (TCon _ ) = []
fv (TSet _ a) = concatMap fv (M.elems a)
fv (TList a ) = concatMap fv a
fv (TMany ts) = concatMap fv ts
normtype (a :~> b) = normtype a :~> normtype b
normtype (TCon a) = TCon a
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
Just x -> TVar x
Nothing -> error "type variable not in signature"
normtype (a :~> b ) = normtype a :~> normtype b
normtype (TCon a ) = TCon a
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
Just x -> TVar x
Nothing -> error "type variable not in signature"
-------------------------------------------------------------------------------
-- Constraint Solver
@ -571,18 +601,18 @@ newtype Solver m a = Solver (LogicT (StateT [TypeError] m) a)
MonadLogic, MonadState [TypeError])
instance MonadTrans Solver where
lift = Solver . lift . lift
lift = Solver . lift . lift
instance Monad m => MonadError TypeError (Solver m) where
throwError err = Solver $ lift (modify (err:)) >> mzero
catchError _ _ = error "This is never used"
throwError err = Solver $ lift (modify (err :)) >> mzero
catchError _ _ = error "This is never used"
runSolver :: Monad m => Solver m a -> m (Either [TypeError] [a])
runSolver (Solver s) = do
res <- runStateT (observeAllT s) []
pure $ case res of
(x:xs, _) -> Right (x:xs)
(_, es) -> Left (nub es)
res <- runStateT (observeAllT s) []
pure $ case res of
(x : xs, _ ) -> Right (x : xs)
(_ , es) -> Left (nub es)
-- | The empty substitution
emptySubst :: Subst
@ -591,62 +621,62 @@ emptySubst = mempty
-- | Compose substitutions
compose :: Subst -> Subst -> Subst
Subst s1 `compose` Subst s2 =
Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1
Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1
unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst
unifyMany [] [] = return emptySubst
unifyMany (t1 : ts1) (t2 : ts2) =
do su1 <- unifies t1 t2
su2 <- unifyMany (apply su1 ts1) (apply su1 ts2)
return (su2 `compose` su1)
unifyMany [] [] = return emptySubst
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
allSameType :: [Type] -> Bool
allSameType [] = True
allSameType [_] = True
allSameType (x:y:ys) = x == y && allSameType (y:ys)
allSameType [] = True
allSameType [_ ] = True
allSameType (x : y : ys) = x == y && allSameType (y : ys)
unifies :: Monad m => Type -> Type -> Solver m Subst
unifies t1 t2 | t1 == t2 = return emptySubst
unifies (TVar v) t = v `bind` t
unifies t (TVar v) = v `bind` t
unifies t1 t2 | t1 == t2 = return emptySubst
unifies (TVar v) t = v `bind` t
unifies t (TVar v) = v `bind` t
unifies (TList xs) (TList ys)
| allSameType xs && allSameType ys = case (xs, ys) of
(x:_, y:_) -> unifies x y
_ -> return emptySubst
| length xs == length ys = unifyMany xs ys
| allSameType xs && allSameType ys = case (xs, ys) of
(x : _, y : _) -> unifies x y
_ -> return emptySubst
| length xs == length ys = unifyMany xs ys
-- We assume that lists of different lengths containing various types cannot
-- be unified.
unifies t1@(TList _) t2@(TList _) = throwError $ UnificationFail t1 t2
unifies (TSet True _) (TSet True _) = return emptySubst
unifies t1@(TList _ ) t2@(TList _ ) = throwError $ UnificationFail t1 t2
unifies ( TSet True _) ( TSet True _) = return emptySubst
unifies (TSet False b) (TSet True s)
| M.keys b `intersect` M.keys s == M.keys s = return emptySubst
| 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
| 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 (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
unifies t1 t2 = throwError $ UnificationFail t1 t2
unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2
unifies t1 (TMany t2s) = considering t2s >>- unifies t1
unifies t1 t2 = throwError $ UnificationFail t1 t2
bind :: Monad m => TVar -> Type -> Solver m Subst
bind a t | t == TVar a = return emptySubst
| occursCheck a t = throwError $ InfiniteType a t
| otherwise = return (Subst $ Map.singleton a t)
occursCheck :: FreeTypeVars a => TVar -> a -> Bool
occursCheck :: FreeTypeVars a => TVar -> a -> Bool
occursCheck a t = a `Set.member` ftv t
nextSolvable :: [Constraint] -> (Constraint, [Constraint])
nextSolvable xs = fromJust (find solvable (chooseOne xs))
where
chooseOne xs = [(x, ys) | x <- xs, let ys = delete x xs]
where
chooseOne xs = [ (x, ys) | x <- xs, let ys = delete x xs ]
solvable (EqConst{}, _) = True
solvable (ExpInstConst{}, _) = True
solvable (ImpInstConst _t1 ms t2, cs) =
Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs)
solvable (EqConst{} , _) = True
solvable (ExpInstConst{}, _) = True
solvable (ImpInstConst _t1 ms t2, cs) =
Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs)
considering :: [a] -> Solver m a
considering xs = Solver $ LogicT $ \c n -> foldr c n xs
@ -654,21 +684,19 @@ considering xs = Solver $ LogicT $ \c n -> foldr c n xs
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)
where
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)
solve' (ImpInstConst t1 ms t2, cs) =
solve (ExpInstConst t1 (generalize ms t2) : cs)
solve' (ExpInstConst t s, cs) = do
s' <- lift $ instantiate s
solve (EqConst t s' : cs)
solve' (ExpInstConst t s, cs) = do
s' <- lift $ instantiate s
solve (EqConst t s' : cs)
instance Monad m => Scoped (JThunkT s m) (InferT s m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(InferT s m) @(JThunkT s m)
pushScopes = pushScopesReader
lookupVar = lookupVarReader
clearScopes = clearScopesReader @(InferT s m) @(JThunkT s m)
pushScopes = pushScopesReader
lookupVar = lookupVarReader

14
src/Nix/Type/Type.hs
View File

@ -1,7 +1,7 @@
module Nix.Type.Type where
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import qualified Data.HashMap.Lazy as M
import Data.Text ( Text )
import Nix.Utils
newtype TVar = TV String
@ -32,11 +32,11 @@ typeFun :: [Type] -> Type
typeFun = foldr1 (:~>)
typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type
typeInt = TCon "integer"
typeFloat = TCon "float"
typeBool = TCon "boolean"
typeInt = TCon "integer"
typeFloat = TCon "float"
typeBool = TCon "boolean"
typeString = TCon "string"
typePath = TCon "path"
typeNull = TCon "null"
typePath = TCon "path"
typeNull = TCon "null"
type Name = Text

103
src/Nix/Utils.hs
View File

@ -12,28 +12,36 @@
module Nix.Utils (module Nix.Utils, module X) where
import Control.Arrow ((&&&))
import Control.Arrow ( (&&&) )
import Control.Monad
import Control.Monad.Fix
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix
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.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 Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
import Data.List ( sortOn )
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.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 ()
@ -71,7 +79,7 @@ para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f = f . fmap (id &&& para f) . unFix
paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a
paraM f = f <=< traverse (\x -> (x,) <$> paraM f x) . unFix
paraM f = f <=< traverse (\x -> (x, ) <$> paraM f x) . unFix
cataP :: Functor f => (Fix f -> f a -> a) -> Fix f -> a
cataP f x = f x . fmap (cataP f) . unFix $ x
@ -79,7 +87,7 @@ cataP f x = f x . fmap (cataP f) . unFix $ x
cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a
cataPM f x = f x <=< traverse (cataPM f) . unFix $ x
transport :: Functor g => (forall x. f x -> g x) -> Fix f -> Fix g
transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g
transport f (Fix x) = Fix $ fmap (transport f) (f x)
-- | adi is Abstracting Definitional Interpreters:
@ -92,31 +100,36 @@ 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
hasLens :: Lens' a b
instance Has a a where
hasLens f = f
hasLens f = f
instance Has (a, b) a where
hasLens = _1
hasLens = _1
instance Has (a, b) b where
hasLens = _2
hasLens = _2
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted = \case
A.Object m ->
A.pairs . mconcat
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
. sortOn fst
$ M.toList m
A.Array l -> A.list toEncodingSorted $ V.toList l
v -> A.toEncoding v
A.Object m ->
A.pairs
. mconcat
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
. sortOn fst
$ M.toList m
A.Array l -> A.list toEncodingSorted $ V.toList l
v -> A.toEncoding v
data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq)
@ -124,16 +137,30 @@ data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq)
-- (i.e. @https://...@)
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)
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
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)
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
| 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
Nothing -> M.delete k m
Just v -> M.insert k v m

596
src/Nix/Value.hs
View File

@ -36,16 +36,16 @@ import Control.Monad
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import qualified Data.Aeson as A
import Data.Align
import Data.Eq.Deriving
import Data.Functor.Classes
import Data.Functor.Identity
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
import Data.Text ( Text )
import Data.These
import Data.Typeable (Typeable)
import Data.Typeable ( Typeable )
import GHC.Generics
import Lens.Family2
import Lens.Family2.Stock
@ -90,65 +90,70 @@ data NValueF p m r
-- | This 'Foldable' instance only folds what the value actually is known to
-- contain at time of fold.
instance Foldable (NValueF p m) where
foldMap f = \case
NVConstantF _ -> mempty
NVStrF _ -> mempty
NVPathF _ -> mempty
NVListF l -> foldMap f l
NVSetF s _ -> foldMap f s
NVClosureF _ _ -> mempty
NVBuiltinF _ _ -> mempty
foldMap f = \case
NVConstantF _ -> mempty
NVStrF _ -> mempty
NVPathF _ -> mempty
NVListF l -> foldMap f l
NVSetF s _ -> foldMap f s
NVClosureF _ _ -> mempty
NVBuiltinF _ _ -> mempty
bindNValueF :: (Monad m, Monad n)
=> (forall x. n x -> m x) -> (a -> n b) -> NValueF p m a
-> n (NValueF p m b)
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
NVStrF s -> pure $ NVStrF s
NVPathF p -> pure $ NVPathF p
NVListF l -> NVListF <$> traverse f l
NVSetF s p -> NVSetF <$> traverse f s <*> pure p
NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g)
NVConstantF a -> pure $ NVConstantF a
NVStrF s -> pure $ NVStrF s
NVPathF p -> pure $ NVPathF p
NVListF l -> NVListF <$> traverse f l
NVSetF s p -> NVSetF <$> traverse f s <*> pure p
NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g)
NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g)
lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
lmapNValueF f = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p (g . fmap f)
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p (g . fmap f)
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
liftNValueF :: (MonadTrans u, Monad m)
=> (forall x. u m x -> m x)
-> NValueF p m a
-> NValueF p (u m) a
liftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p m a
-> NValueF p (u m) a
liftNValueF run = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p $ lift . g . run
NVBuiltinF s g -> NVBuiltinF s $ lift . g . run
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p $ lift . g . run
NVBuiltinF s g -> NVBuiltinF s $ lift . g . run
unliftNValueF :: (MonadTrans u, Monad m)
=> (forall x. u m x -> m x)
-> NValueF p (u m) a
-> NValueF p m a
unliftNValueF
:: (MonadTrans u, Monad m)
=> (forall x . u m x -> m x)
-> NValueF p (u m) a
-> NValueF p m a
unliftNValueF run = \case
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
NVClosureF p g -> NVClosureF p $ run . g . lift
NVBuiltinF s g -> NVBuiltinF s $ run . g . lift
NVConstantF a -> NVConstantF a
NVStrF s -> NVStrF s
NVPathF p -> NVPathF p
NVListF l -> NVListF l
NVSetF s p -> NVSetF s p
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.
@ -156,43 +161,48 @@ newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
deriving (Generic, Typeable, Functor, Foldable)
instance Show r => Show (NValueF p m r) where
showsPrec = flip go where
go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF ns) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
go (NVListF lst) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p) = showsCon1 "NVPath" p
go (NVBuiltinF name _) = showsCon1 "NVBuiltin" name
showsPrec = flip go where
go (NVConstantF atom ) = showsCon1 "NVConstant" atom
go (NVStrF ns ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
go (NVListF lst ) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p ) = showsCon1 "NVPath" p
go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
instance (Comonad f, Show a) => Show (NValue' t f m a) where
show (NValue (extract -> v)) = show v
show (NValue (extract -> v)) = show v
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
-> n (NValue' t f m b)
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
NValue <$> traverse (bindNValueF transform f) v
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
:: (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)
NValue (fmap (lmapNValueF (unliftNValue run) . liftNValueF run) v)
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
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
unliftNValue run (NValue v) =
NValue (fmap (lmapNValueF (liftNValue run) . unliftNValueF run) v)
NValue (fmap (lmapNValueF (liftNValue run) . unliftNValueF run) v)
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is
-- a value in head normal form, where only the "top layer" has been
@ -207,64 +217,75 @@ 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
=> (a -> (NValue' t f m a -> r) -> r)
-> (NValue' t f m r -> r)
-> NValue' t f m a -> r
:: 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
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
iterNValueM
:: (MonadDataContext f m, Monad n)
=> (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
:: (MonadDataContext f m, Monad n)
=> (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
iterNValueM transform k f =
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
iterNValueNF
:: MonadDataContext f m
=> (t -> r)
-> (NValue' t f m r -> r)
-> NValueNF t f m -> r
:: MonadDataContext f m
=> (t -> r)
-> (NValue' t f m r -> 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)
-> n (Free (NValue' t f m) 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
go (Pure a) = Pure <$> a
go (Free fa) = Free <$> bindNValue transform go fa
where
go (Pure a ) = Pure <$> a
go (Free fa) = Free <$> bindNValue transform go fa
iterNValueNFM
:: 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
:: 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
iterNValueNFM transform k f v =
iterM f =<< sequenceNValueNF transform (fmap k 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>")
where
f t = query t cyc id
cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")
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
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
nValueToNF k = iterNValue k Free
nValueToNFM
:: (MonadDataContext f m, Monad n)
=> (forall x. n x -> m x)
-> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
-> NValue t f m
-> n (NValueNF t f m)
:: (MonadDataContext f m, Monad n)
=> (forall x . n x -> m x)
-> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
-> NValue t f m
-> n (NValueNF t f m)
nValueToNFM transform k = iterNValueM transform k $ pure . Free
pattern NVConstant x <- NValue (extract -> NVConstantF x)
@ -329,157 +350,176 @@ 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 ()
(NVConstant (NInt _), NVConstant (NInt _)) -> pure ()
(NVConstant (NFloat _), NVConstant (NFloat _)) -> pure ()
(NVStr _, NVStr _) -> pure ()
(NVPath _, NVPath _) -> pure ()
_ -> throwError $ Comparison x y
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
(NVConstant (NInt _), NVConstant (NInt _)) -> pure ()
(NVConstant (NFloat _), NVConstant (NFloat _)) -> pure ()
(NVStr _, NVStr _) -> pure ()
(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
_ -> valueEqM lv rv
in case (lv, rv) of
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
(NVList _, NVList _) -> unsafePtrEq
(NVSet _ _, NVSet _ _) -> unsafePtrEq
_ -> valueEqM lv rv
let unsafePtrEq = case (lt, rt) of
(thunkId -> lid, thunkId -> rid) | lid == rid -> return True
_ -> valueEqM lv rv
in case (lv, rv) of
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
(NVList _ , NVList _ ) -> unsafePtrEq
(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))
-> 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)
=> 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)
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)
builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
isClosureNF :: Comonad f => NValueNF t f m -> Bool
isClosureNF NVClosureNF {} = True
isClosureNF _ = False
isClosureNF NVClosureNF{} = True
isClosureNF _ = False
-- | Checks whether two containers are equal, using the given item equality
-- predicate. If there are any item slots that don't match between the two
-- containers, the result will be False.
alignEqM
:: (Align f, Traversable f, Monad m)
=> (a -> b -> m Bool)
-> f a
-> f b
-> m Bool
:: (Align f, Traversable f, Monad m)
=> (a -> b -> m Bool)
-> f a
-> f b
-> m Bool
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
pairs <- forM (Data.Align.align fa fb) $ \case
These a b -> return (a, b)
_ -> throwE ()
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
pairs <- forM (Data.Align.align fa fb) $ \case
These a b -> return (a, b)
_ -> throwE ()
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool
alignEq eq fa fb = runIdentity $ alignEqM (\x y -> Identity (eq x y)) fa fb
isDerivationM :: Monad m => (t -> m (Maybe NixString)) -> AttrSet t -> m Bool
isDerivationM f m = case M.lookup "type" m of
Nothing -> pure False
Just t -> do
mres <- f t
case mres of
-- We should probably really make sure the context is empty here
-- but the C++ implementation ignores it.
Just s -> pure $ principledStringIgnoreContext s == "derivation"
Nothing -> pure False
Nothing -> pure False
Just t -> do
mres <- f t
case mres of
-- We should probably really make sure the context is empty here
-- but the C++ implementation ignores it.
Just s -> pure $ principledStringIgnoreContext s == "derivation"
Nothing -> pure False
isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool
isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x))
valueFEqM :: Monad n
=> (AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool)
-> NValueF p m a
-> NValueF p m a
-> n Bool
valueFEqM
:: Monad n
=> (AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool)
-> NValueF p m a
-> NValueF p m a
-> n Bool
valueFEqM attrsEq eq = curry $ \case
(NVConstantF (NFloat x), NVConstantF (NInt y)) -> pure $ x == fromInteger y
(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
(NVListF ls, NVListF rs) -> alignEqM eq ls rs
(NVSetF lm _, NVSetF rm _) -> attrsEq lm rm
(NVPathF lp, NVPathF rp) -> pure $ lp == rp
_ -> pure False
(NVConstantF (NFloat x), NVConstantF (NInt y) ) -> pure $ x == fromInteger y
(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
(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)
-> (a -> a -> Bool)
-> NValueF p m a
-> NValueF p m a
-> Bool
valueFEq attrsEq eq x y =
runIdentity $ valueFEqM
(\x' y' -> Identity (attrsEq x' y'))
(\x' y' -> Identity (eq x' y')) x y
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
(\x' y' -> Identity (attrsEq x' y'))
(\x' y' -> Identity (eq x' y'))
x
y
compareAttrSetsM :: Monad m
=> (t -> m (Maybe NixString))
-> (t -> t -> m Bool)
-> AttrSet t
-> AttrSet t
-> m Bool
compareAttrSetsM
:: Monad m
=> (t -> m (Maybe NixString))
-> (t -> t -> m Bool)
-> AttrSet t
-> AttrSet t
-> m Bool
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
_ -> compareAttrs
_ -> compareAttrs
where
compareAttrs = alignEqM eq lm rm
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
_ -> compareAttrs
_ -> compareAttrs
where compareAttrs = alignEqM eq lm rm
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
:: (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
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
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
valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
where
f (Pure _) = Nothing
f (Free (NVStr s)) = Just s
f _ = Nothing
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
where
f (Pure _ ) = Nothing
f (Free (NVStr s)) = Just s
f _ = Nothing
data TStringContext = NoContext | HasContext
deriving Show
@ -499,52 +539,52 @@ data ValueType
valueType :: NValueF a m r -> ValueType
valueType = \case
NVConstantF a -> case a of
NInt _ -> TInt
NFloat _ -> TFloat
NBool _ -> TBool
NNull -> TNull
NVStrF ns | stringHasContext ns -> TString HasContext
| otherwise -> TString NoContext
NVListF {} -> TList
NVSetF {} -> TSet
NVClosureF {} -> TClosure
NVPathF {} -> TPath
NVBuiltinF {} -> TBuiltin
NVConstantF a -> case a of
NInt _ -> TInt
NFloat _ -> TFloat
NBool _ -> TBool
NNull -> TNull
NVStrF ns | stringHasContext ns -> TString HasContext
| otherwise -> TString NoContext
NVListF{} -> TList
NVSetF{} -> TSet
NVClosureF{} -> TClosure
NVPathF{} -> TPath
NVBuiltinF{} -> TBuiltin
describeValue :: ValueType -> String
describeValue = \case
TInt -> "an integer"
TFloat -> "a float"
TBool -> "a boolean"
TNull -> "a null"
TString NoContext -> "a string"
TString HasContext -> "a string with context"
TList -> "a list"
TSet -> "an attr set"
TClosure -> "a function"
TPath -> "a path"
TBuiltin -> "a builtin function"
TInt -> "an integer"
TFloat -> "a float"
TBool -> "a boolean"
TNull -> "a null"
TString NoContext -> "a string"
TString HasContext -> "a string with context"
TList -> "a list"
TSet -> "an attr set"
TClosure -> "a function"
TPath -> "a path"
TBuiltin -> "a builtin function"
instance Eq1 (NValueF p m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x) (NVStrF y) = x == y
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
liftEq eq (NVSetF x _) (NVSetF y _) = liftEq eq x y
liftEq _ (NVPathF x) (NVPathF y) = x == y
liftEq _ _ _ = False
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x) (NVStrF y) = x == y
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y
liftEq _ (NVPathF x ) (NVPathF y ) = x == y
liftEq _ _ _ = False
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)
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
NVClosure c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
_ -> error "Pattern synonyms mask coverage"
liftShowsPrec sp sl p = \case
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
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
NVClosure c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
_ -> error "Pattern synonyms mask coverage"
data ValueFrame t f m
= ForcingThunk
@ -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 k = nValue.traverse._NVSetF._1.hashAt k
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')

22
src/Nix/Var.hs
View File

@ -10,19 +10,19 @@
module Nix.Var where
import Control.Monad.Ref
import Data.GADT.Compare
import Data.IORef
import Data.Maybe
import Data.STRef
import Control.Monad.Ref
import Data.GADT.Compare
import Data.IORef
import Data.Maybe
import Data.STRef
import Unsafe.Coerce
import Unsafe.Coerce
type Var m = Ref m
type MonadVar m = MonadAtomicRef m
eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
eqVar :: forall m a . GEq (Ref m) => Ref m a -> Ref m a -> Bool
eqVar a b = isJust $ geq a b
newVar :: MonadRef m => a -> m (Ref m a)
@ -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

77
src/Nix/XML.hs
View File

@ -5,63 +5,72 @@
module Nix.XML (toXML) where
import qualified Data.HashMap.Lazy as M
import qualified Data.HashMap.Lazy as M
import Data.List
import Data.Ord
import qualified Data.Text as Text
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Expr.Types
import Nix.String
import Nix.Value
import Text.XML.Light
toXML :: forall t f m. MonadDataContext f m => NValueNF t f m -> NixString
toXML = runWithStringContext
toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString
toXML =
runWithStringContext
. fmap pp
. iterNValueNF (const (pure (mkElem "cycle" "value" ""))) phi
where
pp = ("<?xml version='1.0' encoding='utf-8'?>\n" <>)
where
pp =
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
. (<> "\n")
. Text.pack
. ppElement
. (\e -> Element (unqual "expr") [] [Elem e] Nothing)
phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
phi = \case
NVConstant a -> case a of
NInt n -> return $ mkElem "int" "value" (show n)
NFloat f -> return $ mkElem "float" "value" (show f)
NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false")
NNull -> return $ Element (unqual "null") [] [] Nothing
phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
phi = \case
NVConstant a -> case a of
NInt n -> return $ mkElem "int" "value" (show n)
NFloat f -> return $ mkElem "float" "value" (show f)
NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false")
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
NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
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")
[Attr (unqual "name") (Text.unpack k)]
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList kvs)) Nothing
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
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"
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"
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
battr = [ Attr (unqual "ellipsis") "1" | b ]
nattr = maybe [] ((:[]) . Attr (unqual "name") . Text.unpack) mname
[Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing]
where
battr = [ Attr (unqual "ellipsis") "1" | b ]
nattr = maybe [] ((: []) . Attr (unqual "name") . Text.unpack) mname
paramSetXML :: ParamSet r -> [Content]
paramSetXML = map (\(k,_) -> Elem $ mkElem "attr" "name" (Text.unpack k))
paramSetXML = map (\(k, _) -> Elem $ mkElem "attr" "name" (Text.unpack k))

188
tests/NixLanguageTests.hs
View File

@ -4,19 +4,21 @@
module NixLanguageTests (genTests) where
import Control.Arrow ((&&&))
import Control.Arrow ( (&&&) )
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.ST
import Data.List (delete, sort)
import Data.List.Split (splitOn)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.List ( delete
, sort
)
import Data.List.Split ( splitOn )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Time
import GHC.Exts
import Nix.Lint
@ -27,10 +29,12 @@ import Nix.Pretty
import Nix.String
import Nix.Utils
import Nix.XML
import qualified Options.Applicative as Opts
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,103 +76,123 @@ 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)
<$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
. filter ((`Set.notMember` newFailingTests) . takeBaseName)
. filter ((/= ".xml") . takeExtension)
<$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
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
where
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
time <- liftIO getCurrentTime
let opts = defaultOptions time
case kind of
["parse", "okay"] -> assertParse opts $ the files
["parse", "fail"] -> assertParseFail opts $ the files
["eval", "okay"] -> assertEval opts files
["eval", "fail"] -> assertEvalFail $ the files
_ -> error $ "Unexpected: " ++ show kind
return $ localOption (mkTimeout 2000000) $ testGroup
"Nix (upstream) language tests"
testGroups
where
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
time <- liftIO getCurrentTime
let opts = defaultOptions time
case kind of
["parse", "okay"] -> assertParse opts $ the files
["parse", "fail"] -> assertParseFail opts $ the files
["eval" , "okay"] -> assertEval opts files
["eval" , "fail"] -> assertEvalFail $ the files
_ -> error $ "Unexpected: " ++ show kind
assertParse :: Options -> FilePath -> Assertion
assertParse _opts file = parseNixFileLoc file >>= \case
Success _expr -> return () -- pure $! runST $ void $ lint opts expr
Failure err ->
assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
Failure err ->
assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
assertParseFail :: Options -> FilePath -> Assertion
assertParseFail opts file = do
eres <- parseNixFileLoc file
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 ()
eres <- parseNixFileLoc file
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 ()
assertLangOk :: Options -> FilePath -> Assertion
assertLangOk opts file = do
actual <- printNix <$> hnixEvalFile opts (file ++ ".nix")
actual <- printNix <$> hnixEvalFile opts (file ++ ".nix")
expected <- Text.readFile $ file ++ ".exp"
assertEqual "" expected $ Text.pack (actual ++ "\n")
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
assertEval :: Options -> [FilePath] -> Assertion
assertEval _opts files = do
time <- liftIO getCurrentTime
let opts = defaultOptions time
case delete ".nix" $ sort $ map takeExtensions files of
[] -> () <$ hnixEvalFile opts (name ++ ".nix")
[".exp"] -> assertLangOk opts name
[".exp.xml"] -> assertLangOkXml opts name
[".exp.disabled"] -> return ()
[".exp-disabled"] -> return ()
[".exp", ".flags"] -> do
liftIO $ unsetEnv "NIX_PATH"
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: "
++ show err
Opts.Success opts' ->
assertLangOk
(opts' { include = include opts' ++
[ "nix=../../../../data/nix/corepkgs"
, "lang/dir4"
, "lang/dir5" ] })
name
Opts.CompletionInvoked _ -> error "unused"
_ -> assertFailure $ "Unknown test type " ++ show files
where
name = "data/nix/tests/lang/"
++ the (map (takeFileName . dropExtensions) files)
time <- liftIO getCurrentTime
let opts = defaultOptions time
case delete ".nix" $ sort $ map takeExtensions files of
[] -> () <$ hnixEvalFile opts (name ++ ".nix")
[".exp" ] -> assertLangOk opts name
[".exp.xml" ] -> assertLangOkXml opts name
[".exp.disabled"] -> return ()
[".exp-disabled"] -> return ()
[".exp", ".flags"] -> do
liftIO $ unsetEnv "NIX_PATH"
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: "
++ show err
Opts.Success opts' -> assertLangOk
(opts'
{ include = include opts'
++ [ "nix=../../../../data/nix/corepkgs"
, "lang/dir4"
, "lang/dir5"
]
}
)
name
Opts.CompletionInvoked _ -> error "unused"
_ -> assertFailure $ "Unknown test type " ++ show files
where
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
fixup (x:rest) = x:fixup rest
fixup [] = []
fixup ("--arg" : x : y : rest) = "--arg" : (x ++ "=" ++ y) : fixup rest
fixup ("--argstr" : x : y : rest) = "--argstr" : (x ++ "=" ++ y) : fixup rest
fixup (x : rest) = x : fixup rest
fixup [] = []
assertEvalFail :: FilePath -> Assertion
assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do
time <- liftIO getCurrentTime
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
++ "`."

245
tests/PrettyParseTests.hs
View File

@ -9,26 +9,31 @@
{-# OPTIONS -Wno-orphans#-}
module PrettyParseTests where
module PrettyParseTests where
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Char
import Data.Fix
import qualified Data.List.NonEmpty as NE
import Data.Text (Text, pack)
import qualified Data.List.NonEmpty as NE
import Data.Text ( Text
, pack
)
import Data.Text.Prettyprint.Doc
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Nix.Atoms
import Nix.Expr
import Nix.Parser
import Nix.Pretty
import Test.Tasty
import Test.Tasty.Hedgehog
import Text.Megaparsec (Pos, SourcePos, mkPos)
import qualified Text.Show.Pretty as PS
import Text.Megaparsec ( Pos
, SourcePos
, mkPos
)
import qualified Text.Show.Pretty as PS
asciiString :: MonadGen m => m String
asciiString = Gen.list (Range.linear 1 15) Gen.lower
@ -44,95 +49,90 @@ 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
<*> Gen.list (Range.linear 0 5) genKeyName
<*> genSourcePos
, Inherit
<$> Gen.maybe genExpr
<*> Gen.list (Range.linear 0 5) genKeyName
<*> genSourcePos
]
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)
<*> Gen.bool
<*> Gen.choice [pure Nothing, Just <$> asciiText]
[ Param <$> asciiText
, ParamSet
<$> Gen.list (Range.linear 0 10) ((,) <$> asciiText <*> Gen.maybe genExpr)
<*> Gen.bool
<*> Gen.choice [pure Nothing, Just <$> asciiText]
]
genAtom :: Gen NAtom
genAtom = Gen.choice
[ NInt <$> Gen.integral (Range.linear 0 1000)
[ NInt <$> Gen.integral (Range.linear 0 1000)
, NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0)
, NBool <$> Gen.bool
, pure NNull ]
, NBool <$> Gen.bool
, 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
[ ( 1, genConstant)
, ( 1, genSym)
, ( 4, Gen.resize (Size (n `div` 3)) genIf)
, (10, genRecSet )
, (20, genSet )
, ( 5, genList )
, ( 2, genUnary )
, ( 2, Gen.resize (Size (n `div` 3)) genBinary )
, ( 3, Gen.resize (Size (n `div` 3)) genSelect )
, (20, Gen.resize (Size (n `div` 2)) genAbs )
, ( 2, Gen.resize (Size (n `div` 2)) genHasAttr )
, (10, Gen.resize (Size (n `div` 2)) genLet )
, (10, Gen.resize (Size (n `div` 2)) genWith )
, ( 1, Gen.resize (Size (n `div` 2)) genAssert)
]
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)
, (10, genRecSet)
, (20, genSet)
, (5 , genList)
, (2 , genUnary)
, (2, Gen.resize (Size (n `div` 3)) genBinary)
, (3, Gen.resize (Size (n `div` 3)) genSelect)
, (20, Gen.resize (Size (n `div` 2)) genAbs)
, (2, Gen.resize (Size (n `div` 2)) genHasAttr)
, (10, Gen.resize (Size (n `div` 2)) genLet)
, (10, Gen.resize (Size (n `div` 2)) genWith)
, (1, Gen.resize (Size (n `div` 2)) genAssert)
]
where
genConstant = NConstant <$> genAtom
genStr = NStr <$> genString
genSym = NSym <$> asciiText
genList = NList <$> fairList genExpr
genSet = NSet <$> fairList genBinding
genRecSet = NRecSet <$> fairList genBinding
genConstant = NConstant <$> genAtom
genStr = NStr <$> genString
genSym = NSym <$> asciiText
genList = NList <$> fairList genExpr
genSet = NSet <$> fairList genBinding
genRecSet = NRecSet <$> fairList genBinding
genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
genEnvPath = NEnvPath <$> asciiString
genUnary = NUnary <$> Gen.enumBounded <*> genExpr
genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr
genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr
genHasAttr = NHasAttr <$> genExpr <*> genAttrPath
genAbs = NAbs <$> genParams <*> genExpr
genLet = NLet <$> fairList genBinding <*> genExpr
genIf = NIf <$> genExpr <*> genExpr <*> genExpr
genWith = NWith <$> genExpr <*> genExpr
genAssert = NAssert <$> genExpr <*> genExpr
genEnvPath = NEnvPath <$> asciiString
genUnary = NUnary <$> Gen.enumBounded <*> genExpr
genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr
genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr
genHasAttr = NHasAttr <$> genExpr <*> genAttrPath
genAbs = NAbs <$> genParams <*> genExpr
genLet = NLet <$> fairList genBinding <*> genExpr
genIf = NIf <$> genExpr <*> genExpr <*> genExpr
genWith = NWith <$> genExpr <*> genExpr
genAssert = NAssert <$> genExpr <*> genExpr
-- | Useful when there are recursive positions at each element of the list as
-- it divides the size by the length of the generated list.
@ -147,42 +147,43 @@ 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))
NLet binds r -> Fix (NLet (map normBinding binds) r)
NSet binds -> Fix (NSet (map normBinding binds))
NRecSet binds -> Fix (NRecSet (map normBinding binds))
NLet binds r -> Fix (NLet (map normBinding binds) r)
NAbs params r -> Fix (NAbs (normParams params) r)
NAbs params r -> Fix (NAbs (normParams params) r)
r -> Fix r
r -> Fix r
where
normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos
normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos
normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos
normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos
normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted)
normKey (StaticKey name) = StaticKey name
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'
then Plain (DoubleQuoted strs)
else normAntiquotedString (Plain (DoubleQuoted strs'))
let strs' = map normAntiquotedText strs
in if strs == strs'
then Plain (DoubleQuoted strs)
else normAntiquotedString (Plain (DoubleQuoted strs'))
normAntiquotedString r = r
normAntiquotedText :: Antiquoted Text NExpr -> Antiquoted Text NExpr
normAntiquotedText (Plain "\n") = EscapedNewline
normAntiquotedText (Plain "\n" ) = EscapedNewline
normAntiquotedText (Plain "''\n") = EscapedNewline
normAntiquotedText r = r
normAntiquotedText r = r
normParams (ParamSet binds var (Just "")) = ParamSet binds var Nothing
normParams r = r
normParams r = r
-- | Test that parse . pretty == id up to attribute position information.
prop_prettyparse :: Monad m => NExpr -> PropertyT m ()
@ -190,43 +191,43 @@ prop_prettyparse p = do
let prog = show (prettyNix p)
case parse (pack prog) of
Failure s -> do
footnote $ show $ vsep
[ fillSep ["Parse failed:", pretty (show s)]
, indent 2 (prettyNix p)
]
discard
footnote $ show $ vsep
[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 $
[ "----------------------------------------"
, vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))]
, "----------------------------------------"
, vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))]
, "----------------------------------------"
, vsep ["Pretty before:", indent 2 (pretty prog)]
, "----------------------------------------"
, vsep ["Pretty after:", indent 2 (prettyNix v)]
, "----------------------------------------"
, vsep ["Normalised before:", indent 2 (pretty pp)]
, "----------------------------------------"
, vsep ["Normalised after:", indent 2 (pretty pv)]
, "========================================"
, vsep ["Normalised diff:", pretty (ppDiff (diff pp pv))]
, "========================================"
]
assert (pp == pv)
where
parse = parseNixText
| equivUpToNormalization p v -> success
| otherwise -> do
let pp = normalise prog
pv = normalise (show (prettyNix v))
footnote
$ show
$ vsep
$ [ "----------------------------------------"
, vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))]
, "----------------------------------------"
, vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))]
, "----------------------------------------"
, vsep ["Pretty before:", indent 2 (pretty prog)]
, "----------------------------------------"
, vsep ["Pretty after:", indent 2 (prettyNix v)]
, "----------------------------------------"
, vsep ["Normalised before:", indent 2 (pretty pp)]
, "----------------------------------------"
, vsep ["Normalised after:", indent 2 (pretty pv)]
, "========================================"
, vsep ["Normalised diff:", pretty (ppDiff (diff pp pv))]
, "========================================"
]
assert (pp == pv)
where
parse = parseNixText
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (: []) (lines s1)) (map (: []) (lines s2))
tests :: TestLimit -> TestTree
tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do
x <- forAll genExpr
prop_prettyparse x
x <- forAll genExpr
prop_prettyparse x

29
tests/PrettyTests.hs
View File

@ -2,36 +2,37 @@
{-# LANGUAGE OverloadedStrings #-}
module PrettyTests (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.TH
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.TH
import Nix.Expr
import Nix.Pretty
import Nix.Expr
import Nix.Pretty
case_indented_antiquotation :: Assertion
case_indented_antiquotation = do
assertPretty (mkIndentedStr 0 "echo $foo") "''echo $foo''"
assertPretty (mkIndentedStr 0 "echo ${foo}") "''echo ''${foo}''"
assertPretty (mkIndentedStr 0 "echo $foo") "''echo $foo''"
assertPretty (mkIndentedStr 0 "echo ${foo}") "''echo ''${foo}''"
case_string_antiquotation :: Assertion
case_string_antiquotation = do
assertPretty (mkStr "echo $foo") "\"echo \\$foo\""
assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\""
assertPretty (mkStr "echo $foo") "\"echo \\$foo\""
assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\""
case_function_params :: Assertion
case_function_params =
assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3"
assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3"
case_paths :: Assertion
case_paths = do
assertPretty (mkPath False "~/test.nix") "~/test.nix"
assertPretty (mkPath False "/test.nix") "/test.nix"
assertPretty (mkPath False "./test.nix") "./test.nix"
assertPretty (mkPath False "~/test.nix") "~/test.nix"
assertPretty (mkPath False "/test.nix") "/test.nix"
assertPretty (mkPath False "./test.nix") "./test.nix"
tests :: TestTree
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

51
tests/ReduceExprTests.hs
View File

@ -1,44 +1,45 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module ReduceExprTests (tests) where
import Data.Fix
import Test.Tasty
import Test.Tasty.HUnit
import Data.Fix
import Test.Tasty
import Test.Tasty.HUnit
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Parser
import Nix.Reduce (reduceExpr)
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Parser
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
assertSucc (Success a) = pure a
assertSucc (Failure d) = assertFailure $ show d
cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion
cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion
cmpReduceResult r e = do
r <- assertSucc r
r <- stripAnnotation <$> reduceExpr Nothing r
r @?= e
r <- assertSucc r
r <- stripAnnotation <$> reduceExpr Nothing r
r @?= e
shouldntReduce :: Result NExprLoc -> Assertion
shouldntReduce r = do
r <- assertSucc r
rReduced <- reduceExpr Nothing r
r @?= rReduced
r <- assertSucc r
rReduced <- reduceExpr Nothing r
r @?= rReduced
selectBasic :: Result NExprLoc
selectBasic = parseNixTextLoc "{b=2;a=42;}.a"

77
tests/TestCommon.hs
View File

@ -4,46 +4,52 @@
module TestCommon where
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Text (Text, unpack)
import Data.Time
import Nix
import Nix.Thunk.Standard
import System.Environment
import System.IO
import System.Posix.Files
import System.Posix.Temp
import System.Process
import Test.Tasty.HUnit
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Text ( Text
, unpack
)
import Data.Time
import Nix
import Nix.Thunk.Standard
import System.Environment
import System.IO
import System.Posix.Files
import System.Posix.Temp
import System.Process
import Test.Tasty.HUnit
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF IO)
hnixEvalFile opts file = do
parseResult <- parseNixFileLoc file
case parseResult of
Failure err ->
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
Failure err ->
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
NixException frames ->
errorWithoutStackTrace . show
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
setEnv "TEST_VAR" "foo"
runStdLazyM opts
$ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr)
$ \case
NixException frames ->
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
Success expr ->
-- runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
Failure 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
nixEvalString :: String -> IO String
nixEvalString expr = do
(fp,h) <- mkstemp "nix-test-eval"
(fp, h) <- mkstemp "nix-test-eval"
hPutStr h expr
hClose h
res <- nixEvalFile fp
@ -55,16 +61,15 @@ nixEvalFile fp = readProcess "nix-instantiate" ["--eval", "--strict", fp] ""
assertEvalFileMatchesNix :: FilePath -> Assertion
assertEvalFileMatchesNix fp = do
time <- liftIO getCurrentTime
hnixVal <- (++"\n") . printNix <$> hnixEvalFile (defaultOptions time) fp
nixVal <- nixEvalFile fp
time <- liftIO getCurrentTime
hnixVal <- (++ "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp
nixVal <- nixEvalFile fp
assertEqual fp nixVal hnixVal
assertEvalMatchesNix :: Text -> Assertion
assertEvalMatchesNix expr = do
time <- liftIO getCurrentTime
hnixVal <- (++"\n") . printNix <$> hnixEvalText (defaultOptions time) expr
nixVal <- nixEvalString expr'
time <- liftIO getCurrentTime
hnixVal <- (++ "\n") . printNix <$> hnixEvalText (defaultOptions time) expr
nixVal <- nixEvalString expr'
assertEqual expr' nixVal hnixVal
where
expr' = unpack expr
where expr' = unpack expr