interpolator 1.1.0 → 1.1.0.1
raw patch · 4 files changed
+66/−16 lines, 4 files
Files
- interpolator.cabal +3/−2
- src/Data/Interpolation/TH.hs +22/−10
- src/Ex.hs +26/−0
- test/Data/Interpolation/THSpec.hs +15/−4
interpolator.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ab8642696ba91ce861dbb531062073146cc1d609950a737be8de50775aa8c3da+-- hash: 64628069dbe51b088dc90923f092f02eaf7e619b406bcc15fb7d926aeb60be94 name: interpolator-version: 1.1.0+version: 1.1.0.1 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).@@ -25,6 +25,7 @@ exposed-modules: Data.Interpolation Data.Interpolation.TH+ Ex other-modules: Paths_interpolator hs-source-dirs:
src/Data/Interpolation/TH.hs view
@@ -80,7 +80,7 @@ 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"+ _ -> fail "can only match sum constructors up to 1 argument" sequence [ TH.instanceD (TH.cxt contextConstraints)@@ -215,8 +215,8 @@ 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)+ let con = TH.recC (simpleName cName) (returnQ <$> (fieldToPolyField tName <$> fields))+ primedDecl <- TH.dataD (pure []) (primedName tName) (fieldToTypeVar tName <$> 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)@@ -224,8 +224,8 @@ -- "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)+ let con = TH.recC (simpleName cName) (returnQ <$> [fieldToPolyField tName field])+ primedDecl <- TH.newtypeD (pure []) (primedName tName) [fieldToTypeVar tName field] Nothing con (returnQ <$> deriv) normalSyn <- TH.tySynD (simpleName tName) [] $ returnQ $ AppT (ConT (primedName tName)) (fieldToSimpleType field) pure (primedDecl, normalSyn)@@ -250,14 +250,28 @@ fail $ "Can't handle declaration: " <> pprint decs where+ -- The same name, with a "'" added to the end: primedName n = mkName (nameBase n <> "'")++ -- The same name, in a fresh context: simpleName = mkName . nameBase - fieldToTypeVar (n, _, _) = TH.plainTV (simpleName n) -- TODO: strip prefix?- fieldToPolyField (n, s, _) = (simpleName n, s, VarT (simpleName n))+ -- Remove leading "_" and type name, if either is present:+ unPrefixedFieldName tName = mkName . avoidKeywords . unCap . stripped (unCap $ nameBase tName) . stripped "_" . nameBase++ fieldToTypeVar tName (fName, _, _) = TH.plainTV (unPrefixedFieldName tName fName)+ fieldToPolyField tName (fName, s, _) = (simpleName fName, s, VarT (unPrefixedFieldName tName fName)) fieldToSimpleType (_, _, t) = t - niceName prefix = mkName . unCap . (\ s -> maybe s id (stripPrefix (nameBase prefix) s)) . nameBase+ niceName prefix = mkName . avoidKeywords. unCap . stripped (nameBase prefix) . nameBase+ avoidKeywords str = if str `elem` likelyKeywords then str <> "_" else str+ where+ likelyKeywords =+ [ "as", "case", "class", "data", "default", "deriving", "do", "else", "family", "forall"+ , "foreign", "if", "in", "import", "infix", "infixl", "infixr", "instance", "hiding"+ , "let", "mdo", "module", "newtype", "of", "proc", "qualified", "rec", "then", "type", "where"+ ]+ stripped prefix str = maybe str id (stripPrefix prefix str) unCap = \ case c : cs -> toLower c : cs other -> other@@ -291,8 +305,6 @@ mapOne :: Type -> Q Type mapOne t = do- -- reportWarning $ "mapOne: " <> show t- mapped <- isInstance ''FromTemplateValue [t] >>= \ case True -> pure $ wrap t False -> case t of
+ src/Ex.hs view
@@ -0,0 +1,26 @@+module Ex where++import Prelude+import Data.Text+import Data.Interpolation+import Data.Interpolation.TH++withUninterpolated [d|+ data MyProduct = MyProduct+ { _myProductBar :: Maybe Text --+ , myProductBaz :: Int+ , myProductData :: Double+ -- , myProductQuux :: Bool+ } deriving Eq+ |]++withUninterpolated [d|+ data MySum+ = MySumOne Text+ | MySunTwo Int+ | MySumData Bool+ deriving Eq+ |]++-- foo :: MyProduct -> Int+-- foo = myProductBaz
test/Data/Interpolation/THSpec.hs view
@@ -27,14 +27,16 @@ withUninterpolated [d| data Bar = Bar- { barA :: BarName+ { barName :: BarName -- ^Because BarName has 'FromTemplateValue', it will be 'Uninterpolated BarName' in the generated type.- , barB :: Maybe Int+ , barNum :: Maybe Int -- ^No instance for 'Maybe Int', so this becomes 'Maybe (Uninterpolated Int)'.- , barC :: [Bool]+ , barFlags :: [Bool] -- ^Similarly, this becomes '[Uninterpolated Bool]'.- , barD :: Quux+ , barData :: Quux -- ^No 'FromTemplateValue' instance at all, so this is left as just 'Quux'.+ -- Also note: the generated type parameter for this one is called 'data_' to+ -- avoid a syntax error. } deriving (Eq, Ord, Show) |] @@ -77,6 +79,15 @@ -- { bazName :: BazName -- } deriving (Eq, Ord, Show) -- |]++-- Verify the type and field names are as expected:+aBar :: Bar+aBar = Bar+ { barName = BarName "abc"+ , barNum = Just 1+ , barFlags = [False]+ , barData = QuuxFuzzy+ } key1, key2, key3, key4, key5 :: TemplateKey key1 = TemplateKey "key1"