interpolator 1.0.0 → 1.1.0
raw patch · 4 files changed
+357/−32 lines, 4 filesnew-uploader
Files
- interpolator.cabal +2/−2
- src/Data/Interpolation.hs +2/−1
- src/Data/Interpolation/TH.hs +281/−6
- test/Data/Interpolation/THSpec.hs +72/−23
interpolator.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 979db35e1db7cb62265111ec02f96847dd76e6fe139072073c2b4c0030bb7f85+-- hash: ab8642696ba91ce861dbb531062073146cc1d609950a737be8de50775aa8c3da name: interpolator-version: 1.0.0+version: 1.1.0 synopsis: Runtime interpolation of environment variables in records using profunctors description: Runtime interpolation of environment variables in records using profunctors. See the [README](https://github.com/tvision-insights/interpolator/blob/master/README.md).
src/Data/Interpolation.hs view
@@ -18,7 +18,8 @@ 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 Test.QuickCheck+ (Arbitrary, Arbitrary1, arbitrary, arbitrary1, liftArbitrary, listOf1, oneof, suchThat) import Text.Read (readMaybe) -- |Newtype wrapper for an environment variable key.
src/Data/Interpolation/TH.hs view
@@ -1,18 +1,40 @@-module Data.Interpolation.TH where+module Data.Interpolation.TH+ ( makeInterpolatorSumInstance+ , withUninterpolated+ , withPolymorphic+ , deriveUninterpolated+ ) where import Prelude-+import Data.Char (toLower) import Data.Either.Validation (Validation (Success))+import Data.List (dropWhileEnd) import Data.Profunctor.Product.Default (Default, def) import Data.Semigroup ((<>))-import Data.Sequences (replicateM, singleton)+import Data.Sequences (catMaybes, replicateM, singleton, stripPrefix) import Data.Traversable (for) import Language.Haskell.TH- (Con (NormalC), Dec (DataD, NewtypeD), Info (TyConI), Name, Q, newName, reify)+ ( Con (NormalC, RecC)+ , Dec (DataD, NewtypeD, TySynD)+ , Info (TyConI)+ , Name+ , Q+ , Type (AppT, ConT, VarT)+ , isInstance+ , lookupTypeName+ , mkName+ , nameBase+ , newName+ , pprint+ , reify+ , reportError+ ) import qualified Language.Haskell.TH.Lib as TH+import Language.Haskell.TH.Syntax (returnQ) -import Data.Interpolation (Interpolator (Interpolator), runInterpolator) +import Data.Interpolation (FromTemplateValue, Interpolator (Interpolator), runInterpolator)+ extractSumConstructorsAndNumFields :: Name -> Q [(Name, Int)] extractSumConstructorsAndNumFields ty = do reify ty >>= \ case@@ -59,7 +81,7 @@ 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 $+ sequence [ TH.instanceD (TH.cxt contextConstraints) [t| Default Interpolator $(templateType) $(identityType) |]@@ -68,3 +90,256 @@ [TH.clause [] (TH.normalB [| Interpolator $(TH.lamCaseE matches) |]) []] ] ]++-- |When applied to a simple data type declaration, substitute a fully-polymorphic data type+-- (suffixed with a "prime"), and type aliases for "normal" and "uninterpolated" variants.+--+-- For example, a record or newtype (using record syntax):+--+-- @+-- withUninterpolated [d|+-- data Foo = Foo+-- { fooBar :: String+-- , fooBaz :: Maybe Int+-- } deriving (Eq, Show)+-- |]+-- @+--+-- Is equivalent to:+--+-- @+-- data Foo' bar baz = Foo+-- { fooBar :: bar+-- , fooBaz :: baz+-- } deriving (Eq, Show)+-- type Foo = Foo' String (Maybe Int)+-- type UninterpolatedFoo = Foo' (Uninterpolated String) (Maybe (Uninterpolated Int))+-- @+--+-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.+--+-- A simple sum type whose constructors have one argument or less:+--+-- @+-- withUninterpolated [d|+-- data MaybeFoo+-- = AFoo Foo+-- | NoFoo+-- deriving (Eq, Show)+-- @+--+-- Expands to:+--+-- @+-- data MaybeFoo' aFoo+-- = AFoo aFoo+-- | NoFoo+-- deriving (Eq, Show)+-- type MaybeFoo = MaybeFoo' Foo+-- type UninterpolatedMaybeFoo = MaybeFoo' (Foo' (Uninterpolated String) (Maybe (Uninterpolated Int)))+-- -- Note: UninterpolatedMaybeFoo ~ MaybeFoo' UninterpolatedFoo+-- @+--+-- Whenever the type of a field is one for which an instance of 'FromTemplateValue' is present, the+-- type is wrapped in 'Uninterpolated'. Otherwise, an attempt is made to push 'Uninterpolated' down+-- into the field's type, even if it's a type synonym such as one generated by this same macro.+--+-- Note: this splice is equivalent to @withPolymorphic [d|data Foo ... |]@ followed by+-- @deriveUninterpolated ''Foo@.+withUninterpolated :: Q [Dec] -> Q [Dec]+withUninterpolated qDecs = do+ (poly, simple) <- withPolymorphic_ qDecs+ uninterp <- deriveUninterpolated_ simple+ pure $ [poly, simple] <> uninterp+++-- |When applied to a simple data type declaration, substitute a fully-polymorphic data type+-- (suffixed with a "prime"), and a simple type alias which matches the supplied declaration.+--+-- This splice does not include the corresponding "Uninterpolated" type, so it can be used separately+-- when needed. For example, if you want to define all your record types first, then define/derive+-- the Uninterpolated types for each. This can be important because the presence of a+-- 'FromTemplateValue' instance, defined before the splice, will affect the shape of the derived+-- Uninterpolated type.+--+-- For example, a record or newtype (using record syntax):+--+-- @+-- withPolymorphic [d|+-- data Foo = Foo+-- { fooBar :: String+-- , fooBaz :: Maybe Int+-- } deriving (Eq, Show)+-- |]+-- @+--+-- Is equivalent to:+--+-- @+-- data Foo' bar baz = Foo+-- { fooBar :: bar+-- , fooBaz :: baz+-- } deriving (Eq, Show)+-- type Foo = Foo' String (Maybe Int)+-- @+--+-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.+withPolymorphic :: Q [Dec] -> Q [Dec]+withPolymorphic qDecs = do+ (poly, simple) <- withPolymorphic_ qDecs+ pure [poly, simple]++-- |Given the name of a type alias which specializes a polymorphic type (such as the "simple" type+-- generated by 'withPolymorphic'), generate the corresponding "Uninterpolated" type alias which+-- replaces each simple type with an 'Uninterpolated' form, taking account for which types have+-- 'FromTemplateValue' instances.+--+-- Use this instead of 'withUninterpolated' when you need to define instances for referenced types,+-- and you need flexibility in the ordering of declarations in your module's source.+deriveUninterpolated :: Name -> Q [Dec]+deriveUninterpolated tName =+ reify tName >>= \ case+ TyConI dec -> deriveUninterpolated_ dec+ other -> do+ reportError $ "Can't handle type: " <> show other <> "; expected a \"simple\" type alias"+ pure []++---------------+-- * Internal++-- |From a simple type declaration, generate declarations for the polymorphic type and the simple+-- type alias.+withPolymorphic_ :: Q [Dec] -> Q (Dec, Dec)+withPolymorphic_ qDecs = do+ decs <- qDecs+ case decs of+ -- "data" with a single record constructor:+ [DataD [] tName [] Nothing [RecC cName fields] deriv] -> do+ let con = TH.recC (simpleName cName) (returnQ <$> (fieldToPolyField <$> fields))+ primedDecl <- TH.dataD (pure []) (primedName tName) (fieldToTypeVar <$> fields) Nothing [con] (returnQ <$> deriv)+ normalSyn <- TH.tySynD (simpleName tName) [] $+ returnQ $ foldl (\ t v -> AppT t (fieldToSimpleType v)) (ConT (primedName tName)) fields+ pure (primedDecl, normalSyn)++ -- "newtype" with a single record constructor:+ [NewtypeD [] tName [] Nothing (RecC cName [field]) deriv] -> do+ -- TODO: use the type name, lower-cased, instead of the field name, for the type var?+ let con = TH.recC (simpleName cName) (returnQ <$> [fieldToPolyField field])+ primedDecl <- TH.newtypeD (pure []) (primedName tName) [fieldToTypeVar field] Nothing con (returnQ <$> deriv)+ normalSyn <- TH.tySynD (simpleName tName) [] $+ returnQ $ AppT (ConT (primedName tName)) (fieldToSimpleType field)+ pure (primedDecl, normalSyn)++ -- "data" with multiple simple constructors:+ [DataD [] tName [] Nothing constrs deriv] -> do+ let mapConstr = \ case+ NormalC cName [(s, t)] ->+ let vName = niceName tName cName+ in pure (Just (TH.plainTV vName), NormalC cName [(s, VarT vName)], Just t)+ NormalC cName [] ->+ pure (Nothing, NormalC cName [], Nothing)+ other -> fail $ "Can't handle constructor: " <> pprint other++ (vars, constrs', ts) <- unzip3 <$> traverse mapConstr constrs+ primedDecl <- TH.dataD (pure []) (primedName tName) (catMaybes vars) Nothing (returnQ <$> constrs') (returnQ <$> deriv)+ normalSyn <- TH.tySynD (simpleName tName) [] $+ returnQ $ foldl AppT (ConT (primedName tName)) (catMaybes ts)+ pure (primedDecl, normalSyn)++ _ -> do+ fail $ "Can't handle declaration: " <> pprint decs++ where+ primedName n = mkName (nameBase n <> "'")+ simpleName = mkName . nameBase++ fieldToTypeVar (n, _, _) = TH.plainTV (simpleName n) -- TODO: strip prefix?+ fieldToPolyField (n, s, _) = (simpleName n, s, VarT (simpleName n))+ fieldToSimpleType (_, _, t) = t++ niceName prefix = mkName . unCap . (\ s -> maybe s id (stripPrefix (nameBase prefix) s)) . nameBase+ unCap = \ case+ c : cs -> toLower c : cs+ other -> other+++deriveUninterpolated_ :: Dec -> Q [Dec]+deriveUninterpolated_ dec = do+ case dec of+ TySynD sName [] typ -> do+ uninterp <- TH.tySynD (mkName $ "Uninterpolated" <> nameBase sName) [] (mapUninterp typ)+ pure [uninterp]+ _ -> do+ reportError $ "Can't handle declaration: " <> show dec <> "; expected a \"simple\" type alias"+ pure []++-- Apply the Uninterpolated constructor, pushing it inside an outer type application, and into+-- every type parameter, even in the presence of type synonyms (such as those generated here.)+-- If there is a 'FromTemplateValue' instance for an argument type, that constructor is applied+-- to that type, with its structure left intact.+mapUninterp :: Type -> Q Type+mapUninterp typ = do+ uninterp <- lookupTypeName "Uninterpolated" >>= maybe (fail "Uninterpolated not in scope") returnQ+ let wrap = AppT (ConT uninterp)++ -- Apply only to the _right_ side of (nested) AppTs:+ mapRight :: Type -> Q Type+ mapRight = \ case+ AppT t1@(AppT _ _) t2 -> AppT <$> mapRight t1 <*> mapOne t2+ AppT t1 t2 -> AppT t1 <$> mapOne t2+ t -> mapOne t++ mapOne :: Type -> Q Type+ mapOne t = do+ -- reportWarning $ "mapOne: " <> show t++ mapped <- isInstance ''FromTemplateValue [t] >>= \ case+ True -> pure $ wrap t+ False -> case t of+ ConT n -> do+ info <- reify n+ case info of+ TyConI (DataD _ _ _ _ _ _) -> pure (ConT n)+ TyConI (NewtypeD _ _ _ _ _ _) -> pure (ConT n)+ TyConI (TySynD _ [] t1) -> mapOne t1+ other -> do+ reportError $ "Can't handle constructor: " <> pprint other+ pure $ ConT n+ t1@(AppT _ _) -> mapRight t1+ other -> do+ reportError $ "Can't handle type: " <> pprint other+ pure other++ lookupAlias mapped >>= \ case+ Just uName -> pure $ ConT uName+ Nothing -> pure mapped++ -- Name of the "Uninterpolated..." alias which is already in scope and exactly matches+ -- the given type, if any. This prevents the type aliases for nested types from getting+ -- out of hand, both in Haddock and in compile errors.+ lookupAlias :: Type -> Q (Maybe Name)+ lookupAlias t =+ case constrName t of+ Nothing -> pure Nothing+ Just cName -> do+ let uninterpName = "Uninterpolated" <> dropWhileEnd (== '\'') (nameBase cName)+ lookupTypeName uninterpName >>= \ case+ Nothing -> pure Nothing+ Just uName -> do+ uInfo <- reify uName+ case uInfo of+ TyConI (TySynD _ [] namedT) | namedT == t -> do+ pure $ Just uName+ _ -> do+ pure Nothing++ -- Name of the constructor at the bottom-left of a chain of AppT; that is, the type+ -- constructor being applied to a series of argument types, if that's what it looks like.+ constrName :: Type -> Maybe Name+ constrName = \ case+ ConT name -> Just name+ AppT t _ -> constrName t+ _ -> Nothing+++ mapRight typ
test/Data/Interpolation/THSpec.hs view
@@ -7,37 +7,83 @@ import Data.Either.Validation (validationToEither) import Data.Profunctor.Product.Default (def) import Data.Profunctor.Product.TH (makeAdaptorAndInstance)-import qualified Data.Text as T+import Data.Text (Text, toUpper) 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+-- |A simple newtype with a derived instance for 'FromTemplateValue'; that instance will be in scope+-- when the type is referred to later in this file.+newtype BarName = BarName { unBarName :: Text }+ deriving (Eq, Ord, Show, FromTemplateValue, ToTemplateValue) -data Foo' a b c- = Foo1 a- | Foo2 b- | Foo3 c- | Foo4+-- |A simple non-interpolatable type (no 'FromTemplateValue' instance.)+data Quux+ = QuuxFuzzy+ | QuuxSmooth deriving (Eq, Ord, Show)-type UninterpolatedFoo = Foo' UninterpolatedBar (Uninterpolated Int) (Uninterpolated Bool)-type Foo = Foo' Bar Int Bool +withUninterpolated [d|+ data Bar = Bar+ { barA :: BarName+ -- ^Because BarName has 'FromTemplateValue', it will be 'Uninterpolated BarName' in the generated type.+ , barB :: Maybe Int+ -- ^No instance for 'Maybe Int', so this becomes 'Maybe (Uninterpolated Int)'.+ , barC :: [Bool]+ -- ^Similarly, this becomes '[Uninterpolated Bool]'.+ , barD :: Quux+ -- ^No 'FromTemplateValue' instance at all, so this is left as just 'Quux'.+ } deriving (Eq, Ord, Show)+ |]++-- |A type that will have its FromTemplateValue instance defined manually. For demonstration+-- purposes, this is just a string that is upper-cased when it is interpolated from a template.+newtype Upcased = Upcased { unUpcased :: Text }+ deriving (Eq, Show)++-- |Note: want the uninterpolated type for this sum to account for the late-defined+-- `FromTemplateValue Upcased` instance, so derive only the polymorphic type now:+withPolymorphic [d|+ data Foo+ = FooBar Bar+ | FooInt Int+ | FooBool Bool+ | FooUpcased Upcased+ | FooNone+ deriving (Eq, Ord, Show)+ |]+ makeAdaptorAndInstance "pBar" ''Bar' makeInterpolatorSumInstance ''Foo' -key1, key2, key3, key4 :: TemplateKey+instance FromTemplateValue Upcased where+ parseTemplateValue = Just . Upcased . toUpper . unTemplateValue++-- Finally, derive the uninterpolated type for Foo, with the instance for Upcased defined.+deriveUninterpolated ''Foo++-- --+-- -- Another newtype, this time with a custom FromTemplateValue instance which is defined after the+-- -- type, and a record type that uses it.+-- --++-- newtype BazName = BazName { unBazName :: Text }+-- deriving (Eq, Ord, Show)++-- withPolymorphic [d|+-- data Baz = Baz+-- { bazName :: BazName+-- } deriving (Eq, Ord, Show)+-- |]++key1, key2, key3, key4, key5 :: TemplateKey key1 = TemplateKey "key1" key2 = TemplateKey "key2" key3 = TemplateKey "key3" key4 = TemplateKey "key4"+key5 = TemplateKey "key5" run :: UninterpolatedFoo -> Either [InterpolationFailure] Foo run = validationToEither . flip runReader defaultContext . runInterpolator fooInterpolator@@ -47,10 +93,11 @@ defaultContext :: InterpolationContext defaultContext = InterpolationContext . mapFromList $- [ (key1, (TemplateValue "1"))- , (key2, (TemplateValue "asdf"))- , (key3, (TemplateValue "2"))- , (key4, (TemplateValue "true"))+ [ (key1, TemplateValue "asdf")+ , (key2, TemplateValue "1")+ , (key3, TemplateValue "2")+ , (key4, TemplateValue "true")+ , (key5, TemplateValue "Wow") ] spec :: Spec@@ -58,7 +105,9 @@ 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+ run (FooBar (Bar (Templated $ Template key1 Nothing) (Just . Templated $ Template key2 Nothing) [] QuuxFuzzy))+ `shouldBe` Right (FooBar $ Bar (BarName "asdf") (Just 1) [] QuuxFuzzy)+ run (FooInt (Templated $ Template key3 Nothing)) `shouldBe` Right (FooInt 2)+ run (FooBool (Templated $ Template key4 Nothing)) `shouldBe` Right (FooBool True)+ run (FooUpcased (Templated $ Template key5 Nothing)) `shouldBe` Right (FooUpcased (Upcased "WOW"))+ run FooNone `shouldBe` Right FooNone