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: 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: 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 @@ -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 diff --git a/src/Ex.hs b/src/Ex.hs new file mode 100644 --- /dev/null +++ b/src/Ex.hs @@ -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 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 @@ -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"