{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Faker.TH ( generateFakeField , generateFakeFields , generateFakeFieldUnresolved , generateFakeFieldSingleUnresolved , generateFakeFieldUnresolveds ) where import Config import Control.Monad.Catch import Control.Monad.IO.Class import Data.Char (toLower, toUpper) import Data.Map.Strict (Map) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Vector (Vector) import Data.Yaml import Faker import Faker.Internal import Language.Haskell.TH stringTitle :: String -> String stringTitle [] = [] stringTitle (x:xs) = (toUpper x) : xs lowerTitle :: String -> String lowerTitle [] = [] lowerTitle (x:xs) = (toLower x) : xs -- λ> runQ [d|state :: Fake Text;state = Fake (resolver stateProvider)|] -- [SigD state_0 (AppT (ConT Faker.Fake) (ConT Data.Text.Internal.Text)),ValD (VarP state_0) (NormalB (AppE (ConE Faker.Fake) (AppE (VarE Faker.Internal.resolver) (VarE Faker.Provider.Address.stateProvider)))) []] -- $(genrateFakeField "address" "state") -- The above splice will generate a function named state -- Assumes the presence of the function named "addressStateProvider" generateFakeField :: String -> String -> Q [Dec] generateFakeField entityName fieldName = do let funName = mkName $ case refinedString fieldName of "type" -> "type'" other -> other pfn = refinedString $ entityName <> (stringTitle fieldName) <> "Provider" providerName <- lookupValueName pfn providerFn <- case providerName of Nothing -> fail $ "generateFakefield: Function " <> pfn <> " not found in scope" Just fn -> return fn return $ [ SigD funName (AppT (ConT ''Fake) (ConT ''Text)) , ValD (VarP funName) (NormalB (AppE (ConE 'Fake) (AppE (AppE (AppE (VarE 'cachedRandomVec) (LitE (StringL entityName))) (LitE (StringL fieldName))) (VarE providerFn)))) [] ] generateFakeFields :: String -> [String] -> Q [Dec] generateFakeFields entityName fieldName = do let fieldName' = map stringTitle fieldName fieldName'' = concat fieldName' pfn = refinedString $ entityName <> fieldName'' <> "Provider" funNameString = lowerTitle $ refinedString fieldName'' funName = mkName funNameString providerName <- lookupValueName pfn providerFn <- case providerName of Nothing -> fail $ "generateFakefields: Function " <> pfn <> " not found in scope" Just fn -> return fn return $ [ SigD funName (AppT (ConT ''Fake) (ConT ''Text)) , ValD (VarP funName) (NormalB (AppE (ConE 'Fake) (AppE (AppE (AppE (VarE 'cachedRandomVec) (LitE (StringL entityName))) (LitE (StringL funNameString))) (VarE providerFn)))) [] ] -- λ> runQ runQ [d|community :: Fake Text; community = Fake (cachedRandomUnresolvedVec "address" "community" communityProvider resolveAddressField)|] -- [SigD community_1 (AppT (ConT Faker.Fake) (ConT Data.Text.Internal.Text)),ValD (VarP community_1) (NormalB (AppE (ConE Faker.Fake) (AppE (AppE (AppE (AppE (VarE Faker.Internal.cachedRandomUnresolvedVec) (LitE (StringL "address"))) (LitE (StringL "community"))) (VarE Faker.Provider.Address.communityProvider)) (VarE Faker.Provider.Address.resolveAddressField)))) []] -- $(genrateFakeFieldUnresolved "address" "comunity") -- The above splice will generate a function named state -- Assumes the presence of the function named "addressStateProvider" and "resolveAddressText" generateFakeFieldUnresolved :: String -> String -> Q [Dec] generateFakeFieldUnresolved entityName fieldName = do let funName = mkName $ refinedString fieldName pfn = refinedString $ entityName <> (stringTitle fieldName) <> "Provider" rfn = "resolve" <> (refinedString $ stringTitle entityName) <> "Text" providerName <- lookupValueName pfn resolverName <- lookupValueName rfn providerFn <- case providerName of Nothing -> fail $ "generateFakeFieldUnresolved: Function " <> pfn <> " not found in scope" Just fn -> return fn resolverFn <- case resolverName of Nothing -> fail $ "generateFakeFieldUnresolved: Function " <> rfn <> " not found in scope" Just fn -> return fn return $ [ SigD funName (AppT (ConT ''Fake) (ConT ''Text)) , ValD (VarP funName) (NormalB (AppE (ConE 'Fake) (AppE (AppE (AppE (AppE (VarE 'cachedRandomUnresolvedVec) (LitE (StringL entityName))) (LitE (StringL fieldName))) (VarE providerFn)) (VarE resolverFn)))) [] ] generateFakeFieldSingleUnresolved :: String -> String -> Q [Dec] generateFakeFieldSingleUnresolved entityName fieldName = do let funName = mkName $ refinedString fieldName pfn = refinedString $ entityName <> (stringTitle fieldName) <> "Provider" rfn = "resolve" <> (refinedString $ stringTitle entityName) <> "Text" providerName <- lookupValueName pfn resolverName <- lookupValueName rfn providerFn <- case providerName of Nothing -> fail $ "generateFakeFieldUnresolved: Function " <> pfn <> " not found in scope" Just fn -> return fn resolverFn <- case resolverName of Nothing -> fail $ "generateFakeFieldUnresolved: Function " <> rfn <> " not found in scope" Just fn -> return fn return $ [ SigD funName (AppT (ConT ''Fake) (ConT ''Text)) , ValD (VarP funName) (NormalB (AppE (ConE 'Fake) (AppE (AppE (AppE (AppE (VarE 'cachedRandomUnresolvedVecWithoutVector) (LitE (StringL entityName))) (LitE (StringL fieldName))) (VarE providerFn)) (VarE resolverFn)))) [] ] generateFakeFieldUnresolveds :: String -> [String] -> Q [Dec] generateFakeFieldUnresolveds entityName fieldNames = do let fieldName' = refinedString $ concat $ map stringTitle fieldNames funNameString = lowerTitle fieldName' funName = mkName funNameString pfn = refinedString $ entityName <> fieldName' <> "Provider" rfn = "resolve" <> (refinedString $ stringTitle entityName) <> "Text" providerName <- lookupValueName pfn resolverName <- lookupValueName rfn providerFn <- case providerName of Nothing -> fail $ "generateFakeFieldUnresolveds: Function " <> pfn <> " not found in scope" Just fn -> return fn resolverFn <- case resolverName of Nothing -> fail $ "generateFakeFieldUnresolveds: Function " <> rfn <> " not found in scope" Just fn -> return fn return $ [ SigD funName (AppT (ConT ''Fake) (ConT ''Text)) , ValD (VarP funName) (NormalB (AppE (ConE 'Fake) (AppE (AppE (AppE (AppE (VarE 'cachedRandomUnresolvedVec) (LitE (StringL entityName))) (LitE (StringL funNameString))) (VarE providerFn)) (VarE resolverFn)))) [] ]