diff --git a/interpolator.cabal b/interpolator.cabal --- a/interpolator.cabal +++ b/interpolator.cabal @@ -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). diff --git a/src/Data/Interpolation.hs b/src/Data/Interpolation.hs --- a/src/Data/Interpolation.hs +++ b/src/Data/Interpolation.hs @@ -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. diff --git a/src/Data/Interpolation/TH.hs b/src/Data/Interpolation/TH.hs --- a/src/Data/Interpolation/TH.hs +++ b/src/Data/Interpolation/TH.hs @@ -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 diff --git a/test/Data/Interpolation/THSpec.hs b/test/Data/Interpolation/THSpec.hs --- a/test/Data/Interpolation/THSpec.hs +++ b/test/Data/Interpolation/THSpec.hs @@ -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