All type checks, but many instance definitions are still missing
This commit is contained in:
parent
145e69c9a4
commit
6ae5764221
45
main/Main.hs
45
main/Main.hs
|
@ -13,8 +13,6 @@ import qualified Control.Exception as Exc
|
|||
import Control.Monad
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Ref
|
||||
import Control.Monad.Trans.Class
|
||||
-- import Control.Monad.ST
|
||||
import qualified Data.Aeson.Text as A
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
|
@ -31,7 +29,6 @@ import Nix
|
|||
import Nix.Cited
|
||||
import Nix.Convert
|
||||
import qualified Nix.Eval as Eval
|
||||
import Nix.Fresh
|
||||
import Nix.Json
|
||||
-- import Nix.Lint
|
||||
import Nix.Options.Parser
|
||||
|
@ -59,18 +56,18 @@ main = do
|
|||
Just s -> handleResult opts Nothing (parseNixTextLoc s)
|
||||
Nothing -> case fromFile opts of
|
||||
Just "-" ->
|
||||
liftIO $ mapM_ (processFile opts)
|
||||
=<< (lines <$> getContents)
|
||||
mapM_ (processFile opts)
|
||||
=<< (lines <$> liftIO getContents)
|
||||
Just path ->
|
||||
liftIO $ mapM_ (processFile opts)
|
||||
=<< (lines <$> readFile path)
|
||||
mapM_ (processFile opts)
|
||||
=<< (lines <$> liftIO (readFile path))
|
||||
Nothing -> case filePaths opts of
|
||||
[] -> withNixContext Nothing $ Repl.main
|
||||
["-"] ->
|
||||
handleResult opts Nothing . parseNixTextLoc
|
||||
=<< liftIO Text.getContents
|
||||
paths ->
|
||||
liftIO $ mapM_ (processFile opts) paths
|
||||
mapM_ (processFile opts) paths
|
||||
where
|
||||
processFile opts path = do
|
||||
eres <- parseNixFileLoc path
|
||||
|
@ -98,7 +95,7 @@ main = do
|
|||
catch (process opts mpath expr) $ \case
|
||||
NixException frames ->
|
||||
errorWithoutStackTrace . show
|
||||
=<< renderFrames frames
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
|
||||
when (repl opts) $
|
||||
withNixContext Nothing $ Repl.main
|
||||
|
@ -140,19 +137,19 @@ main = do
|
|||
. prettyNix
|
||||
. stripAnnotation $ expr
|
||||
where
|
||||
printer
|
||||
:: forall e t f m.
|
||||
( MonadNix e t f m
|
||||
, MonadRef m
|
||||
, MonadFreshId Int m
|
||||
, MonadVar m
|
||||
, MonadIO m
|
||||
, Typeable m
|
||||
)
|
||||
=> NValue t f m -> m ()
|
||||
-- printer
|
||||
-- :: forall e t f m.
|
||||
-- ( MonadNix e t f m
|
||||
-- , MonadRef m
|
||||
-- , MonadFreshId Int m
|
||||
-- , MonadVar m
|
||||
-- , MonadIO m
|
||||
-- , Typeable m
|
||||
-- )
|
||||
-- => NValue t f m -> m ()
|
||||
printer
|
||||
| finder opts =
|
||||
fromValue @(AttrSet (StdThunk m)) >=> findAttrs
|
||||
fromValue @(AttrSet (StdThunk IO)) >=> findAttrs
|
||||
| xml opts =
|
||||
liftIO . putStrLn
|
||||
. Text.unpack
|
||||
|
@ -174,12 +171,12 @@ main = do
|
|||
where
|
||||
go prefix s = do
|
||||
xs <- forM (sortOn fst (M.toList s))
|
||||
$ \(k, nv@(StdThunk (NCited _ t))) -> case t of
|
||||
$ \(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 @m ref
|
||||
val <- readVar @(StdLazy IO) ref
|
||||
case val of
|
||||
Computed _ -> pure (k, Nothing)
|
||||
_ | descend -> (k,) <$> forceEntry path nv
|
||||
|
@ -193,7 +190,7 @@ main = do
|
|||
when descend $ case mv of
|
||||
Nothing -> return ()
|
||||
Just v -> case v of
|
||||
StdValue (NVSet s' _) ->
|
||||
NVSet s' _ ->
|
||||
go (path ++ ".") s'
|
||||
_ -> return ()
|
||||
where
|
||||
|
@ -220,7 +217,7 @@ main = do
|
|||
. ("Exception forcing " ++)
|
||||
. (k ++)
|
||||
. (": " ++) . show
|
||||
=<< renderFrames @(StdThunk m) frames
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
return Nothing
|
||||
|
||||
reduction path mp x = do
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
|
@ -17,6 +18,7 @@ import Data.Functor.Compose
|
|||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics
|
||||
import Lens.Family2.TH
|
||||
import Text.Show.Deriving
|
||||
|
||||
import Nix.Expr.Types.Annotated
|
||||
import Nix.Scope
|
||||
|
@ -29,13 +31,15 @@ data Provenance t v m = Provenance
|
|||
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
|
||||
-- result of the call, but what was called and with what arguments.
|
||||
}
|
||||
deriving (Generic, Typeable)
|
||||
deriving (Generic, Typeable, Show)
|
||||
|
||||
data NCited t v m a = NCited
|
||||
{ _provenance :: [Provenance t v m]
|
||||
, _cited :: a
|
||||
}
|
||||
deriving (Generic, Typeable, Functor, Foldable, Traversable)
|
||||
deriving (Generic, Typeable, Functor, Foldable, Traversable, Show)
|
||||
|
||||
$(deriveShow1 ''NCited)
|
||||
|
||||
instance Applicative (NCited t v m) where
|
||||
pure = NCited []
|
||||
|
|
|
@ -119,22 +119,24 @@ nvBuiltinP :: Cited t f m
|
|||
nvBuiltinP p name f = addProvenance1 p (nvBuiltin name f)
|
||||
|
||||
type MonadCitedThunks t f m =
|
||||
(MonadThunk t m (NValue t f m),
|
||||
MonadDataErrorContext t f m,
|
||||
HasCitations1 t (NValue t f m) m f)
|
||||
( MonadThunk t m (NValue t f m)
|
||||
, MonadDataErrorContext t f m
|
||||
, HasCitations1 t (NValue t f m) m f
|
||||
)
|
||||
|
||||
type MonadNix e t f m =
|
||||
(Has e SrcSpan,
|
||||
Has e Options,
|
||||
Scoped t m,
|
||||
Framed e m,
|
||||
MonadFix m,
|
||||
MonadCatch m,
|
||||
MonadThrow m,
|
||||
Typeable m,
|
||||
Alternative m,
|
||||
MonadEffects t f m,
|
||||
MonadCitedThunks t f m)
|
||||
( Has e SrcSpan
|
||||
, Has e Options
|
||||
, Scoped t m
|
||||
, Framed e m
|
||||
, MonadFix m
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, Typeable m
|
||||
, Alternative m
|
||||
, MonadEffects t f m
|
||||
, MonadCitedThunks t f m
|
||||
)
|
||||
|
||||
data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
|
||||
deriving (Show, Typeable)
|
||||
|
|
|
@ -21,7 +21,7 @@ import Lens.Family2
|
|||
import Nix.Utils
|
||||
|
||||
newtype Scope a = Scope { getScope :: AttrSet a }
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
deriving (Functor, Foldable, Traversable, Eq)
|
||||
|
||||
instance Show (Scope a) where
|
||||
show (Scope m) = show (M.keys m)
|
||||
|
|
|
@ -30,6 +30,11 @@ data NThunkF m v
|
|||
= Value v
|
||||
| Thunk Int (Var m Bool) (Var m (Deferred m v))
|
||||
|
||||
instance Eq v => Eq (NThunkF m v) where
|
||||
Value x == Value y = x == y
|
||||
Thunk x _ _ == Thunk y _ _ = x == y
|
||||
_ == _ = False -- jww (2019-03-16): not accurate...
|
||||
|
||||
instance Show v => Show (NThunkF m v) where
|
||||
show (Value v) = show v
|
||||
show (Thunk _ _ _) = "<thunk>"
|
||||
|
|
|
@ -1,12 +1,15 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
@ -16,20 +19,27 @@
|
|||
|
||||
module Nix.Thunk.Standard where
|
||||
|
||||
import Control.Comonad (Comonad)
|
||||
import Control.Comonad.Env (ComonadEnv)
|
||||
import Control.Monad.Catch hiding (catchJust)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Fix
|
||||
import Data.Functor.Classes
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Nix.Cited
|
||||
import Nix.Convert
|
||||
import Nix.Effects
|
||||
import Nix.Eval as Eval
|
||||
import Nix.Exec
|
||||
import Nix.Expr
|
||||
import Nix.Frames
|
||||
import Nix.Fresh
|
||||
import Nix.Options
|
||||
import Nix.Render
|
||||
import Nix.Scope
|
||||
import Nix.String
|
||||
import Nix.Thunk
|
||||
import Nix.Thunk.Basic
|
||||
|
@ -37,37 +47,42 @@ import Nix.Utils
|
|||
import Nix.Value
|
||||
import Nix.Var (MonadVar)
|
||||
|
||||
newtype StdCited m a = StdCited
|
||||
{ _stdCited :: NCited (StdThunk m) (StdValue m) (StdLazy m) a }
|
||||
deriving
|
||||
( Generic
|
||||
, Typeable
|
||||
, Functor
|
||||
, Applicative
|
||||
, Foldable
|
||||
, Traversable
|
||||
, Comonad
|
||||
, ComonadEnv [Provenance (StdThunk m) (StdValue m) (StdLazy m)]
|
||||
)
|
||||
|
||||
newtype StdThunk m = StdThunk
|
||||
{ _stdThunk ::
|
||||
NCited (StdThunk m) (StdValue m)
|
||||
(FreshIdT Int m)
|
||||
(NThunkF (FreshIdT Int m) (StdValue m)) }
|
||||
{ _stdThunk :: StdCited m (NThunkF (StdLazy m) (StdValue m)) }
|
||||
|
||||
newtype StdValue m = StdValue
|
||||
{ _stdValue ::
|
||||
NValue (StdThunk m)
|
||||
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
|
||||
(FreshIdT Int m) }
|
||||
type StdValue m = NValue (StdThunk m) (StdCited m) (StdLazy m)
|
||||
type StdValueNF m = NValueNF (StdThunk m) (StdCited m) (StdLazy m)
|
||||
|
||||
newtype StdValueNF m = StdValueNF
|
||||
{ _stdValueNF ::
|
||||
NValueNF (StdThunk m)
|
||||
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
|
||||
(FreshIdT Int m) }
|
||||
type StdLazy m = Lazy (StdThunk m) (StdCited m) (FreshIdT Int m)
|
||||
|
||||
type StdLazy m =
|
||||
Lazy (StdThunk m)
|
||||
(NCited (StdThunk m) (StdValue m) (FreshIdT Int m))
|
||||
(FreshIdT Int m)
|
||||
instance Show1 (StdLazy m) => Show1 (StdCited m) where
|
||||
liftShowsPrec f g n (StdCited c) = liftShowsPrec f g n c
|
||||
|
||||
instance (MonadNix e t f m, MonadVar m)
|
||||
=> MonadThunk (StdThunk m) (FreshIdT Int m) (StdValue m) where
|
||||
instance ( MonadVar m
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, Typeable m
|
||||
)
|
||||
=> MonadThunk (StdThunk m) (StdLazy m) (StdValue m) where
|
||||
thunk mv = do
|
||||
opts :: Options <- lift $ asks (view hasLens)
|
||||
opts :: Options <- asks (view hasLens)
|
||||
|
||||
if thunks opts
|
||||
then do
|
||||
frames :: Frames <- lift $ asks (view hasLens)
|
||||
frames :: Frames <- asks (view hasLens)
|
||||
|
||||
-- Gather the current evaluation context at the time of thunk
|
||||
-- creation, and record it along with the thunk.
|
||||
|
@ -79,9 +94,9 @@ instance (MonadNix e t f m, MonadVar m)
|
|||
go _ = []
|
||||
ps = concatMap (go . frame) frames
|
||||
|
||||
fmap (StdThunk . NCited ps) . thunk $ mv
|
||||
fmap (StdThunk . StdCited . NCited ps) . thunk $ mv
|
||||
else
|
||||
fmap (StdThunk . NCited []) . thunk $ mv
|
||||
fmap (StdThunk . StdCited . NCited []) . thunk $ mv
|
||||
|
||||
thunkId = error "jww (2019-03-15): NYI"
|
||||
|
||||
|
@ -92,42 +107,71 @@ instance (MonadNix e t f m, MonadVar m)
|
|||
-- which does not capture the current stack frame information to provide
|
||||
-- it in a NixException, so we catch and re-throw it here using
|
||||
-- 'throwError' from Frames.hs.
|
||||
force (StdThunk (NCited ps t)) f =
|
||||
catch go (lift . throwError @ThunkLoop)
|
||||
force (StdThunk (StdCited (NCited ps t))) f =
|
||||
catch go (throwError @ThunkLoop)
|
||||
where
|
||||
go = case ps of
|
||||
[] -> force t f
|
||||
Provenance scope e@(Compose (Ann s _)):_ -> do
|
||||
r <- liftWith $ \run -> do
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
(run (force t f))
|
||||
restoreT $ return r
|
||||
Provenance scope e@(Compose (Ann s _)):_ ->
|
||||
-- r <- liftWith $ \run -> do
|
||||
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
-- (run (force t f))
|
||||
-- restoreT $ return r
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
(force t f)
|
||||
|
||||
forceEff (StdThunk (NCited ps t)) f =
|
||||
catch go (lift . throwError @ThunkLoop)
|
||||
forceEff (StdThunk (StdCited (NCited ps t))) f =
|
||||
catch go (throwError @ThunkLoop)
|
||||
where
|
||||
go = case ps of
|
||||
[] -> forceEff t f
|
||||
Provenance scope e@(Compose (Ann s _)):_ -> do
|
||||
r <- liftWith $ \run -> do
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
(run (forceEff t f))
|
||||
restoreT $ return r
|
||||
-- r <- liftWith $ \run -> do
|
||||
-- withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
-- (run (forceEff t f))
|
||||
-- restoreT $ return r
|
||||
withFrame Info (ForcingExpr scope (wrapExprLoc s e))
|
||||
(forceEff t f)
|
||||
|
||||
wrapValue = StdThunk . NCited [] . wrapValue
|
||||
getValue (StdThunk (NCited _ v)) = getValue v
|
||||
wrapValue = StdThunk . StdCited . NCited [] . wrapValue
|
||||
getValue (StdThunk (StdCited (NCited _ v))) = getValue v
|
||||
|
||||
instance FromValue NixString m (StdThunk m) where
|
||||
instance FromValue Path m (StdThunk m) where
|
||||
instance FromValue [StdThunk m] m (StdThunk m) where
|
||||
instance FromValue (M.HashMap Text (StdThunk m)) m (StdThunk m) where
|
||||
instance ToValue NixString m (StdThunk m) where
|
||||
instance ToValue Int m (StdThunk m) where
|
||||
instance ToValue () m (StdThunk m) where
|
||||
instance FromValue [NixString] m (StdThunk m) where
|
||||
instance FromNix [NixString] m (StdThunk m) where
|
||||
instance ToValue (StdThunk m) m (NValue (StdThunk m) f m) where
|
||||
instance ToNix (StdThunk m) m (NValue (StdThunk m) f m) where
|
||||
instance FromNix Bool (StdLazy IO) (StdThunk IO) where
|
||||
instance FromNix [NixString] (StdLazy IO) (StdThunk IO) where
|
||||
instance FromValue (M.HashMap Text (StdThunk m)) (StdLazy m) (StdThunk m) where
|
||||
instance FromValue Bool (StdLazy IO) (StdThunk IO) where
|
||||
instance FromValue NixString (StdLazy m) (StdThunk m) where
|
||||
instance FromValue Path (StdLazy m) (StdThunk m) where
|
||||
instance FromValue [NixString] (StdLazy IO) (StdThunk IO) where
|
||||
instance FromValue [StdThunk m] (StdLazy m) (StdThunk m) where
|
||||
instance ToNix (StdThunk m) (StdLazy m) (StdValue m) where
|
||||
instance ToNix NixString (StdLazy m) (StdThunk m) where
|
||||
instance ToNix [StdThunk m] (StdLazy m) (StdThunk m) where
|
||||
instance ToValue () (StdLazy m) (StdThunk m) where
|
||||
instance ToValue (StdThunk m) (StdLazy m) (StdValue m) where
|
||||
instance ToValue Int (StdLazy m) (StdThunk m) where
|
||||
instance ToValue NixString (StdLazy m) (StdThunk m) where
|
||||
instance ToValue [StdThunk m] (StdLazy m) (StdThunk m) where
|
||||
|
||||
-- instance FromValue a (StdLazy m) (StdValue m) => FromValue a (StdLazy m) (StdThunk m) where
|
||||
-- instance FromNix a (StdLazy m) (StdValue m) => FromNix a (StdLazy m) (StdThunk m) where
|
||||
|
||||
instance Show (StdThunk m) where
|
||||
show _ = "<thunk>" -- jww (2019-03-15): NYI
|
||||
|
||||
deriving instance MonadReader e m => MonadReader e (FreshIdT Int m)
|
||||
instance MonadFile m => MonadFile (FreshIdT Int m)
|
||||
instance MonadIntrospect m => MonadIntrospect (FreshIdT Int m)
|
||||
instance MonadStore m => MonadStore (FreshIdT Int m)
|
||||
instance MonadPutStr m => MonadPutStr (FreshIdT Int m)
|
||||
instance MonadHttp m => MonadHttp (FreshIdT Int m)
|
||||
instance MonadEnv m => MonadEnv (FreshIdT Int m)
|
||||
instance MonadInstantiate m => MonadInstantiate (FreshIdT Int m)
|
||||
instance MonadExec m => MonadExec (FreshIdT Int m)
|
||||
|
||||
instance MonadEffects t f m => MonadEffects t f (FreshIdT Int m)
|
||||
|
||||
instance HasCitations1 (StdThunk m) (StdValue m) (StdLazy m) (StdCited m)
|
||||
|
||||
runStdLazyM :: MonadIO m => Options -> StdLazy m a -> m a
|
||||
runStdLazyM opts = runFreshIdT (1 :: Int) . runLazyM opts
|
||||
|
|
|
@ -38,6 +38,7 @@ import Control.Monad.Trans.Class
|
|||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Align
|
||||
import Data.Eq.Deriving
|
||||
import Data.Functor.Classes
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
|
@ -121,7 +122,7 @@ lmapNValueF f = \case
|
|||
NVBuiltinF s g -> NVBuiltinF s (g . fmap f)
|
||||
|
||||
type MonadDataContext f (m :: * -> *) =
|
||||
(Show1 f, 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
|
||||
-- that may contain thunks. The type of such thunks are fixed at that time.
|
||||
|
@ -275,7 +276,7 @@ nvBuiltinNF :: Applicative f
|
|||
=> String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
|
||||
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))
|
||||
|
||||
instance Comonad f => Eq (NValue t f m) where
|
||||
instance Comonad f => Eq (NValue' t f m a) where
|
||||
NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y
|
||||
NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y
|
||||
NVConstant (NInt x) == NVConstant (NInt y) = x == y
|
||||
|
@ -284,7 +285,7 @@ instance Comonad f => Eq (NValue t f m) where
|
|||
NVPath x == NVPath y = x == y
|
||||
_ == _ = False
|
||||
|
||||
instance Comonad f => Ord (NValue t f m) where
|
||||
instance Comonad f => Ord (NValue' t f m a) where
|
||||
NVConstant (NFloat x) <= NVConstant (NInt y) = x <= fromInteger y
|
||||
NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y
|
||||
NVConstant (NInt x) <= NVConstant (NInt y) = x <= y
|
||||
|
@ -426,7 +427,7 @@ describeValue = \case
|
|||
TPath -> "a path"
|
||||
TBuiltin -> "a builtin function"
|
||||
|
||||
instance Eq1 (NValueF (NValue' t f m a) m) where
|
||||
instance Eq1 (NValueF p m) where
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
liftEq _ (NVStrF x) (NVStrF y) = x == y
|
||||
liftEq eq (NVListF x) (NVListF y) = liftEq eq x y
|
||||
|
@ -471,3 +472,5 @@ $(makeLenses ''NValue')
|
|||
key :: (Traversable f, Applicative g)
|
||||
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
|
||||
key k = nValue.traverse._NVSetF._1.hashAt k
|
||||
|
||||
$(deriveEq1 ''NValue')
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
|
@ -9,18 +10,19 @@
|
|||
module EvalTests (tests, genEvalCompareTests) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
-- import qualified Data.HashMap.Lazy as M
|
||||
import Data.List ((\\))
|
||||
import Data.Maybe (isJust)
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Set as S
|
||||
import Data.String.Interpolate.IsString
|
||||
import Data.Text (Text)
|
||||
import Data.Time
|
||||
import Nix
|
||||
import Nix.TH
|
||||
import Nix.Thunk.Standard
|
||||
import qualified System.Directory as D
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
|
@ -417,26 +419,29 @@ genEvalCompareTests = do
|
|||
mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> f)
|
||||
|
||||
|
||||
instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
|
||||
NVConstantF x == NVConstantF y = x == y
|
||||
NVStrF ls == NVStrF rs = hackyStringIgnoreContext ls == hackyStringIgnoreContext rs
|
||||
NVListF x == NVListF y = and (zipWith (==) x y)
|
||||
NVSetF x _ == NVSetF y _ =
|
||||
M.keys x == M.keys y &&
|
||||
and (zipWith (==) (M.elems x) (M.elems y))
|
||||
NVPathF x == NVPathF y = x == y
|
||||
x == y = error $ "Need to add comparison for values: "
|
||||
++ show x ++ " == " ++ show y
|
||||
-- instance (Show r, Show (NValueF p m r), Eq r) => Eq (NValueF p m r) where
|
||||
-- NVConstantF x == NVConstantF y = x == y
|
||||
-- NVStrF ls == NVStrF rs = hackyStringIgnoreContext ls == hackyStringIgnoreContext rs
|
||||
-- NVListF x == NVListF y = and (zipWith (==) x y)
|
||||
-- NVSetF x _ == NVSetF y _ =
|
||||
-- M.keys x == M.keys y &&
|
||||
-- and (zipWith (==) (M.elems x) (M.elems y))
|
||||
-- NVPathF x == NVPathF y = x == y
|
||||
-- x == y = error $ "Need to add comparison for values: "
|
||||
-- ++ show x ++ " == " ++ show y
|
||||
|
||||
constantEqual :: NExprLoc -> NExprLoc -> Assertion
|
||||
constantEqual a b = do
|
||||
time <- liftIO getCurrentTime
|
||||
let opts = defaultOptions time
|
||||
-- putStrLn =<< lint (stripAnnotation a)
|
||||
a' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a
|
||||
-- putStrLn =<< lint (stripAnnotation b)
|
||||
b' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing b
|
||||
assertEqual "" a' b'
|
||||
res <- runStdLazyM opts $ do
|
||||
a' <- nixEvalExprLoc Nothing a
|
||||
b' <- nixEvalExprLoc Nothing b
|
||||
iterNValue forceEff (const (return ())) a'
|
||||
iterNValue forceEff (const (return ())) b'
|
||||
valueEq a' b'
|
||||
assertBool "" res
|
||||
|
||||
constantEqualText' :: Text -> Text -> Assertion
|
||||
constantEqualText' a b = do
|
||||
|
@ -456,14 +461,13 @@ assertNixEvalThrows a = do
|
|||
let Success a' = parseNixTextLoc a
|
||||
time <- liftIO getCurrentTime
|
||||
let opts = defaultOptions time
|
||||
errored <- catch ((runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a') >> pure False) handler
|
||||
errored <- catch
|
||||
(False <$ runStdLazyM opts (normalForm =<< nixEvalExprLoc Nothing a'))
|
||||
(\(_ :: NixException) -> pure True)
|
||||
if errored then
|
||||
pure ()
|
||||
else
|
||||
assertFailure "Did not catch nix exception"
|
||||
where
|
||||
handler :: NixException -> IO Bool
|
||||
handler _ = pure True
|
||||
|
||||
freeVarsEqual :: Text -> [VarName] -> Assertion
|
||||
freeVarsEqual a xs = do
|
||||
|
|
|
@ -18,12 +18,12 @@ import Data.Text (unpack)
|
|||
import Data.Time
|
||||
import qualified EvalTests
|
||||
import qualified Nix
|
||||
import Nix.Exec
|
||||
import Nix.Expr.Types
|
||||
import Nix.String
|
||||
import Nix.Options
|
||||
import Nix.Parser
|
||||
import Nix.Value
|
||||
import Nix.Thunk.Standard
|
||||
import qualified NixLanguageTests
|
||||
import qualified ParserTests
|
||||
import qualified PrettyTests
|
||||
|
@ -58,7 +58,7 @@ ensureNixpkgsCanParse =
|
|||
}|]) $ \expr -> do
|
||||
NVStr ns <- do
|
||||
time <- liftIO getCurrentTime
|
||||
runLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
|
||||
runStdLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr
|
||||
let dir = hackyStringIgnoreContext ns
|
||||
exists <- fileExist (unpack dir)
|
||||
unless exists $
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module TestCommon where
|
||||
|
@ -16,7 +17,7 @@ import System.Posix.Temp
|
|||
import System.Process
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF (StdLazy IO))
|
||||
hnixEvalFile :: Options -> FilePath -> IO (StdValueNF IO)
|
||||
hnixEvalFile opts file = do
|
||||
parseResult <- parseNixFileLoc file
|
||||
case parseResult of
|
||||
|
@ -29,14 +30,15 @@ hnixEvalFile opts file = do
|
|||
normalForm expr) $ \case
|
||||
NixException frames ->
|
||||
errorWithoutStackTrace . show
|
||||
=<< renderFrames frames
|
||||
=<< renderFrames @(StdValue IO) @(StdThunk IO) frames
|
||||
|
||||
hnixEvalText :: Options -> Text -> IO (StdValueNF (StdLazy IO))
|
||||
hnixEvalText :: Options -> Text -> IO (StdValueNF IO)
|
||||
hnixEvalText opts src = case parseNixText src of
|
||||
Failure err ->
|
||||
error $ "Parsing failed for expressien `"
|
||||
++ unpack src ++ "`.\n" ++ show err
|
||||
Success expr ->
|
||||
-- runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
|
||||
runStdLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
|
||||
|
||||
nixEvalString :: String -> IO String
|
||||
|
|
Loading…
Reference in a new issue