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

Remove MText abstraction, which also duplicated effort in Nix.Convert

Browse source
This commit is contained in:
John Wiegley 2018-04-16 10:56:29 -07:00
parent df9092b4d2
commit 3901a32e15
4 changed files with 52 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
src/Nix/Convert.hs
View file

@ -7,6 +7,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
@ -152,6 +153,22 @@ instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m)
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValueNF m) where
fromValueMay = \case
Fix (NVStr t d) -> pure $ Just (t, d)
Fix (NVPath p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValue m) where
fromValueMay = \case
NVStr t d -> pure $ Just (t, d)
NVPath p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -328,6 +345,12 @@ instance Applicative m => ToValue Text m (NValueNF m) where
instance Applicative m => ToValue Text m (NValue m) where
toValue = pure . flip NVStr mempty
instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where
toValue = pure . Fix . uncurry NVStr
instance Applicative m => ToValue (Text, DList Text) m (NValue m) where
toValue = pure . uncurry NVStr
instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Fix . flip NVStr mempty . decodeUtf8
@ -439,6 +462,8 @@ instance (Framed e m, MonadVar m, MonadFile m) => FromNix Float m (NValueNF m) w
instance (Framed e m, MonadVar m, MonadFile m) => FromNix Float m (NValue m) where
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m) => FromNix Text m (NValueNF m) where
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m) => FromNix Text m (NValue m) where
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m) => FromNix (Text, DList Text) m (NValueNF m) where
instance (Framed e m, MonadVar m, MonadFile m, MonadEffects m) => FromNix (Text, DList Text) m (NValue m) where
instance (Framed e m, MonadVar m, MonadFile m) => FromNix ByteString m (NValueNF m) where
instance (Framed e m, MonadVar m, MonadFile m) => FromNix ByteString m (NValue m) where
instance (Framed e m, MonadVar m, MonadFile m) => FromNix Path m (NValueNF m) where
@ -481,6 +506,8 @@ instance Applicative m => ToNix Float m (NValueNF m) where
instance Applicative m => ToNix Float m (NValue m) where
instance Applicative m => ToNix Text m (NValueNF m) where
instance Applicative m => ToNix Text m (NValue m) where
instance Applicative m => ToNix (Text, DList Text) m (NValueNF m) where
instance Applicative m => ToNix (Text, DList Text) m (NValue m) where
instance Applicative m => ToNix ByteString m (NValueNF m) where
instance Applicative m => ToNix ByteString m (NValue m) where
instance Applicative m => ToNix Path m (NValueNF m) where

51
src/Nix/Eval.hs
View file

@ -43,12 +43,12 @@ import Nix.StringOperations (runAntiquoted)
import Nix.Thunk
import Nix.Utils
class (Show v, Monoid (MText v), Monad m) => MonadEval v m | v -> m where
class (Show v, Monad m) => MonadEval v m | v -> m where
freeVariable :: Text -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: MText v -> m v
evalString :: Text -> DList Text -> m v
evalLiteralPath :: FilePath -> m v
evalEnvPath :: FilePath -> m v
evalUnary :: NUnaryOp -> v -> m v
@ -63,18 +63,11 @@ class (Show v, Monoid (MText v), Monad m) => MonadEval v m | v -> m where
evalError :: String -> m a
type MText v :: *
wrapMText :: Text -> m (MText v)
unwrapMText :: MText v -> m Text
embedMText :: MText v -> m v
projectMText :: v -> m (Maybe (Maybe (MText v)))
type MonadNixEval e v t m =
(MonadEval v m, Scoped e t m, MonadThunk v t m, MonadFix m,
Framed e m, MonadFile m, MonadVar m,
ToValue Bool m v, ToValue [t] m v,
FromValue (Text, DList Text) m v,
ToValue (AttrSet t) m v, FromValue (AttrSet t) m v,
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
@ -92,7 +85,7 @@ eval (NSym var) = lookupVar var >>= \case
Just v -> force v pure
eval (NConstant x) = evalConstant x
eval (NStr str) = evalString =<< assembleString str
eval (NStr str) = uncurry evalString =<< assembleString str
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
@ -287,14 +280,14 @@ evalSelect aset attr =
Nothing -> Left . (, k:ks) <$> toValue (s, p)
Nothing -> return $ Left (x, k:ks)
evalSelector :: MonadEval v m
evalSelector :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NAttrPath (m v) -> m [Text]
evalSelector allowDynamic =
fmap (map fst) <$> mapM (evalGetterKeyName allowDynamic)
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
evalGetterKeyName :: MonadEval v m
evalGetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalGetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNotNull
@ -307,8 +300,9 @@ evalKeyNameStatic = \case
DynamicKey _ ->
evalError @v "dynamic attribute not allowed in this context"
evalKeyNameDynamicNotNull :: forall v m. MonadEval v m
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
(Nothing, _) ->
evalError @v "value is null while a string was expected"
@ -316,34 +310,31 @@ evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
-- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value
evalSetterKeyName :: MonadEval v m
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Maybe Text, Maybe SourcePos)
evalSetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNullable
| otherwise = fmap (first Just) . evalKeyNameStatic
-- | Returns Nothing iff the key value is null
evalKeyNameDynamicNullable :: forall v m. MonadEval v m
=> NKeyName (m v)
-> m (Maybe Text, Maybe SourcePos)
evalKeyNameDynamicNullable
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v)
-> m (Maybe Text, Maybe SourcePos)
evalKeyNameDynamicNullable = \case
StaticKey k p -> pure (Just k, p)
DynamicKey k -> runAntiquoted "\n" (embedMText <=< assembleString) id k
>>= projectMText >>= \case
Just (Just (s :: MText v)) ->
(\x -> (Just x, Nothing)) <$> unwrapMText @v s
_ -> return (Nothing, Nothing)
DynamicKey k ->
runAntiquoted "\n" (fmap Just . assembleString) (>>= fromValueMay) k
<&> \case Just (t, _) -> (Just t, Nothing)
_ -> (Nothing, Nothing)
assembleString :: forall v m. MonadEval v m => NString (m v) -> m (MText v)
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Text, DList Text)
assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
go = runAntiquoted "\n" (wrapMText @v @m) $ \x -> do
x' <- x
projectMText @v @m x' >>= \case
Just (Just txt) -> return txt
_ -> evalError @v "Value cannot be rendered as text"
go = runAntiquoted "\n" (pure . (, mempty)) (>>= fromValue)
fromParts parts = mconcat <$> mapM go parts

12
src/Nix/Exec.hs
View file

@ -87,7 +87,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
toValue delta
evalConstant = pure . NVConstant
evalString = pure . uncurry NVStr
evalString = (pure .) . NVStr
evalLiteralPath = fmap NVPath . makeAbsolutePath
evalEnvPath = fmap NVPath . findEnvPath
evalUnary = execUnaryOp
@ -104,16 +104,6 @@ instance MonadNix e m => MonadEval (NValue m) m where
evalError = throwError
type MText (NValue m) = (Text, DList Text)
wrapMText = return . (, mempty)
unwrapMText = return . fst
embedMText = return . uncurry NVStr
projectMText = \case
NVConstant NNull -> return $ Just Nothing
v -> fmap (Just . Just) . valueText True =<< normalForm v
infixl 1 `callFunc`
callFunc :: MonadNix e m => NValue m -> m (NValue m) -> m (NValue m)
callFunc fun arg = case fun of

12
src/Nix/Lint.hs
View file

@ -246,6 +246,8 @@ unify context (Symbolic x) (Symbolic y) = do
-- Hindley-Milner, we're not going to be managing Symbolic values this way
-- anymore.
instance FromValue (Text, DList Text) m (Symbolic m) where
instance FromValue (AttrSet (SThunk m)) m (Symbolic m) where
instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where
@ -287,7 +289,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
NNull -> TNull
NUri _ -> TUri
evalString = const $ mkSymbolic [TStr]
evalString = const $ const $ mkSymbolic [TStr]
evalLiteralPath = const $ mkSymbolic [TPath]
evalEnvPath = const $ mkSymbolic [TPath]
@ -326,14 +328,6 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
evalError = throwError
type MText (Symbolic m) = ()
wrapMText = const $ return ()
unwrapMText = const $ return ""
embedMText = const $ mkSymbolic [TStr]
projectMText = const $ return Nothing -- jww (2018-04-10): TODO
lintBinaryOp
:: forall e m. (MonadLint e m, MonadEval (Symbolic m) m)
=> NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)