module Data.Interpolation where
import Prelude hiding (lookup)
import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (Reader, asks, runReader)
import Data.Aeson (FromJSON, ToJSON, Value (String), parseJSON, toJSON, withText)
import Data.Char (isAlphaNum)
import Data.Containers (mapFromList, setFromList, setToList)
import Data.Either.Validation (Validation (Failure, Success), validationToEither)
import Data.Map (Map, lookup)
import Data.Profunctor (Profunctor, dimap)
import Data.Profunctor.Product (ProductProfunctor, SumProfunctor, purePP, (****), (+++!))
import Data.Profunctor.Product.Default (Default, def)
import Data.Semigroup ((<>))
import Data.Sequences (isPrefixOf)
import Data.Set (Set)
import qualified Data.Text as T
import System.Environment (getEnvironment)
import Test.QuickCheck
(Arbitrary, Arbitrary1, arbitrary, arbitrary1, liftArbitrary, listOf1, oneof, suchThat)
import Text.Read (readMaybe)
newtype TemplateKey = TemplateKey { unTemplateKey :: T.Text }
deriving (Eq, Ord, Show, ToJSON, FromJSON)
newtype TemplateValue = TemplateValue { unTemplateValue :: T.Text }
deriving (Eq, Ord, Show, ToJSON, FromJSON)
data Template a = Template
{ _templateKey :: TemplateKey
, _templateDefault :: Maybe a
}
deriving (Eq, Ord, Show)
data Uninterpolated a
= Templated (Template a)
| Literal a
deriving (Eq, Ord, Show)
data InterpolationFailure
= InterpolationFailureKeyNotFound TemplateKey
| InterpolationFailureValueNotReadable TemplateKey TemplateValue
deriving (Eq, Ord)
instance Show InterpolationFailure where
show = \ case
InterpolationFailureKeyNotFound (TemplateKey k) -> "Interpolation key " <> show k <> " not found"
InterpolationFailureValueNotReadable (TemplateKey k) (TemplateValue v) -> "Value " <> show v <> " for interpolation key " <> show k <> " not readable"
newtype InterpolationContext = InterpolationContext { unInterpolationContext :: Map TemplateKey TemplateValue }
class FromTemplateValue a where
parseTemplateValue :: TemplateValue -> Maybe a
instance FromTemplateValue T.Text where
parseTemplateValue = Just . unTemplateValue
instance FromTemplateValue String where
parseTemplateValue = Just . T.unpack . unTemplateValue
instance FromTemplateValue Int where
parseTemplateValue = readMaybe . T.unpack . unTemplateValue
instance FromTemplateValue Bool where
parseTemplateValue x = case T.toLower (unTemplateValue x) of
"true" -> Just True
"false" -> Just False
_ -> Nothing
class ToTemplateValue a where
toTemplateValue :: a -> TemplateValue
instance ToTemplateValue T.Text where
toTemplateValue = TemplateValue
instance ToTemplateValue String where
toTemplateValue = TemplateValue . T.pack
instance ToTemplateValue Int where
toTemplateValue = TemplateValue . T.pack . show
instance ToTemplateValue Bool where
toTemplateValue = TemplateValue . T.toLower . T.pack . show
newtype Interpolator templates identities = Interpolator
{ runInterpolator :: templates -> Reader InterpolationContext (Validation [InterpolationFailure] identities)
}
instance Functor (Interpolator templates) where
fmap f (Interpolator g) = Interpolator $ fmap (fmap (fmap f)) g
instance Applicative (Interpolator templates) where
pure x = Interpolator $ \ _ -> pure $ Success x
Interpolator f <*> Interpolator g = Interpolator $ \ x -> do
f' <- f x
y <- g x
pure $ f' <*> y
instance Profunctor Interpolator where
dimap f g (Interpolator h) = Interpolator (dimap f (fmap (fmap g)) h)
instance ProductProfunctor Interpolator where
purePP = pure
(****) = (<*>)
instance SumProfunctor Interpolator where
Interpolator f +++! Interpolator g = Interpolator $ \ case
Left x -> fmap Left <$> f x
Right y -> fmap Right <$> g y
runTemplate :: FromTemplateValue a => Interpolator (Uninterpolated a) a
runTemplate = Interpolator $ \ case
Literal d -> pure $ Success d
Templated (Template k dMay) -> asks (lookup k . unInterpolationContext) >>= pure . \ case
Just v -> maybe (Failure [InterpolationFailureValueNotReadable k v]) Success $ parseTemplateValue v
Nothing -> maybe (Failure [InterpolationFailureKeyNotFound k]) Success dMay
mkInterpolationContext :: MonadIO m => m InterpolationContext
mkInterpolationContext = InterpolationContext . mapFromList . map toTuple <$> liftIO getEnvironment
where
toTuple (x, y) = (TemplateKey $ T.pack x, TemplateValue $ T.pack y)
interpolateWithContext :: (Default Interpolator templates identities, MonadIO m)
=> templates -> m (Either [InterpolationFailure] identities)
interpolateWithContext = interpolateWithContextExplicit def
interpolateWithContextExplicit :: MonadIO m
=> Interpolator templates identities -> templates -> m (Either [InterpolationFailure] identities)
interpolateWithContextExplicit interpolator x = do
ctx <- mkInterpolationContext
pure . validationToEither . flip runReader ctx . runInterpolator interpolator $ x
instance {-# OVERLAPPABLE #-} Default Interpolator a a where
def = Interpolator $ pure . Success
instance FromTemplateValue a => Default Interpolator (Uninterpolated a) a where
def = runTemplate
instance Default Interpolator a b => Default Interpolator (Map k a) (Map k b) where
def = Interpolator $ fmap sequenceA . traverse (runInterpolator def)
instance (Default Interpolator a b, Ord a, Ord b) => Default Interpolator (Set a) (Set b) where
def = Interpolator $ fmap (fmap setFromList . sequenceA) . traverse (runInterpolator def) . setToList
instance Default Interpolator a b => Default Interpolator [a] [b] where
def = Interpolator $ fmap sequenceA . traverse (runInterpolator def)
instance Default Interpolator a b => Default Interpolator (Maybe a) (Maybe b) where
def = Interpolator $ fmap sequenceA . traverse (runInterpolator def)
instance FromTemplateValue a => FromJSON (Template a) where
parseJSON jv = flip (withText "Template") jv $ \ t ->
case T.splitOn ":" t of
"_env":k:vs -> do
let v = T.intercalate ":" vs
defaultV = parseTemplateValue =<< if T.null v then Nothing else Just (TemplateValue v)
case T.null k of
False -> pure $ Template (TemplateKey k) defaultV
True -> fail $ "Not a template: " <> T.unpack t
_ -> fail $ "Not a template: " <> T.unpack t
instance ToTemplateValue a => ToJSON (Template a) where
toJSON (Template (TemplateKey k) (Just x)) = String $ "_env:" <> k <> ":" <> unTemplateValue (toTemplateValue x)
toJSON (Template (TemplateKey k) Nothing) = String $ "_env:" <> k
instance (FromTemplateValue a, FromJSON a) => FromJSON (Uninterpolated a) where
parseJSON jv = (Templated <$> parseJSON jv) <|> (Literal <$> parseJSON jv)
instance (ToTemplateValue a, ToJSON a) => ToJSON (Uninterpolated a) where
toJSON = \ case
Templated x -> toJSON x
Literal x -> toJSON x
instance Arbitrary TemplateKey where
arbitrary = TemplateKey <$> varNameAllowed
where varNameAllowed = fmap T.pack . listOf1 $ arbitrary `suchThat` (\c -> isAlphaNum c || c == '_')
instance Arbitrary1 Uninterpolated where
liftArbitrary g = oneof
[ Literal <$> g
, Templated <$> (Template <$> arbitrary <*> liftArbitrary g)
]
instance {-# OVERLAPPABLE #-} Arbitrary a => Arbitrary (Uninterpolated a) where
arbitrary = arbitrary1
instance {-# OVERLAPPING #-} Arbitrary (Uninterpolated T.Text) where
arbitrary = liftArbitrary noEnv
where noEnv = fmap T.pack $ arbitrary `suchThat` (\ s -> not ("_env:" `isPrefixOf` s) && not (null s))