diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 TVision Insights + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/interpolator.cabal b/interpolator.cabal new file mode 100644 --- /dev/null +++ b/interpolator.cabal @@ -0,0 +1,70 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 570771306faa364b58cc25e986b865c87ec4fc5906d686911995fbe348cc5ef3 + +name: interpolator +version: 0.1 +synopsis: Runtime interpolation of environment variables in records using profunctors +description: Runtime interpolation of environment variables in records using profunctors. See + https://github.com/tvision-insights/interpolator/README.md. +category: Data +author: Dan Fithian +maintainer: TVision Insights +license: MIT +license-file: LICENSE +build-type: Simple + +library + exposed-modules: + Data.Interpolation + Data.Interpolation.TH + other-modules: + Paths_interpolator + hs-source-dirs: + src + default-extensions: ApplicativeDo ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings PackageImports PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + ghc-options: -Wall -Wredundant-constraints -fwarn-tabs -O2 + build-depends: + QuickCheck + , aeson + , base <5.0 + , containers + , either + , mono-traversable + , mtl + , product-profunctors + , profunctors + , template-haskell + , text + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Data.Interpolation.THSpec + Data.InterpolationSpec + Paths_interpolator + hs-source-dirs: + test + default-extensions: ApplicativeDo ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings PackageImports PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + ghc-options: -Wall -Wredundant-constraints -fwarn-tabs -O2 + build-depends: + QuickCheck + , aeson + , base <5.0 + , containers + , either + , hspec + , interpolator + , mono-traversable + , mtl + , product-profunctors + , profunctors + , template-haskell + , text + default-language: Haskell2010 diff --git a/src/Data/Interpolation.hs b/src/Data/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Interpolation.hs @@ -0,0 +1,206 @@ +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.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, Gen, arbitrary, frequency, listOf1, oneof, suchThat) +import Text.Read (readMaybe) + +-- |Newtype wrapper for an environment variable key. +newtype TemplateKey = TemplateKey { unTemplateKey :: T.Text } + deriving (Eq, Ord, Show, ToJSON, FromJSON) + +-- |Newtype wrapper for an environment variable value. +newtype TemplateValue = TemplateValue { unTemplateValue :: T.Text } + deriving (Eq, Ord, Show, ToJSON, FromJSON) + +-- |Type for a value that is described by '_env:ENVIRONMENT_VARIABLE:default' in JSON. +data Template a = Template + { _templateKey :: TemplateKey + , _templateDefault :: Maybe a + } + deriving (Eq, Ord, Show) + +-- |Type for a value that can be described either with '_env...' or as just a literal value in JSON. +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 } + +-- |A class for parsing environment variable values, which should only be defined on primitives. +-- Similar to 'Read' except that for text-type values it should parse using identity. +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 + +-- |A class for showing environment variable values, which should only be defined on primitives. +-- Similar to 'Show' except that for text-type values it should use identity. +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 + +-- |Run a template using the interpolation context and failing if the value is not found or not readable. +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 + +-- |Pure transformation for the identity interpolation. FIXME this is too clunky for overlapping +-- instances, define an auxiliary class (or type) for IdentityInterpolation. +instance {-# OVERLAPPABLE #-} Default Interpolator a a where + def = Interpolator $ pure . Success + +-- |When we can parse template values, we can interpolate from the template. +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 + +maybeGen :: Gen a -> Gen (Maybe a) +maybeGen x = frequency [(1, pure Nothing), (3, Just <$> x)] + +noEnv, noColons :: Gen T.Text +noEnv = fmap T.pack $ arbitrary `suchThat` (\ s -> not ("_env:" `isPrefixOf` s) && not (null s)) +noColons = fmap T.pack . listOf1 $ arbitrary `suchThat` (/= ':') + +instance Arbitrary TemplateKey where + arbitrary = TemplateKey <$> noColons + +instance {-# OVERLAPPABLE #-} Arbitrary a => Arbitrary (Uninterpolated a) where + arbitrary = oneof + [ Literal <$> arbitrary + , Templated <$> (Template <$> arbitrary <*> arbitrary) + ] + +instance {-# OVERLAPPING #-} Arbitrary (Uninterpolated T.Text) where + arbitrary = oneof + [ Literal <$> noEnv + , Templated <$> (Template <$> arbitrary <*> maybeGen noColons) + ] diff --git a/src/Data/Interpolation/TH.hs b/src/Data/Interpolation/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Interpolation/TH.hs @@ -0,0 +1,70 @@ +module Data.Interpolation.TH where + +import Prelude + +import Data.Either.Validation (Validation (Success)) +import Data.Profunctor.Product.Default (Default, def) +import Data.Semigroup ((<>)) +import Data.Sequences (replicateM, singleton) +import Data.Traversable (for) +import Language.Haskell.TH + (Con (NormalC), Dec (DataD, NewtypeD), Info (TyConI), Name, Q, newName, reify) +import qualified Language.Haskell.TH.Lib as TH + +import Data.Interpolation (Interpolator (Interpolator), runInterpolator) + +extractSumConstructorsAndNumFields :: Name -> Q [(Name, Int)] +extractSumConstructorsAndNumFields ty = do + reify ty >>= \ case + TyConI (NewtypeD _ _ _ _ c _) -> singleton <$> extractConstructor c + TyConI (DataD _ _ _ _ cs _) -> traverse extractConstructor cs + other -> fail $ "can't extract constructors: " <> show other + where + extractConstructor = \ case + NormalC n fs -> pure (n, length fs) + other -> fail $ "won't extract constructors: " <> show other <> " - sum types only" + +-- |Make an instance of 'Default' for 'Interpolator' of an ADT. Can't do it for an arbitrary +-- Profunctor p because of partial functions. This splice is meant to be used in conjunction with +-- 'makeAdaptorAndInstance' for records as a way to project 'Default' instances down to all leaves. +-- +-- @ +-- +-- data Foo' a b = Foo1 a | Foo2 b +-- makeInterpolatorSumInstance ''Foo' +-- +-- @ +-- +-- @ +-- +-- instance (Default Interpolator a1 b1, Default Interpolator a2 b2) => Default Interpolator (Foo' a1 a2) (Foo' b1 b2) where +-- def = Interpolator $ \ case +-- Foo1 x -> Foo1 <$> runInterpolator def x +-- Foo2 x -> Foo2 <$> runInterpolator def x +-- +-- @ +makeInterpolatorSumInstance :: Name -> Q [Dec] +makeInterpolatorSumInstance tyName = do + cs <- extractSumConstructorsAndNumFields tyName + (contextConstraints, templateVars, identityVars) <- fmap (unzip3 . mconcat) $ for cs $ \ (_, i) -> replicateM i $ do + a <- newName "a" + b <- newName "b" + pure ([t| Default Interpolator $(TH.varT a) $(TH.varT b) |], a, b) + let appConstructor x y = TH.appT y (TH.varT x) + templateType = foldr appConstructor (TH.conT tyName) templateVars + identityType = foldr appConstructor (TH.conT tyName) identityVars + matches = flip fmap cs $ \ (c, i) -> case i of + 0 -> TH.match (TH.conP c []) (TH.normalB [| pure $ Success $(TH.conE c) |]) [] + 1 -> do + x <- newName "x" + TH.match (TH.conP c [TH.varP x]) (TH.normalB [| fmap $(TH.conE c) <$> runInterpolator def $(TH.varE x) |]) [] + _ -> fail $ "can only match sum constructors up to 1 argument" + sequence $ + [ TH.instanceD + (TH.cxt contextConstraints) + [t| Default Interpolator $(templateType) $(identityType) |] + [ TH.funD + 'def + [TH.clause [] (TH.normalB [| Interpolator $(TH.lamCaseE matches) |]) []] + ] + ] diff --git a/test/Data/Interpolation/THSpec.hs b/test/Data/Interpolation/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Interpolation/THSpec.hs @@ -0,0 +1,64 @@ +module Data.Interpolation.THSpec where + +import Prelude + +import Control.Monad.Reader (runReader) +import Data.Containers (mapFromList) +import Data.Either.Validation (validationToEither) +import Data.Profunctor.Product.Default (def) +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import qualified Data.Text as T +import Test.Hspec (Spec, describe, it, shouldBe) + +-- the modules being tested +import Data.Interpolation +import Data.Interpolation.TH + +data Bar' a b = Bar + { barA :: a + , barB :: b + } deriving (Eq, Ord, Show) +type UninterpolatedBar = Bar' (Uninterpolated Int) (Uninterpolated T.Text) +type Bar = Bar' Int T.Text + +data Foo' a b c + = Foo1 a + | Foo2 b + | Foo3 c + | Foo4 + deriving (Eq, Ord, Show) +type UninterpolatedFoo = Foo' UninterpolatedBar (Uninterpolated Int) (Uninterpolated Bool) +type Foo = Foo' Bar Int Bool + +makeAdaptorAndInstance "pBar" ''Bar' +makeInterpolatorSumInstance ''Foo' + +key1, key2, key3, key4 :: TemplateKey +key1 = TemplateKey "key1" +key2 = TemplateKey "key2" +key3 = TemplateKey "key3" +key4 = TemplateKey "key4" + +run :: UninterpolatedFoo -> Either [InterpolationFailure] Foo +run = validationToEither . flip runReader defaultContext . runInterpolator fooInterpolator + where + fooInterpolator :: Interpolator UninterpolatedFoo Foo + fooInterpolator = def + + defaultContext :: InterpolationContext + defaultContext = InterpolationContext . mapFromList $ + [ (key1, (TemplateValue "1")) + , (key2, (TemplateValue "asdf")) + , (key3, (TemplateValue "2")) + , (key4, (TemplateValue "true")) + ] + +spec :: Spec +spec = describe "Shared.Interpolation.THSpec" $ do + it "if it compiles, it worked" True + + it "interpolates over all branches" $ do + run (Foo1 (Bar (Templated $ Template key1 Nothing) (Templated $ Template key2 Nothing))) `shouldBe` Right (Foo1 $ Bar 1 "asdf") + run (Foo2 (Templated $ Template key3 Nothing)) `shouldBe` Right (Foo2 2) + run (Foo3 (Templated $ Template key4 Nothing)) `shouldBe` Right (Foo3 True) + run Foo4 `shouldBe` Right Foo4 diff --git a/test/Data/InterpolationSpec.hs b/test/Data/InterpolationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/InterpolationSpec.hs @@ -0,0 +1,178 @@ +module Data.InterpolationSpec where + +import Prelude + +import Control.Monad.Reader (runReader) +import Data.Aeson (FromJSON, ToJSON, decode, eitherDecodeStrict', encode) +import Data.Containers (mapFromList, singletonMap) +import Data.Either (isLeft) +import Data.Either.Validation (validationToEither) +import Data.Map (Map) +import Data.Profunctor.Product.Default (Default, def) +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Test.QuickCheck (Gen, arbitrary, forAll, listOf, resize, suchThat, (===)) + +-- the module being tested +import Data.Interpolation + +upToNCharacters :: Int -> Gen T.Text +upToNCharacters n = fmap T.pack . resize n . listOf . suchThat arbitrary $ \ x -> x /= '\0' + +codecLaws :: (ToJSON a, FromJSON a, Eq a, Show a) => Gen a -> Spec +codecLaws gen = do + it "decode . encode == Just" $ + forAll gen $ \x -> (decode . encode) x === Just x + it "encode . decode == Just (for any JSON resulting from encoding)" $ + forAll gen $ \(y :: b) -> + let json = encode y + in (encode <$> (decode json :: Maybe b)) === Just json + +newtype Bar = Bar { unBar :: Int } + deriving (Eq, Ord, Show, FromTemplateValue, ToTemplateValue) + +data Foo' a b c d e = Foo + { fooA :: a + , fooB :: b + , fooC :: c + , fooD :: d + , fooE :: e + } deriving (Eq, Ord, Show) +type UninterpolatedFoo = Foo' (Uninterpolated T.Text) (Uninterpolated Int) (Uninterpolated Bool) [Uninterpolated Bar] (Map Char (Uninterpolated T.Text)) +type Foo = Foo' T.Text Int Bool [Bar] (Map Char T.Text) + +makeAdaptorAndInstance "pFoo" ''Foo' + +fooInterpolator :: Interpolator UninterpolatedFoo Foo +fooInterpolator = def + +key0, key1, key2, key3, key4, key5 :: TemplateKey +key0 = TemplateKey "key0" +key1 = TemplateKey "key1" +key2 = TemplateKey "key2" +key3 = TemplateKey "key3" +key4 = TemplateKey "key4" +key5 = TemplateKey "key5" + +emptyContext, defaultContext :: InterpolationContext +emptyContext = InterpolationContext mempty +defaultContext = InterpolationContext . mapFromList $ + [ (key1, (TemplateValue "asdf")) + , (key2, (TemplateValue "1")) + , (key3, (TemplateValue "true")) + , (key4, (TemplateValue "2")) + , (key5, (TemplateValue "fdsa")) + ] + +singletonContext :: ToTemplateValue a => TemplateKey -> a -> InterpolationContext +singletonContext k v = InterpolationContext . singletonMap k . toTemplateValue $ v + +run :: InterpolationContext -> Interpolator a b -> a -> Either [InterpolationFailure] b +run ctx x = validationToEither . flip runReader ctx . runInterpolator x + +identityLaw :: (HasCallStack, Eq a, Show a) => Interpolator (Uninterpolated a) a -> Gen a -> Spec +identityLaw interp gen = describe "Identity Law" $ do + it "always succeeds on a literal" $ + forAll gen $ \ x -> + run emptyContext interp (Literal x) `shouldBe` Right x + +roundtripLaw :: (HasCallStack, Eq a, Show a, ToTemplateValue a) => Interpolator (Uninterpolated a) a -> Gen a -> Spec +roundtripLaw interp gen = describe "Round Trip Law" $ do + it "can always interpolate a rendered value" $ + forAll ((,) <$> gen <*> arbitrary) $ \ (x, k) -> + run (singletonContext k x) interp (Templated (Template k Nothing)) `shouldBe` Right x + +defaultLaws :: (HasCallStack, Eq a, Show a) => Interpolator (Uninterpolated a) a -> Gen a -> Spec +defaultLaws interp gen = describe "Default Laws" $ do + it "defaults if the value is not found" $ + forAll ((,) <$> gen <*> arbitrary) $ \ (x, k) -> + run emptyContext interp (Templated (Template k (Just x))) `shouldBe` Right x + it "fails if the value is not found and no default" $ + forAll arbitrary $ \ k -> + run emptyContext interp (Templated (Template k Nothing)) `shouldBe` Left [InterpolationFailureKeyNotFound k] + +interpolationLaws :: + ( HasCallStack, Eq a, Show a + , Default Interpolator (Uninterpolated a) a, ToTemplateValue a ) + => Gen a -> Spec +interpolationLaws gen = do + identityLaw def gen + roundtripLaw def gen + defaultLaws def gen + +spec :: Spec +spec = describe "InterpolationSpec" $ do + let isLeftInt :: Either String (Uninterpolated Int) -> Bool + isLeftInt = isLeft + + noDefaultText :: TemplateKey -> Uninterpolated T.Text + noDefaultText k = Templated (Template k Nothing) + + describe "Foo Unit Tests" $ do + it "interpolates variables from context" $ do + let template = Foo + { fooA = Templated $ Template key1 Nothing + , fooB = Templated $ Template key2 Nothing + , fooC = Templated $ Template key3 Nothing + , fooD = [Templated $ Template key4 Nothing] + , fooE = singletonMap 'a' (Templated $ Template key5 Nothing) + } + expected = Foo "asdf" 1 True [Bar 2] (singletonMap 'a' "fdsa") + run defaultContext fooInterpolator template `shouldBe` Right expected + it "fails with multiple errors" $ do + let template = Foo + { fooA = Templated $ Template key0 Nothing + , fooB = Templated $ Template key1 Nothing + , fooC = Templated $ Template key3 Nothing + , fooD = [Templated $ Template key4 Nothing] + , fooE = singletonMap 'a' (Templated $ Template key5 Nothing) + } + expected = + [ InterpolationFailureKeyNotFound key0 + , InterpolationFailureValueNotReadable key1 (TemplateValue "asdf") + ] + run defaultContext fooInterpolator template `shouldBe` Left expected + + describe "Uninterpolated JSON Unit Tests" $ do + it "parses base case" $ do + eitherDecodeStrict' "\"_env:key1:foo\"" `shouldBe` Right (Templated (Template key1 (Just ("foo" :: T.Text)))) + eitherDecodeStrict' "\"foo\"" `shouldBe` Right (Literal ("foo" :: T.Text)) + eitherDecodeStrict' "\"_env:key1:1\"" `shouldBe` Right (Templated (Template key1 (Just (1 :: Int)))) + eitherDecodeStrict' "1" `shouldBe` Right (Literal (1 :: Int)) + eitherDecodeStrict' "\"_env:key1:true\"" `shouldBe` Right (Templated (Template key1 (Just True))) + eitherDecodeStrict' "true" `shouldBe` Right (Literal True) + + it "parses no default" $ do + eitherDecodeStrict' "\"_env:key1\"" `shouldBe` Right (noDefaultText key1) + eitherDecodeStrict' "\"_env:key1:\"" `shouldBe` Right (noDefaultText key1) + + it "fails with no key" $ do + eitherDecodeStrict' "\"_env:\"" `shouldSatisfy` isLeftInt + eitherDecodeStrict' "\"_env::\"" `shouldSatisfy` isLeftInt + eitherDecodeStrict' "\"_env::1\"" `shouldSatisfy` isLeftInt + + it "succeeds with colons in default value" $ do + eitherDecodeStrict' "\"_env:key1:foo:bar\"" `shouldBe` Right (Templated (Template key1 (Just ("foo:bar" :: T.Text)))) + + it "succeeds even if you are a bad person and do something wrong sometimes" $ do + eitherDecodeStrict' "\"_env:a space\"" `shouldBe` Right (noDefaultText $ TemplateKey "a space") + + describe "Text Primitive" $ do + describe "JSON Laws" $ do + codecLaws (arbitrary :: Gen (Uninterpolated T.Text)) + describe "Interpolation Laws" $ do + interpolationLaws $ upToNCharacters 50 + + describe "Int Primitive" $ do + describe "JSON Laws" $ do + codecLaws (arbitrary :: Gen (Uninterpolated Int)) + describe "Interpolation Laws" $ do + interpolationLaws (arbitrary :: Gen Int) + + describe "Bool Primitive" $ do + describe "JSON Laws" $ do + codecLaws (arbitrary :: Gen (Uninterpolated Bool)) + describe "Interpolation Laws" $ do + interpolationLaws (arbitrary :: Gen Bool) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,11 @@ +import Prelude + +import Test.Hspec (hspec) + +import qualified Data.InterpolationSpec +import qualified Data.Interpolation.THSpec + +main :: IO () +main = hspec $ do + Data.InterpolationSpec.spec + Data.Interpolation.THSpec.spec