Reformat all sources with Brittany, to restore consistency
This commit is contained in:
parent
8cfb965e99
commit
94e0be3882
|
@ -5,6 +5,4 @@ import Criterion.Main
|
|||
import qualified ParserBench
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ ParserBench.benchmarks
|
||||
]
|
||||
main = defaultMain [ParserBench.benchmarks]
|
||||
|
|
|
@ -9,7 +9,8 @@ benchFile :: FilePath -> Benchmark
|
|||
benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++)
|
||||
|
||||
benchmarks :: Benchmark
|
||||
benchmarks = bgroup "Parser"
|
||||
benchmarks = bgroup
|
||||
"Parser"
|
||||
[ benchFile "nixpkgs-all-packages.nix"
|
||||
, benchFile "nixpkgs-all-packages-pretty.nix"
|
||||
, benchFile "let-comments.nix"
|
||||
|
|
177
main/Main.hs
177
main/Main.hs
|
@ -17,8 +17,8 @@ import Control.Monad.IO.Class
|
|||
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.List ( sortOn )
|
||||
import Data.Maybe ( fromJust )
|
||||
import Data.Time
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
|
@ -38,7 +38,7 @@ 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
|
||||
|
@ -55,19 +55,16 @@ main = do
|
|||
Nothing -> case expression opts of
|
||||
Just s -> handleResult opts Nothing (parseNixTextLoc s)
|
||||
Nothing -> case fromFile opts of
|
||||
Just "-" ->
|
||||
mapM_ (processFile opts)
|
||||
=<< (lines <$> liftIO getContents)
|
||||
Just "-" -> mapM_ (processFile opts) =<< (lines <$> liftIO getContents)
|
||||
Just path ->
|
||||
mapM_ (processFile opts)
|
||||
=<< (lines <$> liftIO (readFile path))
|
||||
mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path))
|
||||
Nothing -> case filePaths opts of
|
||||
[] -> withNixContext Nothing $ Repl.main
|
||||
["-"] ->
|
||||
handleResult opts Nothing . parseNixTextLoc
|
||||
handleResult opts Nothing
|
||||
. parseNixTextLoc
|
||||
=<< liftIO Text.getContents
|
||||
paths ->
|
||||
mapM_ (processFile opts) paths
|
||||
paths -> mapM_ (processFile opts) paths
|
||||
where
|
||||
processFile opts path = do
|
||||
eres <- parseNixFileLoc path
|
||||
|
@ -77,90 +74,88 @@ main = do
|
|||
Failure err ->
|
||||
(if ignoreErrors opts
|
||||
then liftIO . hPutStrLn stderr
|
||||
else errorWithoutStackTrace) $ "Parse failed: " ++ show err
|
||||
else errorWithoutStackTrace
|
||||
)
|
||||
$ "Parse failed: "
|
||||
++ show err
|
||||
|
||||
Success expr -> do
|
||||
when (check opts) $ do
|
||||
expr' <- liftIO (reduceExpr mpath expr)
|
||||
case HM.inferTop Env.empty [("it", stripAnnotation expr')] of
|
||||
Left err ->
|
||||
errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
|
||||
Right ty ->
|
||||
liftIO $ putStrLn $ "Type of expression: "
|
||||
++ PS.ppShow (fromJust (Map.lookup "it" (Env.types ty)))
|
||||
Left err -> errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
|
||||
Right ty -> liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow
|
||||
(fromJust (Map.lookup "it" (Env.types ty)))
|
||||
|
||||
-- liftIO $ putStrLn $ runST $
|
||||
-- runLintM opts . renderSymbolic =<< lint opts expr
|
||||
|
||||
catch (process opts mpath expr) $ \case
|
||||
NixException frames ->
|
||||
errorWithoutStackTrace . show
|
||||
errorWithoutStackTrace
|
||||
. show
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
|
||||
when (repl opts) $
|
||||
withNixContext Nothing $ Repl.main
|
||||
when (repl opts) $ withNixContext Nothing $ Repl.main
|
||||
|
||||
process opts mpath expr
|
||||
| evaluate opts, tracing opts =
|
||||
evaluateExpression mpath
|
||||
Nix.nixTracingEvalExprLoc printer expr
|
||||
|
||||
| evaluate opts, Just path <- reduce opts =
|
||||
evaluateExpression mpath (reduction path) printer expr
|
||||
|
||||
| evaluate opts, not (null (arg opts) && null (argstr opts)) =
|
||||
evaluateExpression mpath
|
||||
Nix.nixEvalExprLoc printer expr
|
||||
|
||||
| evaluate opts =
|
||||
processResult printer =<< Nix.nixEvalExprLoc mpath expr
|
||||
|
||||
| xml opts =
|
||||
error "Rendering expression trees to XML is not yet implemented"
|
||||
|
||||
| json opts =
|
||||
liftIO $ TL.putStrLn $
|
||||
A.encodeToLazyText (stripAnnotation expr)
|
||||
|
||||
| verbose opts >= DebugInfo =
|
||||
liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
|
||||
|
||||
| cache opts, Just path <- mpath =
|
||||
liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
|
||||
|
||||
| parseOnly opts =
|
||||
void $ liftIO $ Exc.evaluate $ Deep.force expr
|
||||
|
||||
| otherwise =
|
||||
liftIO $ renderIO stdout
|
||||
| evaluate opts
|
||||
, tracing opts
|
||||
= evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr
|
||||
| evaluate opts
|
||||
, Just path <- reduce opts
|
||||
= evaluateExpression mpath (reduction path) printer expr
|
||||
| evaluate opts
|
||||
, not (null (arg opts) && null (argstr opts))
|
||||
= evaluateExpression mpath Nix.nixEvalExprLoc printer expr
|
||||
| evaluate opts
|
||||
= processResult printer =<< Nix.nixEvalExprLoc mpath expr
|
||||
| xml opts
|
||||
= error "Rendering expression trees to XML is not yet implemented"
|
||||
| json opts
|
||||
= liftIO $ TL.putStrLn $ A.encodeToLazyText (stripAnnotation expr)
|
||||
| verbose opts >= DebugInfo
|
||||
= liftIO $ putStr $ PS.ppShow $ stripAnnotation expr
|
||||
| cache opts
|
||||
, Just path <- mpath
|
||||
= liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr
|
||||
| parseOnly opts
|
||||
= void $ liftIO $ Exc.evaluate $ Deep.force expr
|
||||
| otherwise
|
||||
= liftIO
|
||||
$ renderIO stdout
|
||||
. layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4)
|
||||
. prettyNix
|
||||
. stripAnnotation $ expr
|
||||
. stripAnnotation
|
||||
$ expr
|
||||
where
|
||||
printer
|
||||
| finder opts =
|
||||
fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
|
||||
| xml opts =
|
||||
liftIO . putStrLn
|
||||
| finder opts
|
||||
= fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
|
||||
| xml opts
|
||||
= liftIO
|
||||
. putStrLn
|
||||
. Text.unpack
|
||||
. principledStringIgnoreContext
|
||||
. toXML
|
||||
<=< normalForm
|
||||
| json opts =
|
||||
liftIO . Text.putStrLn
|
||||
| json opts
|
||||
= liftIO
|
||||
. Text.putStrLn
|
||||
. principledStringIgnoreContext
|
||||
<=< nvalueToJSONNixString
|
||||
| strict opts =
|
||||
liftIO . print . prettyNValueNF <=< normalForm
|
||||
| values opts =
|
||||
liftIO . print <=< prettyNValueProv
|
||||
| otherwise =
|
||||
liftIO . print <=< prettyNValue
|
||||
| strict opts
|
||||
= liftIO . print . prettyNValueNF <=< normalForm
|
||||
| values opts
|
||||
= liftIO . print <=< prettyNValueProv
|
||||
| otherwise
|
||||
= liftIO . print <=< prettyNValue
|
||||
where
|
||||
findAttrs = go ""
|
||||
where
|
||||
go prefix s = do
|
||||
xs <- forM (sortOn fst (M.toList s))
|
||||
xs <-
|
||||
forM (sortOn fst (M.toList s))
|
||||
$ \(k, nv@(StdThunk (StdCited (NCited _ t)))) -> case t of
|
||||
Value v -> pure (k, Just v)
|
||||
Thunk _ _ ref -> do
|
||||
|
@ -169,7 +164,7 @@ main = do
|
|||
val <- readVar @(StdLazy IO) ref
|
||||
case val of
|
||||
Computed _ -> pure (k, Nothing)
|
||||
_ | descend -> (k,) <$> forceEntry path nv
|
||||
_ | descend -> (k, ) <$> forceEntry path nv
|
||||
| otherwise -> pure (k, Nothing)
|
||||
|
||||
forM_ xs $ \(k, mv) -> do
|
||||
|
@ -180,42 +175,44 @@ main = do
|
|||
when descend $ case mv of
|
||||
Nothing -> return ()
|
||||
Just v -> case v of
|
||||
NVSet s' _ ->
|
||||
go (path ++ ".") s'
|
||||
NVSet s' _ -> go (path ++ ".") s'
|
||||
_ -> return ()
|
||||
where
|
||||
filterEntry path k = case (path, k) of
|
||||
("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)
|
||||
("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
|
||||
forceEntry k v =
|
||||
catch (Just <$> force v pure) $ \(NixException frames) -> do
|
||||
liftIO
|
||||
. putStrLn
|
||||
. ("Exception forcing " ++)
|
||||
. (k ++)
|
||||
. (": " ++) . show
|
||||
. (": " ++)
|
||||
. show
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
return Nothing
|
||||
|
||||
reduction path mp x = do
|
||||
eres <- Nix.withNixContext mp $
|
||||
Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
|
||||
eres <- Nix.withNixContext mp
|
||||
$ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
|
||||
handleReduced path eres
|
||||
|
||||
handleReduced :: (MonadThrow m, MonadIO m)
|
||||
handleReduced
|
||||
:: (MonadThrow m, MonadIO m)
|
||||
=> FilePath
|
||||
-> (NExprLoc, Either SomeException (NValue t f m))
|
||||
-> m (NValue t f m)
|
||||
|
|
108
main/Repl.hs
108
main/Repl.hs
|
@ -22,8 +22,10 @@
|
|||
|
||||
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
|
||||
|
@ -34,14 +36,18 @@ import Nix.Utils
|
|||
|
||||
import Control.Comonad
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List (isPrefixOf, foldl')
|
||||
import Data.List ( isPrefixOf
|
||||
, foldl'
|
||||
)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid
|
||||
import Data.Text (unpack, pack)
|
||||
import Data.Text ( unpack
|
||||
, pack
|
||||
)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import Data.Version (showVersion)
|
||||
import Paths_hnix (version)
|
||||
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"
|
||||
welcomeText =
|
||||
liftIO
|
||||
$ putStrLn
|
||||
$ "Welcome to hnix "
|
||||
<> showVersion version
|
||||
<> ". For help type :help\n"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
|
@ -87,8 +98,12 @@ hoistErr (Failure err) = do
|
|||
-- Execution
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
exec :: forall e t f m. (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> Bool -> Text.Text -> Repl e t f m (NValue t f m)
|
||||
exec
|
||||
:: forall e t f m
|
||||
. (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> Bool
|
||||
-> Text.Text
|
||||
-> Repl e t f m (NValue t f m)
|
||||
exec update source = do
|
||||
-- Get the current interpreter state
|
||||
st <- get
|
||||
|
@ -105,29 +120,28 @@ exec update source = do
|
|||
|
||||
case mVal of
|
||||
Left (NixException frames) -> do
|
||||
lift $ lift $ liftIO . print
|
||||
=<< renderFrames @(NValue t f m) @t frames
|
||||
lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames
|
||||
abort
|
||||
Right val -> do
|
||||
-- Update the interpreter state
|
||||
when update $ do
|
||||
-- Create the new environment
|
||||
put st { tmctx = tmctx st -- TODO: M.insert key val (tmctx st)
|
||||
}
|
||||
put st { tmctx = tmctx st } -- TODO: M.insert key val (tmctx st)
|
||||
return val
|
||||
|
||||
|
||||
cmd :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => String -> Repl e t f m ()
|
||||
cmd
|
||||
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> String
|
||||
-> Repl e t f m ()
|
||||
cmd source = do
|
||||
val <- exec True (Text.pack source)
|
||||
lift $ lift $ do
|
||||
opts :: Nix.Options <- asks (view hasLens)
|
||||
if | strict opts ->
|
||||
liftIO . print . prettyNValueNF =<< normalForm val
|
||||
| values opts ->
|
||||
liftIO . print =<< prettyNValueProv val
|
||||
| otherwise ->
|
||||
liftIO . print =<< prettyNValue val
|
||||
if
|
||||
| strict opts -> liftIO . print . prettyNValueNF =<< normalForm val
|
||||
| values opts -> liftIO . print =<< prettyNValueProv val
|
||||
| otherwise -> liftIO . print =<< prettyNValue val
|
||||
-------------------------------------------------------------------------------
|
||||
-- Commands
|
||||
-------------------------------------------------------------------------------
|
||||
|
@ -140,21 +154,26 @@ browse _ = do
|
|||
-- liftIO $ mapM_ putStrLn $ ppenv (tyctx st)
|
||||
|
||||
-- :load command
|
||||
load :: (MonadBuiltins e t f m, MonadIO m, MonadException m) => [String] -> Repl e t f m ()
|
||||
load
|
||||
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> [String]
|
||||
-> Repl e t f m ()
|
||||
load args = do
|
||||
contents <- liftIO $ Text.readFile (unwords args)
|
||||
void $ exec True contents
|
||||
|
||||
-- :type command
|
||||
typeof :: (MonadBuiltins e t f m, MonadException m, MonadIO m) => [String] -> Repl e t f m ()
|
||||
typeof
|
||||
:: (MonadBuiltins e t f m, MonadException m, MonadIO m)
|
||||
=> [String]
|
||||
-> Repl e t f m ()
|
||||
typeof args = do
|
||||
st <- get
|
||||
val <- case M.lookup line (tmctx st) of
|
||||
Just val -> return val
|
||||
Nothing -> exec False line
|
||||
liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val
|
||||
where
|
||||
line = Text.pack (unwords args)
|
||||
where line = Text.pack (unwords args)
|
||||
|
||||
-- :quit command
|
||||
quit :: (MonadBuiltins e t f m, MonadIO m) => a -> Repl e t f m ()
|
||||
|
@ -166,8 +185,8 @@ quit _ = liftIO exitSuccess
|
|||
|
||||
-- Prefix tab completer
|
||||
defaultMatcher :: MonadIO m => [(String, CompletionFunc m)]
|
||||
defaultMatcher = [
|
||||
(":load" , fileCompleter)
|
||||
defaultMatcher =
|
||||
[(":load", fileCompleter)
|
||||
--, (":type" , values)
|
||||
]
|
||||
|
||||
|
@ -177,24 +196,35 @@ comp n = do
|
|||
let cmds = [":load", ":type", ":browse", ":quit"]
|
||||
-- Env.TypeEnv ctx <- gets tyctx
|
||||
-- let defs = map unpack $ Map.keys ctx
|
||||
return $ filter (isPrefixOf n) (cmds {-++ defs-})
|
||||
return $ filter (isPrefixOf n) (cmds {-++ defs-}
|
||||
)
|
||||
|
||||
options :: (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
options
|
||||
:: (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> [(String, [String] -> Repl e t f m ())]
|
||||
options = [
|
||||
("load" , load)
|
||||
options =
|
||||
[ ( "load"
|
||||
, load
|
||||
)
|
||||
--, ("browse" , browse)
|
||||
, ("quit" , quit)
|
||||
, ("type" , typeof)
|
||||
, ("help" , help)
|
||||
, ("quit", quit)
|
||||
, ("type", typeof)
|
||||
, ("help", help)
|
||||
]
|
||||
|
||||
help :: forall e t f m . (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> [String] -> Repl e t f m ()
|
||||
help
|
||||
:: forall e t f m
|
||||
. (MonadBuiltins e t f m, MonadIO m, MonadException m)
|
||||
=> [String]
|
||||
-> Repl e t f m ()
|
||||
help _ = liftIO $ do
|
||||
putStrLn "Available commands:\n"
|
||||
mapM_ putStrLn $ map (\o -> ":" ++ (fst o)) (options @e @t @f @m)
|
||||
|
||||
completer :: (MonadBuiltins e t f m, MonadIO m)
|
||||
completer
|
||||
:: (MonadBuiltins e t f m, MonadIO m)
|
||||
=> CompleterStyle (StateT (IState t f m) m)
|
||||
completer = Prefix (wordCompleter comp) defaultMatcher
|
||||
|
||||
|
||||
|
||||
|
|
121
src/Nix.hs
121
src/Nix.hs
|
@ -4,26 +4,32 @@
|
|||
{-# 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
|
||||
|
@ -50,20 +56,33 @@ import Nix.XML
|
|||
-- | This is the entry point for all evaluations, whatever the expression tree
|
||||
-- type. It sets up the common Nix environment and applies the
|
||||
-- transformations, allowing them to be easily composed.
|
||||
nixEval :: (MonadBuiltins e t f m, Has e Options, Functor g)
|
||||
=> Maybe FilePath -> Transform g (m a) -> Alg g (m a) -> Fix g -> m a
|
||||
nixEval
|
||||
:: (MonadBuiltins e t f m, Has e Options, Functor g)
|
||||
=> Maybe FilePath
|
||||
-> Transform g (m a)
|
||||
-> Alg g (m a)
|
||||
-> Fix g
|
||||
-> m a
|
||||
nixEval mpath xform alg = withNixContext mpath . adi alg xform
|
||||
|
||||
-- | Evaluate a nix expression in the default context
|
||||
nixEvalExpr :: (MonadBuiltins e t f m, Has e Options)
|
||||
=> Maybe FilePath -> NExpr -> m (NValue t f m)
|
||||
nixEvalExpr
|
||||
:: (MonadBuiltins e t f m, Has e Options)
|
||||
=> Maybe FilePath
|
||||
-> NExpr
|
||||
-> m (NValue t f m)
|
||||
nixEvalExpr mpath = nixEval mpath id Eval.eval
|
||||
|
||||
-- | Evaluate a nix expression in the default context
|
||||
nixEvalExprLoc :: forall e t f m. (MonadBuiltins e t f m, Has e Options)
|
||||
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
|
||||
nixEvalExprLoc mpath =
|
||||
nixEval mpath (Eval.addStackFrames @t . Eval.addSourcePositions)
|
||||
nixEvalExprLoc
|
||||
:: forall e t f m
|
||||
. (MonadBuiltins e t f m, Has e Options)
|
||||
=> Maybe FilePath
|
||||
-> NExprLoc
|
||||
-> m (NValue t f m)
|
||||
nixEvalExprLoc mpath = nixEval
|
||||
mpath
|
||||
(Eval.addStackFrames @t . Eval.addSourcePositions)
|
||||
(Eval.eval . annotated . getCompose)
|
||||
|
||||
-- | Evaluate a nix expression with tracing in the default context. Note that
|
||||
|
@ -73,7 +92,9 @@ nixEvalExprLoc mpath =
|
|||
-- context.
|
||||
nixTracingEvalExprLoc
|
||||
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m)
|
||||
=> Maybe FilePath -> NExprLoc -> m (NValue t f m)
|
||||
=> Maybe FilePath
|
||||
-> NExprLoc
|
||||
-> m (NValue t f m)
|
||||
nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
|
||||
|
||||
evaluateExpression
|
||||
|
@ -85,9 +106,9 @@ evaluateExpression
|
|||
-> m a
|
||||
evaluateExpression mpath evaluator handler expr = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
args <- traverse (traverse eval') $
|
||||
map (second parseArg) (arg opts) ++
|
||||
map (second mkStr) (argstr opts)
|
||||
args <- traverse (traverse eval') $ map (second parseArg) (arg opts) ++ map
|
||||
(second mkStr)
|
||||
(argstr opts)
|
||||
compute evaluator expr (argmap args) handler
|
||||
where
|
||||
parseArg s = case parseNixText s of
|
||||
|
@ -97,8 +118,7 @@ evaluateExpression mpath evaluator handler expr = do
|
|||
eval' = (normalForm =<<) . nixEvalExpr mpath
|
||||
|
||||
argmap args = pure $ nvSet (M.fromList args') mempty
|
||||
where
|
||||
args' = map (fmap (wrapValue . nValueFromNF)) args
|
||||
where args' = map (fmap (wrapValue . nValueFromNF)) args
|
||||
|
||||
compute ev x args p = do
|
||||
f :: NValue t f m <- ev mpath x
|
||||
|
@ -106,8 +126,12 @@ evaluateExpression mpath evaluator handler expr = do
|
|||
NVClosure _ g -> force ?? pure =<< g args
|
||||
_ -> pure f
|
||||
|
||||
processResult :: forall e t f m a. (MonadNix e t f m, Has e Options)
|
||||
=> (NValue t f m -> m a) -> NValue t f m -> m a
|
||||
processResult
|
||||
:: forall e t f m a
|
||||
. (MonadNix e t f m, Has e Options)
|
||||
=> (NValue t f m -> m a)
|
||||
-> NValue t f m
|
||||
-> m a
|
||||
processResult h val = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
case attr opts of
|
||||
|
@ -116,22 +140,29 @@ processResult h val = do
|
|||
where
|
||||
go :: [Text.Text] -> NValue t f m -> m a
|
||||
go [] v = h v
|
||||
go ((Text.decimal -> Right (n,"")):ks) v = case v of
|
||||
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
|
||||
_ ->
|
||||
errorWithoutStackTrace
|
||||
$ "Expected a list for selector '"
|
||||
++ show n
|
||||
++ "', but got: "
|
||||
++ show v
|
||||
go (k : ks) v = case v of
|
||||
NVSet xs _ -> case M.lookup k xs of
|
||||
Nothing ->
|
||||
errorWithoutStackTrace $
|
||||
"Set does not contain key '"
|
||||
++ Text.unpack k ++ "'"
|
||||
errorWithoutStackTrace
|
||||
$ "Set does not contain key '"
|
||||
++ Text.unpack k
|
||||
++ "'"
|
||||
Just v' -> case ks of
|
||||
[] -> force v' h
|
||||
_ -> force v' (go ks)
|
||||
_ -> errorWithoutStackTrace $
|
||||
"Expected a set for selector '" ++ Text.unpack k
|
||||
++ "', but got: " ++ show v
|
||||
_ ->
|
||||
errorWithoutStackTrace
|
||||
$ "Expected a set for selector '"
|
||||
++ Text.unpack k
|
||||
++ "', but got: "
|
||||
++ show v
|
||||
|
|
|
@ -12,7 +12,9 @@ import Codec.Serialise
|
|||
import Control.DeepSeq
|
||||
import Data.Data
|
||||
import Data.Hashable
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text ( Text
|
||||
, pack
|
||||
)
|
||||
import GHC.Generics
|
||||
|
||||
-- | Atoms are values that evaluate to themselves. This means that
|
||||
|
@ -41,3 +43,11 @@ atomText (NInt i) = pack (show i)
|
|||
atomText (NFloat f) = pack (show f)
|
||||
atomText (NBool b) = if b then "true" else "false"
|
||||
atomText NNull = "null"
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
1067
src/Nix/Builtins.hs
1067
src/Nix/Builtins.hs
File diff suppressed because it is too large
Load Diff
|
@ -14,7 +14,7 @@ module Nix.Cited where
|
|||
|
||||
import Control.Comonad
|
||||
import Control.Comonad.Env
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Typeable ( Typeable )
|
||||
import GHC.Generics
|
||||
import Lens.Family2.TH
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -8,7 +8,9 @@ import Nix.Options
|
|||
import Nix.Scope
|
||||
import Nix.Frames
|
||||
import Nix.Utils
|
||||
import Nix.Expr.Types.Annotated (SrcSpan, nullSpan)
|
||||
import Nix.Expr.Types.Annotated ( SrcSpan
|
||||
, nullSpan
|
||||
)
|
||||
|
||||
data Context m t = Context
|
||||
{ scopes :: Scopes m t
|
||||
|
|
|
@ -29,11 +29,13 @@ module Nix.Convert where
|
|||
|
||||
import Control.Monad
|
||||
import Data.ByteString
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.HashMap.Lazy ( HashMap )
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
import Data.Text.Encoding ( encodeUtf8
|
||||
, decodeUtf8
|
||||
)
|
||||
import Nix.Atoms
|
||||
import Nix.Effects
|
||||
import Nix.Expr.Types
|
||||
|
@ -60,8 +62,8 @@ class FromValue a m v where
|
|||
fromValue :: v -> m a
|
||||
fromValueMay :: v -> m (Maybe a)
|
||||
|
||||
type Convertible e t f m =
|
||||
(Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
|
||||
type Convertible e t f m
|
||||
= (Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m)
|
||||
|
||||
instance Convertible e t f m => FromValue () m (NValueNF t f m) where
|
||||
fromValueMay = \case
|
||||
|
@ -150,8 +152,11 @@ instance (Convertible e t f m, MonadEffects t f m)
|
|||
fromValueMay = \case
|
||||
NVStrNF ns -> pure $ Just ns
|
||||
NVPathNF p ->
|
||||
Just . hackyMakeNixStringWithoutContext
|
||||
. Text.pack . unStorePath <$> addPath p
|
||||
Just
|
||||
. hackyMakeNixStringWithoutContext
|
||||
. Text.pack
|
||||
. unStorePath
|
||||
<$> addPath p
|
||||
NVSetNF s _ -> case M.lookup "outPath" s of
|
||||
Nothing -> pure Nothing
|
||||
Just p -> fromValueMay p
|
||||
|
@ -165,8 +170,11 @@ instance (Convertible e t f m, MonadEffects t f m, FromValue NixString m t)
|
|||
fromValueMay = \case
|
||||
NVStr ns -> pure $ Just ns
|
||||
NVPath p ->
|
||||
Just . hackyMakeNixStringWithoutContext
|
||||
. Text.pack . unStorePath <$> addPath p
|
||||
Just
|
||||
. hackyMakeNixStringWithoutContext
|
||||
. Text.pack
|
||||
. unStorePath
|
||||
<$> addPath p
|
||||
NVSet s _ -> case M.lookup "outPath" s of
|
||||
Nothing -> pure Nothing
|
||||
Just p -> fromValueMay p
|
||||
|
@ -344,8 +352,9 @@ instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where
|
|||
c' <- toValue (unPos c)
|
||||
let pos = M.fromList
|
||||
[ ("file" :: Text, wrapValue f')
|
||||
, ("line", wrapValue l')
|
||||
, ("column", wrapValue c') ]
|
||||
, ("line" , wrapValue l')
|
||||
, ("column" , wrapValue c')
|
||||
]
|
||||
pure $ nvSet pos mempty
|
||||
|
||||
instance (Convertible e t f m, ToValue a m (NValueNF t f m))
|
||||
|
@ -376,8 +385,8 @@ instance Convertible e t f m => ToValue Bool m (NExprF r) where
|
|||
instance Convertible e t f m => ToValue () m (NExprF r) where
|
||||
toValue _ = pure . NConstant $ NNull
|
||||
|
||||
whileForcingThunk :: forall t f m s e r. (Exception s, Convertible e t f m)
|
||||
=> s -> m r -> m r
|
||||
whileForcingThunk
|
||||
:: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
|
||||
whileForcingThunk frame =
|
||||
withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
|
||||
|
||||
|
@ -450,15 +459,15 @@ instance (Convertible e t f m, ToNix a m (NValue t f m))
|
|||
=> ToNix [a] m (NValue t f m) where
|
||||
toNix = fmap nvList . traverse (thunk . go)
|
||||
where
|
||||
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
|
||||
<=< toNix
|
||||
go =
|
||||
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
|
||||
|
||||
instance (Convertible e t f m, ToNix a m (NValue t f m))
|
||||
=> ToNix (HashMap Text a) m (NValue t f m) where
|
||||
toNix = fmap (flip nvSet M.empty) . traverse (thunk . go)
|
||||
where
|
||||
go = (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v))
|
||||
<=< toNix
|
||||
go =
|
||||
(\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix
|
||||
|
||||
instance Convertible e t f m => ToNix () m (NValueNF t f m) where
|
||||
instance Convertible e t f m => ToNix () m (NValue t f m) where
|
||||
|
@ -494,5 +503,5 @@ 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
|
||||
|
||||
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
|
||||
|
|
|
@ -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 Data.Text ( Text )
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Client hiding (path)
|
||||
import Network.HTTP.Client hiding ( path )
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.HTTP.Types
|
||||
import Nix.Expr
|
||||
|
@ -66,9 +69,9 @@ instance MonadIntrospect IO where
|
|||
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
|
||||
|
@ -82,22 +85,31 @@ class Monad m => MonadExec m where
|
|||
instance MonadExec IO where
|
||||
exec' = \case
|
||||
[] -> return $ Left $ ErrorCall "exec: missing program"
|
||||
(prog:args) -> do
|
||||
(exitCode, out, _) <-
|
||||
liftIO $ readProcessWithExitCode prog args ""
|
||||
(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
|
||||
ExitSuccess -> if T.null t
|
||||
then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg
|
||||
else case parseNixTextLoc t of
|
||||
Failure err ->
|
||||
return $ Left $ ErrorCall $
|
||||
"Error parsing output of exec: " ++ show err ++ " " ++ emsg
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "Error parsing output of exec: "
|
||||
++ show err
|
||||
++ " "
|
||||
++ emsg
|
||||
Success v -> return $ Right v
|
||||
err -> return $ Left $ ErrorCall $
|
||||
"exec failed: " ++ show err ++ " " ++ emsg
|
||||
err ->
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "exec failed: "
|
||||
++ show err
|
||||
++ " "
|
||||
++ emsg
|
||||
|
||||
class Monad m => MonadInstantiate m where
|
||||
instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
|
||||
|
@ -106,20 +118,28 @@ class Monad m => MonadInstantiate m where
|
|||
|
||||
instance MonadInstantiate IO where
|
||||
instantiateExpr expr = do
|
||||
traceM $ "Executing: "
|
||||
++ show ["nix-instantiate", "--eval", "--expr ", expr]
|
||||
(exitCode, out, err) <-
|
||||
readProcessWithExitCode "nix-instantiate"
|
||||
[ "--eval", "--expr", expr] ""
|
||||
traceM $ "Executing: " ++ show
|
||||
["nix-instantiate", "--eval", "--expr ", expr]
|
||||
(exitCode, out, err) <- readProcessWithExitCode "nix-instantiate"
|
||||
["--eval", "--expr", expr]
|
||||
""
|
||||
case exitCode of
|
||||
ExitSuccess -> case parseNixTextLoc (T.pack out) of
|
||||
Failure e ->
|
||||
return $ Left $ ErrorCall $
|
||||
"Error parsing output of nix-instantiate: " ++ show e
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "Error parsing output of nix-instantiate: "
|
||||
++ show e
|
||||
Success v -> return $ Right v
|
||||
status ->
|
||||
return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status
|
||||
++ ": " ++ err
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "nix-instantiate failed: "
|
||||
++ show status
|
||||
++ ": "
|
||||
++ err
|
||||
|
||||
pathExists :: MonadFile m => FilePath -> m Bool
|
||||
pathExists = doesFileExist
|
||||
|
@ -140,7 +160,7 @@ instance MonadEnv IO where
|
|||
|
||||
getCurrentSystemOS = return $ T.pack System.Info.os
|
||||
|
||||
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
|
||||
-- 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
|
||||
|
@ -155,20 +175,28 @@ instance MonadHttp IO where
|
|||
let urlstr = T.unpack url
|
||||
traceM $ "fetching HTTP URL: " ++ urlstr
|
||||
req <- parseRequest urlstr
|
||||
manager <-
|
||||
if secure req
|
||||
manager <- if secure req
|
||||
then newTlsManager
|
||||
else newManager defaultManagerSettings
|
||||
-- print req
|
||||
response <- httpLbs (req { method = "GET" }) manager
|
||||
let status = statusCode (responseStatus response)
|
||||
if status /= 200
|
||||
then return $ Left $ ErrorCall $
|
||||
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
|
||||
then
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "fail, got "
|
||||
++ show status
|
||||
++ " when fetching url:"
|
||||
++ urlstr
|
||||
else -- do
|
||||
-- let bstr = responseBody response
|
||||
return $ Left $ ErrorCall $
|
||||
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "success in downloading but hnix-store is not yet ready; url = "
|
||||
++ urlstr
|
||||
|
||||
|
||||
class Monad m => MonadPutStr m where
|
||||
|
@ -179,7 +207,7 @@ 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
|
||||
|
@ -196,16 +224,19 @@ class Monad m => MonadStore m where
|
|||
|
||||
instance MonadStore IO where
|
||||
addPath' path = do
|
||||
(exitCode, out, _) <-
|
||||
readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
(exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
case exitCode of
|
||||
ExitSuccess -> do
|
||||
let dropTrailingLinefeed p = take (length p - 1) p
|
||||
return $ Right $ StorePath $ dropTrailingLinefeed out
|
||||
_ -> return $ Left $ ErrorCall $
|
||||
"addPath: failed: nix-store --add " ++ show path
|
||||
_ ->
|
||||
return
|
||||
$ Left
|
||||
$ ErrorCall
|
||||
$ "addPath: failed: nix-store --add "
|
||||
++ show path
|
||||
|
||||
--TODO: Use a temp directory so we don't overwrite anything important
|
||||
--TODO: Use a temp directory so we don't overwrite anything important
|
||||
toFile_' filepath content = do
|
||||
writeFile filepath content
|
||||
storepath <- addPath' filepath
|
||||
|
@ -217,3 +248,10 @@ addPath p = either throwError return =<< addPath' p
|
|||
|
||||
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
|
||||
toFile_ p contents = either throwError return =<< toFile_' p contents
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
293
src/Nix/Eval.hs
293
src/Nix/Eval.hs
|
@ -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 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.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,18 +107,18 @@ 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)
|
||||
|
@ -123,13 +126,12 @@ eval (NBinary NApp fun arg) = do
|
|||
|
||||
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
|
||||
|
||||
eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id
|
||||
where
|
||||
go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
|
||||
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
|
||||
eval (NList l ) = do
|
||||
scope <- currentScopes
|
||||
for l (thunk @t @m @v . withScopes @t scope) >>= toValue
|
||||
|
||||
|
@ -139,9 +141,9 @@ eval (NSet binds) =
|
|||
eval (NRecSet binds) =
|
||||
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
|
||||
|
||||
|
@ -161,7 +163,7 @@ 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
|
||||
|
@ -169,10 +171,15 @@ evalWithAttrSet aset body = do
|
|||
-- its value is only computed once.
|
||||
scope <- currentScopes :: m (Scopes m t)
|
||||
s <- thunk @t @m @v $ withScopes scope aset
|
||||
pushWeakScope ?? body $ force s $
|
||||
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
pushWeakScope
|
||||
?? body
|
||||
$ force s
|
||||
$ fmap fst
|
||||
. fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
|
||||
attrSetAlter :: forall v t m. MonadNixEval v t m
|
||||
attrSetAlter
|
||||
:: forall v t m
|
||||
. MonadNixEval v t m
|
||||
=> [Text]
|
||||
-> SourcePos
|
||||
-> AttrSet (m v)
|
||||
|
@ -182,48 +189,59 @@ attrSetAlter :: forall v t m. MonadNixEval v t m
|
|||
attrSetAlter [] _ _ _ _ =
|
||||
evalError @v $ ErrorCall "invalid selector with no components"
|
||||
|
||||
attrSetAlter (k:ks) pos m p val = case M.lookup k m of
|
||||
attrSetAlter (k : ks) pos m p val = case M.lookup k m of
|
||||
Nothing | null ks -> go
|
||||
| otherwise -> recurse M.empty M.empty
|
||||
Just x | null ks -> go
|
||||
| otherwise ->
|
||||
x >>= fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
>>= \(st, sp) -> recurse (force ?? pure <$> st) sp
|
||||
Just x
|
||||
| null ks
|
||||
-> go
|
||||
| otherwise
|
||||
-> x >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(st, sp) ->
|
||||
recurse (force ?? pure <$> st) sp
|
||||
where
|
||||
go = return (M.insert k val m, M.insert k pos p)
|
||||
|
||||
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
|
||||
( M.insert k (toValue @(AttrSet t, AttrSet SourcePos)
|
||||
=<< (, mempty) . fmap wrapValue <$> sequence st') st
|
||||
, M.insert k pos sp )
|
||||
( M.insert
|
||||
k
|
||||
( toValue @(AttrSet t, AttrSet SourcePos)
|
||||
=<< (, mempty)
|
||||
. fmap wrapValue
|
||||
<$> sequence st'
|
||||
)
|
||||
st
|
||||
, M.insert k pos sp
|
||||
)
|
||||
|
||||
desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r]
|
||||
desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r]
|
||||
desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
|
||||
where
|
||||
collect :: Binding r
|
||||
-> State (HashMap VarName (SourcePos, [Binding r]))
|
||||
collect
|
||||
:: Binding r
|
||||
-> State
|
||||
(HashMap VarName (SourcePos, [Binding r]))
|
||||
(Either VarName (Binding r))
|
||||
collect (NamedVar (StaticKey x :| y:ys) val p) = do
|
||||
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)
|
||||
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
|
||||
:: Either VarName (Binding r)
|
||||
-> State (HashMap VarName (SourcePos, [Binding r])) (Binding r)
|
||||
go (Right x) = pure x
|
||||
go (Left x) = do
|
||||
maybeValue <- gets (M.lookup x)
|
||||
case maybeValue of
|
||||
Nothing ->
|
||||
fail ("No binding " ++ show x)
|
||||
Just (p, v) ->
|
||||
pure $ NamedVar (StaticKey x :| []) (embed v) p
|
||||
Nothing -> fail ("No binding " ++ show x)
|
||||
Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p
|
||||
|
||||
evalBinds :: forall v t m. MonadNixEval v t m
|
||||
evalBinds
|
||||
:: forall v t m
|
||||
. MonadNixEval v t m
|
||||
=> Bool
|
||||
-> [Binding (m v)]
|
||||
-> m (AttrSet t, AttrSet SourcePos)
|
||||
|
@ -231,17 +249,18 @@ evalBinds recursive binds = do
|
|||
scope <- currentScopes :: m (Scopes m t)
|
||||
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
|
||||
where
|
||||
moveOverridesLast = uncurry (++) .
|
||||
partition (\case
|
||||
moveOverridesLast = uncurry (++) . partition
|
||||
(\case
|
||||
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
|
||||
_ -> True)
|
||||
_ -> True
|
||||
)
|
||||
|
||||
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
|
||||
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
|
||||
finalValue >>= fromValue >>= \(o', p') ->
|
||||
-- jww (2018-05-09): What to do with the key position here?
|
||||
return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'),
|
||||
force @t @m @v v pure))
|
||||
return $ map
|
||||
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure))
|
||||
(M.toList o')
|
||||
|
||||
go _ (NamedVar pathExpr finalValue pos) = do
|
||||
|
@ -249,13 +268,15 @@ evalBinds recursive binds = do
|
|||
go = \case
|
||||
h :| t -> evalSetterKeyName h >>= \case
|
||||
Nothing ->
|
||||
pure ([], nullPos,
|
||||
toValue @(AttrSet t, AttrSet SourcePos)
|
||||
(mempty, mempty))
|
||||
pure
|
||||
( []
|
||||
, nullPos
|
||||
, toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)
|
||||
)
|
||||
Just k -> case t of
|
||||
[] -> pure ([k], pos, finalValue)
|
||||
x:xs -> do
|
||||
(restOfPath, _, v) <- go (x:|xs)
|
||||
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
|
||||
|
@ -263,28 +284,30 @@ evalBinds recursive binds = do
|
|||
([], _, _) -> []
|
||||
result -> [result]
|
||||
|
||||
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
|
||||
evalSetterKeyName >=> \case
|
||||
go scope (Inherit ms names pos) =
|
||||
fmap catMaybes $ forM names $ evalSetterKeyName >=> \case
|
||||
Nothing -> pure Nothing
|
||||
Just key -> pure $ Just ([key], pos, do
|
||||
Just key -> pure $ Just
|
||||
( [key]
|
||||
, pos
|
||||
, do
|
||||
mv <- case ms of
|
||||
Nothing -> withScopes scope $ lookupVar key
|
||||
Just s -> s
|
||||
>>= fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
>>= \(s, _) ->
|
||||
Just s ->
|
||||
s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) ->
|
||||
clearScopes @t $ pushScope s $ lookupVar key
|
||||
case mv of
|
||||
Nothing -> attrMissing (key :| []) Nothing
|
||||
Just v -> force v pure)
|
||||
Just v -> force v pure
|
||||
)
|
||||
|
||||
buildResult :: Scopes m t
|
||||
buildResult
|
||||
:: Scopes m t
|
||||
-> [([Text], SourcePos, m v)]
|
||||
-> m (AttrSet t, AttrSet SourcePos)
|
||||
buildResult scope bindings = do
|
||||
(s, p) <- foldM insert (M.empty, M.empty) bindings
|
||||
res <- if recursive
|
||||
then loebM (encapsulate <$> s)
|
||||
else traverse mkThunk s
|
||||
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
|
||||
return (res, p)
|
||||
where
|
||||
mkThunk = thunk . withScopes scope
|
||||
|
@ -293,7 +316,9 @@ evalBinds recursive binds = do
|
|||
|
||||
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
|
||||
|
||||
evalSelect :: forall v t m. MonadNixEval v t m
|
||||
evalSelect
|
||||
:: forall v t m
|
||||
. MonadNixEval v t m
|
||||
=> m v
|
||||
-> NAttrPath (m v)
|
||||
-> m (Either (v, NonEmpty Text) (m v))
|
||||
|
@ -302,92 +327,116 @@ evalSelect aset attr = do
|
|||
path <- traverse evalGetterKeyName attr
|
||||
extract s path
|
||||
where
|
||||
extract x path@(k:|ks) = fromValueMay x >>= \case
|
||||
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)
|
||||
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"
|
||||
Nothing ->
|
||||
evalError @v $ ErrorCall "value is null while a string was expected"
|
||||
|
||||
-- | Evaluate a component of an attribute path in a context where we are
|
||||
-- *binding* a value
|
||||
evalSetterKeyName :: (MonadEval v m, FromValue NixString m v)
|
||||
=> NKeyName (m v) -> m (Maybe Text)
|
||||
evalSetterKeyName
|
||||
:: (MonadEval v m, FromValue NixString m v)
|
||||
=> NKeyName (m v)
|
||||
-> m (Maybe Text)
|
||||
evalSetterKeyName = \case
|
||||
StaticKey k -> pure (Just k)
|
||||
DynamicKey k ->
|
||||
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
|
||||
\case Just ns -> Just (hackyStringIgnoreContext ns)
|
||||
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case
|
||||
Just ns -> Just (hackyStringIgnoreContext ns)
|
||||
_ -> Nothing
|
||||
|
||||
assembleString :: forall v m. (MonadEval v m, FromValue NixString m v)
|
||||
=> NString (m v) -> m (Maybe NixString)
|
||||
assembleString
|
||||
:: forall v m
|
||||
. (MonadEval v m, FromValue NixString m v)
|
||||
=> NString (m v)
|
||||
-> m (Maybe NixString)
|
||||
assembleString = \case
|
||||
Indented _ parts -> fromParts parts
|
||||
DoubleQuoted parts -> fromParts parts
|
||||
where
|
||||
fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go
|
||||
|
||||
go = runAntiquoted "\n" (pure . Just . principledMakeNixStringWithoutContext) (>>= fromValueMay)
|
||||
go = runAntiquoted "\n"
|
||||
(pure . Just . principledMakeNixStringWithoutContext)
|
||||
(>>= fromValueMay)
|
||||
|
||||
buildArgument :: forall v t m. MonadNixEval v t m
|
||||
=> Params (m v) -> m v -> m (AttrSet t)
|
||||
buildArgument
|
||||
:: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t)
|
||||
buildArgument params arg = do
|
||||
scope <- currentScopes :: m (Scopes m t)
|
||||
case params of
|
||||
Param name -> M.singleton name <$> thunk (withScopes scope arg)
|
||||
ParamSet s isVariadic m ->
|
||||
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
>>= \(args, _) -> do
|
||||
arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do
|
||||
let inject = case m of
|
||||
Nothing -> id
|
||||
Just n -> M.insert n $ const $
|
||||
thunk (withScopes scope arg)
|
||||
loebM (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
|
||||
args (M.fromList s))
|
||||
Just n -> M.insert n $ const $ thunk (withScopes scope arg)
|
||||
loebM
|
||||
(inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
|
||||
args
|
||||
(M.fromList s)
|
||||
)
|
||||
where
|
||||
assemble :: Scopes m t
|
||||
assemble
|
||||
:: Scopes m t
|
||||
-> Bool
|
||||
-> Text
|
||||
-> These t (Maybe (m v))
|
||||
-> Maybe (AttrSet t -> m t)
|
||||
assemble scope isVariadic k = \case
|
||||
That Nothing -> Just $
|
||||
const $ evalError @v $ ErrorCall $
|
||||
"Missing value for parameter: " ++ show k
|
||||
That (Just f) -> Just $ \args ->
|
||||
thunk $ withScopes scope $ pushScope args f
|
||||
This _ | isVariadic -> Nothing
|
||||
| otherwise -> Just $
|
||||
const $ evalError @v $ ErrorCall $
|
||||
"Unexpected parameter: " ++ show k
|
||||
That Nothing ->
|
||||
Just
|
||||
$ const
|
||||
$ evalError @v
|
||||
$ ErrorCall
|
||||
$ "Missing value for parameter: "
|
||||
++ show k
|
||||
That (Just f) ->
|
||||
Just $ \args -> thunk $ withScopes scope $ pushScope args f
|
||||
This _
|
||||
| isVariadic
|
||||
-> Nothing
|
||||
| otherwise
|
||||
-> Just
|
||||
$ const
|
||||
$ evalError @v
|
||||
$ ErrorCall
|
||||
$ "Unexpected parameter: "
|
||||
++ show k
|
||||
These x _ -> Just (const (pure x))
|
||||
|
||||
addSourcePositions :: (MonadReader e m, Has e SrcSpan)
|
||||
=> Transform NExprLocF (m a)
|
||||
addSourcePositions
|
||||
:: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)
|
||||
addSourcePositions f v@(Fix (Compose (Ann ann _))) =
|
||||
local (set hasLens ann) (f v)
|
||||
|
||||
addStackFrames
|
||||
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m)
|
||||
:: forall t e m a
|
||||
. (Scoped t m, Framed e m, Typeable t, Typeable m)
|
||||
=> Transform NExprLocF (m a)
|
||||
addStackFrames f v = do
|
||||
scopes <- currentScopes :: m (Scopes m t)
|
||||
withFrame Info (EvaluatingExpr scopes v) (f v)
|
||||
|
||||
framedEvalExprLoc
|
||||
:: forall t e v m.
|
||||
(MonadNixEval v t m, Framed e m, Has e SrcSpan,
|
||||
Typeable t, Typeable m)
|
||||
=> NExprLoc -> m v
|
||||
framedEvalExprLoc = adi (eval . annotated . getCompose)
|
||||
(addStackFrames @t . addSourcePositions)
|
||||
:: forall t e v m
|
||||
. (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m)
|
||||
=> NExprLoc
|
||||
-> m v
|
||||
framedEvalExprLoc =
|
||||
adi (eval . annotated . getCompose) (addStackFrames @t . addSourcePositions)
|
||||
|
|
462
src/Nix/Exec.hs
462
src/Nix/Exec.hs
|
@ -26,25 +26,29 @@
|
|||
|
||||
module Nix.Exec where
|
||||
|
||||
import Prelude hiding (putStr, putStrLn, print)
|
||||
import Prelude hiding ( putStr
|
||||
, putStrLn
|
||||
, print
|
||||
)
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch hiding (catchJust)
|
||||
import Control.Monad.Catch hiding ( catchJust )
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Ref
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Trans.Reader (ReaderT(..))
|
||||
import Control.Monad.Trans.State.Strict (StateT(..))
|
||||
import Control.Monad.Trans.Reader ( ReaderT(..) )
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( StateT(..) )
|
||||
import Data.Fix
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.HashMap.Lazy ( HashMap )
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.List.Split
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe ( maybeToList )
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Data.Typeable
|
||||
|
@ -67,7 +71,7 @@ import Nix.Thunk
|
|||
import Nix.Utils
|
||||
import Nix.Value
|
||||
#ifdef MIN_VERSION_haskeline
|
||||
import System.Console.Haskeline.MonadException hiding (catch)
|
||||
import System.Console.Haskeline.MonadException hiding(catch)
|
||||
#endif
|
||||
import System.FilePath
|
||||
#ifdef MIN_VERSION_pretty_show
|
||||
|
@ -80,54 +84,52 @@ import GHC.DataSize
|
|||
#endif
|
||||
#endif
|
||||
|
||||
type Cited t f m =
|
||||
( HasCitations1 t f m
|
||||
, MonadDataContext f m
|
||||
)
|
||||
type Cited t f m = (HasCitations1 t f m, MonadDataContext f m)
|
||||
|
||||
nvConstantP :: Cited t f m
|
||||
=> Provenance t f m -> NAtom -> NValue t f m
|
||||
nvConstantP :: Cited t f m => Provenance t f m -> NAtom -> NValue t f m
|
||||
nvConstantP p x = addProvenance p (nvConstant x)
|
||||
|
||||
nvStrP :: Cited t f m
|
||||
=> Provenance t f m -> NixString -> NValue t f m
|
||||
nvStrP :: Cited t f m => Provenance t f m -> NixString -> NValue t f m
|
||||
nvStrP p ns = addProvenance p (nvStr ns)
|
||||
|
||||
nvPathP :: Cited t f m
|
||||
=> Provenance t f m -> FilePath -> NValue t f m
|
||||
nvPathP :: Cited t f m => Provenance t f m -> FilePath -> NValue t f m
|
||||
nvPathP p x = addProvenance p (nvPath x)
|
||||
|
||||
nvListP :: Cited t f m
|
||||
=> Provenance t f m -> [t] -> NValue t f m
|
||||
nvListP :: Cited t f m => Provenance t f m -> [t] -> NValue t f m
|
||||
nvListP p l = addProvenance p (nvList l)
|
||||
|
||||
nvSetP :: Cited t f m
|
||||
=> Provenance t f m -> AttrSet t -> AttrSet SourcePos
|
||||
nvSetP
|
||||
:: Cited t f m
|
||||
=> Provenance t f m
|
||||
-> AttrSet t
|
||||
-> AttrSet SourcePos
|
||||
-> NValue t f m
|
||||
nvSetP p s x = addProvenance p (nvSet s x)
|
||||
|
||||
nvClosureP :: Cited t f m
|
||||
nvClosureP
|
||||
:: Cited t f m
|
||||
=> Provenance t f m
|
||||
-> Params ()
|
||||
-> (m (NValue t f m) -> m t)
|
||||
-> NValue t f m
|
||||
nvClosureP p x f = addProvenance p (nvClosure x f)
|
||||
|
||||
nvBuiltinP :: Cited t f m
|
||||
nvBuiltinP
|
||||
:: Cited t f m
|
||||
=> Provenance t f m
|
||||
-> String
|
||||
-> (m (NValue t f m) -> m t)
|
||||
-> NValue t f m
|
||||
nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
|
||||
|
||||
type MonadCitedThunks t f m =
|
||||
( MonadThunk t m (NValue t f m)
|
||||
type MonadCitedThunks t f m
|
||||
= ( MonadThunk t m (NValue t f m)
|
||||
, MonadDataErrorContext t f m
|
||||
, HasCitations1 t f m
|
||||
)
|
||||
|
||||
type MonadNix e t f m =
|
||||
( Has e SrcSpan
|
||||
type MonadNix e t f m
|
||||
= ( Has e SrcSpan
|
||||
, Has e Options
|
||||
, Scoped t m
|
||||
, Framed e m
|
||||
|
@ -145,12 +147,13 @@ data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
|
|||
instance MonadDataErrorContext t f m => Exception (ExecFrame t f m)
|
||||
|
||||
nverr
|
||||
:: forall e t f s m a.
|
||||
(MonadNix e t f m, FromValue NixString m t, Exception s)
|
||||
=> s -> m a
|
||||
:: forall e t f s m a
|
||||
. (MonadNix e t f m, FromValue NixString m t, Exception s)
|
||||
=> s
|
||||
-> m a
|
||||
nverr = evalError @(NValue t f m)
|
||||
|
||||
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
|
||||
currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan
|
||||
currentPos = asks (view hasLens)
|
||||
|
||||
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
|
||||
|
@ -159,8 +162,12 @@ wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
|
|||
instance ( MonadNix e t f m
|
||||
, FromValue NixString m t
|
||||
) => MonadEval (NValue t f m) m where
|
||||
freeVariable var = nverr @e @t @f $
|
||||
ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
|
||||
freeVariable var =
|
||||
nverr @e @t @f
|
||||
$ ErrorCall
|
||||
$ "Undefined variable '"
|
||||
++ Text.unpack var
|
||||
++ "'"
|
||||
|
||||
synHole name = do
|
||||
span <- currentPos
|
||||
|
@ -171,15 +178,19 @@ instance ( MonadNix e t f m
|
|||
}
|
||||
|
||||
attrMissing ks Nothing =
|
||||
evalError @(NValue t f m) $ ErrorCall $
|
||||
"Inheriting unknown attribute: "
|
||||
evalError @(NValue t f m)
|
||||
$ ErrorCall
|
||||
$ "Inheriting unknown attribute: "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
|
||||
attrMissing ks (Just s) = do
|
||||
s' <- prettyNValue s
|
||||
evalError @(NValue t f m) $ ErrorCall $ "Could not look up attribute "
|
||||
evalError @(NValue t f m)
|
||||
$ ErrorCall
|
||||
$ "Could not look up attribute "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
++ " in " ++ show s'
|
||||
++ " in "
|
||||
++ show s'
|
||||
|
||||
evalCurPos = do
|
||||
scope <- currentScopes
|
||||
|
@ -201,14 +212,19 @@ instance ( MonadNix e t f m
|
|||
Just ns -> do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
pure $ nvStrP (Provenance scope
|
||||
(NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)]))) ns
|
||||
pure $ nvStrP
|
||||
(Provenance
|
||||
scope
|
||||
(NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)]))
|
||||
)
|
||||
ns
|
||||
Nothing -> nverr $ ErrorCall "Failed to assemble string"
|
||||
|
||||
evalLiteralPath p = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath @t @f @m p
|
||||
nvPathP (Provenance scope (NLiteralPath_ span p))
|
||||
<$> makeAbsolutePath @t @f @m p
|
||||
|
||||
evalEnvPath p = do
|
||||
scope <- currentScopes
|
||||
|
@ -234,17 +250,29 @@ instance ( MonadNix e t f m
|
|||
evalIf c t f = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
fromValue c >>= \b ->
|
||||
if b
|
||||
then (\t -> addProvenance (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) t) <$> t
|
||||
else (\f -> addProvenance (Provenance scope (NIf_ span (Just c) Nothing (Just f))) f) <$> f
|
||||
fromValue c >>= \b -> if b
|
||||
then
|
||||
(\t -> addProvenance
|
||||
(Provenance scope (NIf_ span (Just c) (Just t) Nothing))
|
||||
t
|
||||
)
|
||||
<$> t
|
||||
else
|
||||
(\f -> addProvenance
|
||||
(Provenance scope (NIf_ span (Just c) Nothing (Just f)))
|
||||
f
|
||||
)
|
||||
<$> f
|
||||
|
||||
evalAssert c body = fromValue c >>= \b -> do
|
||||
span <- currentPos
|
||||
if b
|
||||
then do
|
||||
scope <- currentScopes
|
||||
(\b -> addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b) <$> body
|
||||
(\b ->
|
||||
addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b
|
||||
)
|
||||
<$> body
|
||||
else nverr $ Assertion span c
|
||||
|
||||
evalApp f x = do
|
||||
|
@ -256,18 +284,24 @@ instance ( MonadNix e t f m
|
|||
evalAbs p k = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
|
||||
(void p) (\arg -> wrapValue . snd <$> k arg (\_ b -> ((),) <$> b))
|
||||
pure $ nvClosureP
|
||||
(Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
|
||||
(void p)
|
||||
(\arg -> wrapValue . snd <$> k arg (\_ b -> ((), ) <$> b))
|
||||
|
||||
evalError = throwError
|
||||
|
||||
infixl 1 `callFunc`
|
||||
callFunc :: forall e t f m. MonadNix e t f m
|
||||
=> NValue t f m -> m (NValue t f m) -> m (NValue t f m)
|
||||
callFunc
|
||||
:: forall e t f m
|
||||
. MonadNix e t f m
|
||||
=> NValue t f m
|
||||
-> m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
callFunc fun arg = do
|
||||
frames :: Frames <- asks (view hasLens)
|
||||
when (length frames > 2000) $
|
||||
throwError $ ErrorCall "Function call stack exhausted"
|
||||
when (length frames > 2000) $ throwError $ ErrorCall
|
||||
"Function call stack exhausted"
|
||||
case fun of
|
||||
NVClosure params f -> do
|
||||
traceM $ "callFunc:NVFunction taking " ++ show params
|
||||
|
@ -280,28 +314,37 @@ callFunc fun arg = do
|
|||
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
|
||||
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
|
||||
|
||||
execUnaryOp :: (Framed e m, Cited t f m, Show t)
|
||||
=> Scopes m t -> SrcSpan -> NUnaryOp -> NValue t f m
|
||||
execUnaryOp
|
||||
:: (Framed e m, Cited t f m, Show t)
|
||||
=> Scopes m t
|
||||
-> SrcSpan
|
||||
-> NUnaryOp
|
||||
-> NValue t f m
|
||||
-> m (NValue t f m)
|
||||
execUnaryOp scope span op arg = do
|
||||
traceM "NUnary"
|
||||
case arg of
|
||||
NVConstant c -> case (op, c) of
|
||||
(NNeg, NInt i) -> unaryOp $ NInt (-i)
|
||||
(NNeg, NInt i ) -> unaryOp $ NInt (-i)
|
||||
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
|
||||
(NNot, NBool b) -> unaryOp $ NBool (not b)
|
||||
_ -> throwError $ ErrorCall $
|
||||
"unsupported argument type for unary operator " ++ show op
|
||||
x -> throwError $ ErrorCall $ "argument to unary operator"
|
||||
++ " must evaluate to an atomic type: " ++ show x
|
||||
(NNot, NBool b ) -> unaryOp $ NBool (not b)
|
||||
_ ->
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "unsupported argument type for unary operator "
|
||||
++ show op
|
||||
x ->
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "argument to unary operator"
|
||||
++ " must evaluate to an atomic type: "
|
||||
++ show x
|
||||
where
|
||||
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
|
||||
|
||||
execBinaryOp
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m,
|
||||
FromValue NixString m t,
|
||||
MonadEval (NValue t f m) m)
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t, MonadEval (NValue t f m) m)
|
||||
=> Scopes m t
|
||||
-> SrcSpan
|
||||
-> NBinaryOp
|
||||
|
@ -309,21 +352,21 @@ execBinaryOp
|
|||
-> m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
|
||||
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
|
||||
if l
|
||||
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> if l
|
||||
then orOp Nothing True
|
||||
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
|
||||
where
|
||||
orOp r b = pure $
|
||||
nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b)
|
||||
orOp r b = pure $ nvConstantP
|
||||
(Provenance scope (NBinary_ span NOr (Just larg) r))
|
||||
(NBool b)
|
||||
|
||||
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
|
||||
if l
|
||||
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l
|
||||
then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)
|
||||
else andOp Nothing False
|
||||
where
|
||||
andOp r b = pure $
|
||||
nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b)
|
||||
andOp r b = pure $ nvConstantP
|
||||
(Provenance scope (NBinary_ span NAnd (Just larg) r))
|
||||
(NBool b)
|
||||
|
||||
execBinaryOp scope span op lval rarg = do
|
||||
rval <- rarg
|
||||
|
@ -332,22 +375,21 @@ execBinaryOp scope span op lval rarg = do
|
|||
toBool = pure . bin nvConstantP . NBool
|
||||
case (lval, rval) of
|
||||
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
|
||||
(NEq, _, _) -> toBool =<< valueEqM lval rval
|
||||
(NEq , _, _) -> toBool =<< valueEqM lval rval
|
||||
(NNEq, _, _) -> toBool . not =<< valueEqM lval rval
|
||||
(NLt, l, r) -> toBool $ l < r
|
||||
(NLt , l, r) -> toBool $ l < r
|
||||
(NLte, l, r) -> toBool $ l <= r
|
||||
(NGt, l, r) -> toBool $ l > r
|
||||
(NGt , l, r) -> toBool $ l > r
|
||||
(NGte, l, r) -> toBool $ l >= r
|
||||
(NAnd, _, _) ->
|
||||
nverr $ ErrorCall "should be impossible: && is handled above"
|
||||
(NOr, _, _) ->
|
||||
nverr $ ErrorCall "should be impossible: || is handled above"
|
||||
(NPlus, l, r) -> numBinOp bin (+) l r
|
||||
(NMinus, l, r) -> numBinOp bin (-) l r
|
||||
(NMult, l, r) -> numBinOp bin (*) l r
|
||||
(NDiv, l, r) -> numBinOp' bin div (/) l r
|
||||
(NImpl,
|
||||
NBool l, NBool r) -> toBool $ not l || r
|
||||
(NPlus , l , r ) -> numBinOp bin (+) l r
|
||||
(NMinus, l , r ) -> numBinOp bin (-) l r
|
||||
(NMult , l , r ) -> numBinOp bin (*) l r
|
||||
(NDiv , l , r ) -> numBinOp' bin div (/) l r
|
||||
(NImpl , NBool l, NBool r) -> toBool $ not l || r
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
||||
|
||||
(NVStr ls, NVStr rs) -> case op of
|
||||
|
@ -388,15 +430,17 @@ execBinaryOp scope span op lval rarg = do
|
|||
NNEq -> toBool . not =<< valueEqM (nvSet M.empty M.empty) rval
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
||||
|
||||
(ls@NVSet {}, NVStr rs) -> case op of
|
||||
NPlus -> (\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))
|
||||
(ls@NVSet{}, NVStr rs) -> case op of
|
||||
NPlus ->
|
||||
(\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))
|
||||
<$> coerceToString DontCopyToStore CoerceStringy ls
|
||||
NEq -> toBool =<< valueEqM lval rval
|
||||
NNEq -> toBool . not =<< valueEqM lval rval
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
||||
|
||||
(NVStr ls, rs@NVSet {}) -> case op of
|
||||
NPlus -> (\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))
|
||||
(NVStr ls, rs@NVSet{}) -> case op of
|
||||
NPlus ->
|
||||
(\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))
|
||||
<$> coerceToString DontCopyToStore CoerceStringy rs
|
||||
NEq -> toBool =<< valueEqM lval rval
|
||||
NNEq -> toBool . not =<< valueEqM lval rval
|
||||
|
@ -439,20 +483,31 @@ execBinaryOp scope span op lval rarg = do
|
|||
unsupportedTypes :: Show a => a -> a -> String
|
||||
unsupportedTypes lval rval =
|
||||
"Unsupported argument types for binary operator "
|
||||
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
|
||||
++ show op
|
||||
++ ": "
|
||||
++ show lval
|
||||
++ ", "
|
||||
++ show rval
|
||||
|
||||
numBinOp :: (forall r. (Provenance t f m -> r) -> r)
|
||||
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue t f m)
|
||||
numBinOp
|
||||
:: (forall r . (Provenance t f m -> r) -> r)
|
||||
-> (forall a . Num a => a -> a -> a)
|
||||
-> NAtom
|
||||
-> NAtom
|
||||
-> m (NValue t f m)
|
||||
numBinOp bin f = numBinOp' bin f f
|
||||
|
||||
numBinOp' :: (forall r. (Provenance t f m -> r) -> r)
|
||||
numBinOp'
|
||||
:: (forall r . (Provenance t f m -> r) -> r)
|
||||
-> (Integer -> Integer -> Integer)
|
||||
-> (Float -> Float -> Float)
|
||||
-> NAtom -> NAtom -> m (NValue t f m)
|
||||
-> NAtom
|
||||
-> NAtom
|
||||
-> m (NValue t f m)
|
||||
numBinOp' bin intF floatF l r = case (l, r) of
|
||||
(NInt li, NInt ri) -> toInt $ li `intF` ri
|
||||
(NInt li, NInt ri ) -> toInt $ li `intF` ri
|
||||
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
|
||||
(NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri
|
||||
(NFloat lf, NInt ri ) -> toFloat $ lf `floatF` fromInteger ri
|
||||
(NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes l r
|
||||
where
|
||||
|
@ -475,43 +530,53 @@ data CopyToStoreMode
|
|||
-- ^ Add paths to the store as they are encountered
|
||||
deriving (Eq,Ord,Enum,Bounded)
|
||||
|
||||
coerceToString :: MonadNix e t f m => CopyToStoreMode -> CoercionLevel -> NValue t f m -> m NixString
|
||||
coerceToString
|
||||
:: MonadNix e t f m
|
||||
=> CopyToStoreMode
|
||||
-> CoercionLevel
|
||||
-> NValue t f m
|
||||
-> m NixString
|
||||
coerceToString ctsm clevel = go
|
||||
where
|
||||
go = \case
|
||||
NVConstant (NBool b)
|
||||
|
|
||||
-- TODO Return a singleton for "" and "1"
|
||||
| b && clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext "1"
|
||||
b && clevel == CoerceAny -> pure
|
||||
$ principledMakeNixStringWithoutContext "1"
|
||||
| clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
|
||||
NVConstant (NInt n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
|
||||
NVConstant (NFloat n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
|
||||
NVConstant NNull | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
|
||||
NVConstant (NInt n) | clevel == CoerceAny ->
|
||||
pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
|
||||
NVConstant (NFloat n) | clevel == CoerceAny ->
|
||||
pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
|
||||
NVConstant NNull | clevel == CoerceAny ->
|
||||
pure $ principledMakeNixStringWithoutContext ""
|
||||
NVStr ns -> pure ns
|
||||
NVPath p | ctsm == CopyToStore -> storePathToNixString <$> addPath p
|
||||
NVPath p
|
||||
| ctsm == CopyToStore -> storePathToNixString <$> addPath p
|
||||
| otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p
|
||||
NVList l | clevel == CoerceAny -> nixStringUnwords <$> traverse (`force` go) l
|
||||
NVList l | clevel == CoerceAny ->
|
||||
nixStringUnwords <$> traverse (`force` go) l
|
||||
|
||||
v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
|
||||
force p $ (`callFunc` pure v) >=> go
|
||||
|
||||
NVSet s _ | Just p <- M.lookup "outPath" s ->
|
||||
force p go
|
||||
NVSet s _ | Just p <- M.lookup "outPath" s -> force p go
|
||||
|
||||
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
|
||||
|
||||
nixStringUnwords = principledIntercalateNixString (principledMakeNixStringWithoutContext " ")
|
||||
nixStringUnwords =
|
||||
principledIntercalateNixString (principledMakeNixStringWithoutContext " ")
|
||||
storePathToNixString :: StorePath -> NixString
|
||||
storePathToNixString sp =
|
||||
principledMakeNixStringWithSingletonContext t (StringContext t DirectPath)
|
||||
where
|
||||
t = Text.pack $ unStorePath sp
|
||||
storePathToNixString sp = principledMakeNixStringWithSingletonContext
|
||||
t
|
||||
(StringContext t DirectPath)
|
||||
where t = Text.pack $ unStorePath sp
|
||||
|
||||
fromStringNoContext :: MonadNix e t f m => NixString -> m Text
|
||||
fromStringNoContext ns =
|
||||
case principledGetStringNoContext ns of
|
||||
fromStringNoContext ns = case principledGetStringNoContext ns of
|
||||
Just str -> return str
|
||||
Nothing -> throwError $ ErrorCall
|
||||
"expected string with no context"
|
||||
Nothing -> throwError $ ErrorCall "expected string with no context"
|
||||
|
||||
newtype Lazy t (f :: * -> *) m a = Lazy
|
||||
{ runLazy :: ReaderT (Context (Lazy t f m) t)
|
||||
|
@ -542,8 +607,8 @@ instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where
|
|||
instance (MonadFile m, Monad m) => MonadFile (Lazy t f m)
|
||||
|
||||
instance MonadCatch m => MonadCatch (Lazy t f m) where
|
||||
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
|
||||
catch (m e) ((`runReaderT` e) . runLazy . f)
|
||||
catch (Lazy (ReaderT m)) f =
|
||||
Lazy $ ReaderT $ \e -> catch (m e) ((`runReaderT` e) . runLazy . f)
|
||||
|
||||
instance MonadThrow m => MonadThrow (Lazy t f m) where
|
||||
throwM = Lazy . throwM
|
||||
|
@ -591,21 +656,26 @@ instance ( MonadFix m
|
|||
=> MonadEffects t f (Lazy t f m) where
|
||||
makeAbsolutePath origPath = do
|
||||
origPathExpanded <- expandHomePath origPath
|
||||
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
|
||||
absPath <- if isAbsolute origPathExpanded
|
||||
then pure origPathExpanded
|
||||
else do
|
||||
cwd <- do
|
||||
mres <- lookupVar "__cur_file"
|
||||
case mres of
|
||||
Nothing -> getCurrentDirectory
|
||||
Just v -> force v $ \case
|
||||
NVPath s -> return $ takeDirectory s
|
||||
v -> throwError $ ErrorCall $ "when resolving relative path,"
|
||||
v ->
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "when resolving relative path,"
|
||||
++ " __cur_file is in scope,"
|
||||
++ " but is not a path; it is: "
|
||||
++ show v
|
||||
pure $ cwd <///> origPathExpanded
|
||||
removeDotDotIndirections <$> canonicalizePath absPath
|
||||
|
||||
-- Given a path, determine the nix file to load
|
||||
-- Given a path, determine the nix file to load
|
||||
pathToDefaultNix = pathToDefaultNixFile
|
||||
|
||||
findEnvPath = findEnvPathM
|
||||
|
@ -621,20 +691,19 @@ instance ( MonadFix m
|
|||
eres <- parseNixFileLoc path
|
||||
case eres of
|
||||
Failure err ->
|
||||
throwError $ ErrorCall . show $ fillSep $
|
||||
[ "Parse during import failed:"
|
||||
, err
|
||||
]
|
||||
throwError
|
||||
$ ErrorCall
|
||||
. show
|
||||
$ fillSep
|
||||
$ ["Parse during import failed:", err]
|
||||
Success expr -> do
|
||||
Lazy $ ReaderT $ const $
|
||||
modify (M.insert path expr)
|
||||
Lazy $ ReaderT $ const $ modify (M.insert path expr)
|
||||
pure expr
|
||||
|
||||
derivationStrict = fromValue @(AttrSet t) >=> \s -> do
|
||||
nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s)
|
||||
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
|
||||
v' <- normalForm
|
||||
=<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
|
||||
v' <- normalForm =<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s'
|
||||
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
|
||||
where
|
||||
mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b]
|
||||
|
@ -642,7 +711,7 @@ instance ( MonadFix m
|
|||
where f x xs = op x >>= (<$> xs) . (++) . maybeToList
|
||||
|
||||
handleEntry :: Bool -> (Text, t) -> Lazy t f m (Maybe (Text, t))
|
||||
handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of
|
||||
handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of
|
||||
-- The `args' attribute is special: it supplies the command-line
|
||||
-- arguments to the builder.
|
||||
-- TODO This use of coerceToString is probably not right and may
|
||||
|
@ -655,8 +724,7 @@ instance ( MonadFix m
|
|||
where
|
||||
coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
|
||||
coerceNixList =
|
||||
toNix <=< traverse (\x -> force x coerceNix)
|
||||
<=< fromValue @[t]
|
||||
toNix <=< traverse (\x -> force x coerceNix) <=< fromValue @[t]
|
||||
|
||||
traceEffect = putStrLn
|
||||
|
||||
|
@ -664,9 +732,8 @@ getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m)
|
|||
getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize
|
||||
|
||||
runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a
|
||||
runLazyM opts = (`evalStateT` M.empty)
|
||||
. (`runReaderT` newContext opts)
|
||||
. runLazy
|
||||
runLazyM opts =
|
||||
(`evalStateT` M.empty) . (`runReaderT` newContext opts) . runLazy
|
||||
|
||||
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
|
||||
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its
|
||||
|
@ -674,9 +741,10 @@ runLazyM opts = (`evalStateT` M.empty)
|
|||
-- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath
|
||||
removeDotDotIndirections :: FilePath -> FilePath
|
||||
removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
|
||||
where go s [] = reverse s
|
||||
go (_:s) ("..":rest) = go s rest
|
||||
go s (this:rest) = go (this:s) rest
|
||||
where
|
||||
go s [] = reverse s
|
||||
go (_ : s) (".." : rest) = go s rest
|
||||
go s (this : rest) = go (this : s) rest
|
||||
|
||||
expandHomePath :: MonadFile m => FilePath -> m FilePath
|
||||
expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory
|
||||
|
@ -694,30 +762,33 @@ x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
|
|||
| otherwise = joinByLargestOverlap x y
|
||||
where
|
||||
joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =
|
||||
joinPath $ head [ xs ++ drop (length tx) ys
|
||||
| tx <- tails xs, tx `elem` inits ys ]
|
||||
joinPath $ head
|
||||
[ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ]
|
||||
|
||||
findPathBy
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
=> (FilePath -> m (Maybe FilePath))
|
||||
-> [t] -> FilePath -> m FilePath
|
||||
-> [t]
|
||||
-> FilePath
|
||||
-> m FilePath
|
||||
findPathBy finder l name = do
|
||||
mpath <- foldM go Nothing l
|
||||
case mpath of
|
||||
Nothing ->
|
||||
throwError $ ErrorCall $ "file '" ++ name
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "file '"
|
||||
++ name
|
||||
++ "' was not found in the Nix search path"
|
||||
++ " (add it using $NIX_PATH or -I)"
|
||||
Just path -> return path
|
||||
where
|
||||
go :: Maybe FilePath -> t -> m (Maybe FilePath)
|
||||
go p@(Just _) _ = pure p
|
||||
go Nothing l = force l $ fromValue >=>
|
||||
\(s :: HashMap Text t) -> do
|
||||
go Nothing l = force l $ fromValue >=> \(s :: HashMap Text t) -> do
|
||||
p <- resolvePath s
|
||||
force p $ fromValue >=> \(Path path) ->
|
||||
case M.lookup "prefix" s of
|
||||
force p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of
|
||||
Nothing -> tryPath path Nothing
|
||||
Just pf -> force pf $ fromValueMay >=> \case
|
||||
Just (nsPfx :: NixString) ->
|
||||
|
@ -727,7 +798,7 @@ findPathBy finder l name = do
|
|||
else tryPath path Nothing
|
||||
_ -> tryPath path Nothing
|
||||
|
||||
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
|
||||
tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' =
|
||||
finder $ p <///> joinPath ns
|
||||
tryPath p _ = finder $ p <///> name
|
||||
|
||||
|
@ -736,13 +807,18 @@ findPathBy finder l name = do
|
|||
Nothing -> case M.lookup "uri" s of
|
||||
Just ut -> thunk $ fetchTarball (force ut pure)
|
||||
Nothing ->
|
||||
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
|
||||
++ " with 'path' elements, but saw: " ++ show s
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "__nixPath must be a list of attr sets"
|
||||
++ " with 'path' elements, but saw: "
|
||||
++ show s
|
||||
|
||||
findPathM
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
=> [t] -> FilePath -> m FilePath
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
=> [t]
|
||||
-> FilePath
|
||||
-> m FilePath
|
||||
findPathM l name = findPathBy path l name
|
||||
where
|
||||
path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
|
||||
|
@ -752,15 +828,16 @@ findPathM l name = findPathBy path l name
|
|||
return $ if exists then Just path else Nothing
|
||||
|
||||
findEnvPathM
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
=> FilePath -> m FilePath
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t, FromValue Path m t)
|
||||
=> FilePath
|
||||
-> m FilePath
|
||||
findEnvPathM name = do
|
||||
mres <- lookupVar "__nixPath"
|
||||
case mres of
|
||||
Nothing -> error "impossible"
|
||||
Just x -> force x $ fromValue >=> \(l :: [t]) ->
|
||||
findPathBy nixFilePath l name
|
||||
Just x ->
|
||||
force x $ fromValue >=> \(l :: [t]) -> findPathBy nixFilePath l name
|
||||
where
|
||||
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
|
||||
nixFilePath path = do
|
||||
|
@ -772,9 +849,10 @@ findEnvPathM name = do
|
|||
exists <- doesFileExist path'
|
||||
return $ if exists then Just path' else Nothing
|
||||
|
||||
addTracing :: (MonadNix e t f m, Has e Options,
|
||||
MonadReader Int n, Alternative n)
|
||||
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
|
||||
addTracing
|
||||
:: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n)
|
||||
=> Alg NExprLocF (m a)
|
||||
-> Alg NExprLocF (n (m a))
|
||||
addTracing k v = do
|
||||
depth <- ask
|
||||
guard (depth < 2000)
|
||||
|
@ -782,8 +860,7 @@ addTracing k v = do
|
|||
v'@(Compose (Ann span x)) <- sequence v
|
||||
return $ do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
let rendered =
|
||||
if verbose opts >= Chatty
|
||||
let rendered = if verbose opts >= Chatty
|
||||
#ifdef MIN_VERSION_pretty_show
|
||||
then pretty $ PS.ppShow (void x)
|
||||
#else
|
||||
|
@ -798,14 +875,15 @@ addTracing k v = do
|
|||
return res
|
||||
|
||||
evalExprLoc
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m, FromValue NixString m t, Has e Options)
|
||||
=> NExprLoc -> m (NValue t f m)
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t, Has e Options)
|
||||
=> NExprLoc
|
||||
-> m (NValue t f m)
|
||||
evalExprLoc expr = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
if tracing opts
|
||||
then join . (`runReaderT` (0 :: Int)) $
|
||||
adi (addTracing phi)
|
||||
then join . (`runReaderT` (0 :: Int)) $ adi
|
||||
(addTracing phi)
|
||||
(raise (addStackFrames @t . addSourcePositions))
|
||||
expr
|
||||
else adi phi (addStackFrames @t . addSourcePositions) expr
|
||||
|
@ -814,23 +892,30 @@ evalExprLoc expr = do
|
|||
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|
||||
|
||||
fetchTarball
|
||||
:: forall e t f m.
|
||||
(MonadNix e t f m, FromValue NixString m t)
|
||||
=> m (NValue t f m) -> m (NValue t f m)
|
||||
:: forall e t f m
|
||||
. (MonadNix e t f m, FromValue NixString m t)
|
||||
=> m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
fetchTarball v = v >>= \case
|
||||
NVSet s _ -> case M.lookup "url" s of
|
||||
Nothing -> throwError $ ErrorCall
|
||||
"builtins.fetchTarball: Missing url attribute"
|
||||
Nothing ->
|
||||
throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute"
|
||||
Just url -> force url $ go (M.lookup "sha256" s)
|
||||
v@NVStr {} -> go Nothing v
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or set, got " ++ show v
|
||||
v@NVStr{} -> go Nothing v
|
||||
v ->
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "builtins.fetchTarball: Expected URI or set, got "
|
||||
++ show v
|
||||
where
|
||||
go :: Maybe t -> NValue t f m -> m (NValue t f m)
|
||||
go msha = \case
|
||||
NVStr ns -> fetch (hackyStringIgnoreContext ns) msha
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or string, got " ++ show v
|
||||
v ->
|
||||
throwError
|
||||
$ ErrorCall
|
||||
$ "builtins.fetchTarball: Expected URI or string, got "
|
||||
++ show v
|
||||
|
||||
{- jww (2018-04-11): This should be written using pipes in another module
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m)
|
||||
|
@ -846,28 +931,26 @@ fetchTarball v = v >>= \case
|
|||
|
||||
fetch :: Text -> Maybe t -> m (NValue t f m)
|
||||
fetch uri Nothing =
|
||||
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
|
||||
Text.unpack uri ++ "\""
|
||||
nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\""
|
||||
fetch url (Just m) = fromValue m >>= \nsSha ->
|
||||
let sha = hackyStringIgnoreContext nsSha
|
||||
in nixInstantiateExpr $ "builtins.fetchTarball { "
|
||||
++ "url = \"" ++ Text.unpack url ++ "\"; "
|
||||
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
|
||||
in nixInstantiateExpr
|
||||
$ "builtins.fetchTarball { "
|
||||
++ "url = \""
|
||||
++ Text.unpack url
|
||||
++ "\"; "
|
||||
++ "sha256 = \""
|
||||
++ Text.unpack sha
|
||||
++ "\"; }"
|
||||
|
||||
exec
|
||||
:: ( MonadNix e t f m
|
||||
, MonadInstantiate m
|
||||
, FromValue NixString m t
|
||||
)
|
||||
:: (MonadNix e t f m, MonadInstantiate m, FromValue NixString m t)
|
||||
=> [String]
|
||||
-> m (NValue t f m)
|
||||
exec args = either throwError evalExprLoc =<< exec' args
|
||||
|
||||
nixInstantiateExpr
|
||||
:: ( MonadNix e t f m
|
||||
, MonadInstantiate m
|
||||
, FromValue NixString m t
|
||||
)
|
||||
:: (MonadNix e t f m, MonadInstantiate m, FromValue NixString m t)
|
||||
=> String
|
||||
-> m (NValue t f m)
|
||||
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
|
||||
|
@ -877,3 +960,10 @@ instance Monad m => Scoped t (Lazy t f m) where
|
|||
clearScopes = clearScopesReader @(Lazy t f m) @t
|
||||
pushScopes = pushScopesReader
|
||||
lookupVar = lookupVarReader
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
-- | Wraps the expression submodules.
|
||||
module Nix.Expr (
|
||||
module Nix.Expr.Types,
|
||||
module Nix.Expr.Types.Annotated,
|
||||
module Nix.Expr.Shorthands
|
||||
) where
|
||||
module Nix.Expr
|
||||
( module Nix.Expr.Types
|
||||
, module Nix.Expr.Types.Annotated
|
||||
, module Nix.Expr.Shorthands
|
||||
)
|
||||
where
|
||||
|
||||
import Nix.Expr.Types
|
||||
import Nix.Expr.Shorthands
|
||||
|
|
|
@ -8,11 +8,11 @@
|
|||
module Nix.Expr.Shorthands where
|
||||
|
||||
import Data.Fix
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Text ( Text )
|
||||
import Nix.Atoms
|
||||
import Nix.Expr.Types
|
||||
import Text.Megaparsec.Pos (SourcePos)
|
||||
import Text.Megaparsec.Pos ( SourcePos )
|
||||
|
||||
-- | Make an integer literal expression.
|
||||
mkInt :: Integer -> 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
|
||||
|
|
|
@ -28,7 +28,7 @@
|
|||
module Nix.Expr.Types where
|
||||
|
||||
#ifdef MIN_VERSION_serialise
|
||||
import Codec.Serialise (Serialise)
|
||||
import Codec.Serialise ( Serialise )
|
||||
import qualified Codec.Serialise as Ser
|
||||
#endif
|
||||
import Control.Applicative
|
||||
|
@ -36,7 +36,7 @@ import Control.DeepSeq
|
|||
import Control.Monad
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Binary (Binary)
|
||||
import Data.Binary ( Binary )
|
||||
import qualified Data.Binary as Bin
|
||||
import Data.Data
|
||||
import Data.Eq.Deriving
|
||||
|
@ -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 Data.List ( inits
|
||||
, tails
|
||||
)
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe (fromMaybe)
|
||||
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,7 +69,7 @@ import Text.Megaparsec.Pos
|
|||
import Text.Read.Deriving
|
||||
import Text.Show.Deriving
|
||||
#if MIN_VERSION_base(4, 10, 0)
|
||||
import Type.Reflection (eqTypeRep)
|
||||
import Type.Reflection ( eqTypeRep )
|
||||
import qualified Type.Reflection as Reflection
|
||||
#endif
|
||||
|
||||
|
@ -245,10 +250,8 @@ data Antiquoted (v :: *) (r :: *) = Plain !v | EscapedNewline | Antiquoted !r
|
|||
instance Hashable v => Hashable1 (Antiquoted v)
|
||||
|
||||
instance Hashable2 Antiquoted where
|
||||
liftHashWithSalt2 ha _ salt (Plain a) =
|
||||
ha (salt `hashWithSalt` (0 :: Int)) a
|
||||
liftHashWithSalt2 _ _ salt EscapedNewline =
|
||||
salt `hashWithSalt` (1 :: Int)
|
||||
liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a
|
||||
liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int)
|
||||
liftHashWithSalt2 _ hb salt (Antiquoted b) =
|
||||
hb (salt `hashWithSalt` (2 :: Int)) b
|
||||
#endif
|
||||
|
@ -342,8 +345,8 @@ instance Generic1 NKeyName where
|
|||
|
||||
#if MIN_VERSION_deepseq(1, 4, 3)
|
||||
instance NFData1 NKeyName where
|
||||
liftRnf _ (StaticKey !_) = ()
|
||||
liftRnf _ (DynamicKey (Plain !_)) = ()
|
||||
liftRnf _ (StaticKey !_ ) = ()
|
||||
liftRnf _ (DynamicKey (Plain !_) ) = ()
|
||||
liftRnf _ (DynamicKey EscapedNewline) = ()
|
||||
liftRnf k (DynamicKey (Antiquoted r)) = k r
|
||||
#endif
|
||||
|
@ -369,7 +372,11 @@ instance Hashable1 NKeyName where
|
|||
-- occurs not only as last argument in @Antiquoted (NString r) r@
|
||||
instance Show1 NKeyName where
|
||||
liftShowsPrec sp sl p = \case
|
||||
DynamicKey a -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl) "DynamicKey" p a
|
||||
DynamicKey a -> showsUnaryWith
|
||||
(liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl)
|
||||
"DynamicKey"
|
||||
p
|
||||
a
|
||||
StaticKey t -> showsUnaryWith showsPrec "StaticKey" p t
|
||||
|
||||
-- Deriving this instance automatically is not possible because @r@
|
||||
|
@ -387,7 +394,7 @@ instance Foldable NKeyName where
|
|||
instance Traversable NKeyName where
|
||||
traverse f = \case
|
||||
DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str
|
||||
DynamicKey (Antiquoted e) -> DynamicKey . Antiquoted <$> f e
|
||||
DynamicKey (Antiquoted e ) -> DynamicKey . Antiquoted <$> f e
|
||||
DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline
|
||||
StaticKey key -> pure (StaticKey key)
|
||||
|
||||
|
@ -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)
|
||||
|
@ -526,14 +533,14 @@ class NExprAnn ann g | g -> ann where
|
|||
fromNExpr :: g r -> (NExprF r, ann)
|
||||
toNExpr :: (NExprF r, ann) -> g r
|
||||
|
||||
ekey :: NExprAnn ann g
|
||||
ekey
|
||||
:: NExprAnn ann g
|
||||
=> NonEmpty Text
|
||||
-> SourcePos
|
||||
-> Lens' (Fix g) (Maybe (Fix g))
|
||||
ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x =
|
||||
case go xs of
|
||||
((v, []):_) -> fromMaybe e <$> f (Just v)
|
||||
((v, r:rest):_) -> ekey (r :| rest) pos f v
|
||||
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
|
||||
|
@ -546,9 +553,9 @@ ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x =
|
|||
(ks, rest) <- zip (inits keys') (tails keys')
|
||||
case ks of
|
||||
[] -> empty
|
||||
j:js -> do
|
||||
j : js -> do
|
||||
NamedVar ns v _p <- xs
|
||||
guard $ (j:js) == (NE.toList ns ^.. traverse._StaticKey)
|
||||
guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
|
||||
return (v, rest)
|
||||
|
||||
ekey _ _ f e = fromMaybe e <$> f Nothing
|
||||
|
@ -556,8 +563,8 @@ ekey _ _ f e = fromMaybe e <$> f Nothing
|
|||
stripPositionInfo :: NExpr -> NExpr
|
||||
stripPositionInfo = transport phi
|
||||
where
|
||||
phi (NSet binds) = NSet (map go binds)
|
||||
phi (NRecSet binds) = NRecSet (map go binds)
|
||||
phi (NSet binds ) = NSet (map go binds)
|
||||
phi (NRecSet binds ) = NRecSet (map go binds)
|
||||
phi (NLet binds body) = NLet (map go binds) body
|
||||
phi x = x
|
||||
|
||||
|
@ -566,3 +573,6 @@ stripPositionInfo = transport phi
|
|||
|
||||
nullPos :: SourcePos
|
||||
nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -18,32 +18,41 @@
|
|||
module Nix.Expr.Types.Annotated
|
||||
( module Nix.Expr.Types.Annotated
|
||||
, module Data.Functor.Compose
|
||||
, SourcePos(..), unPos, mkPos
|
||||
) where
|
||||
, SourcePos(..)
|
||||
, unPos
|
||||
, mkPos
|
||||
)
|
||||
where
|
||||
|
||||
#ifdef MIN_VERSION_serialise
|
||||
import Codec.Serialise
|
||||
#endif
|
||||
import Control.DeepSeq
|
||||
import Data.Aeson (ToJSON(..), FromJSON(..))
|
||||
import Data.Aeson ( ToJSON(..)
|
||||
, FromJSON(..)
|
||||
)
|
||||
import Data.Aeson.TH
|
||||
import Data.Binary (Binary(..))
|
||||
import Data.Binary ( Binary(..) )
|
||||
import Data.Data
|
||||
import Data.Eq.Deriving
|
||||
import Data.Fix
|
||||
import Data.Function (on)
|
||||
import Data.Function ( on )
|
||||
import Data.Functor.Compose
|
||||
import Data.Hashable
|
||||
#if MIN_VERSION_hashable(1, 2, 5)
|
||||
import Data.Hashable.Lifted
|
||||
#endif
|
||||
import Data.Ord.Deriving
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text ( Text
|
||||
, pack
|
||||
)
|
||||
import GHC.Generics
|
||||
import Nix.Atoms
|
||||
import Nix.Expr.Types
|
||||
import Text.Megaparsec (unPos, mkPos)
|
||||
import Text.Megaparsec.Pos (SourcePos(..))
|
||||
import Text.Megaparsec ( unPos
|
||||
, mkPos
|
||||
)
|
||||
import Text.Megaparsec.Pos ( SourcePos(..) )
|
||||
import Text.Read.Deriving
|
||||
import Text.Show.Deriving
|
||||
|
||||
|
@ -93,8 +102,7 @@ $(deriveJSON1 defaultOptions ''Ann)
|
|||
$(deriveJSON2 defaultOptions ''Ann)
|
||||
|
||||
instance Semigroup SrcSpan where
|
||||
s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2)
|
||||
((max `on` spanEnd) s1 s2)
|
||||
s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2)
|
||||
|
||||
type AnnF ann f = Compose (Ann ann) f
|
||||
|
||||
|
@ -153,8 +161,8 @@ nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) =
|
|||
AnnE (s1 <> s2 <> s3) (NBinary b e1 e2)
|
||||
nBinary _ _ _ = error "nBinary: unexpected"
|
||||
|
||||
nSelectLoc :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc
|
||||
-> NExprLoc
|
||||
nSelectLoc
|
||||
:: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc
|
||||
nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of
|
||||
Nothing -> AnnE (s1 <> s2) (NSelect e1 ats Nothing)
|
||||
Just (e2@(AnnE s3 _)) -> AnnE (s1 <> s2 <> s3) (NSelect e1 ats (Just e2))
|
||||
|
|
|
@ -4,15 +4,25 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Nix.Frames (NixLevel(..), Frames, Framed, NixFrame(..),
|
||||
NixException(..), withFrame, throwError,
|
||||
module Data.Typeable,
|
||||
module Control.Exception) where
|
||||
module Nix.Frames
|
||||
( NixLevel(..)
|
||||
, Frames
|
||||
, Framed
|
||||
, NixFrame(..)
|
||||
, NixException(..)
|
||||
, withFrame
|
||||
, throwError
|
||||
, module Data.Typeable
|
||||
, module Control.Exception
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception hiding (catch, evaluate)
|
||||
import Control.Exception hiding ( catch
|
||||
, evaluate
|
||||
)
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Reader
|
||||
import Data.Typeable hiding (typeOf)
|
||||
import Data.Typeable hiding ( typeOf )
|
||||
import Nix.Utils
|
||||
|
||||
data NixLevel = Fatal | Error | Warning | Info | Debug
|
||||
|
@ -25,7 +35,7 @@ data NixFrame = NixFrame
|
|||
|
||||
instance Show NixFrame where
|
||||
show (NixFrame level f) =
|
||||
"Nix frame at level " ++ show level ++ ": "++ show 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)
|
||||
throwM $ NixException (NixFrame Error (toException err) : context)
|
||||
|
|
|
@ -25,7 +25,7 @@ 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
|
||||
|
@ -104,3 +104,10 @@ instance MonadAtomicRef (ST s) where
|
|||
let (a, b) = f v
|
||||
writeRef r $! a
|
||||
return b
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -23,10 +23,14 @@ import Nix.Utils
|
|||
import Nix.Value
|
||||
|
||||
nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString
|
||||
nvalueToJSONNixString = runWithStringContextT
|
||||
. fmap (TL.toStrict . TL.decodeUtf8
|
||||
nvalueToJSONNixString =
|
||||
runWithStringContextT
|
||||
. fmap
|
||||
( TL.toStrict
|
||||
. TL.decodeUtf8
|
||||
. A.encodingToLazyByteString
|
||||
. toEncodingSorted)
|
||||
. toEncodingSorted
|
||||
)
|
||||
. nvalueToJSON
|
||||
|
||||
nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
|
||||
|
@ -37,11 +41,12 @@ nvalueToJSON = \case
|
|||
NVConstant NNull -> pure $ A.Null
|
||||
NVStr ns -> A.toJSON <$> extractNixString ns
|
||||
NVList l ->
|
||||
A.Array . V.fromList
|
||||
A.Array
|
||||
. V.fromList
|
||||
<$> traverse (join . lift . flip force (return . nvalueToJSON)) l
|
||||
NVSet m _ -> case HM.lookup "outPath" m of
|
||||
Nothing -> A.Object
|
||||
<$> traverse (join . lift . flip force (return . nvalueToJSON)) m
|
||||
Nothing ->
|
||||
A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
|
||||
Just outPath -> join $ lift $ force outPath (return . nvalueToJSON)
|
||||
NVPath p -> do
|
||||
fp <- lift $ unStorePath <$> addPath p
|
||||
|
|
175
src/Nix/Lint.hs
175
src/Nix/Lint.hs
|
@ -27,21 +27,21 @@ 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 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 Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import Nix.Atoms
|
||||
import Nix.Context
|
||||
import Nix.Convert
|
||||
import Nix.Eval (MonadEval(..))
|
||||
import Nix.Eval ( MonadEval(..) )
|
||||
import qualified Nix.Eval as Eval
|
||||
import Nix.Expr
|
||||
import Nix.Frames
|
||||
|
@ -84,9 +84,9 @@ compareTypes _ (TList _) = GT
|
|||
compareTypes (TSet _) (TSet _) = EQ
|
||||
compareTypes (TSet _) _ = LT
|
||||
compareTypes _ (TSet _) = GT
|
||||
compareTypes TClosure {} TClosure {} = EQ
|
||||
compareTypes TClosure {} _ = LT
|
||||
compareTypes _ TClosure {} = GT
|
||||
compareTypes TClosure{} TClosure{} = EQ
|
||||
compareTypes TClosure{} _ = LT
|
||||
compareTypes _ TClosure{} = GT
|
||||
compareTypes TPath TPath = EQ
|
||||
compareTypes TPath _ = LT
|
||||
compareTypes _ TPath = GT
|
||||
|
@ -111,18 +111,17 @@ 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
|
||||
|
@ -153,40 +152,45 @@ renderSymbolic = unpackSymbolic >=> \case
|
|||
TBuiltin _n _f -> return "<builtin function>"
|
||||
|
||||
-- This function is order and uniqueness preserving (of types).
|
||||
merge :: forall e m. MonadLint e m
|
||||
=> NExprF () -> [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
|
||||
merge
|
||||
:: forall e m
|
||||
. MonadLint e m
|
||||
=> NExprF ()
|
||||
-> [NTypeF m (SThunk m)]
|
||||
-> [NTypeF m (SThunk m)]
|
||||
-> m [NTypeF m (SThunk m)]
|
||||
merge context = go
|
||||
where
|
||||
go :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
|
||||
-> m [NTypeF m (SThunk m)]
|
||||
go
|
||||
:: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] -> m [NTypeF m (SThunk m)]
|
||||
go [] _ = return []
|
||||
go _ [] = return []
|
||||
go (x:xs) (y:ys) = case (x, y) of
|
||||
(TStr, TStr) -> (TStr :) <$> go xs ys
|
||||
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 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 {}) ->
|
||||
(\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
|
||||
_ | compareTypes x y == LT -> go xs (y : ys)
|
||||
| compareTypes x y == GT -> go (x : xs) ys
|
||||
| otherwise -> error "impossible"
|
||||
|
||||
{-
|
||||
|
@ -209,8 +213,13 @@ merge context = go
|
|||
-}
|
||||
|
||||
-- | unify raises an error if the result is would be 'NMany []'.
|
||||
unify :: forall e m. MonadLint e m
|
||||
=> NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
|
||||
unify
|
||||
:: forall e m
|
||||
. MonadLint e m
|
||||
=> NExprF ()
|
||||
-> Symbolic m
|
||||
-> Symbolic m
|
||||
-> m (Symbolic m)
|
||||
unify context (Symbolic x) (Symbolic y) = do
|
||||
x' <- readVar x
|
||||
y' <- readVar y
|
||||
|
@ -259,18 +268,21 @@ instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where
|
|||
getValue = getValue . getSThunk
|
||||
|
||||
instance MonadLint e m => MonadEval (Symbolic m) m where
|
||||
freeVariable var = symerr $
|
||||
"Undefined variable '" ++ Text.unpack var ++ "'"
|
||||
freeVariable var = symerr $ "Undefined variable '" ++ Text.unpack var ++ "'"
|
||||
|
||||
attrMissing ks Nothing =
|
||||
evalError @(Symbolic m) $ ErrorCall $
|
||||
"Inheriting unknown attribute: "
|
||||
evalError @(Symbolic m)
|
||||
$ ErrorCall
|
||||
$ "Inheriting unknown attribute: "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
|
||||
attrMissing ks (Just s) =
|
||||
evalError @(Symbolic m) $ ErrorCall $ "Could not look up attribute "
|
||||
evalError @(Symbolic m)
|
||||
$ ErrorCall
|
||||
$ "Could not look up attribute "
|
||||
++ intercalate "." (map Text.unpack (NE.toList ks))
|
||||
++ " in " ++ show s
|
||||
++ " in "
|
||||
++ show s
|
||||
|
||||
evalCurPos = do
|
||||
f <- wrapValue <$> mkSymbolic [TPath]
|
||||
|
@ -279,9 +291,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
|
|||
mkSymbolic [TSet (Just (M.fromList (go f l c)))]
|
||||
where
|
||||
go f l c =
|
||||
[ (Text.pack "file", f)
|
||||
, (Text.pack "line", l)
|
||||
, (Text.pack "col", c) ]
|
||||
[(Text.pack "file", f), (Text.pack "line", l), (Text.pack "col", c)]
|
||||
|
||||
evalConstant c = mkSymbolic [TConstant [go c]]
|
||||
where
|
||||
|
@ -296,16 +306,15 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
|
|||
evalEnvPath = const $ mkSymbolic [TPath]
|
||||
|
||||
evalUnary op arg =
|
||||
unify (void (NUnary op arg)) arg
|
||||
=<< mkSymbolic [TConstant [TInt, TBool]]
|
||||
unify (void (NUnary op arg)) arg =<< mkSymbolic [TConstant [TInt, TBool]]
|
||||
|
||||
evalBinary = lintBinaryOp
|
||||
|
||||
-- The scope is deliberately wrapped in a thunk here, since it is evaluated
|
||||
-- each time a name is looked up within the weak scope, and we want to be
|
||||
-- sure the action it evaluates is to force a thunk, so its value is only
|
||||
-- computed once.
|
||||
evalWith scope body = do
|
||||
-- The scope is deliberately wrapped in a thunk here, since it is
|
||||
-- evaluated each time a name is looked up within the weak scope, and
|
||||
-- we want to be sure the action it evaluates is to force a thunk, so
|
||||
-- its value is only computed once.
|
||||
s <- thunk @(SThunk m) @m @(Symbolic m) scope
|
||||
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
|
||||
NMany [TSet (Just s')] -> return s'
|
||||
|
@ -331,38 +340,38 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
|
|||
evalError = throwError
|
||||
|
||||
lintBinaryOp
|
||||
:: forall e m. (MonadLint e m, MonadEval (Symbolic m) m)
|
||||
=> NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
|
||||
:: forall e m
|
||||
. (MonadLint e m, MonadEval (Symbolic m) m)
|
||||
=> NBinaryOp
|
||||
-> Symbolic m
|
||||
-> m (Symbolic m)
|
||||
-> m (Symbolic m)
|
||||
lintBinaryOp op lsym rarg = do
|
||||
rsym <- rarg
|
||||
y <- thunk everyPossible
|
||||
case op of
|
||||
NApp -> symerr "lintBinaryOp:NApp: should never get here"
|
||||
NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
|
||||
, TStr
|
||||
, TList y ]
|
||||
NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull]
|
||||
, TStr
|
||||
, TList y ]
|
||||
NEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y]
|
||||
NNEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y]
|
||||
|
||||
NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
|
||||
NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ]
|
||||
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] ]
|
||||
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 ]
|
||||
NConcat -> check lsym rsym [TList y]
|
||||
where
|
||||
check lsym rsym xs = do
|
||||
let e = NBinary op lsym rsym
|
||||
|
@ -372,12 +381,16 @@ lintBinaryOp op lsym rarg = do
|
|||
unify (void e) lsym rsym
|
||||
|
||||
infixl 1 `lintApp`
|
||||
lintApp :: forall e m. MonadLint e m
|
||||
=> NExprF () -> Symbolic m -> m (Symbolic m)
|
||||
lintApp
|
||||
:: forall e m
|
||||
. MonadLint e m
|
||||
=> NExprF ()
|
||||
-> Symbolic m
|
||||
-> m (Symbolic m)
|
||||
-> m (HashMap VarName (Symbolic m), Symbolic m)
|
||||
lintApp context fun arg = unpackSymbolic fun >>= \case
|
||||
NAny -> throwError $ ErrorCall
|
||||
"Cannot apply something not known to be a function"
|
||||
NAny ->
|
||||
throwError $ ErrorCall "Cannot apply something not known to be a function"
|
||||
NMany xs -> do
|
||||
(args, ys) <- fmap unzip $ forM xs $ \case
|
||||
TClosure _params -> arg >>= unpackSymbolic >>= \case
|
||||
|
@ -393,7 +406,7 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
|
|||
_x -> throwError $ ErrorCall "Attempt to call non-function"
|
||||
|
||||
y <- everyPossible
|
||||
(head args,) <$> foldM (unify context) y ys
|
||||
(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 }
|
||||
|
@ -423,11 +436,13 @@ symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
|
|||
symbolicBaseEnv = return emptyScopes
|
||||
|
||||
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
|
||||
lint opts expr = runLintM opts $
|
||||
symbolicBaseEnv
|
||||
>>= (`pushScopes`
|
||||
adi (Eval.eval . annotated . getCompose)
|
||||
Eval.addSourcePositions expr)
|
||||
lint opts expr =
|
||||
runLintM opts
|
||||
$ symbolicBaseEnv
|
||||
>>= (`pushScopes` adi (Eval.eval . annotated . getCompose)
|
||||
Eval.addSourcePositions
|
||||
expr
|
||||
)
|
||||
|
||||
instance Scoped (SThunk (Lint s)) (Lint s) where
|
||||
currentScopes = currentScopesReader
|
||||
|
|
|
@ -28,13 +28,13 @@ newtype NormalLoop t f m = NormalLoop (NValue t f m)
|
|||
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
|
||||
|
||||
normalForm'
|
||||
:: forall e t m f.
|
||||
( Framed e m
|
||||
:: forall e t m f
|
||||
. ( Framed e m
|
||||
, MonadThunk t m (NValue t f m)
|
||||
, MonadDataErrorContext t f m
|
||||
, Ord (ThunkId m)
|
||||
)
|
||||
=> (forall r. t -> (NValue t f m -> m r) -> m r)
|
||||
=> (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
|
||||
|
@ -45,9 +45,11 @@ normalForm' f = run . nValueToNFM run go
|
|||
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
|
||||
run = (`evalStateT` table) . (`runReaderT` start)
|
||||
|
||||
go :: t
|
||||
-> (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)
|
||||
)
|
||||
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
|
||||
go t k = do
|
||||
b <- seen t
|
||||
|
@ -55,8 +57,8 @@ normalForm' f = run . nValueToNFM run go
|
|||
then return $ pure t
|
||||
else do
|
||||
i <- ask
|
||||
when (i > 2000) $
|
||||
error "Exceeded maximum normalization depth of 2000 levels"
|
||||
when (i > 2000)
|
||||
$ error "Exceeded maximum normalization depth of 2000 levels"
|
||||
s <- lift get
|
||||
(res, s') <- lift $ lift $ f t $ \v ->
|
||||
(`runStateT` s) . (`runReaderT` i) $ local succ $ k v
|
||||
|
@ -68,8 +70,7 @@ normalForm' f = run . nValueToNFM run go
|
|||
res <- gets (member tid)
|
||||
unless res $ modify (insert tid)
|
||||
return res
|
||||
Nothing ->
|
||||
return False
|
||||
Nothing -> return False
|
||||
|
||||
normalForm
|
||||
:: ( Framed e m
|
||||
|
@ -77,7 +78,8 @@ normalForm
|
|||
, MonadDataErrorContext t f m
|
||||
, Ord (ThunkId m)
|
||||
)
|
||||
=> NValue t f m -> m (NValueNF t f m)
|
||||
=> NValue t f m
|
||||
-> m (NValueNF t f m)
|
||||
normalForm = normalForm' force
|
||||
|
||||
normalForm_
|
||||
|
@ -86,21 +88,28 @@ normalForm_
|
|||
, MonadDataErrorContext t f m
|
||||
, Ord (ThunkId m)
|
||||
)
|
||||
=> NValue t f m -> m ()
|
||||
=> NValue t f m
|
||||
-> m ()
|
||||
normalForm_ = void <$> normalForm' forceEff
|
||||
|
||||
removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m -> NValueNF t f m
|
||||
removeEffects
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m
|
||||
-> NValueNF t f m
|
||||
removeEffects = nValueToNF (flip query opaque)
|
||||
|
||||
removeEffectsM :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m -> m (NValueNF t f m)
|
||||
removeEffectsM
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m
|
||||
-> m (NValueNF t f m)
|
||||
removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
|
||||
|
||||
opaque :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValueNF t f m
|
||||
opaque
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m
|
||||
opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
|
||||
dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> t -> m (NValueNF t f m)
|
||||
dethunk
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> t
|
||||
-> m (NValueNF t f m)
|
||||
dethunk t = queryM t (pure opaque) removeEffectsM
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
module Nix.Options where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import Data.Time
|
||||
|
||||
data Options = Options
|
||||
|
@ -37,8 +37,7 @@ data Options = Options
|
|||
deriving Show
|
||||
|
||||
defaultOptions :: UTCTime -> Options
|
||||
defaultOptions current = Options
|
||||
{ verbose = ErrorsOnly
|
||||
defaultOptions current = Options { verbose = ErrorsOnly
|
||||
, tracing = False
|
||||
, thunks = False
|
||||
, values = False
|
||||
|
|
|
@ -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 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"
|
||||
argPair = option $ str >>= \s -> case Text.findIndex (== '=') s of
|
||||
Nothing ->
|
||||
errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr"
|
||||
Just i -> return $ second Text.tail $ Text.splitAt i s
|
||||
|
||||
nixOptions :: UTCTime -> Parser Options
|
||||
nixOptions current = Options
|
||||
<$> (fromMaybe Informational <$>
|
||||
optional
|
||||
(option (do a <- str
|
||||
nixOptions current =
|
||||
Options
|
||||
<$> (fromMaybe Informational <$> optional
|
||||
(option
|
||||
(do
|
||||
a <- str
|
||||
if all isDigit a
|
||||
then pure $ decodeVerbosity (read a)
|
||||
else fail "Argument to -v/--verbose must be a number")
|
||||
( short 'v'
|
||||
<> long "verbose"
|
||||
<> help "Verbose output")))
|
||||
else fail "Argument to -v/--verbose must be a number"
|
||||
)
|
||||
(short 'v' <> long "verbose" <> help "Verbose output")
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( long "trace"
|
||||
<> help "Enable tracing code (even more can be seen if built with --flags=tracing)")
|
||||
<> help
|
||||
"Enable tracing code (even more can be seen if built with --flags=tracing)"
|
||||
)
|
||||
<*> switch
|
||||
( long "thunks"
|
||||
<> help "Enable reporting of thunk tracing as well as regular evaluation")
|
||||
(long "thunks" <> help
|
||||
"Enable reporting of thunk tracing as well as regular evaluation"
|
||||
)
|
||||
<*> switch
|
||||
( long "values"
|
||||
<> help "Enable reporting of value provenance in error messages")
|
||||
<> help "Enable reporting of value provenance in error messages"
|
||||
)
|
||||
<*> switch
|
||||
( long "scopes"
|
||||
<> help "Enable reporting of scopes in evaluation traces")
|
||||
<*> optional (strOption
|
||||
<> help "Enable reporting of scopes in evaluation traces"
|
||||
)
|
||||
<*> optional
|
||||
(strOption
|
||||
( long "reduce"
|
||||
<> help "When done evaluating, output the evaluated part of the expression to FILE"))
|
||||
<> help
|
||||
"When done evaluating, output the evaluated part of the expression to FILE"
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( long "reduce-sets"
|
||||
<> help "Reduce set members that aren't used; breaks if hasAttr is used")
|
||||
(long "reduce-sets" <> help
|
||||
"Reduce set members that aren't used; breaks if hasAttr is used"
|
||||
)
|
||||
<*> switch
|
||||
( long "reduce-lists"
|
||||
<> help "Reduce list members that aren't used; breaks if elemAt is used")
|
||||
(long "reduce-lists" <> help
|
||||
"Reduce list members that aren't used; breaks if elemAt is used"
|
||||
)
|
||||
<*> switch
|
||||
( long "parse"
|
||||
<> help "Whether to parse the file (also the default right now)")
|
||||
<> help "Whether to parse the file (also the default right now)"
|
||||
)
|
||||
<*> switch
|
||||
( long "parse-only"
|
||||
<> help "Whether to parse only, no pretty printing or checking")
|
||||
<*> switch
|
||||
( long "find"
|
||||
<> help "If selected, find paths within attr trees")
|
||||
<*> optional (strOption
|
||||
<> help "Whether to parse only, no pretty printing or checking"
|
||||
)
|
||||
<*> switch (long "find" <> help "If selected, find paths within attr trees")
|
||||
<*> optional
|
||||
(strOption
|
||||
( long "find-file"
|
||||
<> help "Look up the given files in Nix's search path"))
|
||||
<> help "Look up the given files in Nix's search path"
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( long "strict"
|
||||
<> help "When used with --eval, recursively evaluate list elements and attributes")
|
||||
<*> switch
|
||||
( long "eval"
|
||||
<> help "Whether to evaluate, or just pretty-print")
|
||||
<> help
|
||||
"When used with --eval, recursively evaluate list elements and attributes"
|
||||
)
|
||||
<*> switch (long "eval" <> help "Whether to evaluate, or just pretty-print")
|
||||
<*> switch
|
||||
( long "json"
|
||||
<> help "Print the resulting value as an JSON representation")
|
||||
<> help "Print the resulting value as an JSON representation"
|
||||
)
|
||||
<*> switch
|
||||
( long "xml"
|
||||
<> help "Print the resulting value as an XML representation")
|
||||
<*> optional (strOption
|
||||
<> help "Print the resulting value as an XML representation"
|
||||
)
|
||||
<*> optional
|
||||
(strOption
|
||||
( short 'A'
|
||||
<> long "attr"
|
||||
<> help "Select an attribute from the top-level Nix expression being evaluated"))
|
||||
<*> many (strOption
|
||||
( short 'I'
|
||||
<> long "include"
|
||||
<> help "Add a path to the Nix expression search path"))
|
||||
<> help
|
||||
"Select an attribute from the top-level Nix expression being evaluated"
|
||||
)
|
||||
)
|
||||
<*> many
|
||||
(strOption
|
||||
(short 'I' <> long "include" <> help
|
||||
"Add a path to the Nix expression search path"
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( long "check"
|
||||
<> help "Whether to check for syntax errors after parsing")
|
||||
<*> optional (strOption
|
||||
<> help "Whether to check for syntax errors after parsing"
|
||||
)
|
||||
<*> optional
|
||||
(strOption
|
||||
( long "read"
|
||||
<> help "Read in an expression tree from a binary cache"))
|
||||
<> help "Read in an expression tree from a binary cache"
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( long "cache"
|
||||
<> help "Write out the parsed expression tree to a binary cache")
|
||||
<> help "Write out the parsed expression tree to a binary cache"
|
||||
)
|
||||
<*> switch
|
||||
( long "repl"
|
||||
<> help "After performing any indicated actions, enter the REPL")
|
||||
<> help "After performing any indicated actions, enter the REPL"
|
||||
)
|
||||
<*> switch
|
||||
( long "ignore-errors"
|
||||
<> help "Continue parsing files, even if there are errors")
|
||||
<*> optional (strOption
|
||||
( short 'E'
|
||||
<> long "expr"
|
||||
<> help "Expression to parse or evaluate"))
|
||||
<*> many (argPair
|
||||
( long "arg"
|
||||
<> help "Argument to pass to an evaluated lambda"))
|
||||
<*> many (argPair
|
||||
<> help "Continue parsing files, even if there are errors"
|
||||
)
|
||||
<*> optional
|
||||
(strOption
|
||||
(short 'E' <> long "expr" <> help "Expression to parse or evaluate")
|
||||
)
|
||||
<*> many
|
||||
(argPair
|
||||
(long "arg" <> help "Argument to pass to an evaluated lambda")
|
||||
)
|
||||
<*> many
|
||||
(argPair
|
||||
( long "argstr"
|
||||
<> help "Argument string to pass to an evaluated lambda"))
|
||||
<*> optional (strOption
|
||||
( short 'f'
|
||||
<> long "file"
|
||||
<> help "Parse all of the files given in FILE; - means stdin"))
|
||||
<*> option (parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str)
|
||||
( long "now"
|
||||
<> value current
|
||||
<> help "Set current time for testing purposes")
|
||||
<> help "Argument string to pass to an evaluated lambda"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(strOption
|
||||
(short 'f' <> long "file" <> help
|
||||
"Parse all of the files given in FILE; - means stdin"
|
||||
)
|
||||
)
|
||||
<*> option
|
||||
(parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str)
|
||||
(long "now" <> value current <> help
|
||||
"Set current time for testing purposes"
|
||||
)
|
||||
<*> many (strArgument (metavar "FILE" <> help "Path of file to parse"))
|
||||
|
||||
nixOptionsInfo :: UTCTime -> ParserInfo Options
|
||||
nixOptionsInfo current =
|
||||
info (helper <*> nixOptions current)
|
||||
nixOptionsInfo current = info (helper <*> nixOptions current)
|
||||
(fullDesc <> progDesc "" <> header "hnix")
|
||||
|
|
|
@ -26,13 +26,11 @@ module Nix.Parser
|
|||
, getUnaryOperator
|
||||
, getBinaryOperator
|
||||
, getSpecialOperator
|
||||
|
||||
, nixToplevelForm
|
||||
, nixExpr
|
||||
, nixSet
|
||||
, nixBinders
|
||||
, nixSelector
|
||||
|
||||
, nixSym
|
||||
, nixPath
|
||||
, nixString
|
||||
|
@ -44,32 +42,45 @@ module Nix.Parser
|
|||
, nixNull
|
||||
, symbol
|
||||
, whiteSpace
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude hiding (readFile)
|
||||
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 Data.HashSet ( HashSet )
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
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 ( 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
|
||||
|
@ -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,38 +112,45 @@ selDot = try (symbol "." *> notFollowedBy nixPath) <?> "."
|
|||
|
||||
nixSelect :: Parser NExprLoc -> Parser NExprLoc
|
||||
nixSelect term = do
|
||||
res <- build
|
||||
<$> term
|
||||
<*> optional ((,) <$> (selDot *> nixSelector)
|
||||
<*> optional (reserved "or" *> nixTerm))
|
||||
res <- build <$> term <*> optional
|
||||
((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm))
|
||||
continues <- optional $ lookAhead selDot
|
||||
case continues of
|
||||
Nothing -> pure res
|
||||
Just _ -> nixSelect (pure res)
|
||||
where
|
||||
build :: NExprLoc
|
||||
build
|
||||
:: NExprLoc
|
||||
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
|
||||
-> NExprLoc
|
||||
build t Nothing = t
|
||||
build t (Just (s,o)) = nSelectLoc t s o
|
||||
build t (Just (s, o)) = nSelectLoc t s o
|
||||
|
||||
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
|
||||
nixSelector = annotateLocation $ do
|
||||
(x:xs) <- keyName `sepBy1` selDot
|
||||
(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 == '^'
|
||||
pathChar x
|
||||
|| x
|
||||
== '('
|
||||
|| x
|
||||
== '{'
|
||||
|| x
|
||||
== '['
|
||||
|| x
|
||||
== '<'
|
||||
|| x
|
||||
== '/'
|
||||
|| x
|
||||
== '"'
|
||||
|| x
|
||||
== '\''
|
||||
|| x
|
||||
== '^'
|
||||
case c of
|
||||
'(' -> nixSelect nixParens
|
||||
'{' -> nixSelect nixSet
|
||||
|
@ -140,21 +160,21 @@ nixTerm = do
|
|||
'"' -> nixString
|
||||
'\'' -> nixString
|
||||
'^' -> nixSynHole
|
||||
_ -> msum $
|
||||
[ nixSelect nixSet | c == 'r' ] ++
|
||||
[ nixPath | pathChar c ] ++
|
||||
if isDigit c
|
||||
then [ nixFloat
|
||||
, nixInt ]
|
||||
else [ nixUri | isAlpha c ] ++
|
||||
[ nixBool | c == 't' || c == 'f' ] ++
|
||||
[ nixNull | c == 'n' ] ++
|
||||
[ nixSelect nixSym ]
|
||||
_ ->
|
||||
msum
|
||||
$ [ nixSelect nixSet | c == 'r' ]
|
||||
++ [ nixPath | pathChar c ]
|
||||
++ if isDigit c
|
||||
then [nixFloat, nixInt]
|
||||
else
|
||||
[ nixUri | isAlpha c ]
|
||||
++ [ nixBool | c == 't' || c == 'f' ]
|
||||
++ [ nixNull | c == 'n' ]
|
||||
++ [nixSelect nixSym]
|
||||
|
||||
nixToplevelForm :: Parser NExprLoc
|
||||
nixToplevelForm = keywords <+> nixLambda <+> nixExpr
|
||||
where
|
||||
keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
|
||||
where keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
|
||||
|
||||
nixSym :: Parser NExprLoc
|
||||
nixSym = annotateLocation1 $ mkSymF <$> identifier
|
||||
|
@ -166,12 +186,13 @@ nixInt :: Parser NExprLoc
|
|||
nixInt = annotateLocation1 (mkIntF <$> integer <?> "integer")
|
||||
|
||||
nixFloat :: Parser NExprLoc
|
||||
nixFloat = annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
|
||||
nixFloat =
|
||||
annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
|
||||
|
||||
nixBool :: Parser NExprLoc
|
||||
nixBool = annotateLocation1 (bool "true" True <+>
|
||||
bool "false" False) <?> "bool" where
|
||||
bool str b = mkBoolF b <$ reserved str
|
||||
nixBool =
|
||||
annotateLocation1 (bool "true" True <+> bool "false" False) <?> "bool"
|
||||
where bool str b = mkBoolF b <$ reserved str
|
||||
|
||||
nixNull :: Parser NExprLoc
|
||||
nixNull = annotateLocation1 (mkNullF <$ reserved "null" <?> "null")
|
||||
|
@ -183,57 +204,80 @@ nixList :: Parser NExprLoc
|
|||
nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list")
|
||||
|
||||
pathChar :: Char -> Bool
|
||||
pathChar x = isAlpha x || isDigit x || x == '.' || x == '_' || x == '-' || x == '+' || x == '~'
|
||||
pathChar x =
|
||||
isAlpha x
|
||||
|| isDigit x
|
||||
|| x
|
||||
== '.'
|
||||
|| x
|
||||
== '_'
|
||||
|| x
|
||||
== '-'
|
||||
|| x
|
||||
== '+'
|
||||
|| x
|
||||
== '~'
|
||||
|
||||
slash :: Parser Char
|
||||
slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)))
|
||||
slash =
|
||||
try
|
||||
( char '/'
|
||||
<* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x))
|
||||
)
|
||||
<?> "slash"
|
||||
|
||||
-- | A path surrounded by angle brackets, indicating that it should be
|
||||
-- looked up in the NIX_PATH environment variable at evaluation.
|
||||
nixSearchPath :: Parser NExprLoc
|
||||
nixSearchPath = annotateLocation1
|
||||
(mkPathF True <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">")
|
||||
<?> "spath")
|
||||
( mkPathF True
|
||||
<$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">")
|
||||
<?> "spath"
|
||||
)
|
||||
|
||||
pathStr :: Parser FilePath
|
||||
pathStr = lexeme $ liftM2 (++) (many (satisfy pathChar))
|
||||
pathStr = lexeme $ liftM2
|
||||
(++)
|
||||
(many (satisfy pathChar))
|
||||
(Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar))))
|
||||
|
||||
nixPath :: Parser NExprLoc
|
||||
nixPath = annotateLocation1 (try (mkPathF False <$> pathStr) <?> "path")
|
||||
|
||||
nixLet :: Parser NExprLoc
|
||||
nixLet = annotateLocation1 (reserved "let"
|
||||
*> (letBody <+> letBinders)
|
||||
<?> "let block")
|
||||
nixLet = annotateLocation1
|
||||
(reserved "let" *> (letBody <+> letBinders) <?> "let block")
|
||||
where
|
||||
letBinders = NLet
|
||||
<$> nixBinders
|
||||
<*> (reserved "in" *> nixToplevelForm)
|
||||
letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm)
|
||||
-- Let expressions `let {..., body = ...}' are just desugared
|
||||
-- into `(rec {..., body = ...}).body'.
|
||||
letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
|
||||
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
|
||||
|
||||
nixIf :: Parser NExprLoc
|
||||
nixIf = annotateLocation1 (NIf
|
||||
nixIf = annotateLocation1
|
||||
( NIf
|
||||
<$> (reserved "if" *> nixExpr)
|
||||
<*> (reserved "then" *> nixToplevelForm)
|
||||
<*> (reserved "else" *> nixToplevelForm)
|
||||
<?> "if")
|
||||
<?> "if"
|
||||
)
|
||||
|
||||
nixAssert :: Parser NExprLoc
|
||||
nixAssert = annotateLocation1 (NAssert
|
||||
nixAssert = annotateLocation1
|
||||
( NAssert
|
||||
<$> (reserved "assert" *> nixExpr)
|
||||
<*> (semi *> nixToplevelForm)
|
||||
<?> "assert")
|
||||
<?> "assert"
|
||||
)
|
||||
|
||||
nixWith :: Parser NExprLoc
|
||||
nixWith = annotateLocation1 (NWith
|
||||
nixWith = annotateLocation1
|
||||
( NWith
|
||||
<$> (reserved "with" *> nixToplevelForm)
|
||||
<*> (semi *> nixToplevelForm)
|
||||
<?> "with")
|
||||
<?> "with"
|
||||
)
|
||||
|
||||
nixLambda :: Parser NExprLoc
|
||||
nixLambda = nAbs <$> annotateLocation (try argExpr) <*> nixToplevelForm
|
||||
|
@ -249,27 +293,33 @@ nixUri = annotateLocation1 $ lexeme $ try $ do
|
|||
_ <- string ":"
|
||||
address <- some $ satisfy $ \x ->
|
||||
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
|
||||
return $ NStr $
|
||||
DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address]
|
||||
return $ NStr $ DoubleQuoted
|
||||
[Plain $ pack $ start : protocol ++ ':' : address]
|
||||
|
||||
nixString' :: Parser (NString NExprLoc)
|
||||
nixString' = lexeme (doubleQuoted <+> indented <?> "string")
|
||||
where
|
||||
doubleQuoted :: Parser (NString NExprLoc)
|
||||
doubleQuoted = DoubleQuoted . removePlainEmpty . mergePlain
|
||||
<$> (doubleQ *> many (stringChar doubleQ (void $ char '\\')
|
||||
doubleEscape)
|
||||
<* doubleQ)
|
||||
doubleQuoted =
|
||||
DoubleQuoted
|
||||
. removePlainEmpty
|
||||
. mergePlain
|
||||
<$> ( doubleQ
|
||||
*> many (stringChar doubleQ (void $ char '\\') doubleEscape)
|
||||
<* doubleQ
|
||||
)
|
||||
<?> "double quoted string"
|
||||
|
||||
doubleQ = void (char '"')
|
||||
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
|
||||
|
||||
indented :: Parser (NString NExprLoc)
|
||||
indented = stripIndent
|
||||
<$> (indentedQ *> many (stringChar indentedQ indentedQ
|
||||
indentedEscape)
|
||||
<* indentedQ)
|
||||
indented =
|
||||
stripIndent
|
||||
<$> ( indentedQ
|
||||
*> many (stringChar indentedQ indentedQ indentedEscape)
|
||||
<* indentedQ
|
||||
)
|
||||
<?> "indented string"
|
||||
|
||||
indentedQ = void (string "''" <?> "\"''\"")
|
||||
|
@ -278,20 +328,23 @@ nixString' = lexeme (doubleQuoted <+> indented <?> "string")
|
|||
(Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do
|
||||
_ <- char '\\'
|
||||
c <- escapeCode
|
||||
pure $ if c == '\n'
|
||||
then EscapedNewline
|
||||
else Plain $ singleton c
|
||||
pure $ if c == '\n' then EscapedNewline else Plain $ singleton c
|
||||
|
||||
stringChar end escStart esc =
|
||||
Antiquoted <$> (antiStart *> nixToplevelForm <* char '}')
|
||||
<+> Plain . singleton <$> char '$'
|
||||
Antiquoted
|
||||
<$> (antiStart *> nixToplevelForm <* char '}')
|
||||
<+> Plain
|
||||
. singleton
|
||||
<$> char '$'
|
||||
<+> esc
|
||||
<+> Plain . pack <$> some plainChar
|
||||
<+> Plain
|
||||
. pack
|
||||
<$> some plainChar
|
||||
where
|
||||
plainChar =
|
||||
notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle
|
||||
|
||||
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,8 +353,11 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
|
|||
-- in the case of, for example `x:y`. Is it a lambda function `x: y`, or
|
||||
-- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if
|
||||
-- there's a valid URI parse here.
|
||||
onlyname = msum [nixUri >> unexpected (Label ('v' NE.:| "alid uri")),
|
||||
Param <$> identifier]
|
||||
onlyname =
|
||||
msum
|
||||
[ nixUri >> unexpected (Label ('v' NE.:| "alid uri"))
|
||||
, Param <$> identifier
|
||||
]
|
||||
|
||||
-- Parameters named by an identifier on the left (`args @ {x, y}`)
|
||||
atLeft = try $ do
|
||||
|
@ -348,7 +404,8 @@ nixBinders = (inherit <+> namedVar) `endBy` semi where
|
|||
Inherit x <$> many keyName <*> pure p <?> "inherited binding"
|
||||
namedVar = do
|
||||
p <- getSourcePos
|
||||
NamedVar <$> (annotated <$> nixSelector)
|
||||
NamedVar
|
||||
<$> (annotated <$> nixSelector)
|
||||
<*> (equals *> nixToplevelForm)
|
||||
<*> pure p
|
||||
<?> "variable binding"
|
||||
|
@ -360,9 +417,8 @@ keyName = dynamicKey <+> staticKey where
|
|||
dynamicKey = DynamicKey <$> nixAntiquoted nixString'
|
||||
|
||||
nixSet :: Parser NExprLoc
|
||||
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set") where
|
||||
isRec = (reserved "rec" $> NRecSet <?> "recursive set")
|
||||
<+> pure NSet
|
||||
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set")
|
||||
where isRec = (reserved "rec" $> NRecSet <?> "recursive set") <+> pure NSet
|
||||
|
||||
parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
|
||||
parseNixFile =
|
||||
|
@ -381,8 +437,7 @@ parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
|
|||
{- Parser.Library -}
|
||||
|
||||
skipLineComment' :: Tokens Text -> Parser ()
|
||||
skipLineComment' prefix =
|
||||
string prefix
|
||||
skipLineComment' prefix = string prefix
|
||||
*> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
|
||||
|
||||
whiteSpace :: Parser ()
|
||||
|
@ -398,18 +453,41 @@ symbol :: Text -> Parser Text
|
|||
symbol = lexeme . string
|
||||
|
||||
reservedEnd :: Char -> Bool
|
||||
reservedEnd x = isSpace x ||
|
||||
x == '{' || x == '(' || x == '[' ||
|
||||
x == '}' || x == ')' || x == ']' ||
|
||||
x == ';' || x == ':' || x == '.' ||
|
||||
x == '"' || x == '\'' || x == ','
|
||||
reservedEnd x =
|
||||
isSpace x
|
||||
|| x
|
||||
== '{'
|
||||
|| x
|
||||
== '('
|
||||
|| x
|
||||
== '['
|
||||
|| x
|
||||
== '}'
|
||||
|| x
|
||||
== ')'
|
||||
|| x
|
||||
== ']'
|
||||
|| x
|
||||
== ';'
|
||||
|| x
|
||||
== ':'
|
||||
|| x
|
||||
== '.'
|
||||
|| x
|
||||
== '"'
|
||||
|| x
|
||||
== '\''
|
||||
|| x
|
||||
== ','
|
||||
|
||||
reserved :: Text -> Parser ()
|
||||
reserved n = lexeme $ try $
|
||||
string n *> lookAhead (void (satisfy reservedEnd) <|> eof)
|
||||
reserved n =
|
||||
lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof)
|
||||
|
||||
identifier = lexeme $ try $ do
|
||||
ident <- cons <$> satisfy (\x -> isAlpha x || x == '_')
|
||||
ident <-
|
||||
cons
|
||||
<$> satisfy (\x -> isAlpha x || x == '_')
|
||||
<*> takeWhileP Nothing identLetter
|
||||
guard (not (ident `HashSet.member` reservedNames))
|
||||
return ident
|
||||
|
@ -435,12 +513,7 @@ float = lexeme L.float
|
|||
|
||||
reservedNames :: HashSet Text
|
||||
reservedNames = HashSet.fromList
|
||||
[ "let", "in"
|
||||
, "if", "then", "else"
|
||||
, "assert"
|
||||
, "with"
|
||||
, "rec"
|
||||
, "inherit" ]
|
||||
["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"]
|
||||
|
||||
type Parser = ParsecT Void Text Identity
|
||||
|
||||
|
@ -449,13 +522,13 @@ data Result a = Success a | Failure (Doc Void) deriving (Show, Functor)
|
|||
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
|
||||
parseFromFileEx p path = do
|
||||
txt <- decodeUtf8 <$> readFile path
|
||||
return $ either (Failure . pretty . errorBundlePretty) Success
|
||||
$ parse p path txt
|
||||
return $ either (Failure . pretty . errorBundlePretty) Success $ parse p
|
||||
path
|
||||
txt
|
||||
|
||||
parseFromText :: Parser a -> Text -> Result a
|
||||
parseFromText p txt =
|
||||
either (Failure . pretty . errorBundlePretty) Success $
|
||||
parse p "<string>" txt
|
||||
either (Failure . pretty . errorBundlePretty) Success $ parse p "<string>" txt
|
||||
|
||||
{- Parser.Operators -}
|
||||
|
||||
|
@ -491,17 +564,18 @@ operator n = symbol n
|
|||
|
||||
opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a
|
||||
opWithLoc name op f = do
|
||||
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} operator name
|
||||
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -}
|
||||
operator name
|
||||
return $ f (Ann ann op)
|
||||
|
||||
binaryN name op = (NBinaryDef name op NAssocNone,
|
||||
InfixN (opWithLoc name op nBinary))
|
||||
binaryL name op = (NBinaryDef name op NAssocLeft,
|
||||
InfixL (opWithLoc name op nBinary))
|
||||
binaryR name op = (NBinaryDef name op NAssocRight,
|
||||
InfixR (opWithLoc name op nBinary))
|
||||
prefix name op = (NUnaryDef name op,
|
||||
Prefix (manyUnaryOp (opWithLoc name op nUnary)))
|
||||
binaryN name op =
|
||||
(NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary))
|
||||
binaryL name op =
|
||||
(NBinaryDef name op NAssocLeft, InfixL (opWithLoc name op nBinary))
|
||||
binaryR name op =
|
||||
(NBinaryDef name op NAssocRight, InfixR (opWithLoc name op nBinary))
|
||||
prefix name op =
|
||||
(NUnaryDef name op, Prefix (manyUnaryOp (opWithLoc name op nUnary)))
|
||||
-- postfix name op = (NUnaryDef name op,
|
||||
-- Postfix (opWithLoc name op nUnary))
|
||||
|
||||
|
@ -521,28 +595,40 @@ nixOperators selector =
|
|||
-- mor <- optional (reserved "or" *> term)
|
||||
-- return $ \x -> nSelectLoc x sel mor) ]
|
||||
|
||||
{- 2 -} [ (NBinaryDef " " NApp NAssocLeft,
|
||||
{- 2 -}
|
||||
[ ( NBinaryDef " " NApp NAssocLeft
|
||||
,
|
||||
-- Thanks to Brent Yorgey for showing me this trick!
|
||||
InfixL $ nApp <$ symbol "") ]
|
||||
, {- 3 -} [ prefix "-" NNeg ]
|
||||
, {- 4 -} [ (NSpecialDef "?" NHasAttrOp NAssocLeft,
|
||||
Postfix $ symbol "?" *> (flip nHasAttr <$> selector)) ]
|
||||
, {- 5 -} [ binaryR "++" NConcat ]
|
||||
, {- 6 -} [ binaryL "*" NMult
|
||||
, binaryL "/" NDiv ]
|
||||
, {- 7 -} [ binaryL "+" NPlus
|
||||
, binaryL "-" NMinus ]
|
||||
, {- 8 -} [ prefix "!" NNot ]
|
||||
, {- 9 -} [ binaryR "//" NUpdate ]
|
||||
, {- 10 -} [ binaryL "<" NLt
|
||||
, binaryL ">" NGt
|
||||
, binaryL "<=" NLte
|
||||
, binaryL ">=" NGte ]
|
||||
, {- 11 -} [ binaryN "==" NEq
|
||||
, binaryN "!=" NNEq ]
|
||||
, {- 12 -} [ binaryL "&&" NAnd ]
|
||||
, {- 13 -} [ binaryL "||" NOr ]
|
||||
, {- 14 -} [ binaryN "->" NImpl ]
|
||||
InfixL $ nApp <$ symbol ""
|
||||
)
|
||||
]
|
||||
, {- 3 -}
|
||||
[prefix "-" NNeg]
|
||||
, {- 4 -}
|
||||
[ ( NSpecialDef "?" NHasAttrOp NAssocLeft
|
||||
, Postfix $ symbol "?" *> (flip nHasAttr <$> selector)
|
||||
)
|
||||
]
|
||||
, {- 5 -}
|
||||
[binaryR "++" NConcat]
|
||||
, {- 6 -}
|
||||
[binaryL "*" NMult, binaryL "/" NDiv]
|
||||
, {- 7 -}
|
||||
[binaryL "+" NPlus, binaryL "-" NMinus]
|
||||
, {- 8 -}
|
||||
[prefix "!" NNot]
|
||||
, {- 9 -}
|
||||
[binaryR "//" NUpdate]
|
||||
, {- 10 -}
|
||||
[binaryL "<" NLt, binaryL ">" NGt, binaryL "<=" NLte, binaryL ">=" NGte]
|
||||
, {- 11 -}
|
||||
[binaryN "==" NEq, binaryN "!=" NNEq]
|
||||
, {- 12 -}
|
||||
[binaryL "&&" NAnd]
|
||||
, {- 13 -}
|
||||
[binaryL "||" NOr]
|
||||
, {- 14 -}
|
||||
[binaryN "->" NImpl]
|
||||
]
|
||||
|
||||
data OperatorInfo = OperatorInfo
|
||||
|
@ -553,7 +639,8 @@ data OperatorInfo = OperatorInfo
|
|||
|
||||
getUnaryOperator :: NUnaryOp -> OperatorInfo
|
||||
getUnaryOperator = (m Map.!) where
|
||||
m = Map.fromList $ concat $ zipWith buildEntry [1..]
|
||||
m = Map.fromList $ concat $ zipWith buildEntry
|
||||
[1 ..]
|
||||
(nixOperators (error "unused"))
|
||||
buildEntry i = concatMap $ \case
|
||||
(NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)]
|
||||
|
@ -561,7 +648,8 @@ getUnaryOperator = (m Map.!) where
|
|||
|
||||
getBinaryOperator :: NBinaryOp -> OperatorInfo
|
||||
getBinaryOperator = (m Map.!) where
|
||||
m = Map.fromList $ concat $ zipWith buildEntry [1..]
|
||||
m = Map.fromList $ concat $ zipWith buildEntry
|
||||
[1 ..]
|
||||
(nixOperators (error "unused"))
|
||||
buildEntry i = concatMap $ \case
|
||||
(NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
|
||||
|
@ -570,8 +658,17 @@ getBinaryOperator = (m Map.!) where
|
|||
getSpecialOperator :: NSpecialOp -> OperatorInfo
|
||||
getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "."
|
||||
getSpecialOperator o = m Map.! o where
|
||||
m = Map.fromList $ concat $ zipWith buildEntry [1..]
|
||||
m = Map.fromList $ concat $ zipWith buildEntry
|
||||
[1 ..]
|
||||
(nixOperators (error "unused"))
|
||||
buildEntry i = concatMap $ \case
|
||||
(NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
|
||||
_ -> []
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -16,17 +16,25 @@
|
|||
|
||||
module Nix.Pretty where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Control.Comonad
|
||||
import Data.Fix
|
||||
import Data.HashMap.Lazy (toList)
|
||||
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 Data.List ( isPrefixOf
|
||||
, sort
|
||||
)
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe (isJust, fromMaybe)
|
||||
import Data.Text (pack, unpack, replace, strip)
|
||||
import Data.Maybe ( isJust
|
||||
, fromMaybe
|
||||
)
|
||||
import Data.Text ( pack
|
||||
, unpack
|
||||
, replace
|
||||
, strip
|
||||
)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Nix.Atoms
|
||||
|
@ -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.
|
||||
|
@ -96,29 +104,35 @@ hasAttrOp = getSpecialOperator NHasAttrOp
|
|||
|
||||
wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann
|
||||
wrapParens op sub
|
||||
| precedence (rootOp sub) < precedence op = withoutParens sub
|
||||
| precedence (rootOp sub) == precedence op
|
||||
&& associativity (rootOp sub) == associativity op
|
||||
&& associativity op /= NAssocNone = withoutParens sub
|
||||
| otherwise = parens $ withoutParens sub
|
||||
| precedence (rootOp sub) < precedence op
|
||||
= withoutParens sub
|
||||
| precedence (rootOp sub)
|
||||
== precedence op
|
||||
&& associativity (rootOp sub)
|
||||
== associativity op
|
||||
&& associativity op
|
||||
/= NAssocNone
|
||||
= withoutParens sub
|
||||
| otherwise
|
||||
= parens $ withoutParens sub
|
||||
|
||||
-- Used in the selector case to print a path in a selector as
|
||||
-- "${./abc}"
|
||||
wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann
|
||||
wrapPath op sub =
|
||||
if wasPath sub
|
||||
wrapPath op sub = if wasPath sub
|
||||
then dquotes $ "$" <> braces (withoutParens sub)
|
||||
else wrapParens op sub
|
||||
|
||||
prettyString :: NString (NixDoc ann)-> Doc ann
|
||||
prettyString :: NString (NixDoc ann) -> Doc ann
|
||||
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
|
||||
where prettyPart (Plain t) = pretty . concatMap escape . unpack $ t
|
||||
where
|
||||
prettyPart (Plain t) = pretty . concatMap escape . unpack $ t
|
||||
prettyPart EscapedNewline = "''\\n"
|
||||
prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
|
||||
escape '"' = "\\\""
|
||||
escape x = maybe [x] (('\\':) . (:[])) $ toEscapeCode x
|
||||
prettyString (Indented _ parts)
|
||||
= group $ nest 2 $ vcat [dsquote, content, dsquote]
|
||||
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
|
||||
|
@ -126,42 +140,48 @@ prettyString (Indented _ parts)
|
|||
f ([Plain t] : xs) | Text.null (strip t) = xs
|
||||
f xs = xs
|
||||
prettyLine = hcat . map prettyPart
|
||||
prettyPart (Plain t) = pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t
|
||||
prettyPart (Plain t) =
|
||||
pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t
|
||||
prettyPart EscapedNewline = "\\n"
|
||||
prettyPart (Antiquoted r) = "$" <> braces (withoutParens r)
|
||||
|
||||
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)
|
||||
|
||||
prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann
|
||||
prettyParamSet args var =
|
||||
encloseSep (lbrace <> space) (align (space <> rbrace)) sep (map prettySetArg args ++ prettyVariadic)
|
||||
prettyParamSet args var = encloseSep
|
||||
(lbrace <> space)
|
||||
(align (space <> rbrace))
|
||||
sep
|
||||
(map prettySetArg args ++ prettyVariadic)
|
||||
where
|
||||
prettySetArg (n, maybeDef) = case maybeDef of
|
||||
Nothing -> pretty (unpack n)
|
||||
Just v -> pretty (unpack n) <+> "?" <+> withoutParens v
|
||||
prettyVariadic = ["..." | var]
|
||||
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
|
||||
prettyBind (Inherit s ns _p) =
|
||||
"inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi
|
||||
where scope = maybe mempty ((<> space) . parens . withoutParens) s
|
||||
|
||||
prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann
|
||||
prettyKeyName (StaticKey "") = dquotes ""
|
||||
prettyKeyName (StaticKey key)
|
||||
| HashSet.member key reservedNames = dquotes $ pretty $ unpack key
|
||||
prettyKeyName (StaticKey key) | HashSet.member key reservedNames =
|
||||
dquotes $ pretty $ unpack key
|
||||
prettyKeyName (StaticKey key) = pretty . unpack $ key
|
||||
prettyKeyName (DynamicKey key) =
|
||||
runAntiquoted (DoubleQuoted [Plain "\n"])
|
||||
prettyString (("$" <>) . braces . withoutParens) key
|
||||
prettyKeyName (DynamicKey key) = runAntiquoted
|
||||
(DoubleQuoted [Plain "\n"])
|
||||
prettyString
|
||||
(("$" <>) . braces . withoutParens)
|
||||
key
|
||||
|
||||
prettySelector :: NAttrPath (NixDoc ann) -> Doc ann
|
||||
prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList
|
||||
|
@ -177,8 +197,11 @@ instance HasCitations1 t f m
|
|||
citations (NValue f) = citations1 f
|
||||
addProvenance x (NValue f) = NValue (addProvenance1 x f)
|
||||
|
||||
prettyOriginExpr :: forall t f m ann. HasCitations1 t f m
|
||||
=> NExprLocF (Maybe (NValue t f m)) -> Doc ann
|
||||
prettyOriginExpr
|
||||
:: forall t f m ann
|
||||
. HasCitations1 t f m
|
||||
=> NExprLocF (Maybe (NValue t f m))
|
||||
-> Doc ann
|
||||
prettyOriginExpr = withoutParens . go
|
||||
where
|
||||
go = exprFNixDoc . annotated . getCompose . fmap render
|
||||
|
@ -197,27 +220,34 @@ exprFNixDoc = \case
|
|||
NConstant atom -> prettyAtom atom
|
||||
NStr str -> simpleExpr $ prettyString str
|
||||
NList [] -> simpleExpr $ lbracket <> rbracket
|
||||
NList xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
|
||||
[ [lbracket]
|
||||
, map (wrapParens appOpNonAssoc) xs
|
||||
, [rbracket]
|
||||
]
|
||||
NList xs ->
|
||||
simpleExpr
|
||||
$ group
|
||||
$ nest 2
|
||||
$ vsep
|
||||
$ concat
|
||||
$ [[lbracket], map (wrapParens appOpNonAssoc) xs, [rbracket]]
|
||||
NSet [] -> simpleExpr $ lbrace <> rbrace
|
||||
NSet xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
|
||||
[ [lbrace]
|
||||
, map prettyBind xs
|
||||
, [rbrace]
|
||||
]
|
||||
NSet xs ->
|
||||
simpleExpr
|
||||
$ group
|
||||
$ nest 2
|
||||
$ vsep
|
||||
$ concat
|
||||
$ [[lbrace], map prettyBind xs, [rbrace]]
|
||||
NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
|
||||
NRecSet xs -> simpleExpr $ group $ nest 2 $ vsep $ concat $
|
||||
[ [recPrefix <> lbrace]
|
||||
, map prettyBind xs
|
||||
, [rbrace]
|
||||
]
|
||||
NAbs args body -> leastPrecedence $ nest 2 $ vsep $
|
||||
[ prettyParams args <> colon
|
||||
, withoutParens body
|
||||
]
|
||||
NRecSet xs ->
|
||||
simpleExpr
|
||||
$ group
|
||||
$ nest 2
|
||||
$ vsep
|
||||
$ concat
|
||||
$ [[recPrefix <> lbrace], map prettyBind xs, [rbrace]]
|
||||
NAbs args body ->
|
||||
leastPrecedence
|
||||
$ nest 2
|
||||
$ vsep
|
||||
$ [prettyParams args <> colon, withoutParens body]
|
||||
NBinary NApp fun arg ->
|
||||
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
|
||||
|
@ -229,12 +259,16 @@ exprFNixDoc = \case
|
|||
opInfo = getBinaryOperator op
|
||||
f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }
|
||||
| otherwise = opInfo
|
||||
NUnary op r1 ->
|
||||
mkNixDoc (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
|
||||
NUnary op r1 -> mkNixDoc
|
||||
(pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1)
|
||||
opInfo
|
||||
where opInfo = getUnaryOperator op
|
||||
NSelect r' attr o ->
|
||||
(if isJust o then leastPrecedence else flip mkNixDoc selectOp) $
|
||||
wrapPath selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
(if isJust o then leastPrecedence else flip mkNixDoc selectOp)
|
||||
$ wrapPath selectOp r
|
||||
<> dot
|
||||
<> prettySelector attr
|
||||
<> ordoc
|
||||
where
|
||||
r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r'
|
||||
ordoc = maybe mempty (((space <> "or") <+>) . wrapParens appOpNonAssoc) o
|
||||
|
@ -251,43 +285,49 @@ exprFNixDoc = \case
|
|||
| "../" `isPrefixOf` txt -> txt
|
||||
| otherwise -> "./" ++ txt
|
||||
NSym name -> simpleExpr $ pretty (unpack name)
|
||||
NLet binds body -> leastPrecedence $ group $ vsep $
|
||||
[ "let"
|
||||
NLet binds body ->
|
||||
leastPrecedence
|
||||
$ group
|
||||
$ vsep
|
||||
$ [ "let"
|
||||
, indent 2 (vsep (map prettyBind binds))
|
||||
, "in" <+> withoutParens body
|
||||
]
|
||||
NIf cond trueBody falseBody -> leastPrecedence $
|
||||
group $ nest 2 $ vsep $
|
||||
[ "if" <+> withoutParens cond
|
||||
NIf cond trueBody falseBody ->
|
||||
leastPrecedence
|
||||
$ group
|
||||
$ nest 2
|
||||
$ vsep
|
||||
$ [ "if" <+> withoutParens cond
|
||||
, align ("then" <+> withoutParens trueBody)
|
||||
, align ("else" <+> withoutParens falseBody)
|
||||
]
|
||||
NWith scope body -> leastPrecedence $ vsep $
|
||||
[ "with" <+> withoutParens scope <> semi
|
||||
, align $ withoutParens body
|
||||
]
|
||||
NAssert cond body -> leastPrecedence $ vsep $
|
||||
[ "assert" <+> withoutParens cond <> semi
|
||||
, align $ withoutParens body
|
||||
]
|
||||
NWith scope body ->
|
||||
leastPrecedence
|
||||
$ vsep
|
||||
$ ["with" <+> withoutParens scope <> semi, align $ withoutParens body]
|
||||
NAssert cond body ->
|
||||
leastPrecedence
|
||||
$ vsep
|
||||
$ ["assert" <+> withoutParens cond <> semi, align $ withoutParens body]
|
||||
NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
|
||||
where
|
||||
recPrefix = "rec" <> space
|
||||
where recPrefix = "rec" <> space
|
||||
|
||||
valueToExpr :: forall t f m. MonadDataContext f m => NValueNF t f m -> NExpr
|
||||
valueToExpr :: 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 (NVConstant a ) = Fix $ NConstant a
|
||||
phi (NVStr ns) = mkStr ns
|
||||
phi (NVList l) = Fix $ NList l
|
||||
phi (NVSet s p) = Fix $ NSet
|
||||
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
|
||||
| (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"
|
||||
|
||||
|
@ -296,67 +336,88 @@ valueToExpr = iterNValueNF
|
|||
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 (NVConstant a ) = unpack $ atomText a
|
||||
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
|
||||
phi (NVList l) = "[ " ++ unwords l ++ " ]"
|
||||
phi (NVList l ) = "[ " ++ unwords l ++ " ]"
|
||||
phi (NVSet s _) =
|
||||
"{ " ++ concat [ check (unpack k) ++ " = " ++ v ++ "; "
|
||||
| (k, v) <- sort $ toList s ] ++ "}"
|
||||
"{ "
|
||||
++ concat
|
||||
[ check (unpack k) ++ " = " ++ v ++ "; "
|
||||
| (k, v) <- sort $ toList s
|
||||
]
|
||||
++ "}"
|
||||
where
|
||||
check v =
|
||||
fromMaybe v
|
||||
((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
|
||||
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)
|
||||
=> NValue t f m
|
||||
-> m (Doc ann)
|
||||
prettyNValue = fmap prettyNValueNF . removeEffectsM
|
||||
|
||||
prettyNValueProv
|
||||
:: forall t f m ann.
|
||||
( HasCitations1 t f m
|
||||
:: forall t f m ann
|
||||
. ( HasCitations1 t f m
|
||||
, MonadThunk t m (NValue t f m)
|
||||
, MonadDataContext f m
|
||||
)
|
||||
=> NValue t f m -> m (Doc ann)
|
||||
=> NValue t f m
|
||||
-> m (Doc ann)
|
||||
prettyNValueProv v@(NValue nv) = do
|
||||
let ps = citations1 @t @f @m nv
|
||||
case ps of
|
||||
[] -> prettyNValue v
|
||||
ps -> do
|
||||
v' <- prettyNValue v
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
, indent 2 $ parens $ mconcat
|
||||
pure
|
||||
$ fillSep
|
||||
$ [ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
||||
prettyNThunk
|
||||
:: forall t f m ann.
|
||||
( HasCitations t f m t
|
||||
:: forall t f m ann
|
||||
. ( HasCitations t f m t
|
||||
, HasCitations1 t f m
|
||||
, MonadThunk t m (NValue t f m)
|
||||
, MonadDataContext f m
|
||||
)
|
||||
=> t -> m (Doc ann)
|
||||
=> t
|
||||
-> m (Doc ann)
|
||||
prettyNThunk t = do
|
||||
let ps = citations @t @f @m @t t
|
||||
v' <- prettyNValueNF <$> dethunk t
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
, indent 2 $ parens $ mconcat
|
||||
pure
|
||||
$ fillSep
|
||||
$ [ v'
|
||||
, indent 2
|
||||
$ parens
|
||||
$ mconcat
|
||||
$ "thunk from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -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 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 Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe ( fromMaybe
|
||||
, mapMaybe
|
||||
, catMaybes
|
||||
)
|
||||
import Data.Text ( Text )
|
||||
import Nix.Atoms
|
||||
import Nix.Exec
|
||||
import Nix.Expr
|
||||
import Nix.Frames
|
||||
import Nix.Options (Options, reduceSets, reduceLists)
|
||||
import Nix.Options ( Options
|
||||
, reduceSets
|
||||
, reduceLists
|
||||
)
|
||||
import Nix.Parser
|
||||
import Nix.Scope
|
||||
import Nix.Utils
|
||||
|
@ -73,11 +80,16 @@ newtype Reducer m a = Reducer
|
|||
MonadState (HashMap FilePath NExprLoc))
|
||||
|
||||
staticImport
|
||||
:: forall m.
|
||||
(MonadIO m, Scoped NExprLoc m, MonadFail m,
|
||||
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
|
||||
MonadState (HashMap FilePath NExprLoc) m)
|
||||
=> SrcSpan -> FilePath -> m NExprLoc
|
||||
:: forall m
|
||||
. ( MonadIO m
|
||||
, Scoped NExprLoc m
|
||||
, MonadFail m
|
||||
, MonadReader (Maybe FilePath, Scopes m NExprLoc) m
|
||||
, MonadState (HashMap FilePath NExprLoc) m
|
||||
)
|
||||
=> SrcSpan
|
||||
-> FilePath
|
||||
-> m NExprLoc
|
||||
staticImport pann path = do
|
||||
mfile <- asks fst
|
||||
path <- liftIO $ pathToDefaultNixFile path
|
||||
|
@ -96,10 +108,12 @@ staticImport pann path = do
|
|||
case eres of
|
||||
Failure err -> error $ "Parse failed: " ++ show err
|
||||
Success x -> do
|
||||
let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
|
||||
let
|
||||
pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
|
||||
span = SrcSpan pos pos
|
||||
cur = NamedVar (StaticKey "__cur_file" :| [])
|
||||
(Fix (NLiteralPath_ pann path)) pos
|
||||
(Fix (NLiteralPath_ pann path))
|
||||
pos
|
||||
x' = Fix (NLet_ span [cur] x)
|
||||
modify (M.insert path x')
|
||||
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
|
||||
|
@ -112,19 +126,24 @@ staticImport pann path = do
|
|||
-- NSym_ _ var -> S.singleton var
|
||||
-- Compose (Ann _ x) -> fold x
|
||||
|
||||
reduceExpr :: (MonadIO m, MonadFail m)
|
||||
=> Maybe FilePath -> NExprLoc -> m NExprLoc
|
||||
reduceExpr mpath expr
|
||||
= (`evalStateT` M.empty)
|
||||
reduceExpr
|
||||
:: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc
|
||||
reduceExpr mpath expr =
|
||||
(`evalStateT` M.empty)
|
||||
. (`runReaderT` (mpath, emptyScopes))
|
||||
. runReducer
|
||||
$ cata reduce expr
|
||||
|
||||
reduce :: forall m.
|
||||
(MonadIO m, Scoped NExprLoc m, MonadFail m,
|
||||
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
|
||||
MonadState (HashMap FilePath NExprLoc) m)
|
||||
=> NExprLocF (m NExprLoc) -> m NExprLoc
|
||||
reduce
|
||||
:: forall m
|
||||
. ( MonadIO m
|
||||
, Scoped NExprLoc m
|
||||
, MonadFail m
|
||||
, MonadReader (Maybe FilePath, Scopes m NExprLoc) m
|
||||
, MonadState (HashMap FilePath NExprLoc) m
|
||||
)
|
||||
=> NExprLocF (m NExprLoc)
|
||||
-> m NExprLoc
|
||||
|
||||
-- | Reduce the variable to its value if defined.
|
||||
-- Leave it as it is otherwise.
|
||||
|
@ -182,18 +201,18 @@ reduce base@(NSelect_ _ _ attrs _)
|
|||
where
|
||||
sId = Fix <$> sequence base
|
||||
-- The selection AttrPath is composed of StaticKeys.
|
||||
sAttrPath (StaticKey _:xs) = sAttrPath xs
|
||||
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 (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
|
||||
(_, Just attrs) -> inspectSet (unFix e) attrs
|
||||
_ -> pure e
|
||||
_ -> sId
|
||||
inspectSet _ _ = sId
|
||||
|
@ -204,11 +223,10 @@ reduce base@(NSelect_ _ _ attrs _)
|
|||
-- if none of the binds inherit the super set.
|
||||
reduce e@(NSet_ ann binds) = do
|
||||
let usesInherit = flip any binds $ \case
|
||||
Inherit {} -> True
|
||||
Inherit{} -> True
|
||||
_ -> False
|
||||
if usesInherit
|
||||
then clearScopes @NExprLoc $
|
||||
Fix . NSet_ ann <$> traverse sequence binds
|
||||
then clearScopes @NExprLoc $ Fix . NSet_ ann <$> traverse sequence binds
|
||||
else Fix <$> sequence e
|
||||
|
||||
-- Encountering a 'rec set' construction eliminates any hope of inlining
|
||||
|
@ -226,9 +244,9 @@ reduce (NWith_ ann scope body) =
|
|||
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)
|
||||
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
|
||||
|
@ -280,8 +298,7 @@ instance Show (f r) => Show (FlaggedF f r) where
|
|||
|
||||
type Flagged f = Fix (FlaggedF f)
|
||||
|
||||
flagExprLoc :: (MonadIO n, Traversable f)
|
||||
=> Fix f -> n (Flagged f)
|
||||
flagExprLoc :: (MonadIO n, Traversable f) => Fix f -> n (Flagged f)
|
||||
flagExprLoc = cataM $ \x -> do
|
||||
flag <- liftIO $ newIORef False
|
||||
pure $ Fix $ FlaggedF (flag, x)
|
||||
|
@ -292,21 +309,21 @@ flagExprLoc = cataM $ \x -> do
|
|||
pruneTree :: MonadIO n => Options -> Flagged NExprLocF -> n (Maybe NExprLoc)
|
||||
pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
|
||||
used <- liftIO $ readIORef b
|
||||
pure $ if used
|
||||
then Fix . Compose <$> traverse prune x
|
||||
else Nothing
|
||||
pure $ if used then Fix . Compose <$> traverse prune x else Nothing
|
||||
where
|
||||
prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
|
||||
prune = \case
|
||||
NStr str -> Just $ NStr (pruneString str)
|
||||
NHasAttr (Just aset) attr -> Just $ NHasAttr aset (NE.map pruneKeyName attr)
|
||||
NHasAttr (Just aset) attr ->
|
||||
Just $ NHasAttr aset (NE.map pruneKeyName attr)
|
||||
NAbs params (Just body) -> Just $ NAbs (pruneParams params) body
|
||||
|
||||
NList l | reduceLists opts -> Just $ NList (catMaybes l)
|
||||
| otherwise -> Just $ NList (map (fromMaybe nNull) l)
|
||||
NSet binds | reduceSets opts -> Just $ NSet (mapMaybe sequence binds)
|
||||
| otherwise -> Just $ NSet (map (fmap (fromMaybe nNull)) binds)
|
||||
NRecSet binds | reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds)
|
||||
NRecSet binds
|
||||
| reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds)
|
||||
| otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds)
|
||||
|
||||
NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
|
||||
|
@ -341,8 +358,7 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
|
|||
NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body
|
||||
NAssert (Just cond) _ -> Just $ NAssert cond nNull
|
||||
|
||||
NIf Nothing _ _ ->
|
||||
error "How can an if be used, but its condition not?"
|
||||
NIf Nothing _ _ -> error "How can an if be used, but its condition not?"
|
||||
|
||||
NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f
|
||||
NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t
|
||||
|
@ -352,15 +368,13 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
|
|||
pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
|
||||
pruneString (DoubleQuoted xs) =
|
||||
DoubleQuoted (mapMaybe pruneAntiquotedText xs)
|
||||
pruneString (Indented n xs) =
|
||||
Indented n (mapMaybe pruneAntiquotedText xs)
|
||||
pruneString (Indented n xs) = Indented n (mapMaybe pruneAntiquotedText xs)
|
||||
|
||||
pruneAntiquotedText
|
||||
:: Antiquoted Text (Maybe NExprLoc)
|
||||
-> Maybe (Antiquoted Text NExprLoc)
|
||||
:: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)
|
||||
pruneAntiquotedText (Plain v) = Just (Plain v)
|
||||
pruneAntiquotedText EscapedNewline = Just EscapedNewline
|
||||
pruneAntiquotedText (Antiquoted Nothing) = Nothing
|
||||
pruneAntiquotedText (Antiquoted Nothing ) = Nothing
|
||||
pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k)
|
||||
|
||||
pruneAntiquoted
|
||||
|
@ -368,23 +382,22 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
|
|||
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
|
||||
pruneAntiquoted (Plain v) = Just (Plain (pruneString v))
|
||||
pruneAntiquoted EscapedNewline = Just EscapedNewline
|
||||
pruneAntiquoted (Antiquoted Nothing) = Nothing
|
||||
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'
|
||||
pruneKeyName (DynamicKey k) | Just k' <- pruneAntiquoted k = DynamicKey k'
|
||||
| otherwise = StaticKey "<unused?>"
|
||||
|
||||
pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
|
||||
pruneParams (Param n) = Param n
|
||||
pruneParams (ParamSet xs b n)
|
||||
| reduceSets opts =
|
||||
ParamSet (map (second (maybe (Just nNull) Just
|
||||
. fmap (fromMaybe nNull))) xs) b n
|
||||
| otherwise =
|
||||
ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n
|
||||
| reduceSets opts = ParamSet
|
||||
(map (second (maybe (Just nNull) Just . fmap (fromMaybe nNull))) xs)
|
||||
b
|
||||
n
|
||||
| otherwise = ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n
|
||||
|
||||
pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
|
||||
pruneBinding (NamedVar _ Nothing _) = Nothing
|
||||
|
@ -407,8 +420,7 @@ reducingEvalExpr eval mpath expr = do
|
|||
opts :: Options <- asks (view hasLens)
|
||||
expr'' <- pruneTree opts expr'
|
||||
return (fromMaybe nNull expr'', eres)
|
||||
where
|
||||
addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
|
||||
where addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
|
||||
|
||||
instance Monad m => Scoped NExprLoc (Reducer m) where
|
||||
currentScopes = currentScopesReader
|
||||
|
|
|
@ -11,10 +11,10 @@
|
|||
|
||||
module Nix.Render where
|
||||
|
||||
import Prelude hiding (readFile)
|
||||
import Prelude hiding ( readFile )
|
||||
|
||||
import Control.Monad.Trans
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
@ -68,48 +68,59 @@ instance MonadFile IO where
|
|||
getSymbolicLinkStatus = S.getSymbolicLinkStatus
|
||||
|
||||
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
|
||||
posAndMsg (SourcePos _ lineNo _) msg =
|
||||
FancyError (unPos lineNo)
|
||||
posAndMsg (SourcePos _ lineNo _) msg = FancyError
|
||||
(unPos lineNo)
|
||||
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
|
||||
|
||||
renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
|
||||
renderLocation (SrcSpan (SourcePos file begLine begCol)
|
||||
(SourcePos file' endLine endCol)) msg
|
||||
| file /= "<string>" && file == file' = do
|
||||
renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg
|
||||
| file /= "<string>" && file == file'
|
||||
= do
|
||||
exist <- doesFileExist file
|
||||
if exist
|
||||
then do
|
||||
txt <- sourceContext file begLine begCol endLine endCol msg
|
||||
return $ vsep
|
||||
[ "In file " <> errorContext file begLine begCol endLine endCol <> ":"
|
||||
return
|
||||
$ vsep
|
||||
[ "In file "
|
||||
<> errorContext file begLine begCol endLine endCol
|
||||
<> ":"
|
||||
, txt
|
||||
]
|
||||
else return msg
|
||||
renderLocation (SrcSpan beg end) msg =
|
||||
fail $ "Don't know how to render range from " ++ show beg ++ " to " ++ show end
|
||||
++ " for error: " ++ show msg
|
||||
fail
|
||||
$ "Don't know how to render range from "
|
||||
++ show beg
|
||||
++ " to "
|
||||
++ show end
|
||||
++ " for error: "
|
||||
++ show msg
|
||||
|
||||
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
|
||||
errorContext path bl bc _el _ec =
|
||||
pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc)
|
||||
|
||||
sourceContext :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
|
||||
sourceContext path (unPos -> begLine) (unPos -> _begCol)
|
||||
(unPos -> endLine) (unPos -> _endCol) msg = do
|
||||
sourceContext
|
||||
:: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
|
||||
sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg
|
||||
= do
|
||||
let beg' = max 1 (min begLine (begLine - 3))
|
||||
end' = max endLine (endLine + 3)
|
||||
ls <- map pretty
|
||||
ls <-
|
||||
map pretty
|
||||
. take (end' - beg')
|
||||
. drop (pred beg')
|
||||
. T.lines
|
||||
. T.decodeUtf8
|
||||
<$> readFile path
|
||||
let nums = map (show . fst) $ zip [beg'..] ls
|
||||
let
|
||||
nums = map (show . fst) $ zip [beg' ..] ls
|
||||
longest = maximum (map length nums)
|
||||
nums' = flip map nums $ \n ->
|
||||
replicate (longest - length n) ' ' ++ n
|
||||
nums' = flip map nums $ \n -> replicate (longest - length n) ' ' ++ n
|
||||
pad n | read n == begLine = "==> " ++ n
|
||||
| otherwise = " " ++ n
|
||||
ls' = zipWith (<+>) (map (pretty . pad) nums')
|
||||
ls' = zipWith (<+>)
|
||||
(map (pretty . pad) nums')
|
||||
(zipWith (<+>) (repeat "| ") ls)
|
||||
pure $ vsep $ ls' ++ [msg]
|
||||
|
|
|
@ -41,18 +41,17 @@ renderFrames
|
|||
, MonadCitedThunks t f m
|
||||
, Typeable v
|
||||
)
|
||||
=> Frames -> m (Doc ann)
|
||||
=> Frames
|
||||
-> m (Doc ann)
|
||||
renderFrames [] = pure mempty
|
||||
renderFrames (x:xs) = do
|
||||
renderFrames (x : xs) = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
frames <-
|
||||
if | verbose opts <= ErrorsOnly ->
|
||||
renderFrame @v @t @f x
|
||||
frames <- if
|
||||
| verbose opts <= ErrorsOnly -> renderFrame @v @t @f x
|
||||
| verbose opts <= Informational -> do
|
||||
f <- renderFrame @v @t @f x
|
||||
pure $ concatMap go (reverse xs) ++ f
|
||||
| otherwise ->
|
||||
concat <$> mapM (renderFrame @v @t @f) (reverse (x:xs))
|
||||
| otherwise -> concat <$> mapM (renderFrame @v @t @f) (reverse (x : xs))
|
||||
pure $ case frames of
|
||||
[] -> mempty
|
||||
_ -> vsep frames
|
||||
|
@ -60,29 +59,30 @@ renderFrames (x:xs) = do
|
|||
go :: NixFrame -> [Doc ann]
|
||||
go f = case framePos @v @m f of
|
||||
Just pos ->
|
||||
["While evaluating at "
|
||||
<> pretty (sourcePosPretty pos)
|
||||
<> colon]
|
||||
["While evaluating at " <> pretty (sourcePosPretty pos) <> colon]
|
||||
Nothing -> []
|
||||
|
||||
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v)
|
||||
=> NixFrame -> Maybe SourcePos
|
||||
framePos
|
||||
:: forall v (m :: * -> *)
|
||||
. (Typeable m, Typeable v)
|
||||
=> NixFrame
|
||||
-> Maybe SourcePos
|
||||
framePos (NixFrame _ f)
|
||||
| Just (e :: EvalFrame m v) <- fromException f = case e of
|
||||
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
|
||||
Just beg
|
||||
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg
|
||||
_ -> Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
renderFrame
|
||||
:: forall v t f e m ann.
|
||||
( MonadReader e m
|
||||
:: forall v t f e m ann
|
||||
. ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
, Typeable v
|
||||
)
|
||||
=> NixFrame -> m [Doc ann]
|
||||
=> NixFrame
|
||||
-> m [Doc ann]
|
||||
renderFrame (NixFrame level f)
|
||||
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
|
||||
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
|
||||
|
@ -96,39 +96,50 @@ renderFrame (NixFrame level f)
|
|||
wrapExpr :: NExprF r -> NExpr
|
||||
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
|
||||
|
||||
renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m)
|
||||
=> NixLevel -> EvalFrame m v -> m [Doc ann]
|
||||
renderEvalFrame
|
||||
:: (MonadReader e m, Has e Options, MonadFile m)
|
||||
=> NixLevel
|
||||
-> EvalFrame m v
|
||||
-> m [Doc ann]
|
||||
renderEvalFrame level f = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
case f of
|
||||
EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do
|
||||
let scopeInfo | scopes opts = [pretty $ show scope]
|
||||
| otherwise = []
|
||||
fmap (\x -> scopeInfo ++ [x]) $ renderLocation ann
|
||||
fmap (\x -> scopeInfo ++ [x])
|
||||
$ renderLocation ann
|
||||
=<< renderExpr level "While evaluating" "Expression" e
|
||||
|
||||
ForcingExpr _scope e@(Fix (Compose (Ann ann _)))
|
||||
| thunks opts ->
|
||||
fmap (:[]) $ renderLocation ann
|
||||
=<< renderExpr level "While forcing thunk from"
|
||||
"Forcing thunk" e
|
||||
ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts ->
|
||||
fmap (: [])
|
||||
$ renderLocation ann
|
||||
=<< renderExpr level "While forcing thunk from" "Forcing thunk" e
|
||||
|
||||
Calling name ann ->
|
||||
fmap (:[]) $ renderLocation ann $
|
||||
"While calling builtins." <> pretty name
|
||||
fmap (: [])
|
||||
$ renderLocation ann
|
||||
$ "While calling builtins."
|
||||
<> pretty name
|
||||
|
||||
SynHole synfo -> sequence $
|
||||
let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
|
||||
in [ renderLocation ann =<<
|
||||
renderExpr level "While evaluating" "Syntactic Hole" e
|
||||
SynHole synfo ->
|
||||
sequence
|
||||
$ let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
|
||||
in [ renderLocation ann
|
||||
=<< renderExpr level "While evaluating" "Syntactic Hole" e
|
||||
, pure $ pretty $ show (_synHoleInfo_scope synfo)
|
||||
]
|
||||
|
||||
ForcingExpr _ _ -> pure []
|
||||
|
||||
|
||||
renderExpr :: (MonadReader e m, Has e Options, MonadFile m)
|
||||
=> NixLevel -> String -> String -> NExprLoc -> m (Doc ann)
|
||||
renderExpr
|
||||
:: (MonadReader e m, Has e Options, MonadFile m)
|
||||
=> NixLevel
|
||||
-> String
|
||||
-> String
|
||||
-> NExprLoc
|
||||
-> m (Doc ann)
|
||||
renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
let rendered
|
||||
|
@ -138,26 +149,20 @@ renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
|
|||
#else
|
||||
pretty (show (stripAnnotation e))
|
||||
#endif
|
||||
| verbose opts >= Chatty =
|
||||
prettyNix (stripAnnotation e)
|
||||
| otherwise =
|
||||
prettyNix (Fix (Fix (NSym "<?>") <$ x))
|
||||
| verbose opts >= Chatty = prettyNix (stripAnnotation e)
|
||||
| otherwise = prettyNix (Fix (Fix (NSym "<?>") <$ x))
|
||||
pure $ if verbose opts >= Chatty
|
||||
then vsep $
|
||||
[ pretty (longLabel ++ ":\n>>>>>>>>")
|
||||
, indent 2 rendered
|
||||
, "<<<<<<<<"
|
||||
]
|
||||
then
|
||||
vsep
|
||||
$ [pretty (longLabel ++ ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"]
|
||||
else pretty shortLabel <> fillSep [": ", rendered]
|
||||
|
||||
renderValueFrame
|
||||
:: ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
=> NixLevel -> ValueFrame t f m -> m [Doc ann]
|
||||
renderValueFrame level = fmap (:[]) . \case
|
||||
:: (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"
|
||||
|
@ -165,12 +170,8 @@ renderValueFrame level = fmap (:[]) . \case
|
|||
Division _ _ -> pure "Dividing"
|
||||
Multiplication _ _ -> pure "Multiplying"
|
||||
|
||||
Coercion x y -> pure $ mconcat
|
||||
[ desc
|
||||
, pretty (describeValue x)
|
||||
, " to "
|
||||
, pretty (describeValue y)
|
||||
]
|
||||
Coercion x y -> pure
|
||||
$ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)]
|
||||
where
|
||||
desc | level <= Error = "Cannot coerce "
|
||||
| otherwise = "While coercing "
|
||||
|
@ -182,49 +183,54 @@ renderValueFrame level = fmap (:[]) . \case
|
|||
ExpectationNF _t _v -> pure "ExpectationNF"
|
||||
Expectation t v -> do
|
||||
v' <- renderValue level "" "" v
|
||||
pure $ "Saw " <> v'
|
||||
<> " but expected " <> pretty (describeValue t)
|
||||
pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
|
||||
|
||||
renderValue
|
||||
:: ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
=> NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
|
||||
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
|
||||
=> NixLevel
|
||||
-> String
|
||||
-> String
|
||||
-> NValue t f m
|
||||
-> m (Doc ann)
|
||||
renderValue _level _longLabel _shortLabel v = do
|
||||
opts :: Options <- asks (view hasLens)
|
||||
if values opts
|
||||
then prettyNValueProv v
|
||||
else prettyNValue v
|
||||
if values opts then prettyNValueProv v else prettyNValue v
|
||||
|
||||
renderExecFrame
|
||||
:: ( MonadReader e m
|
||||
, Has e Options
|
||||
, MonadFile m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
=> NixLevel -> ExecFrame t f m -> m [Doc ann]
|
||||
:: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
|
||||
=> NixLevel
|
||||
-> ExecFrame t f m
|
||||
-> m [Doc ann]
|
||||
renderExecFrame level = \case
|
||||
Assertion ann v ->
|
||||
fmap (:[]) $ renderLocation ann
|
||||
=<< ((\d -> fillSep ["Assertion failed:", d])
|
||||
<$> renderValue level "" "" 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
|
||||
=> 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
|
||||
:: (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'
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ module Nix.Scope where
|
|||
import Control.Applicative
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import Lens.Family2
|
||||
import Nix.Utils
|
||||
|
||||
|
@ -31,8 +31,7 @@ newScope = Scope
|
|||
|
||||
scopeLookup :: Text -> [Scope t] -> Maybe t
|
||||
scopeLookup key = foldr go Nothing
|
||||
where
|
||||
go (Scope m) rest = M.lookup key m <|> rest
|
||||
where go (Scope m) rest = M.lookup key m <|> rest
|
||||
|
||||
data Scopes m t = Scopes
|
||||
{ lexicalScopes :: [Scope t]
|
||||
|
@ -41,8 +40,7 @@ data Scopes m t = Scopes
|
|||
|
||||
instance Show (Scopes m t) where
|
||||
show (Scopes m t) =
|
||||
"Scopes: " ++ show m ++ ", and "
|
||||
++ show (length t) ++ " with-scopes"
|
||||
"Scopes: " ++ show m ++ ", and " ++ show (length t) ++ " with-scopes"
|
||||
|
||||
instance Semigroup (Scopes m t) where
|
||||
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
|
||||
|
@ -51,7 +49,7 @@ instance Monoid (Scopes m t) where
|
|||
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
|
||||
foldr
|
||||
(\x rest -> do
|
||||
mres' <- M.lookup k . getScope <$> x
|
||||
case mres' of
|
||||
Just sym -> return $ Just sym
|
||||
Nothing -> rest)
|
||||
(return Nothing) ws
|
||||
Nothing -> rest
|
||||
)
|
||||
(return Nothing)
|
||||
ws
|
||||
|
||||
withScopes :: Scoped t m => Scopes m t -> m a -> m a
|
||||
withScopes scope = clearScopes . pushScopes scope
|
||||
|
|
|
@ -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,13 +29,14 @@ module Nix.String (
|
|||
, addSingletonStringContext
|
||||
, runWithStringContextT
|
||||
, runWithStringContext
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Writer
|
||||
import Data.Functor.Identity
|
||||
import qualified Data.HashSet as S
|
||||
import Data.Hashable
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as Text
|
||||
import GHC.Generics
|
||||
|
||||
|
@ -73,11 +74,13 @@ principledMempty = NixString "" mempty
|
|||
|
||||
-- | Combine two NixStrings using mappend
|
||||
principledStringMappend :: NixString -> NixString -> NixString
|
||||
principledStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
|
||||
principledStringMappend (NixString s1 t1) (NixString s2 t2) =
|
||||
NixString (s1 <> s2) (t1 <> t2)
|
||||
|
||||
-- | Combine two NixStrings using mappend
|
||||
hackyStringMappend :: NixString -> NixString -> NixString
|
||||
hackyStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
|
||||
hackyStringMappend (NixString s1 t1) (NixString s2 t2) =
|
||||
NixString (s1 <> s2) (t1 <> t2)
|
||||
|
||||
-- | Combine NixStrings with a separator
|
||||
principledIntercalateNixString :: NixString -> [NixString] -> NixString
|
||||
|
@ -98,7 +101,8 @@ principledStringMempty = NixString mempty mempty
|
|||
|
||||
-- | Combine NixStrings using mconcat
|
||||
principledStringMConcat :: [NixString] -> NixString
|
||||
principledStringMConcat = foldr principledStringMappend (NixString mempty mempty)
|
||||
principledStringMConcat =
|
||||
foldr principledStringMappend (NixString mempty mempty)
|
||||
|
||||
--instance Semigroup NixString where
|
||||
--NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
|
||||
|
@ -142,7 +146,8 @@ principledModifyNixContents :: (Text -> Text) -> NixString -> NixString
|
|||
principledModifyNixContents f (NixString s c) = NixString (f s) c
|
||||
|
||||
-- | Create a NixString using a singleton context
|
||||
principledMakeNixStringWithSingletonContext :: Text -> StringContext -> NixString
|
||||
principledMakeNixStringWithSingletonContext
|
||||
:: Text -> StringContext -> NixString
|
||||
principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)
|
||||
|
||||
-- | Create a NixString from a Text and context
|
||||
|
@ -156,7 +161,8 @@ newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringCo
|
|||
type WithStringContext = WithStringContextT Identity
|
||||
|
||||
-- | Add 'StringContext's into the resulting set.
|
||||
addStringContext :: Monad m => S.HashSet StringContext -> WithStringContextT m ()
|
||||
addStringContext
|
||||
:: Monad m => S.HashSet StringContext -> WithStringContextT m ()
|
||||
addStringContext = WithStringContextT . tell
|
||||
|
||||
-- | Add a 'StringContext' into the resulting set.
|
||||
|
@ -169,7 +175,8 @@ extractNixString (NixString s c) = WithStringContextT $ tell c >> return s
|
|||
|
||||
-- | Run an action producing a string with a context and put those into a 'NixString'.
|
||||
runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString
|
||||
runWithStringContextT (WithStringContextT m) = uncurry NixString <$> runWriterT m
|
||||
runWithStringContextT (WithStringContextT m) =
|
||||
uncurry NixString <$> runWriterT m
|
||||
|
||||
-- | Run an action producing a string with a context and put those into a 'NixString'.
|
||||
runWithStringContext :: WithStringContextT Identity Text -> NixString
|
||||
|
|
|
@ -4,20 +4,23 @@
|
|||
-- | Functions for manipulating nix strings.
|
||||
module Nix.Strings where
|
||||
|
||||
import Data.List (intercalate, dropWhileEnd, inits)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
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.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 : 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 : 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.
|
||||
|
@ -42,11 +45,11 @@ runAntiquoted _ _ k (Antiquoted r) = k r
|
|||
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
|
||||
(l : ls) = T.split (== '\n') t
|
||||
f prefix (finished, current) = ((Plain prefix : current) : finished, [])
|
||||
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'.
|
||||
|
@ -62,10 +65,18 @@ stripIndent xs =
|
|||
. mergePlain
|
||||
. map snd
|
||||
. dropWhileEnd cleanup
|
||||
. (\ys -> zip (map (\case [] -> Nothing
|
||||
x -> Just (last x))
|
||||
(inits ys)) ys)
|
||||
. unsplitLines $ ls'
|
||||
. (\ys -> zip
|
||||
(map
|
||||
(\case
|
||||
[] -> Nothing
|
||||
x -> Just (last x)
|
||||
)
|
||||
(inits ys)
|
||||
)
|
||||
ys
|
||||
)
|
||||
. unsplitLines
|
||||
$ ls'
|
||||
where
|
||||
ls = stripEmptyOpening $ splitLines xs
|
||||
ls' = map (dropSpaces minIndent) ls
|
||||
|
@ -78,11 +89,11 @@ stripIndent xs =
|
|||
[Plain t] -> not $ T.null $ T.strip t
|
||||
_ -> True
|
||||
|
||||
stripEmptyOpening ([Plain t]:ts) | T.null (T.strip t) = ts
|
||||
stripEmptyOpening ([Plain t] : ts) | T.null (T.strip t) = ts
|
||||
stripEmptyOpening ts = ts
|
||||
|
||||
countSpaces (Antiquoted _:_) = 0
|
||||
countSpaces (EscapedNewline:_) = 0
|
||||
countSpaces (Antiquoted _ : _) = 0
|
||||
countSpaces (EscapedNewline : _) = 0
|
||||
countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t
|
||||
countSpaces [] = 0
|
||||
|
||||
|
@ -91,19 +102,12 @@ stripIndent xs =
|
|||
dropSpaces _ _ = error "stripIndent: impossible"
|
||||
|
||||
cleanup (Nothing, Plain y) = T.all (== ' ') y
|
||||
cleanup (Just (Plain x), Plain y)
|
||||
| "\n" `T.isSuffixOf` x = T.all (== ' ') y
|
||||
cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y
|
||||
cleanup _ = False
|
||||
|
||||
escapeCodes :: [(Char, Char)]
|
||||
escapeCodes =
|
||||
[ ('\n', 'n' )
|
||||
, ('\r', 'r' )
|
||||
, ('\t', 't' )
|
||||
, ('\\', '\\')
|
||||
, ('$' , '$' )
|
||||
, ('"', '"')
|
||||
]
|
||||
[('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')]
|
||||
|
||||
fromEscapeCode :: Char -> Maybe Char
|
||||
fromEscapeCode = (`lookup` map swap escapeCodes)
|
||||
|
|
|
@ -10,11 +10,13 @@ module Nix.TH where
|
|||
|
||||
import Data.Fix
|
||||
import Data.Generics.Aliases
|
||||
import Data.Set (Set, (\\))
|
||||
import Data.Set ( Set
|
||||
, (\\)
|
||||
)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Maybe ( mapMaybe )
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Nix.Atoms
|
||||
|
@ -37,40 +39,49 @@ quoteExprPat s = do
|
|||
|
||||
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
|
||||
(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
|
||||
(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
|
||||
(NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr
|
||||
(NSynHole _) -> Set.empty
|
||||
(NSynHole _ ) -> Set.empty
|
||||
|
||||
where
|
||||
|
||||
staticKey :: NKeyName r -> Maybe VarName
|
||||
staticKey (StaticKey varname) = Just varname
|
||||
staticKey (DynamicKey _) = Nothing
|
||||
staticKey (DynamicKey _ ) = Nothing
|
||||
|
||||
bindDefs :: Binding r -> Set VarName
|
||||
bindDefs (Inherit Nothing _ _) = Set.empty;
|
||||
bindDefs (Inherit Nothing _ _) = Set.empty
|
||||
bindDefs (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys
|
||||
bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname
|
||||
bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty
|
||||
|
@ -113,7 +124,4 @@ metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
|
|||
metaPat _ _ = Nothing
|
||||
|
||||
nix :: QuasiQuoter
|
||||
nix = QuasiQuoter
|
||||
{ quoteExp = quoteExprExp
|
||||
, quotePat = quoteExprPat
|
||||
}
|
||||
nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat }
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where
|
||||
|
||||
import Control.Exception hiding (catch)
|
||||
import Control.Exception hiding ( catch )
|
||||
import Control.Monad.Catch
|
||||
|
||||
import Nix.Thunk
|
||||
|
@ -36,7 +36,7 @@ instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where
|
|||
_ == _ = False -- jww (2019-03-16): not accurate...
|
||||
|
||||
instance Show v => Show (NThunkF m v) where
|
||||
show (Value v) = show v
|
||||
show (Value v ) = show v
|
||||
show (Thunk _ _ _) = "<thunk>"
|
||||
|
||||
type MonadBasicThunk m = (MonadThunkId m, MonadVar m)
|
||||
|
@ -62,7 +62,7 @@ thunkValue (Value v) = Just v
|
|||
thunkValue _ = Nothing
|
||||
|
||||
buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
|
||||
buildThunk action =do
|
||||
buildThunk action = do
|
||||
freshThunkId <- freshId
|
||||
Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
|
||||
|
||||
|
@ -71,9 +71,9 @@ queryValue (Value v) _ k = k v
|
|||
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,)
|
||||
nowActive <- atomicModifyVar active (True, )
|
||||
if nowActive
|
||||
then n
|
||||
else do
|
||||
|
@ -81,40 +81,37 @@ queryThunk (Thunk _ active ref) n k = do
|
|||
res <- case eres of
|
||||
Computed v -> k v
|
||||
_ -> n
|
||||
_ <- atomicModifyVar active (False,)
|
||||
_ <- 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,)
|
||||
nowActive <- atomicModifyVar active (True, )
|
||||
if nowActive
|
||||
then
|
||||
throwM $ ThunkLoop $ show n
|
||||
then throwM $ ThunkLoop $ show n
|
||||
else do
|
||||
traceM $ "Forcing " ++ show n
|
||||
v <- catch action $ \(e :: SomeException) -> do
|
||||
_ <- atomicModifyVar active (False,)
|
||||
_ <- atomicModifyVar active (False, )
|
||||
throwM e
|
||||
_ <- atomicModifyVar active (False,)
|
||||
_ <- 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,)
|
||||
nowActive <- atomicModifyVar active (True, )
|
||||
if nowActive
|
||||
then return $ error "Loop detected"
|
||||
else do
|
||||
|
@ -124,5 +121,5 @@ forceEffects (Thunk _ active ref) k = do
|
|||
Deferred action -> do
|
||||
v <- action
|
||||
writeVar ref (Computed v)
|
||||
_ <- atomicModifyVar active (False,)
|
||||
_ <- atomicModifyVar active (False, )
|
||||
k v
|
||||
|
|
|
@ -19,9 +19,9 @@
|
|||
|
||||
module Nix.Thunk.Standard where
|
||||
|
||||
import Control.Comonad (Comonad)
|
||||
import Control.Comonad.Env (ComonadEnv)
|
||||
import Control.Monad.Catch hiding (catchJust)
|
||||
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
|
||||
|
@ -39,7 +39,9 @@ import Nix.Thunk
|
|||
import Nix.Thunk.Basic
|
||||
import Nix.Utils
|
||||
import Nix.Value
|
||||
import Nix.Var (MonadVar, newVar)
|
||||
import Nix.Var ( MonadVar
|
||||
, newVar
|
||||
)
|
||||
|
||||
newtype StdCited m a = StdCited
|
||||
{ _stdCited :: NCited (StdThunk m) (StdCited m) (StdLazy m) a }
|
||||
|
@ -64,12 +66,7 @@ type StdIdT m = FreshIdT Int m
|
|||
|
||||
type StdLazy m = Lazy (StdThunk m) (StdCited m) (StdIdT m)
|
||||
|
||||
type MonadStdThunk m =
|
||||
( MonadVar m
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, Typeable m
|
||||
)
|
||||
type MonadStdThunk m = (MonadVar m, MonadCatch m, MonadThrow m, Typeable m)
|
||||
|
||||
instance MonadStdThunk m
|
||||
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
|
||||
|
@ -91,43 +88,41 @@ instance MonadStdThunk m
|
|||
ps = concatMap (go . frame) frames
|
||||
|
||||
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
|
||||
else
|
||||
fmap (StdThunk . StdCited . NCited []) . thunk $ mv
|
||||
else fmap (StdThunk . StdCited . NCited []) . thunk $ mv
|
||||
|
||||
thunkId (StdThunk (StdCited (NCited _ t))) = thunkId t
|
||||
|
||||
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)
|
||||
-- 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 _)):_ ->
|
||||
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)
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
|
||||
|
||||
forceEff (StdThunk (StdCited (NCited ps t))) f =
|
||||
catch go (throwError @ThunkLoop)
|
||||
forceEff (StdThunk (StdCited (NCited ps t))) f = catch
|
||||
go
|
||||
(throwError @ThunkLoop)
|
||||
where
|
||||
go = case ps of
|
||||
[] -> forceEff t f
|
||||
Provenance scope e@(Compose (Ann s _)):_ -> do
|
||||
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)
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
|
||||
|
||||
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
|
||||
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
|
||||
|
|
|
@ -1,16 +1,17 @@
|
|||
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
|
||||
|
||||
|
|
|
@ -1,23 +1,24 @@
|
|||
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 Data.Foldable hiding ( toList )
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
|
|
|
@ -17,13 +17,14 @@
|
|||
|
||||
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||||
|
||||
module Nix.Type.Infer (
|
||||
Constraint(..),
|
||||
TypeError(..),
|
||||
InferError(..),
|
||||
Subst(..),
|
||||
inferTop
|
||||
) where
|
||||
module Nix.Type.Infer
|
||||
( Constraint(..)
|
||||
, TypeError(..)
|
||||
, InferError(..)
|
||||
, Subst(..)
|
||||
, inferTop
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
|
@ -38,15 +39,20 @@ 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 Data.List ( delete
|
||||
, find
|
||||
, nub
|
||||
, intersect
|
||||
, (\\)
|
||||
)
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Maybe ( fromJust )
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import Nix.Atoms
|
||||
import Nix.Convert
|
||||
import Nix.Eval (MonadEval(..))
|
||||
import Nix.Eval ( MonadEval(..) )
|
||||
import qualified Nix.Eval as Eval
|
||||
import Nix.Expr.Types
|
||||
import Nix.Expr.Types.Annotated
|
||||
|
@ -112,16 +118,17 @@ class Substitutable a where
|
|||
|
||||
instance Substitutable TVar where
|
||||
apply (Subst s) a = tv
|
||||
where t = TVar a
|
||||
where
|
||||
t = TVar a
|
||||
(TVar tv) = Map.findWithDefault t a s
|
||||
|
||||
instance Substitutable Type where
|
||||
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
|
||||
|
@ -130,7 +137,8 @@ instance Substitutable Scheme where
|
|||
instance Substitutable Constraint where
|
||||
apply s (EqConst t1 t2) = EqConst (apply s t1) (apply s t2)
|
||||
apply s (ExpInstConst t sc) = ExpInstConst (apply s t) (apply s sc)
|
||||
apply s (ImpInstConst t1 ms t2) = ImpInstConst (apply s t1) (apply s ms) (apply s t2)
|
||||
apply s (ImpInstConst t1 ms t2) =
|
||||
ImpInstConst (apply s t1) (apply s ms) (apply s t2)
|
||||
|
||||
instance Substitutable a => Substitutable [a] where
|
||||
apply = map . apply
|
||||
|
@ -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
|
||||
|
@ -168,7 +176,8 @@ class ActiveTypeVars a where
|
|||
|
||||
instance ActiveTypeVars Constraint where
|
||||
atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2
|
||||
atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2)
|
||||
atv (ImpInstConst t1 ms t2) =
|
||||
ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2)
|
||||
atv (ExpInstConst t s) = ftv t `Set.union` ftv s
|
||||
|
||||
instance ActiveTypeVars a => ActiveTypeVars [a] where
|
||||
|
@ -206,28 +215,31 @@ instance Monoid InferError where
|
|||
|
||||
-- | Run the inference monad
|
||||
runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a)
|
||||
runInfer' = runExceptT
|
||||
runInfer' =
|
||||
runExceptT
|
||||
. (`evalStateT` initInfer)
|
||||
. (`runReaderT` (Set.empty, emptyScopes))
|
||||
. getInfer
|
||||
|
||||
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)
|
||||
|
||||
inferType :: forall s m. MonadInfer m
|
||||
=> Env -> NExpr -> InferT s m [(Subst, Type)]
|
||||
inferType
|
||||
:: forall s m . MonadInfer m => Env -> NExpr -> InferT s m [(Subst, Type)]
|
||||
inferType env ex = do
|
||||
Judgment as cs t <- infer ex
|
||||
let unbounds = Set.fromList (As.keys as) `Set.difference`
|
||||
Set.fromList (Env.keys env)
|
||||
unless (Set.null unbounds) $
|
||||
typeError $ UnboundVariables (nub (Set.toList unbounds))
|
||||
let cs' = [ ExpInstConst t s
|
||||
let unbounds =
|
||||
Set.fromList (As.keys as) `Set.difference` Set.fromList (Env.keys env)
|
||||
unless (Set.null unbounds) $ typeError $ UnboundVariables
|
||||
(nub (Set.toList unbounds))
|
||||
let cs' =
|
||||
[ ExpInstConst t s
|
||||
| (x, ss) <- Env.toList env
|
||||
, s <- ss
|
||||
, t <- As.lookup x as]
|
||||
, t <- As.lookup x as
|
||||
]
|
||||
inferState <- get
|
||||
let eres = (`evalState` inferState) $ runSolver $ do
|
||||
subst <- solve (cs ++ cs')
|
||||
|
@ -250,12 +262,12 @@ 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}
|
||||
put s { count = count s + 1 }
|
||||
return $ TV (letters !! count s)
|
||||
|
||||
fresh :: MonadState InferState m => m Type
|
||||
|
@ -273,9 +285,12 @@ generalize free t = Forall as t
|
|||
|
||||
unops :: Type -> NUnaryOp -> [Constraint]
|
||||
unops u1 = \case
|
||||
NNot -> [ EqConst u1 (typeFun [typeBool, typeBool]) ]
|
||||
NNeg -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt]
|
||||
, typeFun [typeFloat, typeFloat] ]) ]
|
||||
NNot -> [EqConst u1 (typeFun [typeBool, typeBool])]
|
||||
NNeg ->
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]])
|
||||
]
|
||||
|
||||
binops :: Type -> NBinaryOp -> [Constraint]
|
||||
binops u1 = \case
|
||||
|
@ -291,45 +306,73 @@ binops u1 = \case
|
|||
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]
|
||||
NConcat ->
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany
|
||||
[ typeFun [typeList, typeList, typeList]
|
||||
, typeFun [typeList, typeNull, typeList]
|
||||
, typeFun [typeNull, typeList, typeList]
|
||||
]) ]
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
NUpdate -> [ EqConst u1 (TMany [ typeFun [typeSet, typeSet, typeSet]
|
||||
NUpdate ->
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany
|
||||
[ typeFun [typeSet, typeSet, typeSet]
|
||||
, typeFun [typeSet, typeNull, typeSet]
|
||||
, typeFun [typeNull, typeSet, typeSet]
|
||||
]) ]
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
NPlus -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
|
||||
NPlus ->
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany
|
||||
[ typeFun [typeInt, typeInt, typeInt]
|
||||
, typeFun [typeFloat, typeFloat, typeFloat]
|
||||
, typeFun [typeInt, typeFloat, typeFloat]
|
||||
, typeFun [typeFloat, typeInt, typeFloat]
|
||||
, typeFun [typeString, typeString, typeString]
|
||||
, typeFun [typePath, typePath, typePath]
|
||||
, typeFun [typeString, typeString, typePath]
|
||||
]) ]
|
||||
]
|
||||
)
|
||||
]
|
||||
NMinus -> arithmetic
|
||||
NMult -> arithmetic
|
||||
NDiv -> arithmetic
|
||||
where
|
||||
inequality =
|
||||
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeBool]
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany
|
||||
[ typeFun [typeInt, typeInt, typeBool]
|
||||
, typeFun [typeFloat, typeFloat, typeBool]
|
||||
, typeFun [typeInt, typeFloat, typeBool]
|
||||
, typeFun [typeFloat, typeInt, typeBool]
|
||||
]) ]
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
arithmetic =
|
||||
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
|
||||
[ EqConst
|
||||
u1
|
||||
(TMany
|
||||
[ typeFun [typeInt, typeInt, typeInt]
|
||||
, typeFun [typeFloat, typeFloat, typeFloat]
|
||||
, typeFun [typeInt, typeFloat, typeFloat]
|
||||
, typeFun [typeFloat, typeInt, typeFloat]
|
||||
]) ]
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
liftInfer :: Monad m => m a -> InferT s m a
|
||||
liftInfer = InferT . lift . lift . lift
|
||||
|
@ -353,16 +396,13 @@ instance Monad m => MonadThrow (InferT s m) where
|
|||
|
||||
instance Monad m => MonadCatch (InferT s m) where
|
||||
catch m h = catchError m $ \case
|
||||
EvaluationError e ->
|
||||
maybe (error $ "Exception was not an exception: " ++ show e) h
|
||||
EvaluationError e -> maybe
|
||||
(error $ "Exception was not an exception: " ++ show e)
|
||||
h
|
||||
(fromException (toException e))
|
||||
err -> error $ "Unexpected error: " ++ show err
|
||||
|
||||
type MonadInfer m
|
||||
= ( MonadThunkId m
|
||||
, MonadVar m
|
||||
, MonadFix m
|
||||
)
|
||||
type MonadInfer m = (MonadThunkId m, MonadVar m, MonadFix m)
|
||||
|
||||
instance MonadInfer m
|
||||
=> MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
|
||||
|
@ -372,11 +412,13 @@ instance MonadInfer m
|
|||
query (JThunk x) b f = query x b f
|
||||
queryM (JThunk x) b f = queryM x b f
|
||||
|
||||
force (JThunk t) f = catch (force t f) $ \(_ :: ThunkLoop) ->
|
||||
-- If we have a thunk loop, we just don't know the type.
|
||||
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.
|
||||
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
|
||||
|
@ -391,16 +433,13 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
|
|||
tv <- fresh
|
||||
return $ Judgment (As.singleton var tv) [] tv
|
||||
|
||||
-- If we fail to look up an attribute, we just don't know the type.
|
||||
-- If we fail to look up an attribute, we just don't know the type.
|
||||
attrMissing _ _ = Judgment As.empty [] <$> fresh
|
||||
|
||||
evaledSym _ = pure
|
||||
|
||||
evalCurPos =
|
||||
return $ Judgment As.empty [] $ TSet False $ M.fromList
|
||||
[ ("file", typePath)
|
||||
, ("line", typeInt)
|
||||
, ("col", typeInt) ]
|
||||
evalCurPos = return $ Judgment As.empty [] $ TSet False $ M.fromList
|
||||
[("file", typePath), ("line", typeInt), ("col", typeInt)]
|
||||
|
||||
evalConstant c = return $ Judgment As.empty [] (go c)
|
||||
where
|
||||
|
@ -421,8 +460,7 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
|
|||
evalBinary op (Judgment as1 cs1 t1) e2 = do
|
||||
Judgment as2 cs2 t2 <- e2
|
||||
tv <- fresh
|
||||
return $ Judgment
|
||||
(as1 `As.merge` as2)
|
||||
return $ Judgment (as1 `As.merge` as2)
|
||||
(cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op)
|
||||
tv
|
||||
|
||||
|
@ -438,28 +476,24 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
|
|||
|
||||
evalAssert (Judgment as1 cs1 t1) body = do
|
||||
Judgment as2 cs2 t2 <- body
|
||||
return $ Judgment
|
||||
(as1 `As.merge` as2)
|
||||
(cs1 ++ cs2 ++ [EqConst t1 typeBool])
|
||||
t2
|
||||
return
|
||||
$ Judgment (as1 `As.merge` as2) (cs1 ++ cs2 ++ [EqConst t1 typeBool]) t2
|
||||
|
||||
evalApp (Judgment as1 cs1 t1) e2 = do
|
||||
Judgment as2 cs2 t2 <- e2
|
||||
tv <- fresh
|
||||
return $ Judgment
|
||||
(as1 `As.merge` as2)
|
||||
return $ Judgment (as1 `As.merge` as2)
|
||||
(cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)])
|
||||
tv
|
||||
|
||||
evalAbs (Param x) k = do
|
||||
a <- freshTVar
|
||||
let tv = TVar a
|
||||
((), Judgment as cs t) <-
|
||||
extendMSet a (k (pure (Judgment (As.singleton x tv) [] tv))
|
||||
(\_ b -> ((),) <$> b))
|
||||
return $ Judgment
|
||||
(as `As.remove` x)
|
||||
(cs ++ [EqConst t' tv | t' <- As.lookup x as])
|
||||
((), 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
|
||||
|
@ -467,23 +501,20 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where
|
|||
tv <- fresh
|
||||
pure [(name, tv)]
|
||||
|
||||
let (env, tys) = (\f -> foldl' f (As.empty, M.empty) js)
|
||||
$ \(as1, t1) (k, t) ->
|
||||
let (env, tys) =
|
||||
(\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) ->
|
||||
(as1 `As.merge` As.singleton k t, M.insert k t t1)
|
||||
arg = pure $ Judgment env [] (TSet True tys)
|
||||
call = k arg $ \args b -> (args,) <$> b
|
||||
call = k arg $ \args b -> (args, ) <$> b
|
||||
names = map fst js
|
||||
|
||||
(args, Judgment as cs t) <-
|
||||
foldr (\(_, TVar a) -> extendMSet a) call js
|
||||
(args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js
|
||||
|
||||
ty <- TSet variadic <$> traverse (inferredType <$>) args
|
||||
|
||||
return $ Judgment
|
||||
(foldl' As.remove as names)
|
||||
(cs ++ [ EqConst t' (tys M.! x)
|
||||
| x <- names
|
||||
, t' <- As.lookup x as])
|
||||
(cs ++ [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ])
|
||||
(ty :~> t)
|
||||
|
||||
evalError = throwError . EvaluationError
|
||||
|
@ -513,20 +544,20 @@ instance MonadInfer m
|
|||
instance MonadInfer m
|
||||
=> ToValue (AttrSet (JThunkT s m), AttrSet SourcePos)
|
||||
(InferT s m) (Judgment s) where
|
||||
toValue (xs, _) = Judgment
|
||||
toValue (xs, _) =
|
||||
Judgment
|
||||
<$> foldrM go As.empty xs
|
||||
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
|
||||
<*> (TSet True <$> traverse (`force` (pure . inferredType)) xs)
|
||||
where
|
||||
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
|
||||
where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
|
||||
|
||||
instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
|
||||
toValue xs = Judgment
|
||||
toValue xs =
|
||||
Judgment
|
||||
<$> foldrM go As.empty xs
|
||||
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
|
||||
<*> (TList <$> traverse (`force` (pure . inferredType)) xs)
|
||||
where
|
||||
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
|
||||
where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
|
||||
|
||||
instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where
|
||||
toValue _ = pure $ Judgment As.empty [] typeBool
|
||||
|
@ -536,7 +567,7 @@ 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
|
||||
inferTop env ((name, ex) : xs) = case inferExpr env ex of
|
||||
Left err -> Left err
|
||||
Right ty -> inferTop (extend env (name, ty)) xs
|
||||
|
||||
|
@ -545,20 +576,19 @@ normalize (Forall _ body) = Forall (map snd ord) (normtype body)
|
|||
where
|
||||
ord = zip (nub $ fv body) (map TV letters)
|
||||
|
||||
fv (TVar a) = [a]
|
||||
fv (a :~> b) = fv a ++ fv b
|
||||
fv (TCon _) = []
|
||||
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 (TList a ) = concatMap fv a
|
||||
fv (TMany ts) = concatMap fv ts
|
||||
|
||||
normtype (a :~> b) = normtype a :~> normtype b
|
||||
normtype (TCon a) = TCon a
|
||||
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 (TList a ) = TList (map normtype a)
|
||||
normtype (TMany ts) = TMany (map normtype ts)
|
||||
normtype (TVar a) =
|
||||
case Prelude.lookup a ord of
|
||||
normtype (TVar a ) = case Prelude.lookup a ord of
|
||||
Just x -> TVar x
|
||||
Nothing -> error "type variable not in signature"
|
||||
|
||||
|
@ -574,15 +604,15 @@ instance MonadTrans Solver where
|
|||
lift = Solver . lift . lift
|
||||
|
||||
instance Monad m => MonadError TypeError (Solver m) where
|
||||
throwError err = Solver $ lift (modify (err:)) >> mzero
|
||||
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)
|
||||
(x : xs, _ ) -> Right (x : xs)
|
||||
(_ , es) -> Left (nub es)
|
||||
|
||||
-- | The empty substitution
|
||||
emptySubst :: Subst
|
||||
|
@ -595,16 +625,16 @@ Subst s1 `compose` Subst s2 =
|
|||
|
||||
unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst
|
||||
unifyMany [] [] = return emptySubst
|
||||
unifyMany (t1 : ts1) (t2 : ts2) =
|
||||
do su1 <- unifies t1 t2
|
||||
unifyMany (t1 : ts1) (t2 : ts2) = do
|
||||
su1 <- unifies t1 t2
|
||||
su2 <- unifyMany (apply su1 ts1) (apply su1 ts2)
|
||||
return (su2 `compose` su1)
|
||||
unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2
|
||||
|
||||
allSameType :: [Type] -> Bool
|
||||
allSameType [] = True
|
||||
allSameType [_] = True
|
||||
allSameType (x:y:ys) = x == y && allSameType (y:ys)
|
||||
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
|
||||
|
@ -612,19 +642,19 @@ 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
|
||||
(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
|
||||
unifies (TSet True s) (TSet False b)
|
||||
| M.keys b `intersect` M.keys s == M.keys b = return emptySubst
|
||||
unifies (TSet False s) (TSet False b)
|
||||
| null (M.keys b \\ M.keys s) = return emptySubst
|
||||
unifies (TSet False s) (TSet False b) | null (M.keys b \\ M.keys s) =
|
||||
return emptySubst
|
||||
unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4]
|
||||
unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2
|
||||
unifies t1 (TMany t2s) = considering t2s >>- unifies t1
|
||||
|
@ -641,9 +671,9 @@ 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]
|
||||
chooseOne xs = [ (x, ys) | x <- xs, let ys = delete x xs ]
|
||||
|
||||
solvable (EqConst{}, _) = True
|
||||
solvable (EqConst{} , _) = True
|
||||
solvable (ExpInstConst{}, _) = True
|
||||
solvable (ImpInstConst _t1 ms t2, cs) =
|
||||
Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs)
|
||||
|
@ -655,10 +685,8 @@ solve :: MonadState InferState m => [Constraint] -> Solver m Subst
|
|||
solve [] = return emptySubst
|
||||
solve cs = solve' (nextSolvable cs)
|
||||
where
|
||||
solve' (EqConst t1 t2, cs) =
|
||||
unifies t1 t2 >>- \su1 ->
|
||||
solve (apply su1 cs) >>- \su2 ->
|
||||
return (su2 `compose` su1)
|
||||
solve' (EqConst t1 t2, cs) = unifies t1 t2
|
||||
>>- \su1 -> solve (apply su1 cs) >>- \su2 -> return (su2 `compose` su1)
|
||||
|
||||
solve' (ImpInstConst t1 ms t2, cs) =
|
||||
solve (ExpInstConst t1 (generalize ms t2) : cs)
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
module Nix.Type.Type where
|
||||
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Text (Text)
|
||||
import Data.Text ( Text )
|
||||
import Nix.Utils
|
||||
|
||||
newtype TVar = TV String
|
||||
|
|
|
@ -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 Data.Fix
|
||||
import Data.Hashable
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
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 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.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,8 +100,12 @@ transport f (Fix x) = Fix $ fmap (transport f) (f x)
|
|||
adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
|
||||
adi f g = g (f . fmap (adi f g) . unFix)
|
||||
|
||||
adiM :: (Traversable t, Monad m)
|
||||
=> (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
|
||||
adiM
|
||||
:: (Traversable t, Monad m)
|
||||
=> (t a -> m a)
|
||||
-> ((Fix t -> m a) -> Fix t -> m a)
|
||||
-> Fix t
|
||||
-> m a
|
||||
adiM f g = g ((f <=< traverse (adiM f g)) . unFix)
|
||||
|
||||
class Has a b where
|
||||
|
@ -111,7 +123,8 @@ instance Has (a, b) b where
|
|||
toEncodingSorted :: A.Value -> A.Encoding
|
||||
toEncodingSorted = \case
|
||||
A.Object m ->
|
||||
A.pairs . mconcat
|
||||
A.pairs
|
||||
. mconcat
|
||||
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
|
||||
. sortOn fst
|
||||
$ M.toList m
|
||||
|
@ -126,14 +139,28 @@ uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
|
|||
uriAwareSplit = go where
|
||||
go str = case Text.break (== ':') str of
|
||||
(e1, e2)
|
||||
| Text.null e2 -> [(e1, PathEntryPath)]
|
||||
| Text.pack "://" `Text.isPrefixOf` e2 ->
|
||||
let ((suffix, _):path) = go (Text.drop 3 e2)
|
||||
| Text.null e2
|
||||
-> [(e1, PathEntryPath)]
|
||||
| Text.pack "://" `Text.isPrefixOf` e2
|
||||
-> let ((suffix, _) : path) = go (Text.drop 3 e2)
|
||||
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
|
||||
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
|
||||
| otherwise
|
||||
-> (e1, PathEntryPath) : go (Text.drop 1 e2)
|
||||
|
||||
alterF :: (Eq k, Hashable k, Functor f)
|
||||
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
|
||||
alterF
|
||||
:: (Eq k, Hashable k, Functor f)
|
||||
=> (Maybe v -> f (Maybe v))
|
||||
-> k
|
||||
-> HashMap k v
|
||||
-> f (HashMap k v)
|
||||
alterF f k m = f (M.lookup k m) <&> \case
|
||||
Nothing -> M.delete k m
|
||||
Just v -> M.insert k v m
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
232
src/Nix/Value.hs
232
src/Nix/Value.hs
|
@ -41,11 +41,11 @@ import Data.Align
|
|||
import Data.Eq.Deriving
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Identity
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.HashMap.Lazy ( HashMap )
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Text (Text)
|
||||
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
|
||||
|
@ -99,8 +99,11 @@ instance Foldable (NValueF p m) where
|
|||
NVClosureF _ _ -> mempty
|
||||
NVBuiltinF _ _ -> mempty
|
||||
|
||||
bindNValueF :: (Monad m, Monad n)
|
||||
=> (forall x. n x -> m x) -> (a -> n b) -> NValueF p m a
|
||||
bindNValueF
|
||||
:: (Monad m, Monad n)
|
||||
=> (forall x . n x -> m x)
|
||||
-> (a -> n b)
|
||||
-> NValueF p m a
|
||||
-> n (NValueF p m b)
|
||||
bindNValueF transform f = \case
|
||||
NVConstantF a -> pure $ NVConstantF a
|
||||
|
@ -121,8 +124,9 @@ lmapNValueF f = \case
|
|||
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)
|
||||
liftNValueF
|
||||
:: (MonadTrans u, Monad m)
|
||||
=> (forall x . u m x -> m x)
|
||||
-> NValueF p m a
|
||||
-> NValueF p (u m) a
|
||||
liftNValueF run = \case
|
||||
|
@ -134,8 +138,9 @@ liftNValueF run = \case
|
|||
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)
|
||||
unliftNValueF
|
||||
:: (MonadTrans u, Monad m)
|
||||
=> (forall x . u m x -> m x)
|
||||
-> NValueF p (u m) a
|
||||
-> NValueF p m a
|
||||
unliftNValueF run = \case
|
||||
|
@ -147,8 +152,8 @@ unliftNValueF run = \case
|
|||
NVClosureF p g -> NVClosureF p $ run . g . lift
|
||||
NVBuiltinF s g -> NVBuiltinF s $ run . g . lift
|
||||
|
||||
type MonadDataContext f (m :: * -> *) =
|
||||
(Comonad f, Applicative f, Traversable f, Monad m)
|
||||
type MonadDataContext f (m :: * -> *)
|
||||
= (Comonad f, Applicative f, Traversable f, Monad m)
|
||||
|
||||
-- | At the time of constructor, the expected arguments to closures are values
|
||||
-- that may contain thunks. The type of such thunks are fixed at that time.
|
||||
|
@ -157,13 +162,13 @@ newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
|
|||
|
||||
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 (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
|
||||
go (NVPathF p ) = showsCon1 "NVPath" p
|
||||
go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name
|
||||
|
||||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
||||
showsCon1 con a d =
|
||||
|
@ -174,21 +179,26 @@ instance (Comonad f, Show a) => Show (NValue' t f m a) where
|
|||
|
||||
type NValue t f m = NValue' t f m t
|
||||
|
||||
bindNValue :: (Traversable f, Monad m, Monad n)
|
||||
=> (forall x. n x -> m x) -> (a -> n b) -> NValue' t f m a
|
||||
bindNValue
|
||||
:: (Traversable f, Monad m, Monad n)
|
||||
=> (forall x . n x -> m x)
|
||||
-> (a -> n b)
|
||||
-> NValue' t f m a
|
||||
-> n (NValue' t f m b)
|
||||
bindNValue transform f (NValue v) =
|
||||
NValue <$> traverse (bindNValueF transform f) v
|
||||
|
||||
liftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
|
||||
=> (forall x. u m x -> m x)
|
||||
liftNValue
|
||||
:: (MonadTrans u, Monad m, Functor (u m), Functor f)
|
||||
=> (forall x . u m x -> m x)
|
||||
-> NValue' t f m a
|
||||
-> NValue' t f (u m) a
|
||||
liftNValue run (NValue v) =
|
||||
NValue (fmap (lmapNValueF (unliftNValue run) . liftNValueF run) v)
|
||||
|
||||
unliftNValue :: (MonadTrans u, Monad m, Functor (u m), Functor f)
|
||||
=> (forall x. u m x -> m x)
|
||||
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) =
|
||||
|
@ -207,18 +217,21 @@ unliftNValue run (NValue v) =
|
|||
type NValueNF t f m = Free (NValue' t f m) t
|
||||
|
||||
iterNValue
|
||||
:: forall t f m a r. MonadDataContext f m
|
||||
:: forall t f m a r
|
||||
. MonadDataContext f m
|
||||
=> (a -> (NValue' t f m a -> r) -> r)
|
||||
-> (NValue' t f m r -> r)
|
||||
-> NValue' t f m a -> r
|
||||
-> NValue' t f m a
|
||||
-> r
|
||||
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))
|
||||
|
||||
iterNValueM
|
||||
:: (MonadDataContext f m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
=> (forall x . n x -> m x)
|
||||
-> (a -> (NValue' t f m a -> n r) -> n r)
|
||||
-> (NValue' t f m r -> n r)
|
||||
-> NValue' t f m a -> n r
|
||||
-> NValue' t f m a
|
||||
-> n r
|
||||
iterNValueM transform k f =
|
||||
f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))
|
||||
|
||||
|
@ -226,34 +239,42 @@ iterNValueNF
|
|||
:: MonadDataContext f m
|
||||
=> (t -> r)
|
||||
-> (NValue' t f m r -> r)
|
||||
-> NValueNF t f m -> r
|
||||
-> NValueNF t f m
|
||||
-> r
|
||||
iterNValueNF k f = iter f . fmap k
|
||||
|
||||
sequenceNValueNF :: (Functor n, Traversable f, Monad m, Monad n)
|
||||
=> (forall x. n x -> m x) -> Free (NValue' t f m) (n a)
|
||||
sequenceNValueNF
|
||||
:: (Functor n, Traversable f, Monad m, Monad n)
|
||||
=> (forall x . n x -> m x)
|
||||
-> Free (NValue' t f m) (n a)
|
||||
-> n (Free (NValue' t f m) a)
|
||||
sequenceNValueNF transform = go
|
||||
where
|
||||
go (Pure a) = Pure <$> a
|
||||
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)
|
||||
:: forall f m n t r
|
||||
. (MonadDataContext f m, Monad n)
|
||||
=> (forall x . n x -> m x)
|
||||
-> (t -> n r)
|
||||
-> (NValue' t f m (n r) -> n r)
|
||||
-> NValueNF t f m -> n r
|
||||
-> NValueNF t f m
|
||||
-> n r
|
||||
iterNValueNFM transform k f v =
|
||||
iterM f =<< sequenceNValueNF transform (fmap k v)
|
||||
|
||||
nValueFromNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValueNF t f m -> NValue t f m
|
||||
nValueFromNF
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValueNF t f m
|
||||
-> NValue t f m
|
||||
nValueFromNF = iterNValueNF f (fmap wrapValue)
|
||||
where
|
||||
f t = query t cyc id
|
||||
cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")
|
||||
|
||||
nValueToNF :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
nValueToNF
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
|
||||
-> NValue t f m
|
||||
-> NValueNF t f m
|
||||
|
@ -261,7 +282,7 @@ nValueToNF k = iterNValue k Free
|
|||
|
||||
nValueToNFM
|
||||
:: (MonadDataContext f m, Monad n)
|
||||
=> (forall x. n x -> m x)
|
||||
=> (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)
|
||||
|
@ -329,8 +350,11 @@ nvBuiltinNF :: Applicative f
|
|||
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
|
||||
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
|
||||
|
||||
checkComparable :: (Framed e m, MonadDataErrorContext t f m)
|
||||
=> NValue t f m -> NValue t f m -> m ()
|
||||
checkComparable
|
||||
:: (Framed e m, MonadDataErrorContext t f m)
|
||||
=> NValue t f m
|
||||
-> NValue t f m
|
||||
-> m ()
|
||||
checkComparable x y = case (x, y) of
|
||||
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
|
||||
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
|
||||
|
@ -340,37 +364,46 @@ checkComparable x y = case (x, y) of
|
|||
(NVPath _, NVPath _) -> pure ()
|
||||
_ -> throwError $ Comparison x y
|
||||
|
||||
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f)
|
||||
=> t -> t -> m Bool
|
||||
thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
|
||||
thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||
let unsafePtrEq = case (lt, rt) of
|
||||
(thunkId -> lid, thunkId -> rid)
|
||||
| lid == rid -> return True
|
||||
(thunkId -> lid, thunkId -> rid) | lid == rid -> return True
|
||||
_ -> valueEqM lv rv
|
||||
in case (lv, rv) of
|
||||
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
||||
(NVList _, NVList _) -> unsafePtrEq
|
||||
(NVSet _ _, NVSet _ _) -> 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))
|
||||
builtin2
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> String
|
||||
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
|
||||
-> m (NValue t f m)
|
||||
builtin2 name f = builtin name (builtin name . f)
|
||||
|
||||
builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
builtin3
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> String
|
||||
-> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
|
||||
-> ( m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
-> m (NValue t f m)
|
||||
)
|
||||
-> m (NValue t f m)
|
||||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
isClosureNF :: Comonad f => NValueNF t f m -> Bool
|
||||
isClosureNF NVClosureNF {} = True
|
||||
isClosureNF NVClosureNF{} = True
|
||||
isClosureNF _ = False
|
||||
|
||||
-- | Checks whether two containers are equal, using the given item equality
|
||||
|
@ -405,35 +438,38 @@ isDerivationM f m = case M.lookup "type" m of
|
|||
isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool
|
||||
isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x))
|
||||
|
||||
valueFEqM :: Monad n
|
||||
valueFEqM
|
||||
:: Monad n
|
||||
=> (AttrSet a -> AttrSet a -> n Bool)
|
||||
-> (a -> a -> n Bool)
|
||||
-> NValueF p m a
|
||||
-> NValueF p m a
|
||||
-> n Bool
|
||||
valueFEqM attrsEq eq = curry $ \case
|
||||
(NVConstantF (NFloat x), NVConstantF (NInt y)) -> pure $ x == fromInteger y
|
||||
(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
|
||||
(NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc
|
||||
(NVStrF ls, NVStrF rs) ->
|
||||
pure $ principledStringIgnoreContext ls
|
||||
== principledStringIgnoreContext rs
|
||||
(NVListF ls, NVListF rs) -> alignEqM eq ls 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
|
||||
(NVPathF lp , NVPathF rp ) -> pure $ lp == rp
|
||||
_ -> pure False
|
||||
|
||||
valueFEq :: (AttrSet a -> AttrSet a -> Bool)
|
||||
valueFEq
|
||||
:: (AttrSet a -> AttrSet a -> Bool)
|
||||
-> (a -> a -> Bool)
|
||||
-> NValueF p m a
|
||||
-> NValueF p m a
|
||||
-> Bool
|
||||
valueFEq attrsEq eq x y =
|
||||
runIdentity $ valueFEqM
|
||||
valueFEq attrsEq eq x y = runIdentity $ valueFEqM
|
||||
(\x' y' -> Identity (attrsEq x' y'))
|
||||
(\x' y' -> Identity (eq x' y')) x y
|
||||
(\x' y' -> Identity (eq x' y'))
|
||||
x
|
||||
y
|
||||
|
||||
compareAttrSetsM :: Monad m
|
||||
compareAttrSetsM
|
||||
:: Monad m
|
||||
=> (t -> m (Maybe NixString))
|
||||
-> (t -> t -> m Bool)
|
||||
-> AttrSet t
|
||||
|
@ -442,42 +478,46 @@ compareAttrSetsM :: Monad m
|
|||
compareAttrSetsM f eq lm rm = do
|
||||
isDerivationM f lm >>= \case
|
||||
True -> isDerivationM f rm >>= \case
|
||||
True | Just lp <- M.lookup "outPath" lm
|
||||
, Just rp <- M.lookup "outPath" rm
|
||||
-> eq lp rp
|
||||
True
|
||||
| Just lp <- M.lookup "outPath" lm, Just rp <- M.lookup "outPath" rm -> eq
|
||||
lp
|
||||
rp
|
||||
_ -> compareAttrs
|
||||
_ -> compareAttrs
|
||||
where
|
||||
compareAttrs = alignEqM eq lm rm
|
||||
where compareAttrs = alignEqM eq lm rm
|
||||
|
||||
compareAttrSets :: (t -> Maybe NixString)
|
||||
compareAttrSets
|
||||
:: (t -> Maybe NixString)
|
||||
-> (t -> t -> Bool)
|
||||
-> AttrSet t
|
||||
-> AttrSet t
|
||||
-> Bool
|
||||
compareAttrSets f eq lm rm =
|
||||
runIdentity $ compareAttrSetsM
|
||||
(\t -> Identity (f t))
|
||||
(\x y -> Identity (eq x y)) lm rm
|
||||
compareAttrSets f eq lm rm = runIdentity
|
||||
$ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm
|
||||
|
||||
valueEqM :: (MonadThunk t m (NValue t f m), Comonad f)
|
||||
=> NValue t f m -> NValue t f m -> m Bool
|
||||
valueEqM (NValue (extract -> x)) (NValue (extract -> y)) =
|
||||
valueFEqM (compareAttrSetsM f thunkEqM) thunkEqM x y
|
||||
valueEqM
|
||||
:: (MonadThunk t m (NValue t f m), Comonad f)
|
||||
=> NValue t f m
|
||||
-> NValue t f m
|
||||
-> m Bool
|
||||
valueEqM (NValue (extract -> x)) (NValue (extract -> y)) = valueFEqM
|
||||
(compareAttrSetsM f thunkEqM)
|
||||
thunkEqM
|
||||
x
|
||||
y
|
||||
where
|
||||
f t = force t $ \case
|
||||
NVStr s -> pure $ Just s
|
||||
_ -> pure Nothing
|
||||
|
||||
valueNFEq :: Comonad f
|
||||
=> NValueNF t f m -> NValueNF t f m -> Bool
|
||||
valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool
|
||||
valueNFEq (Pure _) (Pure _) = False
|
||||
valueNFEq (Pure _) (Free _) = False
|
||||
valueNFEq (Free _) (Pure _) = False
|
||||
valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
|
||||
valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
|
||||
where
|
||||
f (Pure _) = Nothing
|
||||
f (Pure _ ) = Nothing
|
||||
f (Free (NVStr s)) = Just s
|
||||
f _ = Nothing
|
||||
|
||||
|
@ -506,11 +546,11 @@ valueType = \case
|
|||
NNull -> TNull
|
||||
NVStrF ns | stringHasContext ns -> TString HasContext
|
||||
| otherwise -> TString NoContext
|
||||
NVListF {} -> TList
|
||||
NVSetF {} -> TSet
|
||||
NVClosureF {} -> TClosure
|
||||
NVPathF {} -> TPath
|
||||
NVBuiltinF {} -> TBuiltin
|
||||
NVListF{} -> TList
|
||||
NVSetF{} -> TSet
|
||||
NVClosureF{} -> TClosure
|
||||
NVPathF{} -> TPath
|
||||
NVBuiltinF{} -> TBuiltin
|
||||
|
||||
describeValue :: ValueType -> String
|
||||
describeValue = \case
|
||||
|
@ -530,15 +570,15 @@ 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 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)
|
||||
NVStr ns ->
|
||||
showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
|
||||
NVList lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
|
||||
NVSet attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
|
||||
NVPath path -> showsUnaryWith showsPrec "NVPathF" p path
|
||||
|
@ -560,16 +600,18 @@ data ValueFrame t f m
|
|||
| Expectation ValueType (NValue t f m)
|
||||
deriving (Show, Typeable)
|
||||
|
||||
type MonadDataErrorContext t f m =
|
||||
(Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
|
||||
type MonadDataErrorContext t f m
|
||||
= (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)
|
||||
|
||||
instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)
|
||||
|
||||
$(makeTraversals ''NValueF)
|
||||
$(makeLenses ''NValue')
|
||||
|
||||
key :: (Traversable f, Applicative g)
|
||||
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
|
||||
key 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,7 +22,7 @@ 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
|
||||
|
|
|
@ -15,12 +15,14 @@ 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" <>)
|
||||
pp =
|
||||
("<?xml version='1.0' encoding='utf-8'?>\n" <>)
|
||||
. (<> "\n")
|
||||
. Text.pack
|
||||
. ppElement
|
||||
|
@ -35,18 +37,26 @@ toXML = runWithStringContext
|
|||
NNull -> return $ Element (unqual "null") [] [] Nothing
|
||||
|
||||
NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str
|
||||
NVList l -> sequence l >>= \els ->
|
||||
return $ Element (unqual "list") [] (Elem <$> els) Nothing
|
||||
NVList l -> sequence l
|
||||
>>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing
|
||||
|
||||
NVSet s _ -> sequence s >>= \kvs ->
|
||||
return $ Element (unqual "attrs") []
|
||||
(map (\(k, v) ->
|
||||
Elem (Element (unqual "attr")
|
||||
NVSet s _ -> sequence s >>= \kvs -> return $ Element
|
||||
(unqual "attrs")
|
||||
[]
|
||||
(map
|
||||
(\(k, v) -> Elem
|
||||
(Element (unqual "attr")
|
||||
[Attr (unqual "name") (Text.unpack k)]
|
||||
[Elem v] Nothing))
|
||||
(sortBy (comparing fst) $ M.toList kvs)) Nothing
|
||||
[Elem v]
|
||||
Nothing
|
||||
)
|
||||
)
|
||||
(sortBy (comparing fst) $ M.toList kvs)
|
||||
)
|
||||
Nothing
|
||||
|
||||
NVClosure p _ -> return $ Element (unqual "function") [] (paramsXML p) Nothing
|
||||
NVClosure p _ ->
|
||||
return $ Element (unqual "function") [] (paramsXML p) Nothing
|
||||
NVPath fp -> return $ mkElem "path" "value" fp
|
||||
NVBuiltin name _ -> return $ mkElem "function" "name" name
|
||||
_ -> error "Pattern synonyms mask coverage"
|
||||
|
@ -55,13 +65,12 @@ 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
|
||||
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))
|
||||
|
|
|
@ -4,16 +4,18 @@
|
|||
|
||||
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 Data.List ( delete
|
||||
, sort
|
||||
)
|
||||
import Data.List.Split ( splitOn )
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import Data.Set ( Set )
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
|
@ -30,7 +32,9 @@ import Nix.XML
|
|||
import qualified Options.Applicative as Opts
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.FilePath.Glob (compile, globDir1)
|
||||
import System.FilePath.Glob ( compile
|
||||
, globDir1
|
||||
)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import TestCommon
|
||||
|
@ -72,7 +76,8 @@ newFailingTests = Set.fromList
|
|||
|
||||
genTests :: IO TestTree
|
||||
genTests = do
|
||||
testFiles <- sort
|
||||
testFiles <-
|
||||
sort
|
||||
-- jww (2018-05-07): Temporarily disable this test until #128 is fixed.
|
||||
. filter ((`Set.notMember` newFailingTests) . takeBaseName)
|
||||
. filter ((/= ".xml") . takeExtension)
|
||||
|
@ -80,22 +85,21 @@ genTests = do
|
|||
let testsByName = groupBy (takeFileName . dropExtensions) testFiles
|
||||
let testsByType = groupBy testType (Map.toList testsByName)
|
||||
let testGroups = map mkTestGroup (Map.toList testsByType)
|
||||
return $ localOption (mkTimeout 2000000)
|
||||
$ testGroup "Nix (upstream) language tests" testGroups
|
||||
return $ localOption (mkTimeout 2000000) $ testGroup
|
||||
"Nix (upstream) language tests"
|
||||
testGroups
|
||||
where
|
||||
testType (fullpath, _files) =
|
||||
take 2 $ splitOn "-" $ takeFileName fullpath
|
||||
testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath
|
||||
mkTestGroup (kind, tests) =
|
||||
testGroup (unwords kind) $ map (mkTestCase kind) tests
|
||||
mkTestCase kind (basename, files) =
|
||||
testCase (takeFileName basename) $ do
|
||||
mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do
|
||||
time <- liftIO getCurrentTime
|
||||
let opts = defaultOptions time
|
||||
case kind of
|
||||
["parse", "okay"] -> assertParse opts $ the files
|
||||
["parse", "fail"] -> assertParseFail opts $ the files
|
||||
["eval", "okay"] -> assertEval opts files
|
||||
["eval", "fail"] -> assertEvalFail $ the files
|
||||
["eval" , "okay"] -> assertEval opts files
|
||||
["eval" , "fail"] -> assertEvalFail $ the files
|
||||
_ -> error $ "Unexpected: " ++ show kind
|
||||
|
||||
assertParse :: Options -> FilePath -> Assertion
|
||||
|
@ -107,13 +111,18 @@ assertParse _opts file = parseNixFileLoc file >>= \case
|
|||
assertParseFail :: Options -> FilePath -> Assertion
|
||||
assertParseFail opts file = do
|
||||
eres <- parseNixFileLoc file
|
||||
catch (case eres of
|
||||
catch
|
||||
(case eres of
|
||||
Success expr -> do
|
||||
_ <- pure $! runST $ void $ lint opts expr
|
||||
assertFailure $ "Unexpected success parsing `"
|
||||
++ file ++ ":\nParsed value: " ++ show expr
|
||||
Failure _ -> return ()) $ \(_ :: SomeException) ->
|
||||
return ()
|
||||
assertFailure
|
||||
$ "Unexpected success parsing `"
|
||||
++ file
|
||||
++ ":\nParsed value: "
|
||||
++ show expr
|
||||
Failure _ -> return ()
|
||||
)
|
||||
$ \(_ :: SomeException) -> return ()
|
||||
|
||||
assertLangOk :: Options -> FilePath -> Assertion
|
||||
assertLangOk opts file = do
|
||||
|
@ -123,7 +132,9 @@ assertLangOk opts file = do
|
|||
|
||||
assertLangOkXml :: Options -> FilePath -> Assertion
|
||||
assertLangOkXml opts file = do
|
||||
actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile opts (file ++ ".nix")
|
||||
actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile
|
||||
opts
|
||||
(file ++ ".nix")
|
||||
expected <- Text.readFile $ file ++ ".exp.xml"
|
||||
assertEqual "" expected actual
|
||||
|
||||
|
@ -133,8 +144,8 @@ assertEval _opts files = do
|
|||
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" ] -> assertLangOk opts name
|
||||
[".exp.xml" ] -> assertLangOkXml opts name
|
||||
[".exp.disabled"] -> return ()
|
||||
[".exp-disabled"] -> return ()
|
||||
[".exp", ".flags"] -> do
|
||||
|
@ -142,33 +153,46 @@ assertEval _opts files = do
|
|||
flags <- Text.readFile (name ++ ".flags")
|
||||
let flags' | Text.last flags == '\n' = Text.init flags
|
||||
| otherwise = flags
|
||||
case Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time)
|
||||
(fixup (map Text.unpack (Text.splitOn " " flags'))) of
|
||||
Opts.Failure err -> errorWithoutStackTrace $
|
||||
"Error parsing flags from " ++ name ++ ".flags: "
|
||||
case
|
||||
Opts.execParserPure
|
||||
Opts.defaultPrefs
|
||||
(nixOptionsInfo time)
|
||||
(fixup (map Text.unpack (Text.splitOn " " flags')))
|
||||
of
|
||||
Opts.Failure err ->
|
||||
errorWithoutStackTrace
|
||||
$ "Error parsing flags from "
|
||||
++ name
|
||||
++ ".flags: "
|
||||
++ show err
|
||||
Opts.Success opts' ->
|
||||
assertLangOk
|
||||
(opts' { include = include opts' ++
|
||||
[ "nix=../../../../data/nix/corepkgs"
|
||||
Opts.Success opts' -> assertLangOk
|
||||
(opts'
|
||||
{ include = include opts'
|
||||
++ [ "nix=../../../../data/nix/corepkgs"
|
||||
, "lang/dir4"
|
||||
, "lang/dir5" ] })
|
||||
, "lang/dir5"
|
||||
]
|
||||
}
|
||||
)
|
||||
name
|
||||
Opts.CompletionInvoked _ -> error "unused"
|
||||
_ -> assertFailure $ "Unknown test type " ++ show files
|
||||
where
|
||||
name = "data/nix/tests/lang/"
|
||||
++ the (map (takeFileName . dropExtensions) files)
|
||||
name =
|
||||
"data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files)
|
||||
|
||||
fixup ("--arg":x:y:rest) = "--arg":(x ++ "=" ++ y):fixup rest
|
||||
fixup ("--argstr":x:y:rest) = "--argstr":(x ++ "=" ++ y):fixup rest
|
||||
fixup (x:rest) = x:fixup rest
|
||||
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
|
||||
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
|
||||
++ "`."
|
||||
|
|
|
@ -16,7 +16,9 @@ import Data.Algorithm.DiffOutput
|
|||
import Data.Char
|
||||
import Data.Fix
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text ( Text
|
||||
, pack
|
||||
)
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Hedgehog
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
|
@ -27,7 +29,10 @@ import Nix.Parser
|
|||
import Nix.Pretty
|
||||
import Test.Tasty
|
||||
import Test.Tasty.Hedgehog
|
||||
import Text.Megaparsec (Pos, SourcePos, mkPos)
|
||||
import Text.Megaparsec ( Pos
|
||||
, SourcePos
|
||||
, mkPos
|
||||
)
|
||||
import qualified Text.Show.Pretty as PS
|
||||
|
||||
asciiString :: MonadGen m => m String
|
||||
|
@ -44,20 +49,18 @@ genSourcePos :: Gen SourcePos
|
|||
genSourcePos = SourcePos <$> asciiString <*> genPos <*> genPos
|
||||
|
||||
genKeyName :: Gen (NKeyName NExpr)
|
||||
genKeyName = Gen.choice [ DynamicKey <$> genAntiquoted genString
|
||||
, StaticKey <$> asciiText ]
|
||||
genKeyName =
|
||||
Gen.choice [DynamicKey <$> genAntiquoted genString, StaticKey <$> asciiText]
|
||||
|
||||
genAntiquoted :: Gen a -> Gen (Antiquoted a NExpr)
|
||||
genAntiquoted gen = Gen.choice
|
||||
[ Plain <$> gen
|
||||
, pure EscapedNewline
|
||||
, Antiquoted <$> genExpr
|
||||
]
|
||||
genAntiquoted gen =
|
||||
Gen.choice [Plain <$> gen, pure EscapedNewline, Antiquoted <$> genExpr]
|
||||
|
||||
genBinding :: Gen (Binding NExpr)
|
||||
genBinding = Gen.choice
|
||||
[ NamedVar <$> genAttrPath <*> genExpr <*> genSourcePos
|
||||
, Inherit <$> Gen.maybe genExpr
|
||||
, Inherit
|
||||
<$> Gen.maybe genExpr
|
||||
<*> Gen.list (Range.linear 0 5) genKeyName
|
||||
<*> genSourcePos
|
||||
]
|
||||
|
@ -65,19 +68,19 @@ genBinding = Gen.choice
|
|||
genString :: Gen (NString NExpr)
|
||||
genString = Gen.choice
|
||||
[ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
|
||||
, Indented <$> Gen.int (Range.linear 0 10)
|
||||
<*> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
|
||||
, Indented <$> Gen.int (Range.linear 0 10) <*> Gen.list
|
||||
(Range.linear 0 5)
|
||||
(genAntiquoted asciiText)
|
||||
]
|
||||
|
||||
genAttrPath :: Gen (NAttrPath NExpr)
|
||||
genAttrPath = (NE.:|) <$> genKeyName
|
||||
<*> Gen.list (Range.linear 0 4) genKeyName
|
||||
genAttrPath = (NE.:|) <$> genKeyName <*> Gen.list (Range.linear 0 4) genKeyName
|
||||
|
||||
genParams :: Gen (Params NExpr)
|
||||
genParams = Gen.choice
|
||||
[ Param <$> asciiText
|
||||
, ParamSet <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText
|
||||
<*> Gen.maybe genExpr)
|
||||
, ParamSet
|
||||
<$> Gen.list (Range.linear 0 10) ((,) <$> asciiText <*> Gen.maybe genExpr)
|
||||
<*> Gen.bool
|
||||
<*> Gen.choice [pure Nothing, Just <$> asciiText]
|
||||
]
|
||||
|
@ -87,33 +90,30 @@ genAtom = Gen.choice
|
|||
[ NInt <$> Gen.integral (Range.linear 0 1000)
|
||||
, NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0)
|
||||
, NBool <$> Gen.bool
|
||||
, pure NNull ]
|
||||
, pure NNull
|
||||
]
|
||||
|
||||
-- This is written by hand so we can use `fairList` rather than the normal
|
||||
-- list Arbitrary instance which makes the generator terminate. The
|
||||
-- distribution is not scientifically chosen.
|
||||
genExpr :: Gen NExpr
|
||||
genExpr = Gen.sized $ \(Size n) ->
|
||||
Fix <$>
|
||||
if n < 2
|
||||
then Gen.choice
|
||||
[genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
|
||||
else
|
||||
Gen.frequency
|
||||
[ ( 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
|
||||
|
@ -147,8 +147,10 @@ equivUpToNormalization x y = normalize x == normalize y
|
|||
|
||||
normalize :: NExpr -> NExpr
|
||||
normalize = cata $ \case
|
||||
NConstant (NInt n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NInt (negate n)))))
|
||||
NConstant (NFloat n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n)))))
|
||||
NConstant (NInt n) | n < 0 ->
|
||||
Fix (NUnary NNeg (Fix (NConstant (NInt (negate n)))))
|
||||
NConstant (NFloat n) | n < 0 ->
|
||||
Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n)))))
|
||||
|
||||
NSet binds -> Fix (NSet (map normBinding binds))
|
||||
NRecSet binds -> Fix (NRecSet (map normBinding binds))
|
||||
|
@ -163,12 +165,11 @@ normalize = cata $ \case
|
|||
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'
|
||||
|
@ -177,7 +178,7 @@ normalize = cata $ \case
|
|||
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
|
||||
|
||||
|
@ -191,17 +192,17 @@ prop_prettyparse p = do
|
|||
case parse (pack prog) of
|
||||
Failure s -> do
|
||||
footnote $ show $ vsep
|
||||
[ fillSep ["Parse failed:", pretty (show s)]
|
||||
, indent 2 (prettyNix p)
|
||||
]
|
||||
[fillSep ["Parse failed:", pretty (show s)], indent 2 (prettyNix p)]
|
||||
discard
|
||||
Success v
|
||||
| equivUpToNormalization p v -> success
|
||||
| otherwise -> do
|
||||
let pp = normalise prog
|
||||
pv = normalise (show (prettyNix v))
|
||||
footnote $ show $ vsep $
|
||||
[ "----------------------------------------"
|
||||
footnote
|
||||
$ show
|
||||
$ vsep
|
||||
$ [ "----------------------------------------"
|
||||
, vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))]
|
||||
, "----------------------------------------"
|
||||
, vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))]
|
||||
|
@ -224,7 +225,7 @@ prop_prettyparse p = do
|
|||
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
|
||||
|
||||
diff :: String -> String -> [Diff [String]]
|
||||
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
|
||||
diff s1 s2 = getDiff (map (: []) (lines s1)) (map (: []) (lines s2))
|
||||
|
||||
tests :: TestLimit -> TestTree
|
||||
tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do
|
||||
|
|
|
@ -34,4 +34,5 @@ tests = $testGroupGenerator
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
assertPretty :: NExpr -> String -> Assertion
|
||||
assertPretty e s = assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e
|
||||
assertPretty e s =
|
||||
assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e
|
||||
|
|
|
@ -9,19 +9,20 @@ import Nix.Atoms
|
|||
import Nix.Expr.Types
|
||||
import Nix.Expr.Types.Annotated
|
||||
import Nix.Parser
|
||||
import Nix.Reduce (reduceExpr)
|
||||
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
|
||||
|
|
|
@ -6,7 +6,9 @@ module TestCommon where
|
|||
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text ( Text
|
||||
, unpack
|
||||
)
|
||||
import Data.Time
|
||||
import Nix
|
||||
import Nix.Thunk.Standard
|
||||
|
@ -25,25 +27,29 @@ hnixEvalFile opts file = do
|
|||
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
|
||||
Success expr -> do
|
||||
setEnv "TEST_VAR" "foo"
|
||||
runStdLazyM opts $
|
||||
catch (evaluateExpression (Just file) nixEvalExprLoc
|
||||
normalForm expr) $ \case
|
||||
runStdLazyM opts
|
||||
$ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr)
|
||||
$ \case
|
||||
NixException frames ->
|
||||
errorWithoutStackTrace . show
|
||||
errorWithoutStackTrace
|
||||
. show
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
|
||||
hnixEvalText :: Options -> Text -> IO (StdValueNF IO)
|
||||
hnixEvalText opts src = case parseNixText src of
|
||||
Failure err ->
|
||||
error $ "Parsing failed for expressien `"
|
||||
++ unpack src ++ "`.\n" ++ show err
|
||||
error
|
||||
$ "Parsing failed for expressien `"
|
||||
++ unpack src
|
||||
++ "`.\n"
|
||||
++ show err
|
||||
Success expr ->
|
||||
-- runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
|
||||
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
|
||||
|
||||
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
|
||||
|
@ -56,15 +62,14 @@ nixEvalFile fp = readProcess "nix-instantiate" ["--eval", "--strict", fp] ""
|
|||
assertEvalFileMatchesNix :: FilePath -> Assertion
|
||||
assertEvalFileMatchesNix fp = do
|
||||
time <- liftIO getCurrentTime
|
||||
hnixVal <- (++"\n") . printNix <$> hnixEvalFile (defaultOptions time) fp
|
||||
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
|
||||
hnixVal <- (++ "\n") . printNix <$> hnixEvalText (defaultOptions time) expr
|
||||
nixVal <- nixEvalString expr'
|
||||
assertEqual expr' nixVal hnixVal
|
||||
where
|
||||
expr' = unpack expr
|
||||
where expr' = unpack expr
|
||||
|
|
Loading…
Reference in New Issue