{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Convert where
import Control.Monad.Free
import Data.ByteString
import qualified Data.HashMap.Lazy as M
import Data.Maybe
import Data.Text ( Text )
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8
, decodeUtf8
)
import Nix.Atoms
import Nix.Effects
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.String
import Nix.Value
import Nix.Value.Monad
import Nix.Thunk
import Nix.Utils
newtype Deeper a = Deeper { getDeeper :: a }
deriving (Typeable, Functor, Foldable, Traversable)
class FromValue a m v where
fromValue :: v -> m a
fromValueMay :: v -> m (Maybe a)
type Convertible e t f m
= (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m))
instance ( Convertible e t f m
, MonadValue (NValue t f m) m
, FromValue a m (NValue' t f m (NValue t f m))
)
=> FromValue a m (NValue t f m) where
fromValueMay = flip demand $ \case
Pure t -> force t fromValueMay
Free v -> fromValueMay v
fromValue = flip demand $ \case
Pure t -> force t fromValue
Free v -> fromValue v
instance ( Convertible e t f m
, MonadValue (NValue t f m) m
, FromValue a m (Deeper (NValue' t f m (NValue t f m)))
)
=> FromValue a m (Deeper (NValue t f m)) where
fromValueMay (Deeper v) = demand v $ \case
Pure t -> force t (fromValueMay . Deeper)
Free v -> fromValueMay (Deeper v)
fromValue (Deeper v) = demand v $ \case
Pure t -> force t (fromValue . Deeper)
Free v -> fromValue (Deeper v)
instance Convertible e t f m
=> FromValue () m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVConstant' NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TNull (Free v)
instance Convertible e t f m
=> FromValue Bool m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVConstant' (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TBool (Free v)
instance Convertible e t f m
=> FromValue Int m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVConstant' (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TInt (Free v)
instance Convertible e t f m
=> FromValue Integer m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVConstant' (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TInt (Free v)
instance Convertible e t f m
=> FromValue Float m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVConstant' (NFloat b) -> pure $ Just b
NVConstant' (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TFloat (Free v)
instance ( Convertible e t f m
, MonadValue (NValue t f m) m
, MonadEffects t f m
)
=> FromValue NixString m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVStr' ns -> pure $ Just ns
NVPath' p ->
Just
. hackyMakeNixStringWithoutContext
. Text.pack
. unStorePath
<$> addPath p
NVSet' s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v)
instance Convertible e t f m
=> FromValue ByteString m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVStr' ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m (TString NoContext) (Free v)
newtype Path = Path { getPath :: FilePath }
deriving Show
instance ( Convertible e t f m
, MonadValue (NValue t f m) m
)
=> FromValue Path m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVPath' p -> pure $ Just (Path p)
NVStr' ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet' s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TPath (Free v)
instance Convertible e t f m
=> FromValue [NValue t f m] m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVList' l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TList (Free v)
instance ( Convertible e t f m
, FromValue a m (NValue t f m)
)
=> FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where
fromValueMay = \case
Deeper (NVList' l) -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TList (Free (getDeeper v))
instance Convertible e t f m
=> FromValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVSet' s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TSet (Free v)
instance ( Convertible e t f m
, FromValue a m (NValue t f m)
)
=> FromValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where
fromValueMay = \case
Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v))
instance Convertible e t f m
=> FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m
(NValue' t f m (NValue t f m)) where
fromValueMay = \case
NVSet' s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TSet (Free v)
instance ( Convertible e t f m
, FromValue a m (NValue t f m)
)
=> FromValue (AttrSet a, AttrSet SourcePos) m
(Deeper (NValue' t f m (NValue t f m))) where
fromValueMay = \case
Deeper (NVSet' s p) -> fmap (, p) <$> sequence <$> traverse fromValueMay s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ Expectation @t @f @m TSet (Free (getDeeper v))
instance ( Convertible e t f m
, FromValue a m (NValue' t f m (NValue t f m))
)
=> FromValue a m (Deeper (NValue' t f m (NValue t f m))) where
fromValueMay = fromValueMay . getDeeper
fromValue = fromValue . getDeeper
class ToValue a m v where
toValue :: a -> m v
instance (Convertible e t f m, ToValue a m (NValue' t f m (NValue t f m)))
=> ToValue a m (NValue t f m) where
toValue = fmap Free . toValue
instance ( Convertible e t f m
, ToValue a m (Deeper (NValue' t f m (NValue t f m)))
)
=> ToValue a m (Deeper (NValue t f m)) where
toValue = fmap (fmap Free) . toValue
instance Convertible e t f m
=> ToValue () m (NValue' t f m (NValue t f m)) where
toValue _ = pure . nvConstant' $ NNull
instance Convertible e t f m
=> ToValue Bool m (NValue' t f m (NValue t f m)) where
toValue = pure . nvConstant' . NBool
instance Convertible e t f m
=> ToValue Int m (NValue' t f m (NValue t f m)) where
toValue = pure . nvConstant' . NInt . toInteger
instance Convertible e t f m
=> ToValue Integer m (NValue' t f m (NValue t f m)) where
toValue = pure . nvConstant' . NInt
instance Convertible e t f m
=> ToValue Float m (NValue' t f m (NValue t f m)) where
toValue = pure . nvConstant' . NFloat
instance Convertible e t f m
=> ToValue NixString m (NValue' t f m (NValue t f m)) where
toValue = pure . nvStr'
instance Convertible e t f m
=> ToValue ByteString m (NValue' t f m (NValue t f m)) where
toValue = pure . nvStr' . hackyMakeNixStringWithoutContext . decodeUtf8
instance Convertible e t f m
=> ToValue Path m (NValue' t f m (NValue t f m)) where
toValue = pure . nvPath' . getPath
instance Convertible e t f m
=> ToValue StorePath m (NValue' t f m (NValue t f m)) where
toValue = toValue . Path . unStorePath
instance ( Convertible e t f m
)
=> ToValue SourcePos m (NValue' t f m (NValue t f m)) where
toValue (SourcePos f l c) = do
f' <- toValue (principledMakeNixStringWithoutContext (Text.pack f))
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')]
pure $ nvSet' pos mempty
instance Convertible e t f m
=> ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where
toValue = pure . nvList'
instance (Convertible e t f m, ToValue a m (NValue t f m))
=> ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where
toValue = fmap (Deeper . nvList') . traverse toValue
instance Convertible e t f m
=> ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where
toValue s = pure $ nvSet' s mempty
instance (Convertible e t f m, ToValue a m (NValue t f m))
=> ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where
toValue s = (Deeper .) . nvSet' <$> traverse toValue s <*> pure mempty
instance Convertible e t f m
=> ToValue (AttrSet (NValue t f m), AttrSet SourcePos) m
(NValue' t f m (NValue t f m)) where
toValue (s, p) = pure $ nvSet' s p
instance (Convertible e t f m, ToValue a m (NValue t f m))
=> ToValue (AttrSet a, AttrSet SourcePos) m
(Deeper (NValue' t f m (NValue t f m))) where
toValue (s, p) = (Deeper .) . nvSet' <$> traverse toValue s <*> pure p
instance Convertible e t f m
=> ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where
toValue nlcv = do
path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing
allOutputs <- if nlcvAllOutputs nlcv
then Just <$> toValue True
else return Nothing
outputs <- do
let outputs =
fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv
ts :: [NValue t f m] <- traverse toValue outputs
case ts of
[] -> return Nothing
_ -> Just <$> toValue ts
pure $ flip nvSet' M.empty $ M.fromList $ catMaybes
[ (\p -> ("path", p)) <$> path
, (\ao -> ("allOutputs", ao)) <$> allOutputs
, (\os -> ("outputs", os)) <$> outputs
]
instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where
toValue _ = pure . NConstant $ NNull
instance Convertible e t f m => ToValue Bool m (NExprF (NValue t f m)) where
toValue = pure . NConstant . NBool