More work toward getting Exec.hs to compile
This commit is contained in:
John Wiegley
parent
996266bbdc
commit
5d9c858f5d
|
|
@ -54,23 +54,19 @@ $(makeLenses ''NCited)
|
|||
|
||||
class HasCitations t v m a where
|
||||
citations :: a -> [Provenance t v m]
|
||||
|
||||
instance HasCitations t v m (NCited t v m a) where
|
||||
citations = _provenance
|
||||
|
||||
class HasCitations1 t v m f where
|
||||
citations1 :: f a -> [Provenance t v m]
|
||||
|
||||
instance HasCitations1 t v m f => HasCitations1 t v m (Compose f g) where
|
||||
citations1 (Compose f) = citations1 f
|
||||
addProvenance :: Provenance t v m -> a -> a
|
||||
|
||||
-- addProvenance :: (NValue t f m a -> Provenance t (NValue t f m a) m) -> NValue t f m a -> NValue t f m a
|
||||
-- addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
|
||||
|
||||
-- nvConstantP p x = NValue (NCited [p] (NVConstantF x))
|
||||
-- nvStrP p ns = NValue (NCited [p] (NVStrF ns))
|
||||
-- nvPathP p x = NValue (NCited [p] (NVPathF x))
|
||||
-- nvListP p l = NValue (NCited [p] (NVListF l))
|
||||
-- nvSetP p s x = NValue (NCited [p] (NVSetF s x))
|
||||
-- nvClosureP p x f = NValue (NCited [p] (NVClosureF x f))
|
||||
-- nvBuiltinP p name f = NValue (NCited [p] (NVBuiltinF name f))
|
||||
instance HasCitations t v m (NCited t v m a) where
|
||||
citations = _provenance
|
||||
addProvenance x (NCited p v) = (NCited (x : p) v)
|
||||
|
||||
class HasCitations1 t v m f where
|
||||
citations1 :: f a -> [Provenance t v m]
|
||||
addProvenance1 :: Provenance t v m -> f a -> f a
|
||||
|
||||
instance HasCitations1 t v m f => HasCitations1 t v m (Compose f g) where
|
||||
citations1 (Compose f) = citations1 f
|
||||
addProvenance1 x (Compose f) = Compose (addProvenance1 x f)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ import Nix.Expr.Types.Annotated
|
|||
import Nix.Frames
|
||||
import Nix.String
|
||||
import Nix.Thunk
|
||||
import Nix.Utils
|
||||
-- import Nix.Utils
|
||||
import Nix.Value
|
||||
|
||||
{-
|
||||
|
|
@ -461,9 +461,9 @@ instance (Monad m, FromNix a m v) => FromNix a m (m v) where
|
|||
-- fromNixMay = force ?? fromNixMay
|
||||
-- fromNix = force ?? fromNix
|
||||
|
||||
instance MonadThunk t m (NValue t f m) => FromNix t m (NValue t f m) where
|
||||
fromNixMay = pure . Just . wrapValue
|
||||
fromNix = pure . wrapValue
|
||||
-- instance MonadThunk t m (NValue t f m) => FromNix t m (NValue t f m) where
|
||||
-- fromNixMay = pure . Just . wrapValue
|
||||
-- fromNix = pure . wrapValue
|
||||
|
||||
class ToNix a m v where
|
||||
toNix :: a -> m v
|
||||
|
|
@ -522,8 +522,8 @@ instance (Convertible e t f m, ToNix a m (NValueNF t f m))
|
|||
=> ToNix [a] m (NValueNF t f m) where
|
||||
toNix = fmap nvListNF . traverse toNix
|
||||
|
||||
instance MonadThunk t m (NValue t f m) => ToNix t m (NValue t f m) where
|
||||
toNix = force ?? pure
|
||||
-- instance MonadThunk t m (NValue t f m) => ToNix t m (NValue t f m) where
|
||||
-- toNix = force ?? pure
|
||||
|
||||
convertNix :: forall a t m v. (FromNix a m t, ToNix a m v, Monad m) => t -> m v
|
||||
convertNix = fromNix @a >=> toNix
|
||||
|
|
|
|||
157
src/Nix/Exec.hs
157
src/Nix/Exec.hs
|
|
@ -85,10 +85,57 @@ import GHC.DataSize
|
|||
#endif
|
||||
#endif
|
||||
|
||||
type Cited t f m = (HasCitations1 t (NValue t f m) m f, MonadDataContext f m)
|
||||
|
||||
nvConstantP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m -> NAtom -> NValue t f m
|
||||
nvConstantP p x = addProvenance1 p (nvConstant x)
|
||||
|
||||
nvStrP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m -> NixString -> NValue t f m
|
||||
nvStrP p ns = addProvenance1 p (nvStr ns)
|
||||
|
||||
nvPathP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m -> FilePath -> NValue t f m
|
||||
nvPathP p x = addProvenance1 p (nvPath x)
|
||||
|
||||
nvListP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m -> [t] -> NValue t f m
|
||||
nvListP p l = addProvenance1 p (nvList l)
|
||||
|
||||
nvSetP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m -> AttrSet t -> AttrSet SourcePos
|
||||
-> NValue t f m
|
||||
nvSetP p s x = addProvenance1 p (nvSet s x)
|
||||
|
||||
nvClosureP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m
|
||||
-> Params ()
|
||||
-> (m (NValue t f m) -> m t)
|
||||
-> NValue t f m
|
||||
nvClosureP p x f = addProvenance1 p (nvClosure x f)
|
||||
|
||||
nvBuiltinP :: Cited t f m
|
||||
=> Provenance t (NValue t f m) m
|
||||
-> String
|
||||
-> (m (NValue t f m) -> m t)
|
||||
-> NValue t f m
|
||||
nvBuiltinP p name f = addProvenance1 p (nvBuiltin name f)
|
||||
|
||||
type MonadNix e t f m =
|
||||
(Scoped t m, Framed e m, Has e SrcSpan, Has e Options,
|
||||
MonadEffects t f m, MonadFix m, MonadCatch m,
|
||||
Typeable m, Alternative m, MonadDataErrorContext 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,
|
||||
MonadThunk t m (NValue t f m),
|
||||
MonadDataErrorContext t f m,
|
||||
HasCitations1 t (NValue t f m) m f)
|
||||
|
||||
data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
|
||||
deriving (Show, Typeable)
|
||||
|
|
@ -187,13 +234,13 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
|
|||
evalCurPos = do
|
||||
scope <- currentScopes
|
||||
span@(SrcSpan delta _) <- currentPos
|
||||
addProvenance (\_ -> Provenance scope (NSym_ span "__curPos"))
|
||||
addProvenance1 @_ @(NValue t f m) (Provenance scope (NSym_ span "__curPos"))
|
||||
<$> toValue delta
|
||||
|
||||
evaledSym name val = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
pure $ addProvenance (const $ Provenance scope (NSym_ span name)) val
|
||||
pure $ addProvenance1 @_ @(NValue t f m) (Provenance scope (NSym_ span name)) val
|
||||
|
||||
evalConstant c = do
|
||||
scope <- currentScopes
|
||||
|
|
@ -231,7 +278,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
|
|||
evalWith c b = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
addProvenance (\b -> Provenance scope (NWith_ span Nothing (Just b)))
|
||||
(\b -> addProvenance1 (Provenance scope (NWith_ span Nothing (Just b))) b)
|
||||
<$> evalWithAttrSet c b
|
||||
|
||||
evalIf c t f = do
|
||||
|
|
@ -239,21 +286,21 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where
|
|||
span <- currentPos
|
||||
fromValue c >>= \b ->
|
||||
if b
|
||||
then addProvenance (\t -> Provenance scope (NIf_ span (Just c) (Just t) Nothing)) <$> t
|
||||
else addProvenance (\f -> Provenance scope (NIf_ span (Just c) Nothing (Just f))) <$> f
|
||||
then (\t -> addProvenance1 (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) t) <$> t
|
||||
else (\f -> addProvenance1 (Provenance scope (NIf_ span (Just c) Nothing (Just f))) f) <$> f
|
||||
|
||||
evalAssert c body = fromValue c >>= \b -> do
|
||||
span <- currentPos
|
||||
if b
|
||||
then do
|
||||
scope <- currentScopes
|
||||
addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body
|
||||
(\b -> addProvenance1 (Provenance scope (NAssert_ span (Just c) (Just b))) b) <$> body
|
||||
else nverr $ Assertion span c
|
||||
|
||||
evalApp f x = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
addProvenance (const $ Provenance scope (NBinary_ span NApp (Just f) Nothing))
|
||||
addProvenance1 (Provenance scope (NBinary_ span NApp (Just f) Nothing))
|
||||
<$> callFunc f x
|
||||
|
||||
evalAbs p k = do
|
||||
|
|
@ -274,16 +321,16 @@ callFunc fun arg = do
|
|||
case fun of
|
||||
NVClosure params f -> do
|
||||
traceM $ "callFunc:NVFunction taking " ++ show params
|
||||
f arg
|
||||
force ?? pure =<< f arg
|
||||
NVBuiltin name f -> do
|
||||
span <- currentPos
|
||||
withFrame Info (Calling @m @t name span) $ f arg
|
||||
force ?? pure =<< withFrame Info (Calling @m @t name span) (f arg)
|
||||
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
|
||||
traceM "callFunc:__functor"
|
||||
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
|
||||
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
|
||||
|
||||
execUnaryOp :: Framed e m
|
||||
execUnaryOp :: (Framed e m, Cited t f m, Show t)
|
||||
=> Scopes m t -> SrcSpan -> NUnaryOp -> NValue t f m
|
||||
-> m (NValue t f m)
|
||||
execUnaryOp scope span op arg = do
|
||||
|
|
@ -327,7 +374,7 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
|
|||
|
||||
execBinaryOp scope span op lval rarg = do
|
||||
rval <- rarg
|
||||
let bin :: (Provenance m -> a) -> a
|
||||
let bin :: (Provenance t (NValue t f m) m -> a) -> a
|
||||
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
|
||||
toBool = pure . bin nvConstantP . NBool
|
||||
case (lval, rval) of
|
||||
|
|
@ -423,11 +470,12 @@ execBinaryOp scope span op lval rarg = do
|
|||
(NVPath p, NVStr ns) -> case op of
|
||||
NEq -> toBool False -- From eqValues in nix/src/libexpr/eval.cc
|
||||
NNEq -> toBool True
|
||||
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack (hackyStringIgnoreContext ns))
|
||||
NPlus -> bin nvPathP <$> makeAbsolutePath @t @f
|
||||
(p `mappend` Text.unpack (hackyStringIgnoreContext ns))
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
||||
|
||||
(NVPath ls, NVPath rs) -> case op of
|
||||
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
|
||||
NPlus -> bin nvPathP <$> makeAbsolutePath @t @f (ls ++ rs)
|
||||
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
||||
|
||||
_ -> case op of
|
||||
|
|
@ -440,11 +488,11 @@ execBinaryOp scope span op lval rarg = do
|
|||
"Unsupported argument types for binary operator "
|
||||
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
|
||||
|
||||
numBinOp :: (forall r. (Provenance m -> r) -> r)
|
||||
numBinOp :: (forall r. (Provenance t (NValue t f m) m -> r) -> r)
|
||||
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue t f m)
|
||||
numBinOp bin f = numBinOp' bin f f
|
||||
|
||||
numBinOp' :: (forall r. (Provenance m -> r) -> r)
|
||||
numBinOp' :: (forall r. (Provenance t (NValue t f m) m -> r) -> r)
|
||||
-> (Integer -> Integer -> Integer)
|
||||
-> (Float -> Float -> Float)
|
||||
-> NAtom -> NAtom -> m (NValue t f m)
|
||||
|
|
@ -519,7 +567,7 @@ newtype Lazy t (f :: * -> *) m a = Lazy
|
|||
MonadFix, MonadIO, MonadReader (Context (Lazy t f m) t))
|
||||
|
||||
instance MonadTrans (Lazy t f) where
|
||||
lift = Lazy . lift . lift . lift
|
||||
lift = Lazy . lift . lift
|
||||
|
||||
instance MonadRef m => MonadRef (Lazy t f m) where
|
||||
type Ref (Lazy t f m) = Ref m
|
||||
|
|
@ -546,8 +594,8 @@ instance MonadException m => MonadException (Lazy t f m) where
|
|||
in runLazy <$> f run'
|
||||
#endif
|
||||
|
||||
instance Monad m => MonadFreshId Int (Lazy t f m) where
|
||||
freshId = Lazy $ lift $ lift freshId
|
||||
-- instance Monad m => MonadFreshId Int (Lazy t f m) where
|
||||
-- freshId = Lazy $ lift $ lift freshId
|
||||
|
||||
instance MonadStore m => MonadStore (Lazy t f m) where
|
||||
addPath' = lift . addPath'
|
||||
|
|
@ -565,9 +613,11 @@ instance MonadExec m => MonadExec (Lazy t f m)
|
|||
|
||||
instance MonadIntrospect m => MonadIntrospect (Lazy t f m)
|
||||
|
||||
instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m,
|
||||
MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m,
|
||||
MonadExec m, MonadIntrospect m, MonadThunk t m (NValue t f m),
|
||||
instance (MonadFix m, MonadCatch m, MonadFile m,
|
||||
MonadStore m, MonadPutStr m, MonadHttp m,
|
||||
MonadEnv m, MonadInstantiate m,
|
||||
MonadExec m, MonadIntrospect m,
|
||||
MonadThunk t m (NValue t f m),
|
||||
Alternative m, MonadPlus m, Typeable m)
|
||||
=> MonadEffects t f (Lazy t f m) where
|
||||
makeAbsolutePath origPath = do
|
||||
|
|
@ -640,12 +690,11 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m,
|
|||
|
||||
traceEffect = putStrLn
|
||||
|
||||
getRecursiveSize :: MonadIntrospect m => a -> m (NValue t f m)
|
||||
getRecursiveSize = toNix @Integer . fromIntegral <=< recursiveSize
|
||||
getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m)
|
||||
getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize
|
||||
|
||||
runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a
|
||||
runLazyM opts = runFreshIdT 0
|
||||
. (`evalStateT` M.empty)
|
||||
runLazyM opts = (`evalStateT` M.empty)
|
||||
. (`runReaderT` newContext opts)
|
||||
. runLazy
|
||||
|
||||
|
|
@ -721,9 +770,9 @@ findPathBy finder l name = do
|
|||
findPathM :: forall e t f m. MonadNix e t f m => [t] -> FilePath -> m FilePath
|
||||
findPathM l name = findPathBy path l name
|
||||
where
|
||||
path :: MonadEffects m => FilePath -> m (Maybe FilePath)
|
||||
path :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
|
||||
path path = do
|
||||
path <- makeAbsolutePath path
|
||||
path <- makeAbsolutePath @t @f path
|
||||
exists <- doesPathExist path
|
||||
return $ if exists then Just path else Nothing
|
||||
|
||||
|
|
@ -735,12 +784,12 @@ findEnvPathM name = do
|
|||
Just x -> force x $ fromValue >=> \(l :: [t]) ->
|
||||
findPathBy nixFilePath l name
|
||||
where
|
||||
nixFilePath :: MonadEffects m => FilePath -> m (Maybe FilePath)
|
||||
nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath)
|
||||
nixFilePath path = do
|
||||
path <- makeAbsolutePath path
|
||||
path <- makeAbsolutePath @t @f path
|
||||
exists <- doesDirectoryExist path
|
||||
path' <- if exists
|
||||
then makeAbsolutePath $ path </> "default.nix"
|
||||
then makeAbsolutePath @t @f $ path </> "default.nix"
|
||||
else return path
|
||||
exists <- doesFileExist path'
|
||||
return $ if exists then Just path' else Nothing
|
||||
|
|
@ -823,41 +872,23 @@ fetchTarball v = v >>= \case
|
|||
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
|
||||
|
||||
exec
|
||||
:: ( MonadExec m
|
||||
, Framed e m
|
||||
, MonadThrow m
|
||||
, Alternative m
|
||||
, MonadCatch m
|
||||
, MonadFix m
|
||||
, MonadEffects t f m
|
||||
, MonadFreshId Int m
|
||||
, GEq (Ref m)
|
||||
, MonadAtomicRef m
|
||||
, Typeable m
|
||||
, Has e Options
|
||||
, Has e SrcSpan
|
||||
, Scoped t m
|
||||
)
|
||||
:: ( MonadNix e t f m
|
||||
, MonadInstantiate m
|
||||
-- , MonadFreshId Int m
|
||||
-- , GEq (Ref m)
|
||||
-- , MonadAtomicRef m
|
||||
)
|
||||
=> [String]
|
||||
-> m (NValue t f m)
|
||||
exec args = either throwError evalExprLoc =<< exec' args
|
||||
|
||||
nixInstantiateExpr
|
||||
:: ( MonadInstantiate m
|
||||
, Framed e m
|
||||
, MonadThrow m
|
||||
, Alternative m
|
||||
, MonadCatch m
|
||||
, MonadFix m
|
||||
, MonadEffects t f m
|
||||
, MonadFreshId Int m
|
||||
, GEq (Ref m)
|
||||
, MonadAtomicRef m
|
||||
, Typeable m
|
||||
, Has e Options
|
||||
, Has e SrcSpan
|
||||
, Scoped t m
|
||||
)
|
||||
:: ( MonadNix e t f m
|
||||
, MonadInstantiate m
|
||||
-- , MonadFreshId Int m
|
||||
-- , GEq (Ref m)
|
||||
-- , MonadAtomicRef m
|
||||
)
|
||||
=> String
|
||||
-> m (NValue t f m)
|
||||
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
|
||||
|
|
|
|||
|
|
@ -18,8 +18,6 @@ module Nix.Pretty where
|
|||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Comonad
|
||||
import Control.Monad
|
||||
import Control.Monad.Free
|
||||
import Data.Fix
|
||||
import Data.HashMap.Lazy (toList)
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
|
|
@ -31,7 +29,6 @@ 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.Void
|
||||
import Nix.Atoms
|
||||
import Nix.Cited
|
||||
import Nix.Expr
|
||||
|
|
@ -172,18 +169,24 @@ prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList
|
|||
prettyAtom :: NAtom -> NixDoc ann
|
||||
prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom
|
||||
|
||||
{-
|
||||
prettyNix :: NExpr -> Doc ann
|
||||
prettyNix = withoutParens . cata exprFNixDoc
|
||||
|
||||
prettyOriginExpr :: HasCitations1 t (NValue t f m) m f
|
||||
instance HasCitations1 t (NValue t f m) m f
|
||||
=> HasCitations1 t (NValue t f m) m (NValue' t f m) where
|
||||
citations1 (NValue f) = citations1 f
|
||||
addProvenance1 x (NValue f) = NValue (addProvenance1 x f)
|
||||
|
||||
prettyOriginExpr :: forall t f m ann. HasCitations1 t (NValue t f m) m f
|
||||
=> NExprLocF (Maybe (NValue t f m)) -> Doc ann
|
||||
prettyOriginExpr = withoutParens . go
|
||||
where
|
||||
go = exprFNixDoc . annotated . getCompose . fmap render
|
||||
|
||||
render :: Maybe (NValue t f m) -> NixDoc ann
|
||||
render Nothing = simpleExpr $ "_"
|
||||
render (Just (reverse . citations1 -> p:_)) = go (_originExpr p)
|
||||
render (Just (reverse . citations1 @t @_ @m -> p:_)) =
|
||||
go (_originExpr p)
|
||||
render _ = simpleExpr "?"
|
||||
-- render (Just (NValue (citations -> ps))) =
|
||||
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
|
||||
|
|
@ -272,34 +275,36 @@ exprFNixDoc = \case
|
|||
where
|
||||
recPrefix = "rec" <> space
|
||||
|
||||
valueToExpr :: MonadDataContext f m => NValueNF t f m -> NExpr
|
||||
valueToExpr = nValueF
|
||||
valueToExpr :: forall t f m. MonadDataContext f m => NValueNF t f m -> NExpr
|
||||
valueToExpr = iterNValueNF
|
||||
(const (mkStr (principledMakeNixStringWithoutContext "<CYCLE>")))
|
||||
(phi . extract)
|
||||
phi
|
||||
where
|
||||
phi (NVConstantF a) = Fix $ NConstant a
|
||||
phi (NVStrF ns) = mkStr ns
|
||||
phi (NVListF l) = Fix $ NList (fmap valueToExpr l)
|
||||
phi (NVSetF s p) = Fix $ NSet
|
||||
phi :: NValue' t f m NExpr -> NExpr
|
||||
phi (NVConstant a) = Fix $ NConstant a
|
||||
phi (NVStr ns) = mkStr ns
|
||||
phi (NVList l) = Fix $ NList l
|
||||
phi (NVSet s p) = Fix $ NSet
|
||||
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
|
||||
| (k, v) <- toList (fmap valueToExpr s) ]
|
||||
phi (NVClosureF _ _) = Fix . NSym . pack $ "<closure>"
|
||||
phi (NVPathF p) = Fix $ NLiteralPath p
|
||||
phi (NVBuiltinF name _) = Fix . NSym . pack $ "builtins." ++ name
|
||||
| (k, v) <- toList s ]
|
||||
phi (NVClosure _ _) = Fix . NSym . pack $ "<closure>"
|
||||
phi (NVPath p) = Fix $ NLiteralPath p
|
||||
phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name
|
||||
phi _ = error "Pattern synonyms foil completeness check"
|
||||
|
||||
mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)]
|
||||
|
||||
prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann
|
||||
prettyNValueNF = prettyNix . valueToExpr
|
||||
|
||||
printNix :: MonadDataContext f m => NValueNF t f m -> String
|
||||
printNix = iterNValueNF (const "<CYCLE>") (phi . extract)
|
||||
printNix :: forall t f m. MonadDataContext f m => NValueNF t f m -> String
|
||||
printNix = iterNValueNF (const "<CYCLE>") phi
|
||||
where
|
||||
phi :: NValueF (NValue t f m) m String -> String
|
||||
phi (NVConstantF a) = unpack $ atomText a
|
||||
phi (NVStrF ns) = show $ hackyStringIgnoreContext ns
|
||||
phi (NVListF l) = "[ " ++ unwords l ++ " ]"
|
||||
phi (NVSetF s _) =
|
||||
phi :: NValue' t f m String -> String
|
||||
phi (NVConstant a) = unpack $ atomText a
|
||||
phi (NVStr ns) = show $ hackyStringIgnoreContext ns
|
||||
phi (NVList l) = "[ " ++ unwords l ++ " ]"
|
||||
phi (NVSet s _) =
|
||||
"{ " ++ concat [ check (unpack k) ++ " = " ++ v ++ "; "
|
||||
| (k, v) <- sort $ toList s ] ++ "}"
|
||||
where
|
||||
|
|
@ -309,30 +314,28 @@ printNix = iterNValueNF (const "<CYCLE>") (phi . extract)
|
|||
<|> (fmap (surround . show) (readMaybe v :: Maybe Float)))
|
||||
where
|
||||
surround s = "\"" ++ s ++ "\""
|
||||
phi NVClosureF {} = "<<lambda>>"
|
||||
phi (NVPathF fp) = fp
|
||||
phi (NVBuiltinF name _) = "<<builtin " ++ name ++ ">>"
|
||||
phi NVClosure {} = "<<lambda>>"
|
||||
phi (NVPath fp) = fp
|
||||
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
|
||||
phi _ = error "Pattern synonyms foil completeness check"
|
||||
|
||||
prettyNValue
|
||||
:: (MonadThunk t m (NValue t f m),
|
||||
MonadDataContext f m)
|
||||
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
=> NValue t f m -> m (Doc ann)
|
||||
prettyNValue = fmap prettyNValueNF . removeEffectsM
|
||||
|
||||
instance HasCitations1 t (NValue t f m) m f
|
||||
=> HasCitations t (NValue t f m) m (NValue t f m) where
|
||||
citations (NValue (Fix (Compose f))) = citations1 f
|
||||
|
||||
prettyNValueProv :: (HasCitations1 t (NValue t f m) m f,
|
||||
MonadDataContext f m)
|
||||
=> NValue t f m -> m (Doc ann)
|
||||
prettyNValueProv (NValue (Fix (Compose nv))) = do
|
||||
let ps = citations nv
|
||||
Compose v = extract nv
|
||||
prettyNValueProv
|
||||
:: forall t f m ann.
|
||||
(HasCitations1 t (NValue t f m) m f,
|
||||
MonadThunk t m (NValue t f m),
|
||||
MonadDataContext f m)
|
||||
=> NValue t f m -> m (Doc ann)
|
||||
prettyNValueProv v@(NValue nv) = do
|
||||
let ps = citations1 @t @(NValue t f m) @m nv
|
||||
case ps of
|
||||
[] -> prettyNValueF v
|
||||
[] -> prettyNValue v
|
||||
ps -> do
|
||||
v' <- prettyNValueF v
|
||||
v' <- prettyNValue v
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
, indent 2 $ parens $ mconcat
|
||||
|
|
@ -342,13 +345,13 @@ prettyNValueProv (NValue (Fix (Compose nv))) = do
|
|||
|
||||
prettyNThunk
|
||||
:: forall t f m ann.
|
||||
(HasCitations1 t (NValue t f m) m t,
|
||||
(HasCitations t (NValue t f m) m t,
|
||||
HasCitations1 t (NValue t f m) m f,
|
||||
MonadThunk t m (NValue t f m),
|
||||
MonadDataContext f m)
|
||||
=> t -> m (Doc ann)
|
||||
prettyNThunk t = do
|
||||
let ps = citations1 @t @(NValue t f m) @m @t t
|
||||
let ps = citations @t @(NValue t f m) @m @t t
|
||||
v' <- prettyNValueNF <$> dethunk t
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
|
|
@ -356,4 +359,3 @@ prettyNThunk t = do
|
|||
$ "thunk from: "
|
||||
: map (prettyOriginExpr . _originExpr) ps
|
||||
]
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -142,7 +142,7 @@ instance Show r => Show (NValueF p m r) where
|
|||
showsCon1 con a d =
|
||||
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
||||
|
||||
instance (MonadDataContext f m, 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
|
||||
|
||||
type NValue t f m = NValue' t f m t
|
||||
|
|
@ -216,66 +216,66 @@ nValueToNFM transform k = iterNValueM transform k $ pure . Free
|
|||
pattern NVConstant x <- NValue (extract -> NVConstantF x)
|
||||
pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))
|
||||
|
||||
nvConstant :: MonadDataContext f m => NAtom -> NValue t f m
|
||||
nvConstant :: Applicative f => NAtom -> NValue t f m
|
||||
nvConstant x = NValue (pure (NVConstantF x))
|
||||
nvConstantNF :: MonadDataContext f m => NAtom -> NValueNF t f m
|
||||
nvConstantNF :: Applicative f => NAtom -> NValueNF t f m
|
||||
nvConstantNF x = Free (NValue (pure (NVConstantF x)))
|
||||
|
||||
pattern NVStr ns <- NValue (extract -> NVStrF ns)
|
||||
pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))
|
||||
|
||||
nvStr :: MonadDataContext f m => NixString -> NValue t f m
|
||||
nvStr :: Applicative f => NixString -> NValue t f m
|
||||
nvStr ns = NValue (pure (NVStrF ns))
|
||||
nvStrNF :: MonadDataContext f m => NixString -> NValueNF t f m
|
||||
nvStrNF :: Applicative f => NixString -> NValueNF t f m
|
||||
nvStrNF ns = Free (NValue (pure (NVStrF ns)))
|
||||
|
||||
pattern NVPath x <- NValue (extract -> NVPathF x)
|
||||
pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))
|
||||
|
||||
nvPath :: MonadDataContext f m => FilePath -> NValue t f m
|
||||
nvPath :: Applicative f => FilePath -> NValue t f m
|
||||
nvPath x = NValue (pure (NVPathF x))
|
||||
nvPathNF :: MonadDataContext f m => FilePath -> NValueNF t f m
|
||||
nvPathNF :: Applicative f => FilePath -> NValueNF t f m
|
||||
nvPathNF x = Free (NValue (pure (NVPathF x)))
|
||||
|
||||
pattern NVList l <- NValue (extract -> NVListF l)
|
||||
pattern NVListNF l <- Free (NValue (extract -> NVListF l))
|
||||
|
||||
nvList :: MonadDataContext f m => [t] -> NValue t f m
|
||||
nvList :: Applicative f => [t] -> NValue t f m
|
||||
nvList l = NValue (pure (NVListF l))
|
||||
nvListNF :: MonadDataContext f m => [NValueNF t f m] -> NValueNF t f m
|
||||
nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m
|
||||
nvListNF l = Free (NValue (pure (NVListF l)))
|
||||
|
||||
pattern NVSet s x <- NValue (extract -> NVSetF s x)
|
||||
pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))
|
||||
|
||||
nvSet :: MonadDataContext f m
|
||||
nvSet :: Applicative f
|
||||
=> HashMap Text t -> HashMap Text SourcePos -> NValue t f m
|
||||
nvSet s x = NValue (pure (NVSetF s x))
|
||||
nvSetNF :: MonadDataContext f m
|
||||
nvSetNF :: Applicative f
|
||||
=> HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m
|
||||
nvSetNF s x = Free (NValue (pure (NVSetF s x)))
|
||||
|
||||
pattern NVClosure x f <- NValue (extract -> NVClosureF x f)
|
||||
pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))
|
||||
|
||||
nvClosure :: MonadDataContext f m
|
||||
nvClosure :: Applicative f
|
||||
=> Params () -> (m (NValue t f m) -> m t) -> NValue t f m
|
||||
nvClosure x f = NValue (pure (NVClosureF x f))
|
||||
nvClosureNF :: MonadDataContext f m
|
||||
nvClosureNF :: Applicative f
|
||||
=> Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
|
||||
nvClosureNF x f = Free (NValue (pure (NVClosureF x f)))
|
||||
|
||||
pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)
|
||||
pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))
|
||||
|
||||
nvBuiltin :: MonadDataContext f m
|
||||
nvBuiltin :: Applicative f
|
||||
=> String -> (m (NValue t f m) -> m t) -> NValue t f m
|
||||
nvBuiltin name f = NValue (pure (NVBuiltinF name f))
|
||||
nvBuiltinNF :: MonadDataContext f m
|
||||
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 MonadDataContext f m => Eq (NValue t f m) where
|
||||
instance Comonad f => Eq (NValue t f m) 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 +284,7 @@ instance MonadDataContext f m => Eq (NValue t f m) where
|
|||
NVPath x == NVPath y = x == y
|
||||
_ == _ = False
|
||||
|
||||
instance MonadDataContext f m => Ord (NValue t f m) where
|
||||
instance Comonad f => Ord (NValue t f m) 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
|
||||
|
|
@ -304,9 +304,7 @@ checkComparable x y = case (x, y) of
|
|||
(NVPath _, NVPath _) -> pure ()
|
||||
_ -> throwError $ Comparison x y
|
||||
|
||||
type IsThunk f m t = (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
|
||||
thunkEq :: IsThunk f m t => t -> t -> m Bool
|
||||
thunkEq :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
|
||||
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||
let unsafePtrEq = case (lt, rt) of
|
||||
(thunkId -> lid, thunkId -> rid)
|
||||
|
|
@ -334,7 +332,7 @@ builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
|||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
isClosureNF :: MonadDataContext f m => NValueNF t f m -> Bool
|
||||
isClosureNF :: Comonad f => NValueNF t f m -> Bool
|
||||
isClosureNF NVClosureNF {} = True
|
||||
isClosureNF _ = False
|
||||
|
||||
|
|
@ -353,7 +351,7 @@ alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
|
|||
_ -> throwE ()
|
||||
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
|
||||
|
||||
isDerivation :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
isDerivation :: (MonadThunk t m (NValue t f m), Comonad f)
|
||||
=> AttrSet t -> m Bool
|
||||
isDerivation m = case M.lookup "type" m of
|
||||
Nothing -> pure False
|
||||
|
|
@ -363,7 +361,7 @@ isDerivation m = case M.lookup "type" m of
|
|||
NVStr s -> pure $ principledStringIgnoreContext s == "derivation"
|
||||
_ -> pure False
|
||||
|
||||
valueEq :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
|
||||
valueEq :: (MonadThunk t m (NValue t f m), Comonad f)
|
||||
=> NValue t f m -> NValue t f m -> m Bool
|
||||
valueEq = curry $ \case
|
||||
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
|
||||
|
|
@ -436,7 +434,7 @@ instance Eq1 (NValueF (NValue' t f m a) m) where
|
|||
liftEq _ (NVPathF x) (NVPathF y) = x == y
|
||||
liftEq _ _ _ = False
|
||||
|
||||
instance MonadDataContext f m => Show1 (NValue' t f m) where
|
||||
instance Comonad f => Show1 (NValue' t f m) where
|
||||
liftShowsPrec sp sl p = \case
|
||||
NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
|
||||
NVStr ns -> showsUnaryWith showsPrec "NVStrF" p
|
||||
|
|
@ -470,6 +468,6 @@ instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)
|
|||
$(makeTraversals ''NValueF)
|
||||
$(makeLenses ''NValue')
|
||||
|
||||
key :: (MonadDataContext f m, Applicative g)
|
||||
key :: (Traversable f, Applicative g)
|
||||
=> VarName -> LensLike' g (NValue' t f m a) (Maybe a)
|
||||
key k = nValue.traverse._NVSetF._1.hashAt k
|
||||
|
|
|
|||
Loading…
Reference in a new issue