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

Reformat all sources with Brittany, to restore consistency

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

6
benchmarks/Main.hs
View file

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

9
benchmarks/ParserBench.hs
View file

@ -1,15 +1,16 @@
module ParserBench (benchmarks) where module ParserBench (benchmarks) where
import Nix.Parser import Nix.Parser
import Control.Applicative import Control.Applicative
import Criterion import Criterion
benchFile :: FilePath -> Benchmark benchFile :: FilePath -> Benchmark
benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++) benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++)
benchmarks :: Benchmark benchmarks :: Benchmark
benchmarks = bgroup "Parser" benchmarks = bgroup
"Parser"
[ benchFile "nixpkgs-all-packages.nix" [ benchFile "nixpkgs-all-packages.nix"
, benchFile "nixpkgs-all-packages-pretty.nix" , benchFile "nixpkgs-all-packages-pretty.nix"
, benchFile "let-comments.nix" , benchFile "let-comments.nix"

367
main/Main.hs
View file

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

134
main/Repl.hs
View file

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

201
src/Nix.hs
View file

@ -4,34 +4,40 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Nix (module Nix.Cache, module Nix
module Nix.Exec, ( module Nix.Cache
module Nix.Expr, , module Nix.Exec
module Nix.Frames, , module Nix.Expr
module Nix.Render.Frame, , module Nix.Frames
module Nix.Normal, , module Nix.Render.Frame
module Nix.Options, , module Nix.Normal
module Nix.String, , module Nix.Options
module Nix.Parser, , module Nix.String
module Nix.Pretty, , module Nix.Parser
module Nix.Reduce, , module Nix.Pretty
module Nix.Thunk, , module Nix.Reduce
module Nix.Value, , module Nix.Thunk
module Nix.XML, , module Nix.Value
withNixContext, , module Nix.XML
nixEvalExpr, nixEvalExprLoc, nixTracingEvalExprLoc, , withNixContext
evaluateExpression, processResult) where , nixEvalExpr
, nixEvalExprLoc
, nixTracingEvalExprLoc
, evaluateExpression
, processResult
)
where
import Control.Applicative import Control.Applicative
import Control.Arrow (second) import Control.Arrow ( second )
import Control.Monad.Reader import Control.Monad.Reader
import Data.Fix import Data.Fix
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Read as Text import qualified Data.Text.Read as Text
import Nix.Builtins import Nix.Builtins
import Nix.Cache import Nix.Cache
import qualified Nix.Eval as Eval import qualified Nix.Eval as Eval
import Nix.Exec import Nix.Exec
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
@ -50,21 +56,34 @@ import Nix.XML
-- | This is the entry point for all evaluations, whatever the expression tree -- | This is the entry point for all evaluations, whatever the expression tree
-- type. It sets up the common Nix environment and applies the -- type. It sets up the common Nix environment and applies the
-- transformations, allowing them to be easily composed. -- transformations, allowing them to be easily composed.
nixEval :: (MonadBuiltins e t f m, Has e Options, Functor g) nixEval
=> Maybe FilePath -> Transform g (m a) -> Alg g (m a) -> Fix g -> m a :: (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 nixEval mpath xform alg = withNixContext mpath . adi alg xform
-- | Evaluate a nix expression in the default context -- | Evaluate a nix expression in the default context
nixEvalExpr :: (MonadBuiltins e t f m, Has e Options) nixEvalExpr
=> Maybe FilePath -> NExpr -> m (NValue t f m) :: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath
-> NExpr
-> m (NValue t f m)
nixEvalExpr mpath = nixEval mpath id Eval.eval nixEvalExpr mpath = nixEval mpath id Eval.eval
-- | Evaluate a nix expression in the default context -- | Evaluate a nix expression in the default context
nixEvalExprLoc :: forall e t f m. (MonadBuiltins e t f m, Has e Options) nixEvalExprLoc
=> Maybe FilePath -> NExprLoc -> m (NValue t f m) :: forall e t f m
nixEvalExprLoc mpath = . (MonadBuiltins e t f m, Has e Options)
nixEval mpath (Eval.addStackFrames @t . Eval.addSourcePositions) => Maybe FilePath
(Eval.eval . annotated . getCompose) -> 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 -- | Evaluate a nix expression with tracing in the default context. Note that
-- this function doesn't do any tracing itself, but 'evalExprLoc' will be -- this function doesn't do any tracing itself, but 'evalExprLoc' will be
@ -72,66 +91,78 @@ nixEvalExprLoc mpath =
-- 'MonadNix'). All this function does is provide the right type class -- 'MonadNix'). All this function does is provide the right type class
-- context. -- context.
nixTracingEvalExprLoc nixTracingEvalExprLoc
:: (MonadBuiltins e t f m, Has e Options, MonadIO m, Alternative m) :: (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 nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
evaluateExpression evaluateExpression
:: (MonadBuiltins e t f m, Has e Options) :: (MonadBuiltins e t f m, Has e Options)
=> Maybe FilePath => Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue t f m)) -> (Maybe FilePath -> NExprLoc -> m (NValue t f m))
-> (NValue t f m -> m a) -> (NValue t f m -> m a)
-> NExprLoc -> NExprLoc
-> m a -> m a
evaluateExpression mpath evaluator handler expr = do evaluateExpression mpath evaluator handler expr = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
args <- traverse (traverse eval') $ args <- traverse (traverse eval') $ map (second parseArg) (arg opts) ++ map
map (second parseArg) (arg opts) ++ (second mkStr)
map (second mkStr) (argstr opts) (argstr opts)
compute evaluator expr (argmap args) handler compute evaluator expr (argmap args) handler
where where
parseArg s = case parseNixText s of parseArg s = case parseNixText s of
Success x -> x Success x -> x
Failure err -> errorWithoutStackTrace (show err) Failure err -> errorWithoutStackTrace (show err)
eval' = (normalForm =<<) . nixEvalExpr mpath eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = pure $ nvSet (M.fromList args') mempty argmap args = pure $ nvSet (M.fromList args') mempty
where where args' = map (fmap (wrapValue . nValueFromNF)) args
args' = map (fmap (wrapValue . nValueFromNF)) args
compute ev x args p = do compute ev x args p = do
f :: NValue t f m <- ev mpath x f :: NValue t f m <- ev mpath x
processResult p =<< case f of processResult p =<< case f of
NVClosure _ g -> force ?? pure =<< g args NVClosure _ g -> force ?? pure =<< g args
_ -> pure f _ -> pure f
processResult :: forall e t f m a. (MonadNix e t f m, Has e Options) processResult
=> (NValue t f m -> m a) -> NValue t f m -> m a :: 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 processResult h val = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
case attr opts of case attr opts of
Nothing -> h val Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val Just (Text.splitOn "." -> keys) -> go keys val
where where
go :: [Text.Text] -> NValue t f m -> m a go :: [Text.Text] -> NValue t f m -> m a
go [] v = h v 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 NVList xs -> case ks of
[] -> force @t @m @(NValue t f m) (xs !! n) h [] -> force @t @m @(NValue t f m) (xs !! n) h
_ -> force (xs !! n) (go ks) _ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $ _ ->
"Expected a list for selector '" ++ show n errorWithoutStackTrace
++ "', but got: " ++ show v $ "Expected a list for selector '"
go (k:ks) v = case v of ++ show n
NVSet xs _ -> case M.lookup k xs of ++ "', but got: "
Nothing -> ++ show v
errorWithoutStackTrace $ go (k : ks) v = case v of
"Set does not contain key '" NVSet xs _ -> case M.lookup k xs of
++ Text.unpack k ++ "'" Nothing ->
Just v' -> case ks of errorWithoutStackTrace
[] -> force v' h $ "Set does not contain key '"
_ -> force v' (go ks) ++ Text.unpack k
_ -> errorWithoutStackTrace $ ++ "'"
"Expected a set for selector '" ++ Text.unpack k Just v' -> case ks of
++ "', but got: " ++ show v [] -> force v' h
_ -> force v' (go ks)
_ ->
errorWithoutStackTrace
$ "Expected a set for selector '"
++ Text.unpack k
++ "', but got: "
++ show v

24
src/Nix/Atoms.hs
View file

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

1975
src/Nix/Builtins.hs
View file

File diff suppressed because it is too large Load diff

14
src/Nix/Cache.hs
View file

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

21
src/Nix/Cited.hs
View file

@ -12,15 +12,15 @@
module Nix.Cited where module Nix.Cited where
import Control.Comonad import Control.Comonad
import Control.Comonad.Env import Control.Comonad.Env
import Data.Typeable (Typeable) import Data.Typeable ( Typeable )
import GHC.Generics import GHC.Generics
import Lens.Family2.TH import Lens.Family2.TH
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.Scope import Nix.Scope
import Nix.Value import Nix.Value
data Provenance t f m = Provenance data Provenance t f m = Provenance
{ _lexicalScope :: Scopes m t { _lexicalScope :: Scopes m t
@ -40,7 +40,6 @@ data NCited t f m a = NCited
instance Applicative (NCited t f m) where instance Applicative (NCited t f m) where
pure = NCited [] pure = NCited []
-- jww (2019-03-11): ??
NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x)
instance Comonad (NCited t f m) where instance Comonad (NCited t f m) where
@ -58,8 +57,8 @@ class HasCitations t f m a where
addProvenance :: Provenance t f m -> a -> a addProvenance :: Provenance t f m -> a -> a
instance HasCitations t f m (NCited t f m a) where instance HasCitations t f m (NCited t f m a) where
citations = _provenance citations = _provenance
addProvenance x (NCited p v) = (NCited (x : p) v) addProvenance x (NCited p v) = (NCited (x : p) v)
class HasCitations1 t f m where class HasCitations1 t f m where
citations1 :: f a -> [Provenance t f m] citations1 :: f a -> [Provenance t f m]

20
src/Nix/Context.hs
View file

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

463
src/Nix/Convert.hs
View file

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

204
src/Nix/Effects.hs
View file

@ -10,13 +10,16 @@
module Nix.Effects where module Nix.Effects where
import Prelude hiding (putStr, putStrLn, print) import Prelude hiding ( putStr
, putStrLn
, print
)
import qualified Prelude import qualified Prelude
import Control.Monad.Trans import Control.Monad.Trans
import Data.Text (Text) import Data.Text ( Text )
import qualified Data.Text as T 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.Client.TLS
import Network.HTTP.Types import Network.HTTP.Types
import Nix.Expr import Nix.Expr
@ -25,7 +28,7 @@ import Nix.Parser
import Nix.Render import Nix.Render
import Nix.Utils import Nix.Utils
import Nix.Value import Nix.Value
import qualified System.Directory as S import qualified System.Directory as S
import System.Environment import System.Environment
import System.Exit import System.Exit
import qualified System.Info import qualified System.Info
@ -63,15 +66,15 @@ class Monad m => MonadIntrospect m where
recursiveSize = lift . recursiveSize recursiveSize = lift . recursiveSize
instance MonadIntrospect IO where instance MonadIntrospect IO where
recursiveSize = recursiveSize =
#ifdef MIN_VERSION_ghc_datasize #ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 #if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
recursiveSize recursiveSize
#else #else
\_ -> return 0 \_ -> return 0
#endif #endif
#else #else
\_ -> return 0 \_ -> return 0
#endif #endif
class Monad m => MonadExec m where class Monad m => MonadExec m where
@ -80,24 +83,33 @@ class Monad m => MonadExec m where
exec' = lift . exec' exec' = lift . exec'
instance MonadExec IO where instance MonadExec IO where
exec' = \case exec' = \case
[] -> return $ Left $ ErrorCall "exec: missing program" [] -> return $ Left $ ErrorCall "exec: missing program"
(prog:args) -> do (prog : args) -> do
(exitCode, out, _) <- (exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args ""
liftIO $ readProcessWithExitCode prog args "" let t = T.strip (T.pack out)
let t = T.strip (T.pack out) let emsg = "program[" ++ prog ++ "] args=" ++ show args
let emsg = "program[" ++ prog ++ "] args=" ++ show args case exitCode of
case exitCode of ExitSuccess -> if T.null t
ExitSuccess -> then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg
if T.null t else case parseNixTextLoc t of
then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg Failure err ->
else case parseNixTextLoc t of return
Failure err -> $ Left
return $ Left $ ErrorCall $ $ ErrorCall
"Error parsing output of exec: " ++ show err ++ " " ++ emsg $ "Error parsing output of exec: "
Success v -> return $ Right v ++ show err
err -> return $ Left $ ErrorCall $ ++ " "
"exec failed: " ++ show err ++ " " ++ emsg ++ emsg
Success v -> return $ Right v
err ->
return
$ Left
$ ErrorCall
$ "exec failed: "
++ show err
++ " "
++ emsg
class Monad m => MonadInstantiate m where class Monad m => MonadInstantiate m where
instantiateExpr :: String -> m (Either ErrorCall NExprLoc) instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
@ -105,21 +117,29 @@ class Monad m => MonadInstantiate m where
instantiateExpr = lift . instantiateExpr instantiateExpr = lift . instantiateExpr
instance MonadInstantiate IO where instance MonadInstantiate IO where
instantiateExpr expr = do instantiateExpr expr = do
traceM $ "Executing: " traceM $ "Executing: " ++ show
++ show ["nix-instantiate", "--eval", "--expr ", expr] ["nix-instantiate", "--eval", "--expr ", expr]
(exitCode, out, err) <- (exitCode, out, err) <- readProcessWithExitCode "nix-instantiate"
readProcessWithExitCode "nix-instantiate" ["--eval", "--expr", expr]
[ "--eval", "--expr", expr] "" ""
case exitCode of case exitCode of
ExitSuccess -> case parseNixTextLoc (T.pack out) of ExitSuccess -> case parseNixTextLoc (T.pack out) of
Failure e -> Failure e ->
return $ Left $ ErrorCall $ return
"Error parsing output of nix-instantiate: " ++ show e $ Left
Success v -> return $ Right v $ ErrorCall
status -> $ "Error parsing output of nix-instantiate: "
return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status ++ show e
++ ": " ++ err Success v -> return $ Right v
status ->
return
$ Left
$ ErrorCall
$ "nix-instantiate failed: "
++ show status
++ ": "
++ err
pathExists :: MonadFile m => FilePath -> m Bool pathExists :: MonadFile m => FilePath -> m Bool
pathExists = doesFileExist pathExists = doesFileExist
@ -136,14 +156,14 @@ class Monad m => MonadEnv m where
getCurrentSystemArch = lift getCurrentSystemArch getCurrentSystemArch = lift getCurrentSystemArch
instance MonadEnv IO where instance MonadEnv IO where
getEnvVar = lookupEnv getEnvVar = lookupEnv
getCurrentSystemOS = return $ T.pack System.Info.os getCurrentSystemOS = return $ T.pack System.Info.os
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
getCurrentSystemArch = return $ T.pack $ case System.Info.arch of getCurrentSystemArch = return $ T.pack $ case System.Info.arch of
"i386" -> "i686" "i386" -> "i686"
arch -> arch arch -> arch
class Monad m => MonadHttp m where class Monad m => MonadHttp m where
getURL :: Text -> m (Either ErrorCall StorePath) getURL :: Text -> m (Either ErrorCall StorePath)
@ -151,24 +171,32 @@ class Monad m => MonadHttp m where
getURL = lift . getURL getURL = lift . getURL
instance MonadHttp IO where instance MonadHttp IO where
getURL url = do getURL url = do
let urlstr = T.unpack url let urlstr = T.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr traceM $ "fetching HTTP URL: " ++ urlstr
req <- parseRequest urlstr req <- parseRequest urlstr
manager <- manager <- if secure req
if secure req then newTlsManager
then newTlsManager else newManager defaultManagerSettings
else newManager defaultManagerSettings -- print req
-- print req response <- httpLbs (req { method = "GET" }) manager
response <- httpLbs (req { method = "GET" }) manager let status = statusCode (responseStatus response)
let status = statusCode (responseStatus response) if status /= 200
if status /= 200 then
then return $ Left $ ErrorCall $ return
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr $ Left
else -- do $ ErrorCall
-- let bstr = responseBody response $ "fail, got "
return $ Left $ ErrorCall $ ++ show status
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr ++ " when fetching url:"
++ urlstr
else -- do
-- let bstr = responseBody response
return
$ Left
$ ErrorCall
$ "success in downloading but hnix-store is not yet ready; url = "
++ urlstr
class Monad m => MonadPutStr m where class Monad m => MonadPutStr m where
@ -179,13 +207,13 @@ class Monad m => MonadPutStr m where
putStr = lift . putStr putStr = lift . putStr
putStrLn :: MonadPutStr m => String -> m () putStrLn :: MonadPutStr m => String -> m ()
putStrLn = putStr . (++"\n") putStrLn = putStr . (++ "\n")
print :: (MonadPutStr m, Show a) => a -> m () print :: (MonadPutStr m, Show a) => a -> m ()
print = putStrLn . show print = putStrLn . show
instance MonadPutStr IO where instance MonadPutStr IO where
putStr = Prelude.putStr putStr = Prelude.putStr
class Monad m => MonadStore m where class Monad m => MonadStore m where
-- | Import a path into the nix store, and return the resulting path -- | Import a path into the nix store, and return the resulting path
@ -195,25 +223,35 @@ class Monad m => MonadStore m where
toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath) toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath)
instance MonadStore IO where instance MonadStore IO where
addPath' path = do addPath' path = do
(exitCode, out, _) <- (exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] ""
readProcessWithExitCode "nix-store" ["--add", path] "" case exitCode of
case exitCode of ExitSuccess -> do
ExitSuccess -> do let dropTrailingLinefeed p = take (length p - 1) p
let dropTrailingLinefeed p = take (length p - 1) p return $ Right $ StorePath $ dropTrailingLinefeed out
return $ Right $ StorePath $ dropTrailingLinefeed out _ ->
_ -> return $ Left $ ErrorCall $ return
"addPath: failed: nix-store --add " ++ show path $ 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 toFile_' filepath content = do
writeFile filepath content writeFile filepath content
storepath <- addPath' filepath storepath <- addPath' filepath
S.removeFile filepath S.removeFile filepath
return storepath return storepath
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
addPath p = either throwError return =<< addPath' p addPath p = either throwError return =<< addPath' p
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ p contents = either throwError return =<< toFile_' p contents toFile_ p contents = either throwError return =<< toFile_' p contents

525
src/Nix/Eval.hs
View file

@ -18,24 +18,26 @@ import Control.Monad
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Align.Key (alignWithKey) import Data.Align.Key ( alignWithKey )
import Data.Either (isRight) import Data.Either ( isRight )
import Data.Fix (Fix(Fix)) import Data.Fix ( Fix(Fix) )
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
import Data.List (partition) import Data.List ( partition )
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe (fromMaybe, catMaybes) import Data.Maybe ( fromMaybe
import Data.Text (Text) , catMaybes
import Data.These (These(..)) )
import Data.Traversable (for) import Data.Text ( Text )
import Data.These ( These(..) )
import Data.Traversable ( for )
import Nix.Atoms import Nix.Atoms
import Nix.Convert import Nix.Convert
import Nix.Expr import Nix.Expr
import Nix.Frames import Nix.Frames
import Nix.String import Nix.String
import Nix.Scope import Nix.Scope
import Nix.Strings (runAntiquoted) import Nix.Strings ( runAntiquoted )
import Nix.Thunk import Nix.Thunk
import Nix.Utils import Nix.Utils
@ -77,16 +79,17 @@ class (Show v, Monad m) => MonadEval v m where
-} -}
evalError :: Exception s => s -> m a evalError :: Exception s => s -> m a
type MonadNixEval v t m = type MonadNixEval v t m
(MonadEval v m, = ( MonadEval v m
Scoped t m, , Scoped t m
MonadThunk t m v, , MonadThunk t m v
MonadFix m, , MonadFix m
ToValue Bool m v, , ToValue Bool m v
ToValue [t] m v, , ToValue [t] m v
FromValue NixString m v, , FromValue NixString m v
ToValue (AttrSet t, AttrSet SourcePos) m v, , ToValue (AttrSet t, AttrSet SourcePos) m v
FromValue (AttrSet t, AttrSet SourcePos) m v) , FromValue (AttrSet t, AttrSet SourcePos) m v
)
data EvalFrame m t data EvalFrame m t
= EvaluatingExpr (Scopes m t) NExprLoc = EvaluatingExpr (Scopes m t) NExprLoc
@ -104,290 +107,336 @@ data SynHoleInfo m t = SynHoleInfo
instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t) 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 "__curPos") = evalCurPos
eval (NSym var) = eval (NSym var ) = (lookupVar var :: m (Maybe t))
(lookupVar var :: m (Maybe t)) >>= maybe (freeVariable var) (force ?? evaledSym var) >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x) = evalConstant x eval (NConstant x ) = evalConstant x
eval (NStr str) = evalString str eval (NStr str ) = evalString str
eval (NLiteralPath p) = evalLiteralPath p eval (NLiteralPath p ) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p eval (NEnvPath p ) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg eval (NUnary op arg ) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do eval (NBinary NApp fun arg) = do
scope <- currentScopes :: m (Scopes m t) scope <- currentScopes :: m (Scopes m t)
fun >>= (`evalApp` withScopes scope arg) fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id
where where go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l) = do eval (NList l ) = do
scope <- currentScopes scope <- currentScopes
for l (thunk @t @m @v . withScopes @t scope) >>= toValue for l (thunk @t @m @v . withScopes @t scope) >>= toValue
eval (NSet binds) = eval (NSet binds) =
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
eval (NRecSet binds) = eval (NRecSet binds) =
evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue
eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst
eval (NIf cond t f) = cond >>= \v -> evalIf v t f eval (NIf cond t f ) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = evalWith scope body eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= evalAssert ?? body eval (NAssert cond body) = cond >>= evalAssert ?? body
eval (NAbs params body) = do eval (NAbs params body) = do
-- It is the environment at the definition site, not the call site, that -- It is the environment at the definition site, not the call site, that
-- needs to be used when evaluating the body and default arguments, hence -- needs to be used when evaluating the body and default arguments, hence
-- we defer here so the present scope is restored when the parameters and -- we defer here so the present scope is restored when the parameters and
-- body are forced during application. -- body are forced during application.
scope <- currentScopes :: m (Scopes m t) scope <- currentScopes :: m (Scopes m t)
evalAbs params $ \arg k -> withScopes scope $ do evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body) pushScope args (k (M.map (`force` pure) args) body)
eval (NSynHole name) = synHole name eval (NSynHole name) = synHole name
-- | If you know that the 'scope' action will result in an 'AttrSet t', then -- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- this implementation may be used as an implementation for 'evalWith'. -- 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 evalWithAttrSet aset body = do
-- The scope is deliberately wrapped in a thunk here, since it is -- 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 -- 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 -- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once. -- its value is only computed once.
scope <- currentScopes :: m (Scopes m t) scope <- currentScopes :: m (Scopes m t)
s <- thunk @t @m @v $ withScopes scope aset s <- thunk @t @m @v $ withScopes scope aset
pushWeakScope ?? body $ force s $ pushWeakScope
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos) ?? body
$ force s
$ fmap fst
. fromValue @(AttrSet t, AttrSet SourcePos)
attrSetAlter :: forall v t m. MonadNixEval v t m attrSetAlter
=> [Text] :: forall v t m
-> SourcePos . MonadNixEval v t m
-> AttrSet (m v) => [Text]
-> AttrSet SourcePos -> SourcePos
-> m v -> AttrSet (m v)
-> m (AttrSet (m v), AttrSet SourcePos) -> AttrSet SourcePos
-> m v
-> m (AttrSet (m v), AttrSet SourcePos)
attrSetAlter [] _ _ _ _ = attrSetAlter [] _ _ _ _ =
evalError @v $ ErrorCall "invalid selector with no components" evalError @v $ ErrorCall "invalid selector with no components"
attrSetAlter (k:ks) pos m p val = case M.lookup k m of attrSetAlter (k : ks) pos m p val = case M.lookup k m of
Nothing | null ks -> go Nothing | null ks -> go
| otherwise -> recurse M.empty M.empty | otherwise -> recurse M.empty M.empty
Just x | null ks -> go Just x
| otherwise -> | null ks
x >>= fromValue @(AttrSet t, AttrSet SourcePos) -> go
>>= \(st, sp) -> recurse (force ?? pure <$> st) sp | otherwise
where -> x >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(st, sp) ->
go = return (M.insert k val m, M.insert k pos p) 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', _) -> recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
( M.insert k (toValue @(AttrSet t, AttrSet SourcePos) ( M.insert
=<< (, mempty) . fmap wrapValue <$> sequence st') st k
, M.insert k pos sp ) ( 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 desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
where where
collect :: Binding r collect
-> State (HashMap VarName (SourcePos, [Binding r])) :: Binding r
(Either VarName (Binding r)) -> State
collect (NamedVar (StaticKey x :| y:ys) val p) = do (HashMap VarName (SourcePos, [Binding r]))
m <- get (Either VarName (Binding r))
put $ M.insert x ?? m $ case M.lookup x m of collect (NamedVar (StaticKey x :| y : ys) val p) = do
Nothing -> (p, [NamedVar (y:|ys) val p]) m <- get
Just (q, v) -> (q, NamedVar (y:|ys) val q : v) put $ M.insert x ?? m $ case M.lookup x m of
pure $ Left x Nothing -> (p, [NamedVar (y :| ys) val p])
collect x = pure $ Right x Just (q, v) -> (q, NamedVar (y :| ys) val q : v)
pure $ Left x
collect x = pure $ Right x
go :: Either VarName (Binding r) go
-> State (HashMap VarName (SourcePos, [Binding r])) :: Either VarName (Binding r)
(Binding r) -> State (HashMap VarName (SourcePos, [Binding r])) (Binding r)
go (Right x) = pure x go (Right x) = pure x
go (Left x) = do go (Left x) = do
maybeValue <- gets (M.lookup x) maybeValue <- gets (M.lookup x)
case maybeValue of case maybeValue of
Nothing -> Nothing -> fail ("No binding " ++ show x)
fail ("No binding " ++ show x) Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p
Just (p, v) ->
pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds :: forall v t m. MonadNixEval v t m evalBinds
=> Bool :: forall v t m
-> [Binding (m v)] . MonadNixEval v t m
-> m (AttrSet t, AttrSet SourcePos) => Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds recursive binds = do evalBinds recursive binds = do
scope <- currentScopes :: m (Scopes m t) scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where where
moveOverridesLast = uncurry (++) . moveOverridesLast = uncurry (++) . partition
partition (\case (\case
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
_ -> True) _ -> True
)
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)] go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
finalValue >>= fromValue >>= \(o', p') -> finalValue >>= fromValue >>= \(o', p') ->
-- jww (2018-05-09): What to do with the key position here? -- jww (2018-05-09): What to do with the key position here?
return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), return $ map
force @t @m @v v pure)) (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure))
(M.toList o') (M.toList o')
go _ (NamedVar pathExpr finalValue pos) = do go _ (NamedVar pathExpr finalValue pos) = do
let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v) let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
go = \case go = \case
h :| t -> evalSetterKeyName h >>= \case h :| t -> evalSetterKeyName h >>= \case
Nothing -> Nothing ->
pure ([], nullPos, pure
toValue @(AttrSet t, AttrSet SourcePos) ( []
(mempty, mempty)) , nullPos
Just k -> case t of , toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty)
[] -> pure ([k], pos, finalValue) )
x:xs -> do Just k -> case t of
(restOfPath, _, v) <- go (x:|xs) [] -> pure ([k], pos, finalValue)
pure (k : restOfPath, pos, v) x : xs -> do
go pathExpr <&> \case (restOfPath, _, v) <- go (x :| xs)
-- When there are no path segments, e.g. `${null} = 5;`, we don't pure (k : restOfPath, pos, v)
-- bind anything go pathExpr <&> \case
([], _, _) -> [] -- When there are no path segments, e.g. `${null} = 5;`, we don't
result -> [result] -- bind anything
([], _, _) -> []
result -> [result]
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $ go scope (Inherit ms names pos) =
evalSetterKeyName >=> \case fmap catMaybes $ forM names $ evalSetterKeyName >=> \case
Nothing -> pure Nothing Nothing -> pure Nothing
Just key -> pure $ Just ([key], pos, do Just key -> pure $ Just
mv <- case ms of ( [key]
Nothing -> withScopes scope $ lookupVar key , pos
Just s -> s , do
>>= fromValue @(AttrSet t, AttrSet SourcePos) mv <- case ms of
>>= \(s, _) -> Nothing -> withScopes scope $ lookupVar key
clearScopes @t $ pushScope s $ lookupVar key Just s ->
case mv of s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) ->
Nothing -> attrMissing (key :| []) Nothing clearScopes @t $ pushScope s $ lookupVar key
Just v -> force v pure) case mv of
Nothing -> attrMissing (key :| []) Nothing
Just v -> force v pure
)
buildResult :: Scopes m t buildResult
-> [([Text], SourcePos, m v)] :: Scopes m t
-> m (AttrSet t, AttrSet SourcePos) -> [([Text], SourcePos, m v)]
buildResult scope bindings = do -> m (AttrSet t, AttrSet SourcePos)
(s, p) <- foldM insert (M.empty, M.empty) bindings buildResult scope bindings = do
res <- if recursive (s, p) <- foldM insert (M.empty, M.empty) bindings
then loebM (encapsulate <$> s) res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
else traverse mkThunk s return (res, p)
return (res, p) where
where mkThunk = thunk . withScopes scope
mkThunk = thunk . withScopes scope
encapsulate f attrs = mkThunk . pushScope attrs $ f encapsulate f attrs = mkThunk . pushScope attrs $ f
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall v t m. MonadNixEval v t m evalSelect
=> m v :: forall v t m
-> NAttrPath (m v) . MonadNixEval v t m
-> m (Either (v, NonEmpty Text) (m v)) => m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
evalSelect aset attr = do evalSelect aset attr = do
s <- aset s <- aset
path <- traverse evalGetterKeyName attr path <- traverse evalGetterKeyName attr
extract s path extract s path
where 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 (s :: AttrSet t, p :: AttrSet SourcePos)
| Just t <- M.lookup k s -> case ks of | Just t <- M.lookup k s -> case ks of
[] -> pure $ Right $ force t pure [] -> 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) | otherwise -> Left . (, path) <$> toValue (s, p)
Nothing -> return $ Left (x, path) Nothing -> return $ Left (x, path)
-- | Evaluate a component of an attribute path in a context where we are -- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value -- *retrieving* a value
evalGetterKeyName :: forall v m. (MonadEval v m, FromValue NixString m v) evalGetterKeyName
=> NKeyName (m v) -> m Text :: forall v m
. (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v)
-> m Text
evalGetterKeyName = evalSetterKeyName >=> \case evalGetterKeyName = evalSetterKeyName >=> \case
Just k -> pure k 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 -- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value -- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue NixString m v) evalSetterKeyName
=> NKeyName (m v) -> m (Maybe Text) :: (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v)
-> m (Maybe Text)
evalSetterKeyName = \case evalSetterKeyName = \case
StaticKey k -> pure (Just k) StaticKey k -> pure (Just k)
DynamicKey k -> DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case
\case Just ns -> Just (hackyStringIgnoreContext ns) Just ns -> Just (hackyStringIgnoreContext ns)
_ -> Nothing _ -> Nothing
assembleString :: forall v m. (MonadEval v m, FromValue NixString m v) assembleString
=> NString (m v) -> m (Maybe NixString) :: forall v m
. (MonadEval v m, FromValue NixString m v)
=> NString (m v)
-> m (Maybe NixString)
assembleString = \case assembleString = \case
Indented _ parts -> fromParts parts Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts DoubleQuoted parts -> fromParts parts
where where
fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go 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 buildArgument
=> Params (m v) -> m v -> m (AttrSet t) :: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do buildArgument params arg = do
scope <- currentScopes :: m (Scopes m t) scope <- currentScopes :: m (Scopes m t)
case params of case params of
Param name -> M.singleton name <$> thunk (withScopes scope arg) Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m -> ParamSet s isVariadic m ->
arg >>= fromValue @(AttrSet t, AttrSet SourcePos) arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do
>>= \(args, _) -> do let inject = case m of
let inject = case m of Nothing -> id
Nothing -> id Just n -> M.insert n $ const $ thunk (withScopes scope arg)
Just n -> M.insert n $ const $ loebM
thunk (withScopes scope arg) (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
loebM (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic) args
args (M.fromList s)) (M.fromList s)
where )
assemble :: Scopes m t where
-> Bool assemble
-> Text :: Scopes m t
-> These t (Maybe (m v)) -> Bool
-> Maybe (AttrSet t -> m t) -> Text
assemble scope isVariadic k = \case -> These t (Maybe (m v))
That Nothing -> Just $ -> Maybe (AttrSet t -> m t)
const $ evalError @v $ ErrorCall $ assemble scope isVariadic k = \case
"Missing value for parameter: " ++ show k That Nothing ->
That (Just f) -> Just $ \args -> Just
thunk $ withScopes scope $ pushScope args f $ const
This _ | isVariadic -> Nothing $ evalError @v
| otherwise -> Just $ $ ErrorCall
const $ evalError @v $ ErrorCall $ $ "Missing value for parameter: "
"Unexpected parameter: " ++ show k ++ show k
These x _ -> Just (const (pure x)) 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) addSourcePositions
=> Transform NExprLocF (m a) :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)
addSourcePositions f v@(Fix (Compose (Ann ann _))) = addSourcePositions f v@(Fix (Compose (Ann ann _))) =
local (set hasLens ann) (f v) local (set hasLens ann) (f v)
addStackFrames addStackFrames
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m) :: forall t e m a
=> Transform NExprLocF (m a) . (Scoped t m, Framed e m, Typeable t, Typeable m)
=> Transform NExprLocF (m a)
addStackFrames f v = do addStackFrames f v = do
scopes <- currentScopes :: m (Scopes m t) scopes <- currentScopes :: m (Scopes m t)
withFrame Info (EvaluatingExpr scopes v) (f v) withFrame Info (EvaluatingExpr scopes v) (f v)
framedEvalExprLoc framedEvalExprLoc
:: forall t e v m. :: forall t e v m
(MonadNixEval v t m, Framed e m, Has e SrcSpan, . (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m)
Typeable t, Typeable m) => NExprLoc
=> NExprLoc -> m v -> m v
framedEvalExprLoc = adi (eval . annotated . getCompose) framedEvalExprLoc =
(addStackFrames @t . addSourcePositions) adi (eval . annotated . getCompose) (addStackFrames @t . addSourcePositions)

1258
src/Nix/Exec.hs
View file

File diff suppressed because it is too large Load diff

17
src/Nix/Expr.hs
View file

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

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

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

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

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

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

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

44
src/Nix/Frames.hs
View file

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

49
src/Nix/Fresh.hs
View file

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

49
src/Nix/Json.hs
View file

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

507
src/Nix/Lint.hs
View file

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

141
src/Nix/Normal.hs
View file

@ -12,15 +12,15 @@
module Nix.Normal where module Nix.Normal where
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Data.Set import Data.Set
import Nix.Frames import Nix.Frames
import Nix.String import Nix.String
import Nix.Thunk import Nix.Thunk
import Nix.Value import Nix.Value
newtype NormalLoop t f m = NormalLoop (NValue t f m) newtype NormalLoop t f m = NormalLoop (NValue t f m)
deriving Show deriving Show
@ -28,79 +28,88 @@ newtype NormalLoop t f m = NormalLoop (NValue t f m)
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m) instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalForm' normalForm'
:: forall e t m f. :: forall e t m f
( Framed e m . ( Framed e m
, MonadThunk t m (NValue t f m) , MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m , MonadDataErrorContext t f m
, Ord (ThunkId 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 -> NValue t f m
-> m (NValueNF t f m) -> m (NValueNF t f m)
normalForm' f = run . nValueToNFM run go normalForm' f = run . nValueToNFM run go
where where
start = 0 :: Int start = 0 :: Int
table = mempty table = mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (`evalStateT` table) . (`runReaderT` start) run = (`evalStateT` table) . (`runReaderT` start)
go :: t go
-> (NValue t f m :: t
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)) -> ( 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 -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m)
if b go t k = do
then return $ pure t b <- seen t
else do if b
i <- ask then return $ pure t
when (i > 2000) $ else do
error "Exceeded maximum normalization depth of 2000 levels" i <- ask
s <- lift get when (i > 2000)
(res, s') <- lift $ lift $ f t $ \v -> $ error "Exceeded maximum normalization depth of 2000 levels"
(`runStateT` s) . (`runReaderT` i) $ local succ $ k v s <- lift get
lift $ put s' (res, s') <- lift $ lift $ f t $ \v ->
return res (`runStateT` s) . (`runReaderT` i) $ local succ $ k v
lift $ put s'
return res
seen t = case thunkId t of seen t = case thunkId t of
Just tid -> lift $ do Just tid -> lift $ do
res <- gets (member tid) res <- gets (member tid)
unless res $ modify (insert tid) unless res $ modify (insert tid)
return res return res
Nothing -> Nothing -> return False
return False
normalForm normalForm
:: ( Framed e m :: ( Framed e m
, MonadThunk t m (NValue t f m) , MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m , MonadDataErrorContext t f m
, Ord (ThunkId 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 = normalForm' force
normalForm_ normalForm_
:: ( Framed e m :: ( Framed e m
, MonadThunk t m (NValue t f m) , MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m , MonadDataErrorContext t f m
, Ord (ThunkId m) , Ord (ThunkId m)
) )
=> NValue t f m -> m () => NValue t f m
-> m ()
normalForm_ = void <$> normalForm' forceEff normalForm_ = void <$> normalForm' forceEff
removeEffects :: (MonadThunk t m (NValue t f m), MonadDataContext f m) removeEffects
=> NValue t f m -> NValueNF t f m :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> NValueNF t f m
removeEffects = nValueToNF (flip query opaque) removeEffects = nValueToNF (flip query opaque)
removeEffectsM :: (MonadThunk t m (NValue t f m), MonadDataContext f m) removeEffectsM
=> NValue t f m -> m (NValueNF t f m) :: (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)) removeEffectsM = nValueToNFM id (flip queryM (pure opaque))
opaque :: (MonadThunk t m (NValue t f m), MonadDataContext f m) opaque
=> NValueNF t f m :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m
opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>" opaque = nvStrNF $ principledMakeNixStringWithoutContext "<thunk>"
dethunk :: (MonadThunk t m (NValue t f m), MonadDataContext f m) dethunk
=> t -> m (NValueNF t f m) :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t
-> m (NValueNF t f m)
dethunk t = queryM t (pure opaque) removeEffectsM dethunk t = queryM t (pure opaque) removeEffectsM

63
src/Nix/Options.hs
View file

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

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

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

647
src/Nix/Parser.hs
View file

@ -10,71 +10,82 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}
module Nix.Parser module Nix.Parser
( parseNixFile ( parseNixFile
, parseNixFileLoc , parseNixFileLoc
, parseNixText , parseNixText
, parseNixTextLoc , parseNixTextLoc
, parseFromFileEx , parseFromFileEx
, Parser , Parser
, parseFromText , parseFromText
, Result(..) , Result(..)
, reservedNames , reservedNames
, OperatorInfo(..) , OperatorInfo(..)
, NSpecialOp(..) , NSpecialOp(..)
, NAssoc(..) , NAssoc(..)
, NOperatorDef , NOperatorDef
, getUnaryOperator , getUnaryOperator
, getBinaryOperator , getBinaryOperator
, getSpecialOperator , getSpecialOperator
, nixToplevelForm
, nixExpr
, nixSet
, nixBinders
, nixSelector
, nixSym
, nixPath
, nixString
, nixUri
, nixSearchPath
, nixFloat
, nixInt
, nixBool
, nixNull
, symbol
, whiteSpace
)
where
, nixToplevelForm import Prelude hiding ( readFile )
, nixExpr
, nixSet
, nixBinders
, nixSelector
, nixSym import Control.Applicative hiding ( many
, nixPath , some
, nixString )
, nixUri
, nixSearchPath
, nixFloat
, nixInt
, nixBool
, nixNull
, symbol
, whiteSpace
) where
import Prelude hiding (readFile)
import Control.Applicative hiding (many, some)
import Control.DeepSeq import Control.DeepSeq
import Control.Monad import Control.Monad
import Control.Monad.Combinators.Expr import Control.Monad.Combinators.Expr
import Data.Char (isAlpha, isDigit, isSpace) import Data.Char ( isAlpha
import Data.Data (Data(..)) , isDigit
import Data.Foldable (concat) , isSpace
)
import Data.Data ( Data(..) )
import Data.Foldable ( concat )
import Data.Functor import Data.Functor
import Data.Functor.Identity import Data.Functor.Identity
import Data.HashSet (HashSet) import Data.HashSet ( HashSet )
import qualified Data.HashSet as 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.List.NonEmpty as NE
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text (Text) import Data.Text ( Text )
import Data.Text hiding (map, foldr1, concat, concatMap, zipWith) import Data.Text hiding ( map
import Data.Text.Prettyprint.Doc (Doc, pretty) , foldr1
, concat
, concatMap
, zipWith
)
import Data.Text.Prettyprint.Doc ( Doc
, pretty
)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Typeable (Typeable) import Data.Typeable ( Typeable )
import Data.Void import Data.Void
import GHC.Generics hiding (Prefix) import GHC.Generics hiding ( Prefix )
import Nix.Expr hiding (($>)) import Nix.Expr hiding ( ($>) )
import Nix.Render import Nix.Render
import Nix.Strings import Nix.Strings
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L import qualified Text.Megaparsec.Char.Lexer as L
infixl 3 <+> infixl 3 <+>
(<+>) :: MonadPlus m => m a -> m a -> m a (<+>) :: MonadPlus m => m a -> m a -> m a
@ -90,8 +101,10 @@ antiStart = symbol "${" <?> show ("${" :: String)
nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc)
nixAntiquoted p = nixAntiquoted p =
Antiquoted <$> (antiStart *> nixToplevelForm <* symbol "}") Antiquoted
<+> Plain <$> p <$> (antiStart *> nixToplevelForm <* symbol "}")
<+> Plain
<$> p
<?> "anti-quotation" <?> "anti-quotation"
selDot :: Parser () selDot :: Parser ()
@ -99,62 +112,69 @@ selDot = try (symbol "." *> notFollowedBy nixPath) <?> "."
nixSelect :: Parser NExprLoc -> Parser NExprLoc nixSelect :: Parser NExprLoc -> Parser NExprLoc
nixSelect term = do nixSelect term = do
res <- build res <- build <$> term <*> optional
<$> term ((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm))
<*> optional ((,) <$> (selDot *> nixSelector) continues <- optional $ lookAhead selDot
<*> optional (reserved "or" *> nixTerm)) case continues of
continues <- optional $ lookAhead selDot Nothing -> pure res
case continues of Just _ -> nixSelect (pure res)
Nothing -> pure res
Just _ -> nixSelect (pure res)
where where
build :: NExprLoc build
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) :: NExprLoc
-> NExprLoc -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
build t Nothing = t -> NExprLoc
build t (Just (s,o)) = nSelectLoc t s o build t Nothing = t
build t (Just (s, o)) = nSelectLoc t s o
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
nixSelector = annotateLocation $ do nixSelector = annotateLocation $ do
(x:xs) <- keyName `sepBy1` selDot (x : xs) <- keyName `sepBy1` selDot
return $ x :| xs return $ x :| xs
nixTerm :: Parser NExprLoc nixTerm :: Parser NExprLoc
nixTerm = do nixTerm = do
c <- try $ lookAhead $ satisfy $ \x -> c <- try $ lookAhead $ satisfy $ \x ->
pathChar x || pathChar x
x == '(' || || x
x == '{' || == '('
x == '[' || || x
x == '<' || == '{'
x == '/' || || x
x == '"' || == '['
x == '\''|| || x
x == '^' == '<'
case c of || x
'(' -> nixSelect nixParens == '/'
'{' -> nixSelect nixSet || x
'[' -> nixList == '"'
'<' -> nixSearchPath || x
'/' -> nixPath == '\''
'"' -> nixString || x
'\'' -> nixString == '^'
'^' -> nixSynHole case c of
_ -> msum $ '(' -> nixSelect nixParens
[ nixSelect nixSet | c == 'r' ] ++ '{' -> nixSelect nixSet
[ nixPath | pathChar c ] ++ '[' -> nixList
if isDigit c '<' -> nixSearchPath
then [ nixFloat '/' -> nixPath
, nixInt ] '"' -> nixString
else [ nixUri | isAlpha c ] ++ '\'' -> nixString
[ nixBool | c == 't' || c == 'f' ] ++ '^' -> nixSynHole
[ 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 :: Parser NExprLoc
nixToplevelForm = keywords <+> nixLambda <+> nixExpr nixToplevelForm = keywords <+> nixLambda <+> nixExpr
where where keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith
nixSym :: Parser NExprLoc nixSym :: Parser NExprLoc
nixSym = annotateLocation1 $ mkSymF <$> identifier nixSym = annotateLocation1 $ mkSymF <$> identifier
@ -166,12 +186,13 @@ nixInt :: Parser NExprLoc
nixInt = annotateLocation1 (mkIntF <$> integer <?> "integer") nixInt = annotateLocation1 (mkIntF <$> integer <?> "integer")
nixFloat :: Parser NExprLoc nixFloat :: Parser NExprLoc
nixFloat = annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float") nixFloat =
annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
nixBool :: Parser NExprLoc nixBool :: Parser NExprLoc
nixBool = annotateLocation1 (bool "true" True <+> nixBool =
bool "false" False) <?> "bool" where annotateLocation1 (bool "true" True <+> bool "false" False) <?> "bool"
bool str b = mkBoolF b <$ reserved str where bool str b = mkBoolF b <$ reserved str
nixNull :: Parser NExprLoc nixNull :: Parser NExprLoc
nixNull = annotateLocation1 (mkNullF <$ reserved "null" <?> "null") nixNull = annotateLocation1 (mkNullF <$ reserved "null" <?> "null")
@ -183,57 +204,80 @@ nixList :: Parser NExprLoc
nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list") nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list")
pathChar :: Char -> Bool 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 :: Parser Char
slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x))) slash =
try
( char '/'
<* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x))
)
<?> "slash" <?> "slash"
-- | A path surrounded by angle brackets, indicating that it should be -- | A path surrounded by angle brackets, indicating that it should be
-- looked up in the NIX_PATH environment variable at evaluation. -- looked up in the NIX_PATH environment variable at evaluation.
nixSearchPath :: Parser NExprLoc nixSearchPath :: Parser NExprLoc
nixSearchPath = annotateLocation1 nixSearchPath = annotateLocation1
(mkPathF True <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") ( mkPathF True
<?> "spath") <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">")
<?> "spath"
)
pathStr :: Parser FilePath pathStr :: Parser FilePath
pathStr = lexeme $ liftM2 (++) (many (satisfy pathChar)) pathStr = lexeme $ liftM2
(Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar)))) (++)
(many (satisfy pathChar))
(Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar))))
nixPath :: Parser NExprLoc nixPath :: Parser NExprLoc
nixPath = annotateLocation1 (try (mkPathF False <$> pathStr) <?> "path") nixPath = annotateLocation1 (try (mkPathF False <$> pathStr) <?> "path")
nixLet :: Parser NExprLoc nixLet :: Parser NExprLoc
nixLet = annotateLocation1 (reserved "let" nixLet = annotateLocation1
*> (letBody <+> letBinders) (reserved "let" *> (letBody <+> letBinders) <?> "let block")
<?> "let block") where
where letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm)
letBinders = NLet -- Let expressions `let {..., body = ...}' are just desugared
<$> nixBinders -- into `(rec {..., body = ...}).body'.
<*> (reserved "in" *> nixToplevelForm) letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
-- Let expressions `let {..., body = ...}' are just desugared aset = annotateLocation1 $ NRecSet <$> braces nixBinders
-- into `(rec {..., body = ...}).body'.
letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
nixIf :: Parser NExprLoc nixIf :: Parser NExprLoc
nixIf = annotateLocation1 (NIf nixIf = annotateLocation1
<$> (reserved "if" *> nixExpr) ( NIf
<*> (reserved "then" *> nixToplevelForm) <$> (reserved "if" *> nixExpr)
<*> (reserved "else" *> nixToplevelForm) <*> (reserved "then" *> nixToplevelForm)
<?> "if") <*> (reserved "else" *> nixToplevelForm)
<?> "if"
)
nixAssert :: Parser NExprLoc nixAssert :: Parser NExprLoc
nixAssert = annotateLocation1 (NAssert nixAssert = annotateLocation1
( NAssert
<$> (reserved "assert" *> nixExpr) <$> (reserved "assert" *> nixExpr)
<*> (semi *> nixToplevelForm) <*> (semi *> nixToplevelForm)
<?> "assert") <?> "assert"
)
nixWith :: Parser NExprLoc nixWith :: Parser NExprLoc
nixWith = annotateLocation1 (NWith nixWith = annotateLocation1
( NWith
<$> (reserved "with" *> nixToplevelForm) <$> (reserved "with" *> nixToplevelForm)
<*> (semi *> nixToplevelForm) <*> (semi *> nixToplevelForm)
<?> "with") <?> "with"
)
nixLambda :: Parser NExprLoc nixLambda :: Parser NExprLoc
nixLambda = nAbs <$> annotateLocation (try argExpr) <*> nixToplevelForm nixLambda = nAbs <$> annotateLocation (try argExpr) <*> nixToplevelForm
@ -243,55 +287,64 @@ nixString = nStr <$> annotateLocation nixString'
nixUri :: Parser NExprLoc nixUri :: Parser NExprLoc
nixUri = annotateLocation1 $ lexeme $ try $ do nixUri = annotateLocation1 $ lexeme $ try $ do
start <- letterChar start <- letterChar
protocol <- many $ satisfy $ \x -> protocol <- many $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("+-." :: String) isAlpha x || isDigit x || x `elem` ("+-." :: String)
_ <- string ":" _ <- string ":"
address <- some $ satisfy $ \x -> address <- some $ satisfy $ \x ->
isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String) isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String)
return $ NStr $ return $ NStr $ DoubleQuoted
DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address] [Plain $ pack $ start : protocol ++ ':' : address]
nixString' :: Parser (NString NExprLoc) nixString' :: Parser (NString NExprLoc)
nixString' = lexeme (doubleQuoted <+> indented <?> "string") nixString' = lexeme (doubleQuoted <+> indented <?> "string")
where where
doubleQuoted :: Parser (NString NExprLoc) doubleQuoted :: Parser (NString NExprLoc)
doubleQuoted = DoubleQuoted . removePlainEmpty . mergePlain doubleQuoted =
<$> (doubleQ *> many (stringChar doubleQ (void $ char '\\') DoubleQuoted
doubleEscape) . removePlainEmpty
<* doubleQ) . mergePlain
<?> "double quoted string" <$> ( doubleQ
*> many (stringChar doubleQ (void $ char '\\') doubleEscape)
<* doubleQ
)
<?> "double quoted string"
doubleQ = void (char '"') doubleQ = void (char '"')
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode) doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
indented :: Parser (NString NExprLoc) indented :: Parser (NString NExprLoc)
indented = stripIndent indented =
<$> (indentedQ *> many (stringChar indentedQ indentedQ stripIndent
indentedEscape) <$> ( indentedQ
<* indentedQ) *> many (stringChar indentedQ indentedQ indentedEscape)
<?> "indented string" <* indentedQ
)
<?> "indented string"
indentedQ = void (string "''" <?> "\"''\"") indentedQ = void (string "''" <?> "\"''\"")
indentedEscape = try $ do indentedEscape = try $ do
indentedQ indentedQ
(Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do
_ <- char '\\' _ <- char '\\'
c <- escapeCode c <- escapeCode
pure $ if c == '\n' pure $ if c == '\n' then EscapedNewline else Plain $ singleton c
then EscapedNewline
else Plain $ singleton c
stringChar end escStart esc = stringChar end escStart esc =
Antiquoted <$> (antiStart *> nixToplevelForm <* char '}') Antiquoted
<+> Plain . singleton <$> char '$' <$> (antiStart *> nixToplevelForm <* char '}')
<+> esc <+> Plain
<+> Plain . pack <$> some plainChar . singleton
where <$> char '$'
plainChar = <+> esc
notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle <+> 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. -- | Gets all of the arguments for a function.
argExpr :: Parser (Params NExprLoc) argExpr :: Parser (Params NExprLoc)
@ -300,19 +353,22 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
-- in the case of, for example `x:y`. Is it a lambda function `x: y`, or -- 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 -- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if
-- there's a valid URI parse here. -- there's a valid URI parse here.
onlyname = msum [nixUri >> unexpected (Label ('v' NE.:| "alid uri")), onlyname =
Param <$> identifier] msum
[ nixUri >> unexpected (Label ('v' NE.:| "alid uri"))
, Param <$> identifier
]
-- Parameters named by an identifier on the left (`args @ {x, y}`) -- Parameters named by an identifier on the left (`args @ {x, y}`)
atLeft = try $ do atLeft = try $ do
name <- identifier <* symbol "@" name <- identifier <* symbol "@"
(variadic, params) <- params (variadic, params) <- params
return $ ParamSet params variadic (Just name) return $ ParamSet params variadic (Just name)
-- Parameters named by an identifier on the right, or none (`{x, y} @ args`) -- Parameters named by an identifier on the right, or none (`{x, y} @ args`)
atRight = do atRight = do
(variadic, params) <- params (variadic, params) <- params
name <- optional $ symbol "@" *> identifier name <- optional $ symbol "@" *> identifier
return $ ParamSet params variadic name return $ ParamSet params variadic name
-- Return the parameters set. -- Return the parameters set.
@ -323,7 +379,7 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
-- Collects the parameters within curly braces. Returns the parameters and -- Collects the parameters within curly braces. Returns the parameters and
-- a boolean indicating if the parameters are variadic. -- a boolean indicating if the parameters are variadic.
getParams :: Parser ([(Text, Maybe NExprLoc)], Bool) getParams :: Parser ([(Text, Maybe NExprLoc)], Bool)
getParams = go [] where getParams = go [] where
-- Attempt to parse `...`. If this succeeds, stop and return True. -- Attempt to parse `...`. If this succeeds, stop and return True.
-- Otherwise, attempt to parse an argument, optionally with a -- Otherwise, attempt to parse an argument, optionally with a
-- default. If this fails, then return what has been accumulated -- default. If this fails, then return what has been accumulated
@ -331,49 +387,49 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where
go acc = ((acc, True) <$ symbol "...") <+> getMore acc go acc = ((acc, True) <$ symbol "...") <+> getMore acc
getMore acc = getMore acc =
-- Could be nothing, in which just return what we have so far. -- Could be nothing, in which just return what we have so far.
option (acc, False) $ do option (acc, False) $ do
-- Get an argument name and an optional default. -- Get an argument name and an optional default.
pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm)
-- Either return this, or attempt to get a comma and restart. -- Either return this, or attempt to get a comma and restart.
option (acc ++ [pair], False) $ comma >> go (acc ++ [pair]) option (acc ++ [pair], False) $ comma >> go (acc ++ [pair])
nixBinders :: Parser [Binding NExprLoc] nixBinders :: Parser [Binding NExprLoc]
nixBinders = (inherit <+> namedVar) `endBy` semi where nixBinders = (inherit <+> namedVar) `endBy` semi where
inherit = do inherit = do
-- We can't use 'reserved' here because it would consume the whitespace -- We can't use 'reserved' here because it would consume the whitespace
-- after the keyword, which is not exactly the semantics of C++ Nix. -- after the keyword, which is not exactly the semantics of C++ Nix.
try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) try $ string "inherit" *> lookAhead (void (satisfy reservedEnd))
p <- getSourcePos p <- getSourcePos
x <- whiteSpace *> optional scope x <- whiteSpace *> optional scope
Inherit x <$> many keyName <*> pure p <?> "inherited binding" Inherit x <$> many keyName <*> pure p <?> "inherited binding"
namedVar = do namedVar = do
p <- getSourcePos p <- getSourcePos
NamedVar <$> (annotated <$> nixSelector) NamedVar
<*> (equals *> nixToplevelForm) <$> (annotated <$> nixSelector)
<*> pure p <*> (equals *> nixToplevelForm)
<?> "variable binding" <*> pure p
<?> "variable binding"
scope = parens nixToplevelForm <?> "inherit scope" scope = parens nixToplevelForm <?> "inherit scope"
keyName :: Parser (NKeyName NExprLoc) keyName :: Parser (NKeyName NExprLoc)
keyName = dynamicKey <+> staticKey where keyName = dynamicKey <+> staticKey where
staticKey = StaticKey <$> identifier staticKey = StaticKey <$> identifier
dynamicKey = DynamicKey <$> nixAntiquoted nixString' dynamicKey = DynamicKey <$> nixAntiquoted nixString'
nixSet :: Parser NExprLoc nixSet :: Parser NExprLoc
nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set") where nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set")
isRec = (reserved "rec" $> NRecSet <?> "recursive set") where isRec = (reserved "rec" $> NRecSet <?> "recursive set") <+> pure NSet
<+> pure NSet
parseNixFile :: MonadFile m => FilePath -> m (Result NExpr) parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
parseNixFile = parseNixFile =
parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc) parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc)
parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof) parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof)
parseNixText :: Text -> Result NExpr parseNixText :: Text -> Result NExpr
parseNixText = parseNixText =
parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseNixTextLoc :: Text -> Result NExprLoc parseNixTextLoc :: Text -> Result NExprLoc
parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof) parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
@ -381,15 +437,14 @@ parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof)
{- Parser.Library -} {- Parser.Library -}
skipLineComment' :: Tokens Text -> Parser () skipLineComment' :: Tokens Text -> Parser ()
skipLineComment' prefix = skipLineComment' prefix = string prefix
string prefix *> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
*> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r'))
whiteSpace :: Parser () whiteSpace :: Parser ()
whiteSpace = L.space space1 lineCmnt blockCmnt whiteSpace = L.space space1 lineCmnt blockCmnt
where where
lineCmnt = skipLineComment' "#" lineCmnt = skipLineComment' "#"
blockCmnt = L.skipBlockComment "/*" "*/" blockCmnt = L.skipBlockComment "/*" "*/"
lexeme :: Parser a -> Parser a lexeme :: Parser a -> Parser a
lexeme p = p <* whiteSpace lexeme p = p <* whiteSpace
@ -398,34 +453,57 @@ symbol :: Text -> Parser Text
symbol = lexeme . string symbol = lexeme . string
reservedEnd :: Char -> Bool reservedEnd :: Char -> Bool
reservedEnd x = isSpace x || reservedEnd x =
x == '{' || x == '(' || x == '[' || isSpace x
x == '}' || x == ')' || x == ']' || || x
x == ';' || x == ':' || x == '.' || == '{'
x == '"' || x == '\'' || x == ',' || x
== '('
|| x
== '['
|| x
== '}'
|| x
== ')'
|| x
== ']'
|| x
== ';'
|| x
== ':'
|| x
== '.'
|| x
== '"'
|| x
== '\''
|| x
== ','
reserved :: Text -> Parser () reserved :: Text -> Parser ()
reserved n = lexeme $ try $ reserved n =
string n *> lookAhead (void (satisfy reservedEnd) <|> eof) lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof)
identifier = lexeme $ try $ do identifier = lexeme $ try $ do
ident <- cons <$> satisfy (\x -> isAlpha x || x == '_') ident <-
<*> takeWhileP Nothing identLetter cons
guard (not (ident `HashSet.member` reservedNames)) <$> satisfy (\x -> isAlpha x || x == '_')
return ident <*> takeWhileP Nothing identLetter
where guard (not (ident `HashSet.member` reservedNames))
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-' return ident
where
identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-'
parens = between (symbol "(") (symbol ")") parens = between (symbol "(") (symbol ")")
braces = between (symbol "{") (symbol "}") braces = between (symbol "{") (symbol "}")
-- angles = between (symbol "<") (symbol ">") -- angles = between (symbol "<") (symbol ">")
brackets = between (symbol "[") (symbol "]") brackets = between (symbol "[") (symbol "]")
semi = symbol ";" semi = symbol ";"
comma = symbol "," comma = symbol ","
-- colon = symbol ":" -- colon = symbol ":"
-- dot = symbol "." -- dot = symbol "."
equals = symbol "=" equals = symbol "="
question = symbol "?" question = symbol "?"
integer :: Parser Integer integer :: Parser Integer
integer = lexeme L.decimal integer = lexeme L.decimal
@ -435,12 +513,7 @@ float = lexeme L.float
reservedNames :: HashSet Text reservedNames :: HashSet Text
reservedNames = HashSet.fromList reservedNames = HashSet.fromList
[ "let", "in" ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"]
, "if", "then", "else"
, "assert"
, "with"
, "rec"
, "inherit" ]
type Parser = ParsecT Void Text Identity type Parser = ParsecT Void Text Identity
@ -448,14 +521,14 @@ data Result a = Success a | Failure (Doc Void) deriving (Show, Functor)
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a) parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
parseFromFileEx p path = do parseFromFileEx p path = do
txt <- decodeUtf8 <$> readFile path txt <- decodeUtf8 <$> readFile path
return $ either (Failure . pretty . errorBundlePretty) Success return $ either (Failure . pretty . errorBundlePretty) Success $ parse p
$ parse p path txt path
txt
parseFromText :: Parser a -> Text -> Result a parseFromText :: Parser a -> Text -> Result a
parseFromText p txt = parseFromText p txt =
either (Failure . pretty . errorBundlePretty) Success $ either (Failure . pretty . errorBundlePretty) Success $ parse p "<string>" txt
parse p "<string>" txt
{- Parser.Operators -} {- Parser.Operators -}
@ -491,23 +564,24 @@ operator n = symbol n
opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a
opWithLoc name op f = do opWithLoc name op f = do
Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} operator name Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -}
return $ f (Ann ann op) operator name
return $ f (Ann ann op)
binaryN name op = (NBinaryDef name op NAssocNone, binaryN name op =
InfixN (opWithLoc name op nBinary)) (NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary))
binaryL name op = (NBinaryDef name op NAssocLeft, binaryL name op =
InfixL (opWithLoc name op nBinary)) (NBinaryDef name op NAssocLeft, InfixL (opWithLoc name op nBinary))
binaryR name op = (NBinaryDef name op NAssocRight, binaryR name op =
InfixR (opWithLoc name op nBinary)) (NBinaryDef name op NAssocRight, InfixR (opWithLoc name op nBinary))
prefix name op = (NUnaryDef name op, prefix name op =
Prefix (manyUnaryOp (opWithLoc name op nUnary))) (NUnaryDef name op, Prefix (manyUnaryOp (opWithLoc name op nUnary)))
-- postfix name op = (NUnaryDef name op, -- postfix name op = (NUnaryDef name op,
-- Postfix (opWithLoc name op nUnary)) -- Postfix (opWithLoc name op nUnary))
nixOperators nixOperators
:: Parser (Ann SrcSpan (NAttrPath NExprLoc)) :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
-> [[(NOperatorDef, Operator Parser NExprLoc)]] -> [[(NOperatorDef, Operator Parser NExprLoc)]]
nixOperators selector = nixOperators selector =
[ -- This is not parsed here, even though technically it's part of the [ -- This is not parsed here, even though technically it's part of the
-- expression table. The problem is that in some cases, such as list -- expression table. The problem is that in some cases, such as list
@ -521,28 +595,40 @@ nixOperators selector =
-- mor <- optional (reserved "or" *> term) -- mor <- optional (reserved "or" *> term)
-- return $ \x -> nSelectLoc x sel mor) ] -- return $ \x -> nSelectLoc x sel mor) ]
{- 2 -} [ (NBinaryDef " " NApp NAssocLeft, {- 2 -}
[ ( NBinaryDef " " NApp NAssocLeft
,
-- Thanks to Brent Yorgey for showing me this trick! -- Thanks to Brent Yorgey for showing me this trick!
InfixL $ nApp <$ symbol "") ] InfixL $ nApp <$ symbol ""
, {- 3 -} [ prefix "-" NNeg ] )
, {- 4 -} [ (NSpecialDef "?" NHasAttrOp NAssocLeft, ]
Postfix $ symbol "?" *> (flip nHasAttr <$> selector)) ] , {- 3 -}
, {- 5 -} [ binaryR "++" NConcat ] [prefix "-" NNeg]
, {- 6 -} [ binaryL "*" NMult , {- 4 -}
, binaryL "/" NDiv ] [ ( NSpecialDef "?" NHasAttrOp NAssocLeft
, {- 7 -} [ binaryL "+" NPlus , Postfix $ symbol "?" *> (flip nHasAttr <$> selector)
, binaryL "-" NMinus ] )
, {- 8 -} [ prefix "!" NNot ] ]
, {- 9 -} [ binaryR "//" NUpdate ] , {- 5 -}
, {- 10 -} [ binaryL "<" NLt [binaryR "++" NConcat]
, binaryL ">" NGt , {- 6 -}
, binaryL "<=" NLte [binaryL "*" NMult, binaryL "/" NDiv]
, binaryL ">=" NGte ] , {- 7 -}
, {- 11 -} [ binaryN "==" NEq [binaryL "+" NPlus, binaryL "-" NMinus]
, binaryN "!=" NNEq ] , {- 8 -}
, {- 12 -} [ binaryL "&&" NAnd ] [prefix "!" NNot]
, {- 13 -} [ binaryL "||" NOr ] , {- 9 -}
, {- 14 -} [ binaryN "->" NImpl ] [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 data OperatorInfo = OperatorInfo
@ -553,25 +639,36 @@ data OperatorInfo = OperatorInfo
getUnaryOperator :: NUnaryOp -> OperatorInfo getUnaryOperator :: NUnaryOp -> OperatorInfo
getUnaryOperator = (m Map.!) where getUnaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..] m = Map.fromList $ concat $ zipWith buildEntry
(nixOperators (error "unused")) [1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case buildEntry i = concatMap $ \case
(NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)]
_ -> [] _ -> []
getBinaryOperator :: NBinaryOp -> OperatorInfo getBinaryOperator :: NBinaryOp -> OperatorInfo
getBinaryOperator = (m Map.!) where getBinaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..] m = Map.fromList $ concat $ zipWith buildEntry
(nixOperators (error "unused")) [1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case buildEntry i = concatMap $ \case
(NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> [] _ -> []
getSpecialOperator :: NSpecialOp -> OperatorInfo getSpecialOperator :: NSpecialOp -> OperatorInfo
getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "."
getSpecialOperator o = m Map.! o where getSpecialOperator o = m Map.! o where
m = Map.fromList $ concat $ zipWith buildEntry [1..] m = Map.fromList $ concat $ zipWith buildEntry
(nixOperators (error "unused")) [1 ..]
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case buildEntry i = concatMap $ \case
(NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> [] _ -> []

475
src/Nix/Pretty.hs
View file

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

478
src/Nix/Reduce.hs
View file

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

107
src/Nix/Render.hs
View file

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

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

@ -35,196 +35,202 @@ import qualified Text.Show.Pretty as PS
renderFrames renderFrames
:: forall v t f e m ann :: forall v t f e m ann
. ( MonadReader e m . ( MonadReader e m
, Has e Options , Has e Options
, MonadFile m , MonadFile m
, MonadCitedThunks t f m , MonadCitedThunks t f m
, Typeable v , Typeable v
) )
=> Frames -> m (Doc ann) => Frames
renderFrames [] = pure mempty -> m (Doc ann)
renderFrames (x:xs) = do renderFrames [] = pure mempty
opts :: Options <- asks (view hasLens) renderFrames (x : xs) = do
frames <- opts :: Options <- asks (view hasLens)
if | verbose opts <= ErrorsOnly -> frames <- if
renderFrame @v @t @f x | verbose opts <= ErrorsOnly -> renderFrame @v @t @f x
| verbose opts <= Informational -> do | verbose opts <= Informational -> do
f <- renderFrame @v @t @f x f <- renderFrame @v @t @f x
pure $ concatMap go (reverse xs) ++ f pure $ concatMap go (reverse xs) ++ f
| otherwise -> | otherwise -> concat <$> mapM (renderFrame @v @t @f) (reverse (x : xs))
concat <$> mapM (renderFrame @v @t @f) (reverse (x:xs)) pure $ case frames of
pure $ case frames of [] -> mempty
[] -> mempty _ -> vsep frames
_ -> vsep frames where
where go :: NixFrame -> [Doc ann]
go :: NixFrame -> [Doc ann] go f = case framePos @v @m f of
go f = case framePos @v @m f of Just pos ->
Just pos -> ["While evaluating at " <> pretty (sourcePosPretty pos) <> colon]
["While evaluating at " Nothing -> []
<> pretty (sourcePosPretty pos)
<> colon]
Nothing -> []
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) framePos
=> NixFrame -> Maybe SourcePos :: forall v (m :: * -> *)
. (Typeable m, Typeable v)
=> NixFrame
-> Maybe SourcePos
framePos (NixFrame _ f) framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromException f = case e of | Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg
Just beg _ -> Nothing
_ -> Nothing | otherwise = Nothing
| otherwise = Nothing
renderFrame renderFrame
:: forall v t f e m ann. :: forall v t f e m ann
( MonadReader e m . ( MonadReader e m
, Has e Options , Has e Options
, MonadFile m , MonadFile m
, MonadCitedThunks t f m , MonadCitedThunks t f m
, Typeable v , Typeable v
) )
=> NixFrame -> m [Doc ann] => NixFrame
-> m [Doc ann]
renderFrame (NixFrame level f) renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e | Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e | Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e | Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e | Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)] | Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
| Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)] | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show f | otherwise = error $ "Unrecognized frame: " ++ show f
wrapExpr :: NExprF r -> NExpr wrapExpr :: NExprF r -> NExpr
wrapExpr x = Fix (Fix (NSym "<?>") <$ x) wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m) renderEvalFrame
=> NixLevel -> EvalFrame m v -> m [Doc ann] :: (MonadReader e m, Has e Options, MonadFile m)
=> NixLevel
-> EvalFrame m v
-> m [Doc ann]
renderEvalFrame level f = do renderEvalFrame level f = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
case f of case f of
EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do
let scopeInfo | scopes opts = [pretty $ show scope] let scopeInfo | scopes opts = [pretty $ show scope]
| otherwise = [] | otherwise = []
fmap (\x -> scopeInfo ++ [x]) $ renderLocation ann fmap (\x -> scopeInfo ++ [x])
=<< renderExpr level "While evaluating" "Expression" e $ renderLocation ann
=<< renderExpr level "While evaluating" "Expression" e
ForcingExpr _scope e@(Fix (Compose (Ann ann _))) ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts ->
| thunks opts -> fmap (: [])
fmap (:[]) $ renderLocation ann $ renderLocation ann
=<< renderExpr level "While forcing thunk from" =<< renderExpr level "While forcing thunk from" "Forcing thunk" e
"Forcing thunk" e
Calling name ann -> Calling name ann ->
fmap (:[]) $ renderLocation ann $ fmap (: [])
"While calling builtins." <> pretty name $ renderLocation ann
$ "While calling builtins."
<> pretty name
SynHole synfo -> sequence $ SynHole synfo ->
let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo sequence
in [ renderLocation ann =<< $ let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
renderExpr level "While evaluating" "Syntactic Hole" e in [ renderLocation ann
, pure $ pretty $ show (_synHoleInfo_scope synfo) =<< renderExpr level "While evaluating" "Syntactic Hole" e
] , pure $ pretty $ show (_synHoleInfo_scope synfo)
]
ForcingExpr _ _ -> pure [] ForcingExpr _ _ -> pure []
renderExpr :: (MonadReader e m, Has e Options, MonadFile m) renderExpr
=> NixLevel -> String -> String -> NExprLoc -> m (Doc ann) :: (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 renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
let rendered let rendered
| verbose opts >= DebugInfo = | verbose opts >= DebugInfo =
#ifdef MIN_VERSION_pretty_show #ifdef MIN_VERSION_pretty_show
pretty (PS.ppShow (stripAnnotation e)) pretty (PS.ppShow (stripAnnotation e))
#else #else
pretty (show (stripAnnotation e)) pretty (show (stripAnnotation e))
#endif #endif
| verbose opts >= Chatty = | verbose opts >= Chatty = prettyNix (stripAnnotation e)
prettyNix (stripAnnotation e) | otherwise = prettyNix (Fix (Fix (NSym "<?>") <$ x))
| otherwise = pure $ if verbose opts >= Chatty
prettyNix (Fix (Fix (NSym "<?>") <$ x)) then
pure $ if verbose opts >= Chatty vsep
then vsep $ $ [pretty (longLabel ++ ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"]
[ pretty (longLabel ++ ":\n>>>>>>>>") else pretty shortLabel <> fillSep [": ", rendered]
, indent 2 rendered
, "<<<<<<<<"
]
else pretty shortLabel <> fillSep [": ", rendered]
renderValueFrame renderValueFrame
:: ( MonadReader e m :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
, Has e Options => NixLevel
, MonadFile m -> ValueFrame t f m
, MonadCitedThunks t f m -> m [Doc ann]
) renderValueFrame level = fmap (: []) . \case
=> NixLevel -> ValueFrame t f m -> m [Doc ann] ForcingThunk -> pure "ForcingThunk"
renderValueFrame level = fmap (:[]) . \case ConcerningValue _v -> pure "ConcerningValue"
ForcingThunk -> pure "ForcingThunk" Comparison _ _ -> pure "Comparing"
ConcerningValue _v -> pure "ConcerningValue" Addition _ _ -> pure "Adding"
Comparison _ _ -> pure "Comparing" Division _ _ -> pure "Dividing"
Addition _ _ -> pure "Adding" Multiplication _ _ -> pure "Multiplying"
Division _ _ -> pure "Dividing"
Multiplication _ _ -> pure "Multiplying"
Coercion x y -> pure $ mconcat Coercion x y -> pure
[ desc $ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)]
, pretty (describeValue x) where
, " to " desc | level <= Error = "Cannot coerce "
, pretty (describeValue y) | otherwise = "While coercing "
]
where
desc | level <= Error = "Cannot coerce "
| otherwise = "While coercing "
CoercionToJson v -> do CoercionToJson v -> do
v' <- renderValue level "" "" v v' <- renderValue level "" "" v
pure $ "CoercionToJson " <> v' pure $ "CoercionToJson " <> v'
CoercionFromJson _j -> pure "CoercionFromJson" CoercionFromJson _j -> pure "CoercionFromJson"
ExpectationNF _t _v -> pure "ExpectationNF" ExpectationNF _t _v -> pure "ExpectationNF"
Expectation t v -> do Expectation t v -> do
v' <- renderValue level "" "" v v' <- renderValue level "" "" v
pure $ "Saw " <> v' pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t)
<> " but expected " <> pretty (describeValue t)
renderValue renderValue
:: ( MonadReader e m :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
, Has e Options => NixLevel
, MonadFile m -> String
, MonadCitedThunks t f m -> String
) -> NValue t f m
=> NixLevel -> String -> String -> NValue t f m -> m (Doc ann) -> m (Doc ann)
renderValue _level _longLabel _shortLabel v = do renderValue _level _longLabel _shortLabel v = do
opts :: Options <- asks (view hasLens) opts :: Options <- asks (view hasLens)
if values opts if values opts then prettyNValueProv v else prettyNValue v
then prettyNValueProv v
else prettyNValue v
renderExecFrame renderExecFrame
:: ( MonadReader e m :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
, Has e Options => NixLevel
, MonadFile m -> ExecFrame t f m
, MonadCitedThunks t f m -> m [Doc ann]
)
=> NixLevel -> ExecFrame t f m -> m [Doc ann]
renderExecFrame level = \case renderExecFrame level = \case
Assertion ann v -> Assertion ann v ->
fmap (:[]) $ renderLocation ann fmap (: [])
=<< ((\d -> fillSep ["Assertion failed:", d]) $ renderLocation ann
<$> renderValue level "" "" v) =<< ( (\d -> fillSep ["Assertion failed:", d])
<$> renderValue level "" "" v
)
renderThunkLoop renderThunkLoop
:: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
=> NixLevel -> ThunkLoop -> m [Doc ann] => NixLevel
renderThunkLoop _level = pure . (:[]) . \case -> ThunkLoop
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n -> m [Doc ann]
renderThunkLoop _level = pure . (: []) . \case
ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n
renderNormalLoop renderNormalLoop
:: ( MonadReader e m :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
, Has e Options => NixLevel
, MonadFile m -> NormalLoop t f m
, MonadCitedThunks t f m -> m [Doc ann]
) renderNormalLoop level = fmap (: []) . \case
=> NixLevel -> NormalLoop t f m -> m [Doc ann] NormalLoop v -> do
renderNormalLoop level = fmap (:[]) . \case v' <- renderValue level "" "" v
NormalLoop v -> do pure $ "Infinite recursion during normalization forcing " <> v'
v' <- renderValue level "" "" v
pure $ "Infinite recursion during normalization forcing " <> v'

59
src/Nix/Scope.hs
View file

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

51
src/Nix/String.hs
View file

@ -2,8 +2,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Nix.String ( module Nix.String
NixString ( NixString
, principledGetContext , principledGetContext
, principledMakeNixString , principledMakeNixString
, principledMempty , principledMempty
@ -29,14 +29,15 @@ module Nix.String (
, addSingletonStringContext , addSingletonStringContext
, runWithStringContextT , runWithStringContextT
, runWithStringContext , runWithStringContext
) where )
where
import Control.Monad.Writer import Control.Monad.Writer
import Data.Functor.Identity import Data.Functor.Identity
import qualified Data.HashSet as S import qualified Data.HashSet as S
import Data.Hashable import Data.Hashable
import Data.Text (Text) import Data.Text ( Text )
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC.Generics import GHC.Generics
-- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-} -- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-}
@ -73,20 +74,22 @@ principledMempty = NixString "" mempty
-- | Combine two NixStrings using mappend -- | Combine two NixStrings using mappend
principledStringMappend :: NixString -> NixString -> NixString 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 -- | Combine two NixStrings using mappend
hackyStringMappend :: NixString -> NixString -> NixString 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 -- | Combine NixStrings with a separator
principledIntercalateNixString :: NixString -> [NixString] -> NixString principledIntercalateNixString :: NixString -> [NixString] -> NixString
principledIntercalateNixString _ [] = principledMempty principledIntercalateNixString _ [] = principledMempty
principledIntercalateNixString _ [ns] = ns principledIntercalateNixString _ [ns] = ns
principledIntercalateNixString sep nss = NixString contents ctx principledIntercalateNixString sep nss = NixString contents ctx
where where
contents = Text.intercalate (nsContents sep) (map nsContents nss) contents = Text.intercalate (nsContents sep) (map nsContents nss)
ctx = S.unions (nsContext sep : map nsContext nss) ctx = S.unions (nsContext sep : map nsContext nss)
-- | Combine NixStrings using mconcat -- | Combine NixStrings using mconcat
hackyStringMConcat :: [NixString] -> NixString hackyStringMConcat :: [NixString] -> NixString
@ -98,7 +101,8 @@ principledStringMempty = NixString mempty mempty
-- | Combine NixStrings using mconcat -- | Combine NixStrings using mconcat
principledStringMConcat :: [NixString] -> NixString principledStringMConcat :: [NixString] -> NixString
principledStringMConcat = foldr principledStringMappend (NixString mempty mempty) principledStringMConcat =
foldr principledStringMappend (NixString mempty mempty)
--instance Semigroup NixString where --instance Semigroup NixString where
--NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2) --NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
@ -109,13 +113,13 @@ principledStringMConcat = foldr principledStringMappend (NixString mempty mempty
-- | Extract the string contents from a NixString that has no context -- | Extract the string contents from a NixString that has no context
hackyGetStringNoContext :: NixString -> Maybe Text hackyGetStringNoContext :: NixString -> Maybe Text
hackyGetStringNoContext (NixString s c) | null c = Just s hackyGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing | otherwise = Nothing
-- | Extract the string contents from a NixString that has no context -- | Extract the string contents from a NixString that has no context
principledGetStringNoContext :: NixString -> Maybe Text principledGetStringNoContext :: NixString -> Maybe Text
principledGetStringNoContext (NixString s c) | null c = Just s principledGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing | otherwise = Nothing
-- | Extract the string contents from a NixString even if the NixString has an associated context -- | Extract the string contents from a NixString even if the NixString has an associated context
principledStringIgnoreContext :: NixString -> Text principledStringIgnoreContext :: NixString -> Text
@ -142,7 +146,8 @@ principledModifyNixContents :: (Text -> Text) -> NixString -> NixString
principledModifyNixContents f (NixString s c) = NixString (f s) c principledModifyNixContents f (NixString s c) = NixString (f s) c
-- | Create a NixString using a singleton context -- | Create a NixString using a singleton context
principledMakeNixStringWithSingletonContext :: Text -> StringContext -> NixString principledMakeNixStringWithSingletonContext
:: Text -> StringContext -> NixString
principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c) principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)
-- | Create a NixString from a Text and context -- | 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 type WithStringContext = WithStringContextT Identity
-- | Add 'StringContext's into the resulting set. -- | 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 addStringContext = WithStringContextT . tell
-- | Add a 'StringContext' into the resulting set. -- | 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'. -- | Run an action producing a string with a context and put those into a 'NixString'.
runWithStringContextT :: Monad m => WithStringContextT m Text -> m 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'. -- | Run an action producing a string with a context and put those into a 'NixString'.
runWithStringContext :: WithStringContextT Identity Text -> NixString runWithStringContext :: WithStringContextT Identity Text -> NixString

106
src/Nix/Strings.hs
View file

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

122
src/Nix/TH.hs
View file

@ -10,11 +10,13 @@ module Nix.TH where
import Data.Fix import Data.Fix
import Data.Generics.Aliases 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 qualified Data.Set as Set
import Data.Maybe (mapMaybe) import qualified Data.Text as Text
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( mapMaybe )
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import Nix.Atoms import Nix.Atoms
@ -23,97 +25,103 @@ import Nix.Parser
quoteExprExp :: String -> ExpQ quoteExprExp :: String -> ExpQ
quoteExprExp s = do quoteExprExp s = do
expr <- case parseNixText (Text.pack s) of expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err Failure err -> fail $ show err
Success e -> return e Success e -> return e
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
quoteExprPat :: String -> PatQ quoteExprPat :: String -> PatQ
quoteExprPat s = do quoteExprPat s = do
expr <- case parseNixText (Text.pack s) of expr <- case parseNixText (Text.pack s) of
Failure err -> fail $ show err Failure err -> fail $ show err
Success e -> return e Success e -> return e
dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
freeVars :: NExpr -> Set VarName freeVars :: NExpr -> Set VarName
freeVars e = case unFix e of freeVars e = case unFix e of
(NConstant _) -> Set.empty (NConstant _ ) -> Set.empty
(NStr string) -> foldMap freeVars string (NStr string ) -> foldMap freeVars string
(NSym var) -> Set.singleton var (NSym var ) -> Set.singleton var
(NList list) -> foldMap freeVars list (NList list ) -> foldMap freeVars list
(NSet bindings) -> foldMap bindFree bindings (NSet bindings) -> foldMap bindFree bindings
(NRecSet bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings (NRecSet bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings
(NLiteralPath _) -> Set.empty (NLiteralPath _ ) -> Set.empty
(NEnvPath _) -> Set.empty (NEnvPath _ ) -> Set.empty
(NUnary _ expr) -> freeVars expr (NUnary _ expr ) -> freeVars expr
(NBinary _ left right) -> freeVars left `Set.union` freeVars right (NBinary _ left right ) -> freeVars left `Set.union` freeVars right
(NSelect expr path orExpr) -> freeVars expr `Set.union` pathFree path `Set.union` maybe Set.empty freeVars orExpr (NSelect expr path orExpr) ->
(NHasAttr expr path) -> freeVars expr `Set.union` pathFree path freeVars expr
(NAbs (Param varname) expr) -> Set.delete varname (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) -> (NAbs (ParamSet set _ varname) expr) ->
-- Include all free variables from the expression and the default arguments -- 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 -- 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) \\ maybe Set.empty Set.singleton varname
(NLet bindings expr) -> freeVars expr `Set.union` foldMap bindFree bindings \\ foldMap bindDefs bindings \\ Set.fromList (map fst set)
(NIf cond th el) -> freeVars cond `Set.union` freeVars th `Set.union` freeVars el (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 -- 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` -- This also makes sense because its value can be overridden by `x: with y; x`
(NWith set expr) -> freeVars set `Set.union` freeVars expr (NWith set expr) -> freeVars set `Set.union` freeVars expr
(NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr (NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr
(NSynHole _) -> Set.empty (NSynHole _ ) -> Set.empty
where where
staticKey :: NKeyName r -> Maybe VarName staticKey :: NKeyName r -> Maybe VarName
staticKey (StaticKey varname) = Just varname staticKey (StaticKey varname) = Just varname
staticKey (DynamicKey _) = Nothing staticKey (DynamicKey _ ) = Nothing
bindDefs :: Binding r -> Set VarName 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 (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys
bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname
bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty
bindFree :: Binding NExpr -> Set VarName bindFree :: Binding NExpr -> Set VarName
bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys
bindFree (Inherit (Just scope) _ _) = freeVars scope bindFree (Inherit (Just scope) _ _) = freeVars scope
bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr
pathFree :: NAttrPath NExpr -> Set VarName pathFree :: NAttrPath NExpr -> Set VarName
pathFree = foldMap (foldMap freeVars) pathFree = foldMap (foldMap freeVars)
class ToExpr a where class ToExpr a where
toExpr :: a -> NExprLoc toExpr :: a -> NExprLoc
instance ToExpr NExprLoc where instance ToExpr NExprLoc where
toExpr = id toExpr = id
instance ToExpr VarName where instance ToExpr VarName where
toExpr = Fix . NSym_ nullSpan toExpr = Fix . NSym_ nullSpan
instance ToExpr Int where instance ToExpr Int where
toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
instance ToExpr Integer where instance ToExpr Integer where
toExpr = Fix . NConstant_ nullSpan . NInt toExpr = Fix . NConstant_ nullSpan . NInt
instance ToExpr Float where instance ToExpr Float where
toExpr = Fix . NConstant_ nullSpan . NFloat toExpr = Fix . NConstant_ nullSpan . NFloat
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just [| toExpr $(varE (mkName (Text.unpack x))) |] Just [| toExpr $(varE (mkName (Text.unpack x))) |]
metaExp _ _ = Nothing metaExp _ _ = Nothing
metaPat :: Set VarName -> NExprLoc -> Maybe PatQ metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
Just (varP (mkName (Text.unpack x))) Just (varP (mkName (Text.unpack x)))
metaPat _ _ = Nothing metaPat _ _ = Nothing
nix :: QuasiQuoter nix :: QuasiQuoter
nix = QuasiQuoter nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat }
{ quoteExp = quoteExprExp
, quotePat = quoteExprPat
}

8
src/Nix/Thunk.hs
View file

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

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

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

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

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

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

@ -1,20 +1,21 @@
module Nix.Type.Assumption ( module Nix.Type.Assumption
Assumption(..), ( Assumption(..)
empty, , empty
lookup, , lookup
remove, , remove
extend, , extend
keys, , keys
merge, , merge
mergeAssumptions, , mergeAssumptions
singleton, , singleton
) where )
where
import Prelude hiding (lookup) import Prelude hiding ( lookup )
import Nix.Type.Type import Nix.Type.Type
import Data.Foldable import Data.Foldable
newtype Assumption = Assumption { assumptions :: [(Name, Type)] } newtype Assumption = Assumption { assumptions :: [(Name, Type)] }
deriving (Eq, Show) deriving (Eq, Show)

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

@ -1,24 +1,25 @@
module Nix.Type.Env ( module Nix.Type.Env
Env(..), ( Env(..)
empty, , empty
lookup, , lookup
remove, , remove
extend, , extend
extends, , extends
merge, , merge
mergeEnvs, , mergeEnvs
singleton, , singleton
keys, , keys
fromList, , fromList
toList, , toList
) where )
where
import Prelude hiding (lookup) import Prelude hiding ( lookup )
import Nix.Type.Type import Nix.Type.Type
import Data.Foldable hiding (toList) import Data.Foldable hiding ( toList )
import qualified Data.Map as Map import qualified Data.Map as Map
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Typing Environment -- Typing Environment
@ -37,8 +38,7 @@ remove :: Env -> Name -> Env
remove (TypeEnv env) var = TypeEnv (Map.delete var env) remove (TypeEnv env) var = TypeEnv (Map.delete var env)
extends :: Env -> [(Name, [Scheme])] -> Env extends :: Env -> [(Name, [Scheme])] -> Env
extends env xs = extends env xs = env { types = Map.union (Map.fromList xs) (types env) }
env { types = Map.union (Map.fromList xs) (types env) }
lookup :: Name -> Env -> Maybe [Scheme] lookup :: Name -> Env -> Maybe [Scheme]
lookup key (TypeEnv tys) = Map.lookup key tys lookup key (TypeEnv tys) = Map.lookup key tys
@ -65,5 +65,5 @@ instance Semigroup Env where
(<>) = merge (<>) = merge
instance Monoid Env where instance Monoid Env where
mempty = empty mempty = empty
mappend = merge mappend = merge

694
src/Nix/Type/Infer.hs
View file

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

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

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

103
src/Nix/Utils.hs
View file

@ -12,28 +12,36 @@
module Nix.Utils (module Nix.Utils, module X) where module Nix.Utils (module Nix.Utils, module X) where
import Control.Arrow ((&&&)) import Control.Arrow ( (&&&) )
import Control.Monad import Control.Monad
import Control.Monad.Fix import Control.Monad.Fix
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A import qualified Data.Aeson.Encoding as A
import Data.Fix import Data.Fix
import Data.Hashable import Data.Hashable
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
import Data.List (sortOn) import Data.List ( sortOn )
import Data.Monoid (Endo, (<>)) import Data.Monoid ( Endo
import Data.Text (Text) , (<>)
import qualified Data.Text as Text )
import qualified Data.Vector as V import Data.Text ( Text )
import Lens.Family2 as X import qualified Data.Text as Text
import Lens.Family2.Stock (_1, _2) import qualified Data.Vector as V
import Lens.Family2 as X
import Lens.Family2.Stock ( _1
, _2
)
import Lens.Family2.TH import Lens.Family2.TH
#if ENABLE_TRACING #if ENABLE_TRACING
import Debug.Trace as X import Debug.Trace as X
#else #else
import Prelude as X hiding (putStr, putStrLn, print) import Prelude as X
hiding ( putStr
, putStrLn
, print
)
trace :: String -> a -> a trace :: String -> a -> a
trace = const id trace = const id
traceM :: Monad m => String -> m () 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 para f = f . fmap (id &&& para f) . unFix
paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a 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 :: Functor f => (Fix f -> f a -> a) -> Fix f -> a
cataP f x = f x . fmap (cataP f) . unFix $ x 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 :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a
cataPM f x = f x <=< traverse (cataPM f) . unFix $ x 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) transport f (Fix x) = Fix $ fmap (transport f) (f x)
-- | adi is Abstracting Definitional Interpreters: -- | adi is Abstracting Definitional Interpreters:
@ -92,31 +100,36 @@ transport f (Fix x) = Fix $ fmap (transport f) (f x)
adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi f g = g (f . fmap (adi f g) . unFix) adi f g = g (f . fmap (adi f g) . unFix)
adiM :: (Traversable t, Monad m) adiM
=> (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a :: (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) adiM f g = g ((f <=< traverse (adiM f g)) . unFix)
class Has a b where class Has a b where
hasLens :: Lens' a b hasLens :: Lens' a b
instance Has a a where instance Has a a where
hasLens f = f hasLens f = f
instance Has (a, b) a where instance Has (a, b) a where
hasLens = _1 hasLens = _1
instance Has (a, b) b where instance Has (a, b) b where
hasLens = _2 hasLens = _2
toEncodingSorted :: A.Value -> A.Encoding toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted = \case toEncodingSorted = \case
A.Object m -> A.Object m ->
A.pairs . mconcat A.pairs
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v) . mconcat
. sortOn fst . fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
$ M.toList m . sortOn fst
A.Array l -> A.list toEncodingSorted $ V.toList l $ M.toList m
v -> A.toEncoding v A.Array l -> A.list toEncodingSorted $ V.toList l
v -> A.toEncoding v
data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq) data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq)
@ -124,16 +137,30 @@ data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq)
-- (i.e. @https://...@) -- (i.e. @https://...@)
uriAwareSplit :: Text -> [(Text, NixPathEntryType)] uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit = go where uriAwareSplit = go where
go str = case Text.break (== ':') str of go str = case Text.break (== ':') str of
(e1, e2) (e1, e2)
| Text.null e2 -> [(e1, PathEntryPath)] | Text.null e2
| Text.pack "://" `Text.isPrefixOf` e2 -> -> [(e1, PathEntryPath)]
let ((suffix, _):path) = go (Text.drop 3 e2) | Text.pack "://" `Text.isPrefixOf` e2
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path -> let ((suffix, _) : path) = go (Text.drop 3 e2)
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2) in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
| otherwise
-> (e1, PathEntryPath) : go (Text.drop 1 e2)
alterF :: (Eq k, Hashable k, Functor f) alterF
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) :: (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 alterF f k m = f (M.lookup k m) <&> \case
Nothing -> M.delete k m Nothing -> M.delete k m
Just v -> M.insert k v m Just v -> M.insert k v m

596
src/Nix/Value.hs
View file

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

22
src/Nix/Var.hs
View file

@ -10,19 +10,19 @@
module Nix.Var where module Nix.Var where
import Control.Monad.Ref import Control.Monad.Ref
import Data.GADT.Compare import Data.GADT.Compare
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.STRef import Data.STRef
import Unsafe.Coerce import Unsafe.Coerce
type Var m = Ref m type Var m = Ref m
type MonadVar m = MonadAtomicRef 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 eqVar a b = isJust $ geq a b
newVar :: MonadRef m => a -> m (Ref m a) newVar :: MonadRef m => a -> m (Ref m a)
@ -39,11 +39,7 @@ atomicModifyVar = atomicModifyRef
--TODO: Upstream GEq instances --TODO: Upstream GEq instances
instance GEq IORef where instance GEq IORef where
a `geq` b = if a == unsafeCoerce b a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing
then Just $ unsafeCoerce Refl
else Nothing
instance GEq (STRef s) where instance GEq (STRef s) where
a `geq` b = if a == unsafeCoerce b a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing
then Just $ unsafeCoerce Refl
else Nothing

77
src/Nix/XML.hs
View file

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

188
tests/NixLanguageTests.hs
View file

@ -4,19 +4,21 @@
module NixLanguageTests (genTests) where module NixLanguageTests (genTests) where
import Control.Arrow ((&&&)) import Control.Arrow ( (&&&) )
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.ST import Control.Monad.ST
import Data.List (delete, sort) import Data.List ( delete
import Data.List.Split (splitOn) , sort
import Data.Map (Map) )
import qualified Data.Map as Map import Data.List.Split ( splitOn )
import Data.Set (Set) import Data.Map ( Map )
import qualified Data.Set as Set import qualified Data.Map as Map
import qualified Data.Text as Text import Data.Set ( Set )
import qualified Data.Text.IO as Text import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Time import Data.Time
import GHC.Exts import GHC.Exts
import Nix.Lint import Nix.Lint
@ -27,10 +29,12 @@ import Nix.Pretty
import Nix.String import Nix.String
import Nix.Utils import Nix.Utils
import Nix.XML import Nix.XML
import qualified Options.Applicative as Opts import qualified Options.Applicative as Opts
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.FilePath.Glob (compile, globDir1) import System.FilePath.Glob ( compile
, globDir1
)
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import TestCommon import TestCommon
@ -72,103 +76,123 @@ newFailingTests = Set.fromList
genTests :: IO TestTree genTests :: IO TestTree
genTests = do genTests = do
testFiles <- sort testFiles <-
sort
-- jww (2018-05-07): Temporarily disable this test until #128 is fixed. -- jww (2018-05-07): Temporarily disable this test until #128 is fixed.
. filter ((`Set.notMember` newFailingTests) . takeBaseName) . filter ((`Set.notMember` newFailingTests) . takeBaseName)
. filter ((/= ".xml") . takeExtension) . filter ((/= ".xml") . takeExtension)
<$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang" <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
let testsByName = groupBy (takeFileName . dropExtensions) testFiles let testsByName = groupBy (takeFileName . dropExtensions) testFiles
let testsByType = groupBy testType (Map.toList testsByName) let testsByType = groupBy testType (Map.toList testsByName)
let testGroups = map mkTestGroup (Map.toList testsByType) let testGroups = map mkTestGroup (Map.toList testsByType)
return $ localOption (mkTimeout 2000000) return $ localOption (mkTimeout 2000000) $ testGroup
$ testGroup "Nix (upstream) language tests" testGroups "Nix (upstream) language tests"
where testGroups
testType (fullpath, _files) = where
take 2 $ splitOn "-" $ takeFileName fullpath testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath
mkTestGroup (kind, tests) = mkTestGroup (kind, tests) =
testGroup (unwords kind) $ map (mkTestCase kind) tests testGroup (unwords kind) $ map (mkTestCase kind) tests
mkTestCase kind (basename, files) = mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do
testCase (takeFileName basename) $ do time <- liftIO getCurrentTime
time <- liftIO getCurrentTime let opts = defaultOptions time
let opts = defaultOptions time case kind of
case kind of ["parse", "okay"] -> assertParse opts $ the files
["parse", "okay"] -> assertParse opts $ the files ["parse", "fail"] -> assertParseFail opts $ the files
["parse", "fail"] -> assertParseFail opts $ the files ["eval" , "okay"] -> assertEval opts files
["eval", "okay"] -> assertEval opts files ["eval" , "fail"] -> assertEvalFail $ the files
["eval", "fail"] -> assertEvalFail $ the files _ -> error $ "Unexpected: " ++ show kind
_ -> error $ "Unexpected: " ++ show kind
assertParse :: Options -> FilePath -> Assertion assertParse :: Options -> FilePath -> Assertion
assertParse _opts file = parseNixFileLoc file >>= \case assertParse _opts file = parseNixFileLoc file >>= \case
Success _expr -> return () -- pure $! runST $ void $ lint opts expr Success _expr -> return () -- pure $! runST $ void $ lint opts expr
Failure err -> Failure err ->
assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
assertParseFail :: Options -> FilePath -> Assertion assertParseFail :: Options -> FilePath -> Assertion
assertParseFail opts file = do assertParseFail opts file = do
eres <- parseNixFileLoc file eres <- parseNixFileLoc file
catch (case eres of catch
Success expr -> do (case eres of
_ <- pure $! runST $ void $ lint opts expr Success expr -> do
assertFailure $ "Unexpected success parsing `" _ <- pure $! runST $ void $ lint opts expr
++ file ++ ":\nParsed value: " ++ show expr assertFailure
Failure _ -> return ()) $ \(_ :: SomeException) -> $ "Unexpected success parsing `"
return () ++ file
++ ":\nParsed value: "
++ show expr
Failure _ -> return ()
)
$ \(_ :: SomeException) -> return ()
assertLangOk :: Options -> FilePath -> Assertion assertLangOk :: Options -> FilePath -> Assertion
assertLangOk opts file = do assertLangOk opts file = do
actual <- printNix <$> hnixEvalFile opts (file ++ ".nix") actual <- printNix <$> hnixEvalFile opts (file ++ ".nix")
expected <- Text.readFile $ file ++ ".exp" expected <- Text.readFile $ file ++ ".exp"
assertEqual "" expected $ Text.pack (actual ++ "\n") assertEqual "" expected $ Text.pack (actual ++ "\n")
assertLangOkXml :: Options -> FilePath -> Assertion assertLangOkXml :: Options -> FilePath -> Assertion
assertLangOkXml opts file = do assertLangOkXml opts file = do
actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile opts (file ++ ".nix") actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile
opts
(file ++ ".nix")
expected <- Text.readFile $ file ++ ".exp.xml" expected <- Text.readFile $ file ++ ".exp.xml"
assertEqual "" expected actual assertEqual "" expected actual
assertEval :: Options -> [FilePath] -> Assertion assertEval :: Options -> [FilePath] -> Assertion
assertEval _opts files = do assertEval _opts files = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
let opts = defaultOptions time let opts = defaultOptions time
case delete ".nix" $ sort $ map takeExtensions files of case delete ".nix" $ sort $ map takeExtensions files of
[] -> () <$ hnixEvalFile opts (name ++ ".nix") [] -> () <$ hnixEvalFile opts (name ++ ".nix")
[".exp"] -> assertLangOk opts name [".exp" ] -> assertLangOk opts name
[".exp.xml"] -> assertLangOkXml opts name [".exp.xml" ] -> assertLangOkXml opts name
[".exp.disabled"] -> return () [".exp.disabled"] -> return ()
[".exp-disabled"] -> return () [".exp-disabled"] -> return ()
[".exp", ".flags"] -> do [".exp", ".flags"] -> do
liftIO $ unsetEnv "NIX_PATH" liftIO $ unsetEnv "NIX_PATH"
flags <- Text.readFile (name ++ ".flags") flags <- Text.readFile (name ++ ".flags")
let flags' | Text.last flags == '\n' = Text.init flags let flags' | Text.last flags == '\n' = Text.init flags
| otherwise = flags | otherwise = flags
case Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time) case
(fixup (map Text.unpack (Text.splitOn " " flags'))) of Opts.execParserPure
Opts.Failure err -> errorWithoutStackTrace $ Opts.defaultPrefs
"Error parsing flags from " ++ name ++ ".flags: " (nixOptionsInfo time)
++ show err (fixup (map Text.unpack (Text.splitOn " " flags')))
Opts.Success opts' -> of
assertLangOk Opts.Failure err ->
(opts' { include = include opts' ++ errorWithoutStackTrace
[ "nix=../../../../data/nix/corepkgs" $ "Error parsing flags from "
, "lang/dir4" ++ name
, "lang/dir5" ] }) ++ ".flags: "
name ++ show err
Opts.CompletionInvoked _ -> error "unused" Opts.Success opts' -> assertLangOk
_ -> assertFailure $ "Unknown test type " ++ show files (opts'
where { include = include opts'
name = "data/nix/tests/lang/" ++ [ "nix=../../../../data/nix/corepkgs"
++ the (map (takeFileName . dropExtensions) files) , "lang/dir4"
, "lang/dir5"
]
}
)
name
Opts.CompletionInvoked _ -> error "unused"
_ -> assertFailure $ "Unknown test type " ++ show files
where
name =
"data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files)
fixup ("--arg":x:y:rest) = "--arg":(x ++ "=" ++ y):fixup rest fixup ("--arg" : x : y : rest) = "--arg" : (x ++ "=" ++ y) : fixup rest
fixup ("--argstr":x:y:rest) = "--argstr":(x ++ "=" ++ y):fixup rest fixup ("--argstr" : x : y : rest) = "--argstr" : (x ++ "=" ++ y) : fixup rest
fixup (x:rest) = x:fixup rest fixup (x : rest) = x : fixup rest
fixup [] = [] fixup [] = []
assertEvalFail :: FilePath -> Assertion assertEvalFail :: FilePath -> Assertion
assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file
evalResult `seq` assertFailure $ evalResult
file ++ " should not evaluate.\nThe evaluation result was `" `seq` assertFailure
++ evalResult ++ "`." $ file
++ " should not evaluate.\nThe evaluation result was `"
++ evalResult
++ "`."

245
tests/PrettyParseTests.hs
View file

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

29
tests/PrettyTests.hs
View file

@ -2,36 +2,37 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module PrettyTests (tests) where module PrettyTests (tests) where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.TH import Test.Tasty.TH
import Nix.Expr import Nix.Expr
import Nix.Pretty import Nix.Pretty
case_indented_antiquotation :: Assertion case_indented_antiquotation :: Assertion
case_indented_antiquotation = do case_indented_antiquotation = do
assertPretty (mkIndentedStr 0 "echo $foo") "''echo $foo''" assertPretty (mkIndentedStr 0 "echo $foo") "''echo $foo''"
assertPretty (mkIndentedStr 0 "echo ${foo}") "''echo ''${foo}''" assertPretty (mkIndentedStr 0 "echo ${foo}") "''echo ''${foo}''"
case_string_antiquotation :: Assertion case_string_antiquotation :: Assertion
case_string_antiquotation = do case_string_antiquotation = do
assertPretty (mkStr "echo $foo") "\"echo \\$foo\"" assertPretty (mkStr "echo $foo") "\"echo \\$foo\""
assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\"" assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\""
case_function_params :: Assertion case_function_params :: Assertion
case_function_params = case_function_params =
assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3" assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3"
case_paths :: Assertion case_paths :: Assertion
case_paths = do case_paths = do
assertPretty (mkPath False "~/test.nix") "~/test.nix" assertPretty (mkPath False "~/test.nix") "~/test.nix"
assertPretty (mkPath False "/test.nix") "/test.nix" assertPretty (mkPath False "/test.nix") "/test.nix"
assertPretty (mkPath False "./test.nix") "./test.nix" assertPretty (mkPath False "./test.nix") "./test.nix"
tests :: TestTree tests :: TestTree
tests = $testGroupGenerator tests = $testGroupGenerator
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
assertPretty :: NExpr -> String -> Assertion assertPretty :: NExpr -> String -> Assertion
assertPretty e s = assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e assertPretty e s =
assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e

51
tests/ReduceExprTests.hs
View file

@ -1,44 +1,45 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module ReduceExprTests (tests) where module ReduceExprTests (tests) where
import Data.Fix import Data.Fix
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Nix.Atoms import Nix.Atoms
import Nix.Expr.Types import Nix.Expr.Types
import Nix.Expr.Types.Annotated import Nix.Expr.Types.Annotated
import Nix.Parser import Nix.Parser
import Nix.Reduce (reduceExpr) import Nix.Reduce ( reduceExpr )
tests :: TestTree tests :: TestTree
tests = testGroup "Expr Reductions" tests = testGroup
[ testCase "Non nested NSelect on set should be reduced" $ "Expr Reductions"
cmpReduceResult selectBasic selectBasicExpect, [ testCase "Non nested NSelect on set should be reduced"
testCase "Nested NSelect on set should be reduced" $ $ cmpReduceResult selectBasic selectBasicExpect
cmpReduceResult selectNested selectNestedExpect, , testCase "Nested NSelect on set should be reduced"
testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" $ $ cmpReduceResult selectNested selectNestedExpect
shouldntReduce selectIncorrectAttrPath, , testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced"
testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" $ $ shouldntReduce selectIncorrectAttrPath
shouldntReduce selectNestedIncorrectAttrPath , testCase "Nested NSelect with incorrect attrpath shouldn't be reduced"
] $ shouldntReduce selectNestedIncorrectAttrPath
]
assertSucc :: Result a -> IO a assertSucc :: Result a -> IO a
assertSucc (Success a) = pure a assertSucc (Success a) = pure a
assertSucc (Failure d) = assertFailure $ show d assertSucc (Failure d) = assertFailure $ show d
cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion
cmpReduceResult r e = do cmpReduceResult r e = do
r <- assertSucc r r <- assertSucc r
r <- stripAnnotation <$> reduceExpr Nothing r r <- stripAnnotation <$> reduceExpr Nothing r
r @?= e r @?= e
shouldntReduce :: Result NExprLoc -> Assertion shouldntReduce :: Result NExprLoc -> Assertion
shouldntReduce r = do shouldntReduce r = do
r <- assertSucc r r <- assertSucc r
rReduced <- reduceExpr Nothing r rReduced <- reduceExpr Nothing r
r @?= rReduced r @?= rReduced
selectBasic :: Result NExprLoc selectBasic :: Result NExprLoc
selectBasic = parseNixTextLoc "{b=2;a=42;}.a" selectBasic = parseNixTextLoc "{b=2;a=42;}.a"

77
tests/TestCommon.hs
View file

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