{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
module RON.Schema.TH.Common (
fieldExp',
fieldPat',
let1S,
liftText,
mkFieldType,
mkGuideType,
mkNameT,
newNameT,
valD,
valDP,
) where
import RON.Prelude
import qualified Data.Text as Text
import Language.Haskell.TH (Q, conT, normalB, varP)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (liftString)
import RON.Data.ORSet (ORSet, ORSetMap)
import RON.Data.RGA (RGA)
import RON.Data.VersionVector (VersionVector)
import RON.Schema as X
import RON.Types (ObjectRef, UUID)
mkNameT :: Text -> TH.Name
mkNameT = TH.mkName . Text.unpack
newNameT :: Text -> Q TH.Name
newNameT = TH.newName . Text.unpack
valD :: TH.PatQ -> TH.ExpQ -> TH.DecQ
valD pat body = TH.valD pat (normalB body) []
valDP :: TH.Name -> TH.ExpQ -> TH.DecQ
valDP = valD . varP
mkGuideType :: RonType -> TH.TypeQ
mkGuideType typ = case typ of
TAtom atom -> case atom of
TAFloat -> [t| Double |]
TAInteger -> [t| Int64 |]
TAString -> [t| Text |]
TAUuid -> [t| UUID |]
TObjectRef t -> wrap ''ObjectRef t
TEnum Enum{name} -> conT $ mkNameT name
TObject t -> case t of
TOpaqueObject u -> mkOpaque u
TORSet item -> wrap ''ORSet item
TORSetMap key value -> wrap2 ''ORSetMap key value
TRga item -> wrap ''RGA item
TStructLww Struct{name} -> conT $ mkNameT name
TStructSet Struct{name} -> conT $ mkNameT name
TVersionVector -> [t| VersionVector |]
TOpaqueAtoms t -> mkOpaque t
where
wrap w a = [t| $(conT w) $(mkGuideType a) |]
wrap2 w a b = [t| $(conT w) $(mkGuideType a) $(mkGuideType b) |]
mkOpaque Opaque{name, annotations = OpaqueAnnotations{haskellType}} =
conT $ mkNameT $ fromMaybe name haskellType
mkFieldType :: RonType -> Maybe MergeStrategy -> TH.TypeQ
mkFieldType typ mergeStrategy = case (typ, mergeStrategy) of
(_, Just Set) -> listGuide
_ -> maybeGuide
where
listGuide = [t| [ $guide ] |]
maybeGuide = [t| Maybe $guide |]
guide = mkGuideType typ
liftText :: Text -> TH.ExpQ
liftText t = [| Text.pack $(liftString $ Text.unpack t) |]
let1S :: TH.PatQ -> TH.ExpQ -> TH.StmtQ
let1S pat exp = TH.letS [valD pat exp]
fieldExp' :: Text -> TH.ExpQ -> TH.Q (TH.Name, TH.Exp)
fieldExp' = TH.fieldExp . mkNameT
fieldPat' :: Text -> TH.PatQ -> TH.FieldPatQ
fieldPat' = TH.fieldPat . mkNameT