module Data.API.Tools.Datatypes
( datatypesTool
, type_nm
, rep_type_nm
, nodeT
, nodeRepT
, nodeConE
, nodeNewtypeConE
, nodeFieldE
, nodeAltConE
, nodeAltConP
, newtypeProjectionE
) where
import Data.API.TH
import Data.API.Tools.Combinators
import Data.API.Types
import Control.Applicative
import Data.Aeson
import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.Maybe
import Data.String
import qualified Data.Text as T
import Data.Time
import Data.Typeable
import Language.Haskell.TH
import Text.Regex
datatypesTool :: APITool
datatypesTool = apiNodeTool $ apiSpecTool (mkTool $ uncurry . gen_sn_dt)
(simpleTool $ uncurry gen_sr_dt)
(simpleTool $ uncurry gen_su_dt)
(simpleTool $ uncurry gen_se_dt)
(simpleTool $ uncurry gen_sy)
gen_sy :: APINode -> APIType -> Q [Dec]
gen_sy as ty = return [TySynD (type_nm as) [] $ mk_type ty]
gen_sn_dt :: ToolSettings -> APINode -> SpecNewtype -> Q [Dec]
gen_sn_dt ts as sn = (nd :) <$> if smart then sc else return []
where
nd = NewtypeD [] nm [] c $ derive_leaf_nms ++ iss
c = RecC (newtype_con_nm smart as) [(newtype_prj_nm as,NotStrict,wrapped_ty)]
wrapped_ty = mk_type $ TyBasic (snType sn)
nm = rep_type_nm as
iss = case snType sn of
BTstring -> [''IsString]
BTbinary -> []
BTbool -> []
BTint -> []
BTutc -> []
smart = newtypeSmartConstructors ts && isJust (snFilter sn)
sc = simpleSigD (newtype_smart_con_nm as) [t| $(return wrapped_ty) -> Maybe $(nodeRepT as) |] $
case snFilter sn of
Just (FtrStrg re) -> [| \ s -> if isJust (matchRegex (re_regex re) (T.unpack s))
then Just ($nt_con s) else Nothing |]
Just (FtrIntg ir) -> [| \ i -> if i `inIntRange` ir then Just ($nt_con i) else Nothing |]
Just (FtrUTC ur) -> [| \ u -> if u `inUTCRange` ur then Just ($nt_con u) else Nothing |]
Nothing -> [| Just . $nt_con |]
nt_con = nodeNewtypeConE ts as sn
gen_sr_dt :: APINode -> SpecRecord -> Q [Dec]
gen_sr_dt as sr = return [DataD [] nm [] cs derive_node_nms]
where
cs = [RecC nm [(pref_field_nm as fnm,IsStrict,mk_type (ftType fty)) |
(fnm,fty)<-srFields sr]]
nm = rep_type_nm as
gen_su_dt :: APINode -> SpecUnion -> Q [Dec]
gen_su_dt as su = return [DataD [] nm [] cs derive_node_nms]
where
cs = [NormalC (pref_con_nm as fnm) [(IsStrict,mk_type ty)] |
(fnm,(ty,_))<-suFields su]
nm = rep_type_nm as
gen_se_dt :: APINode -> SpecEnum -> Q [Dec]
gen_se_dt as se = return [DataD [] nm [] cs $ derive_leaf_nms ++ [''Bounded, ''Enum]]
where
cs = [NormalC (pref_con_nm as fnm) [] | (fnm,_) <- seAlts se ]
nm = rep_type_nm as
mk_type :: APIType -> Type
mk_type ty =
case ty of
TyList ty' -> AppT ListT $ mk_type ty'
TyMaybe ty' -> AppT (ConT ''Maybe) $ mk_type ty'
TyName nm -> ConT $ mkName $ _TypeName nm
TyBasic bt -> basic_type bt
TyJSON -> ConT ''Value
basic_type :: BasicType -> Type
basic_type bt =
case bt of
BTstring -> ConT ''T.Text
BTbinary -> ConT ''Binary
BTbool -> ConT ''Bool
BTint -> ConT ''Int
BTutc -> ConT ''UTCTime
derive_leaf_nms :: [Name]
derive_leaf_nms = [''Show,''Eq,''Ord,''Typeable]
derive_node_nms :: [Name]
derive_node_nms = [''Show,''Eq,''Typeable]
type_nm :: APINode -> Name
type_nm an = mkName $ _TypeName $ anName an
rep_type_nm :: APINode -> Name
rep_type_nm an = mkName $ rep_type_s an
newtype_prj_nm :: APINode -> Name
newtype_prj_nm an = mkName $ "_" ++ rep_type_s an
newtype_con_nm :: Bool -> APINode -> Name
newtype_con_nm smart an | smart = mkName $ "UnsafeMk" ++ rep_type_s an
| otherwise = mkName $ rep_type_s an
newtype_smart_con_nm :: APINode -> Name
newtype_smart_con_nm an = mkName $ "mk" ++ rep_type_s an
rep_type_s :: APINode -> String
rep_type_s an = f $ _TypeName $ anName an
where
f s = maybe s (const ("REP__"++s)) $ anConvert an
pref_field_nm :: APINode -> FieldName -> Name
pref_field_nm as fnm = mkName $ pre ++ _FieldName fnm
where
pre = "_" ++ map toLower (CI.original $ anPrefix as) ++ "_"
pref_con_nm :: APINode -> FieldName -> Name
pref_con_nm as fnm = mkName $ pre ++ _FieldName fnm
where
pre = map toUpper (CI.original $ anPrefix as) ++ "_"
nodeT :: APINode -> TypeQ
nodeT = conT . type_nm
nodeRepT :: APINode -> TypeQ
nodeRepT = conT . rep_type_nm
nodeConE :: APINode -> ExpQ
nodeConE = conE . rep_type_nm
nodeNewtypeConE :: ToolSettings -> APINode -> SpecNewtype -> ExpQ
nodeNewtypeConE ts an sn = conE $ newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an
nodeFieldE :: APINode -> FieldName -> ExpQ
nodeFieldE an fnm = varE $ pref_field_nm an fnm
nodeAltConE :: APINode -> FieldName -> ExpQ
nodeAltConE an fn = conE $ pref_con_nm an fn
nodeAltConP :: APINode -> FieldName -> [PatQ] -> PatQ
nodeAltConP an fn = conP (pref_con_nm an fn)
newtypeProjectionE :: APINode -> ExpQ
newtypeProjectionE = varE . newtype_prj_nm