Datatypes.hs

{-# LANGUAGE TemplateHaskell            #-}
module Data.API.Tools.Datatypes
    ( datatypesTool
    , datatypesTool'
    , type_nm
    , rep_type_nm
    , nodeT
    , nodeRepT
    , nodeConE
    , nodeConP
    , nodeNewtypeConE
    , nodeNewtypeConP
    , nodeFieldE
    , nodeFieldP
    , nodeAltConE
    , nodeAltConP
    , newtypeProjectionE
    , pref_field_nm
    ) where

import           Data.API.TH
import           Data.API.TH.Compat
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.Set (Set)
import           Data.String
import qualified Data.Text                      as T
import           Data.Time
import           Language.Haskell.TH
import           Text.Regex
import           Prelude


-- | Tool to generate datatypes and type synonyms corresponding to an API
datatypesTool :: ToolSettings -> APITool
datatypesTool = datatypesTool' . defaultDerivedClasses

-- | Tool to generate datatypes and type synonyms corresponding to an
-- API, where the function specifies the derived classes for each datatype.
datatypesTool' :: (APINode -> [Name]) -> APITool
datatypesTool' deriv = apiNodeTool $ apiSpecTool (mkTool     (gen_sn_dt deriv))
                                                 (simpleTool (gen_sr_dt deriv))
                                                 (simpleTool (gen_su_dt deriv))
                                                 (simpleTool (gen_se_dt deriv))
                                                 (simpleTool gen_sy)


-- | Generate a type synonym definition
gen_sy :: (APINode, APIType) -> Q [Dec]
gen_sy (as, ty) = return [TySynD (type_nm as) [] $ mk_type ty]


-- | Generate a newtype definition, like this:
--
-- > newtype JobId = JobId { _JobId :: T.Text }
-- >     deriving (Show,IsString,Eq)
--
-- If a filter has been applied, and smart constructors are enabled,
-- instead generate this:
--
-- > newtype EmailAddress = UnsafeMkEmailAddress { _EmailAddress :: T.Text }
-- >     deriving (Show,Eq)
-- > mkEmailAddress :: T.Text -> Maybe EmailAddress
-- > mkEmailAddress t = ... -- check filter

gen_sn_dt :: (APINode -> [Name]) -> ToolSettings -> (APINode, SpecNewtype) -> Q [Dec]
gen_sn_dt deriv ts (as, sn) = (nd :) <$> if smart then sc else return []
  where
    nd  = mkNewtypeD [] nm [] c (deriv as)
    c   = RecC (newtype_con_nm smart as) [(newtype_prj_nm as,annNotStrict,wrapped_ty)]
    wrapped_ty = mk_type $ TyBasic (snType sn)

    nm  = rep_type_nm as

    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



-- | Generate a record type definition, like this:
--
-- > data JobSpecId
-- >     = JobSpecId
-- >         { _jsi_id         :: JobId
-- >         , _jsi_input      :: JSInput
-- >         , _jsi_output     :: JSOutputStatus
-- >         , _jsi_pipelineId :: PipelineId
-- >         }
-- >     deriving (Show,Eq)

gen_sr_dt :: (APINode -> [Name]) -> (APINode, SpecRecord) -> Q [Dec]
gen_sr_dt deriv (as, sr) = return [mkDataD [] nm [] cs (deriv as)]
  where
    cs = [RecC nm [(pref_field_nm as fnm,annIsStrict,mk_type (ftType fty)) |
                                                (fnm,fty)<-srFields sr]]
    nm = rep_type_nm as


-- | Generate a union type definition, like this:
--
-- > data Foo = F_Bar Int | F_Baz Bool
-- >     deriving (Show)

gen_su_dt :: (APINode -> [Name]) -> (APINode, SpecUnion) -> Q [Dec]
gen_su_dt deriv (as, su) = return [mkDataD [] nm [] cs (deriv as)]
  where
    cs = [NormalC (pref_con_nm as fnm) [(annIsStrict,mk_type ty)] |
                                            (fnm,(ty,_))<-suFields su]
    nm = rep_type_nm as


-- | Generate an enum type definition, like this:
--
-- > data FrameRate
-- >     = FR_auto
-- >     | FR_10
-- >     | FR_15
-- >     | FR_23_97
-- >     | FR_24
-- >     | FR_25
-- >     | FR_29_97
-- >     | FR_30
-- >     | FR_60
-- >     deriving (Show,Eq,Ord,Bounded,Enum)

gen_se_dt :: (APINode -> [Name]) -> (APINode, SpecEnum) -> Q [Dec]
gen_se_dt deriv (as, se) = return [mkDataD [] nm [] cs (deriv as)]
  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'
      TySet   ty'  -> AppT (ConT ''Set) $ mk_type ty'
      TyMaybe ty'  -> AppT (ConT ''Maybe) $ mk_type ty'
      TyName  nm   -> ConT  $ mkNameText $ _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


-- | Name of the type corresponding to the API node, e.g. @JobId@
type_nm :: APINode -> Name
type_nm an = mkName $ T.unpack $ _TypeName $ anName an

-- | Name of the representation type corresponding to the API node,
-- which differs from the 'type_nm' only if custom conversion
-- functions are specified.  This is also the name of the sole
-- constructor for newtypes and records.
rep_type_nm :: APINode -> Name
rep_type_nm an = mkName $ rep_type_s an

-- | Name of the single field in a newtype, prefixed by an underscore,
-- e.g. @_JobId@
newtype_prj_nm :: APINode -> Name
newtype_prj_nm an = mkName $ "_" ++ rep_type_s an

-- | Name of the constructor of a newtype, which will be same as the
-- representation type unless a smart constructor is requested, in
-- which case we just prefix it with "UnsafeMk".
newtype_con_nm :: Bool -> APINode -> Name
newtype_con_nm smart an | smart     = mkName $ "UnsafeMk" ++ rep_type_s an
                        | otherwise = mkName $               rep_type_s an

-- | Name of the smart constructor of a newtype, prefixed with "mk".
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 $ T.unpack $ _TypeName $ anName an
  where
    f s = maybe s (const ("REP__"++s)) $ anConvert an

-- | Construct the name of a record field by attaching the
-- type-specific prefix, in lowercase, e.g. @_jsi_id@
pref_field_nm :: APINode -> FieldName -> Name
pref_field_nm as fnm = mkName $ pre ++ T.unpack (_FieldName fnm)
  where
    pre = "_" ++ map toLower (CI.original $ anPrefix as) ++ "_"

-- | Construct the name of a union or enum constructor by attaching
-- the type-specific prefix, in uppercase, e.g. @FR_auto@
pref_con_nm :: APINode -> FieldName -> Name
pref_con_nm as fnm = mkName $ pre ++ T.unpack (_FieldName fnm)
  where
    pre = map toUpper (CI.original $ anPrefix as) ++ "_"


-- | The type corresponding to an API node
nodeT :: APINode -> TypeQ
nodeT = conT . type_nm

-- | The representation type corresponding to an API node
nodeRepT :: APINode -> TypeQ
nodeRepT = conT . rep_type_nm

-- | The constructor for a record API node, as an expression
nodeConE :: APINode -> ExpQ
nodeConE = conE . rep_type_nm

-- | The constructor for a record API node, as a pattern
nodeConP :: APINode -> [PatQ] -> PatQ
nodeConP an = conP (rep_type_nm an)

-- | The constructor for a newtype, which might be renamed
nodeNewtypeConE :: ToolSettings -> APINode -> SpecNewtype -> ExpQ
nodeNewtypeConE ts an sn = conE $ newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an

nodeNewtypeConP :: ToolSettings -> APINode -> SpecNewtype -> [Q Pat] -> PatQ
nodeNewtypeConP ts an sn ps = conP (newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an) ps

-- | A record field in an API node, as an expression
nodeFieldE :: APINode -> FieldName -> ExpQ
nodeFieldE an fnm = varE $ pref_field_nm an fnm

-- | A record field in an API node, as a pattern
nodeFieldP :: APINode -> FieldName -> PatQ
nodeFieldP an fnm = varP $ pref_field_nm an fnm

-- | A prefixed constructor for a union or enum, as an expression
nodeAltConE :: APINode -> FieldName -> ExpQ
nodeAltConE an fn = conE $ pref_con_nm an fn

-- | A prefixed constructor for a union or enum, as a pattern
nodeAltConP :: APINode -> FieldName -> [PatQ] -> PatQ
nodeAltConP an fn = conP (pref_con_nm an fn)

-- | The projection function from a newtype API node, as an expression
newtypeProjectionE :: APINode -> ExpQ
newtypeProjectionE = varE . newtype_prj_nm