interpolator (empty) → 0.1
raw patch · 7 files changed
+620/−0 lines, 7 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, containers, either, hspec, interpolator, mono-traversable, mtl, product-profunctors, profunctors, template-haskell, text
Files
- LICENSE +21/−0
- interpolator.cabal +70/−0
- src/Data/Interpolation.hs +206/−0
- src/Data/Interpolation/TH.hs +70/−0
- test/Data/Interpolation/THSpec.hs +64/−0
- test/Data/InterpolationSpec.hs +178/−0
- test/Spec.hs +11/−0
+ LICENSE view
@@ -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.
+ interpolator.cabal view
@@ -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 <daniel.m.fithian@gmail.com>+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
+ src/Data/Interpolation.hs view
@@ -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)+ ]
+ src/Data/Interpolation/TH.hs view
@@ -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) |]) []]+ ]+ ]
+ test/Data/Interpolation/THSpec.hs view
@@ -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
+ test/Data/InterpolationSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -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