thrift-compiler-0.1.0.1: Thrift/Compiler/GenStruct.hs
{-
Copyright (c) Meta Platforms, Inc. and affiliates.
All rights reserved.
This source code is licensed under the BSD-style license found in the
LICENSE file in the root directory of this source tree.
-}
module Thrift.Compiler.GenStruct
( genStructDecl
, genStructImports
-- * Helpers
, fixToJSONValue
, ParseMode(..)
, genFieldParser
, genBuildValue, genBuildFields, genFieldBase, genParseType
, getUn
, transformValue, mkHashable, mkOrd
) where
import Prelude hiding (exp)
import Data.Maybe
import Data.Set (union)
import Data.Text (Text)
import Language.Haskell.Exts.Syntax hiding
(Name, Type, Annotation, Decl)
import Language.Haskell.Exts.Pretty (prettyPrint)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Language.Haskell.Exts.Syntax as HS
import Thrift.Compiler.GenUtils
import Thrift.Compiler.Plugins.Haskell
import Thrift.Compiler.Types
-- Generate Datatype -----------------------------------------------------------
genStructImports :: HS Struct -> Set.Set Import
genStructImports Struct{..} =
foldr (Set.union . getImports) baseImports structMembers
where
getImports :: HS (Field u) -> Set.Set Import
getImports Field{..} = typeToImport fieldResolvedType
baseImports = Set.fromList
[ QImport "Prelude" "Prelude"
, QImport "Control.DeepSeq" "DeepSeq"
, QImport "Control.Monad" "Monad"
, QImport "Control.Monad.ST.Trans" "ST"
, QImport "Control.Monad.Trans.Class" "Trans"
, QImport "Data.Aeson" "Aeson"
, QImport "Data.Aeson.Types" "Aeson"
, QImport "Data.Default" "Default"
, QImport "Data.HashMap.Strict" "HashMap"
, QImport "Data.Hashable" "Hashable"
, QImport "Data.List" "List"
, QImport "Data.Ord" "Ord"
, QImport "Thrift.Binary.Parser" "Parser"
, SymImport "Prelude"
[ ".", "<$>", "<*>", ">>=", "==", "/=", "<", "++" ]
, SymImport "Control.Applicative" [ "<|>", "*>", "<*" ]
, SymImport "Data.Aeson" [ ".:", ".:?", ".=", ".!=" ]
, SymImport "Data.Monoid" [ "<>" ]
] `union`
(case structType of
StructTy -> Set.empty
ExceptionTy ->
Set.singleton $
QImport "Control.Exception" "Exception")
genStructDecl :: Bool -> HS Struct -> [HS.Decl ()]
genStructDecl extraHasFields struct@Struct{..} =
-- Struct Declaration
[ DataDecl () (dataOrNew ()) Nothing
(DHead () $ textToName structResolvedName)
-- Record Constructor
[QualConDecl () Nothing Nothing
(RecDecl () (textToName structResolvedName) (map genFieldDecl structMembers))
]
-- Deriving
(pure $ deriving_ $ map (IRule () Nothing Nothing . IHCon ()) $
[ qualSym "Prelude" "Eq"
, qualSym "Prelude" "Show"
] ++
[ qualSym "Prelude" "Ord" | deriveOrd ])
-- Aeson Instances
, genToJSONInst struct
-- ThriftStruct Instance
, genThriftStruct struct
-- Other Instances
, genNFData struct
, genDefault struct
, genHashable struct
] ++
[ genOrd struct | not deriveOrd ] ++
(case structType of
StructTy -> []
ExceptionTy -> [ genException struct ]) ++
(if extraHasFields
then genExtraHasFields struct
else []
)
where
dataOrNew = case structMembers of
-- Make the struct a newtype iff it has exactly one element
[_] -> NewType
_ -> DataType
deriveOrd = canDeriveOrd struct
genFieldType :: HS (Field u) -> HS.Type ()
genFieldType Field{..} = opTy
where
baseTy = genType fieldResolvedType
opTy =
case fieldRequiredness of
Optional{} -> TyApp () (qualType "Prelude" "Maybe") baseTy
_ -> baseTy
genFieldDecl :: HS (Field u) -> FieldDecl ()
genFieldDecl field@Field{..} = FieldDecl () [textToName fieldResolvedName] ty
where
baseTy = genFieldType field
ty =
case fieldLaziness of
Lazy -> baseTy
Strict | isBaseType fieldResolvedType ->
TyBang () (BangedTy ()) (Unpack ()) baseTy
| otherwise ->
TyBang () (BangedTy ()) (NoUnpack ()) baseTy
-- Generate Aeson Instances ----------------------------------------------------
genToJSONInst :: HS Struct -> HS.Decl ()
genToJSONInst struct@Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp ()
(IHCon () $ qualSym "Aeson" "ToJSON")
(TyCon () $ unqualSym structResolvedName))
(Just $ map (InsDecl ())
[ genToJSON "toJSON" ":" (qvar "Aeson" "object") struct
])
genToJSON :: Text -> Text -> Exp () -> HS Struct -> HS.Decl ()
genToJSON name op combine Struct{..} =
FunBind ()
[ Match ()
(textToName name)
[ PApp () (unqualSym structResolvedName) $
map (\Field{..} -> pvar ("__field__" <> fieldName)) structMembers
]
(UnGuardedRhs () $
combine `app`
foldr (genToJSONField op) (qvar "Prelude" "mempty") structMembers)
Nothing
]
genToJSONField :: Text -> HS (Field u) -> Exp () -> Exp ()
genToJSONField op Field{..} exps =
case fieldRequiredness of
Optional{} ->
qvar "Prelude" "maybe" `app`
qvar "Prelude" "id" `app`
(Var () (UnQual () (Symbol () (Text.unpack op))) `compose`
LeftSection () (stringLit fieldName)
(QVarOp () (UnQual () (Symbol () ".=")))) `app`
fieldValue `app`
exps
_ ->
infixApp op
(infixApp ".=" (stringLit fieldName) fieldValue)
exps
where
fieldValue =
case (fieldRequiredness, fixToJSONValue fieldResolvedType) of
(_, Nothing) -> val
(Optional{}, Just f) -> qvar "Prelude" "fmap" `app` f `app` val
(_ , Just f) -> f `app` val
val = var $ "__field__" <> fieldName
fixToJSONValue :: HSType t -> Maybe (Exp ())
fixToJSONValue I8 = Nothing
fixToJSONValue I16 = Nothing
fixToJSONValue I32 = Nothing
fixToJSONValue I64 = Nothing
fixToJSONValue (TSpecial HsInt) = Nothing
fixToJSONValue TFloat = Nothing
fixToJSONValue TDouble = Nothing
fixToJSONValue TBool = Nothing
fixToJSONValue (TSpecial HsString) = Nothing
fixToJSONValue (TSpecial HsByteString) = Just $ qvar "Text" "decodeUtf8"
fixToJSONValue TText = Nothing
fixToJSONValue TBytes = Just $ qvar "Thrift" "encodeBase64Text"
fixToJSONValue (TList u) = app (qvar "Prelude" "map") <$> fixToJSONValue u
fixToJSONValue (TSpecial (HsVector vec u)) =
app (qvar (hsVectorQual vec) "map") <$> fixToJSONValue u
fixToJSONValue (TSet u) = app (qvar "Set" "map") <$> fixToJSONValue u
fixToJSONValue (THashSet u) = app (qvar "HashSet" "map") <$> fixToJSONValue u
fixToJSONValue (TMap k v) =
fixToJSONMap (qvar "Map" "mapKeys") (qvar "Map" "map") k v
fixToJSONValue (THashMap k v) =
fixToJSONMap (qvar "Thrift" "hmMapKeys") (qvar "HashMap" "map") k v
fixToJSONValue TEnum{} = Nothing
fixToJSONValue TStruct{} = Nothing
fixToJSONValue TException{} = Nothing
fixToJSONValue TUnion{} = Nothing
fixToJSONValue (TTypedef _ ty _loc) = fixToJSONValue ty
fixToJSONValue (TNewtype name ty _loc) = Just $
maybe id compose (fixToJSONValue ty) $ getUn name
fixToJSONMap
:: Exp () -> Exp () -> HSType k -> HSType v -> Maybe (Exp ())
fixToJSONMap mapK mapV k v
| t:ts <- catMaybes [ keyToStr, fixK, fixV ] =
Just $ foldl compose t ts
| otherwise = Nothing
where
keyToStr
| isAesonKey k = Nothing
| otherwise = Just $ mapK `app` qvar "Thrift" "keyToStr"
fixK = app mapK <$> fixToJSONValue k
fixV = app mapV <$> fixToJSONValue v
getUn :: Name -> Exp ()
getUn Name{..} = case resolvedName of
UName name -> var $ "un" <> name
QName m name -> qvar m $ "un" <> name
isAesonKey :: HSType t -> Bool
isAesonKey TText = True
isAesonKey (TSpecial HsString) = True
-- ByteString isn't actually an Aeson key, but it will be transformed to Text by
-- fixToJSONValue, so we don't want to encode it twice
isAesonKey TBytes = True
isAesonKey (TSpecial HsByteString) = True
isAesonKey _ = False
-- Generate ThriftStruct Instance ----------------------------------------------
genThriftStruct :: HS Struct -> HS.Decl ()
genThriftStruct struct@Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp ()
(IHCon () $ qualSym "Thrift" "ThriftStruct")
(TyCon () $ unqualSym structResolvedName))
(Just $ map (InsDecl ())
[ genBuilder struct
, genParser struct
])
data ParseMode = P_FieldMode | P_ListMode
insertParens :: ParseMode -> Exp () -> Exp ()
insertParens P_FieldMode = id
insertParens P_ListMode = Paren ()
genBuilder :: HS Struct -> HS.Decl ()
genBuilder Struct{..} =
FunBind ()
[ Match ()
(textToName "buildStruct")
[ PVar () $ textToName "_proxy"
, PApp () (unqualSym structResolvedName) $
map (PVar () . textToName . ("__field__" <>) . fieldName) structMembers
]
(UnGuardedRhs () $ genBuildFields structMembers)
Nothing
]
genBuildFields :: [HS (Field u)] -> Exp ()
genBuildFields fields =
protocolFun "genStruct" `app`
(case genBuildField NoField fields of
NoField -> id
ReqField _ f -> f
OptField _ f -> f)
(HS.List () [])
data PreviousField
= NoField
-- Both ReqField and OptField contain continuations for building the output
-- of the function
| ReqField FieldId (Exp () -> Exp ())
| OptField Text (Exp () -> Exp ())
genBuildField :: PreviousField -> [HS (Field u)] -> PreviousField
genBuildField prev [] = prev
genBuildField prev (Field{..} : fs) = flip genBuildField fs $
case fieldRequiredness of
Optional{} | null fs ->
ReqField fieldId $ \e -> combine $
Case () (var ("__field__" <> fieldName))
[ Alt () (PApp () (qualSym "Prelude" "Just") [ pvar "_val" ])
(UnGuardedRhs () $
infixApp ":"
(genField $ var "_val")
e)
Nothing
, Alt () (PApp () (qualSym "Prelude" "Nothing") [])
(UnGuardedRhs () e)
Nothing
]
Optional{} ->
OptField fieldName $ \e -> combine $
Let ()
(BDecls ()
[ PatBind () (PTuple () Boxed
[ pvar ("__cereal__" <> fieldName)
, pvar ("__id__" <> fieldName)
])
(UnGuardedRhs () $
Case () (var ("__field__" <> fieldName))
[ Alt () (PApp () (qualSym "Prelude" "Just") [ pvar "_val" ])
(UnGuardedRhs () $
Tuple () Boxed
[ Con () (UnQual () (Symbol () ":")) `app`
genField (var "_val")
, intLit fieldId
])
Nothing
, Alt () (PApp () (qualSym "Prelude" "Nothing") [])
(UnGuardedRhs () $
Tuple () Boxed
[ qvar "Prelude" "id"
, lastId
])
Nothing
])
Nothing
]) $
(var $ "__cereal__" <> fieldName) `app` e
_ -> ReqField fieldId $
combine .
infixApp ":"
(genField $ var $ "__field__" <> fieldName)
where
genField = genFieldBase fieldResolvedType fieldName fieldId lastId
(lastId, combine) =
case prev of
NoField -> (intLit (0 :: FieldId), id)
ReqField fid f -> (intLit fid, f)
OptField name f -> (var $ "__id__" <> name, f)
genFieldBase :: HSType t -> Text -> FieldId -> Exp () -> Exp () -> Exp ()
genFieldBase ty name fid lastId arg =
case getPrim ty of
Nothing ->
protocolFun "genField" `app`
stringLit name `app`
genThriftType ty `app`
intLit fid `app`
lastId `app`
(genBuildValue ty `app` arg)
Just P_Bool ->
protocolFun "genFieldBool" `app`
stringLit name `app`
intLit fid `app`
lastId `app`
arg
Just primTy ->
protocolFun "genFieldPrim" `app`
stringLit name `app`
genThriftType ty `app`
intLit fid `app`
lastId `app`
genBuildPrim primTy `app`
arg
genBuildValue :: HSType t -> Exp ()
-- Primatives
genBuildValue I8 = protocolFun "genByte"
genBuildValue I16 = protocolFun "genI16"
genBuildValue I32 = protocolFun "genI32"
genBuildValue I64 = protocolFun "genI64"
genBuildValue (TSpecial HsInt) =
protocolFun "genI64" `compose`
qvar "Prelude" "fromIntegral"
genBuildValue TFloat = protocolFun "genFloat"
genBuildValue TDouble = protocolFun "genDouble"
genBuildValue TBool = protocolFun "genBool"
genBuildValue TText = protocolFun "genText"
genBuildValue (TSpecial HsString) =
genBuildValue TText `compose` qvar "Text" "pack"
genBuildValue (TSpecial HsByteString) = protocolFun "genByteString"
genBuildValue TBytes = protocolFun "genBytes"
-- Containers
genBuildValue (TList ty) = genBuildList ty
genBuildValue (TSpecial (HsVector vec ty)) =
genBuildList ty `compose` qvar (hsVectorQual vec) "toList"
genBuildValue (TSet ty) =
genBuildList ty `compose` qvar "Set" "toList"
genBuildValue (THashSet ty) =
genBuildList ty `compose` qvar "HashSet" "toList"
genBuildValue (TMap k v) =
genBuildMap k v `compose` qvar "Map" "toList"
genBuildValue (THashMap k v) =
genBuildMap k v `compose` qvar "HashMap" "toList"
-- Named Types
genBuildValue (TTypedef _ ty _loc) = genBuildValue ty
genBuildValue (TNewtype name ty _loc) =
genBuildValue ty `compose` getUn name
genBuildValue (TStruct _ _loc) = protocolFun "buildStruct"
genBuildValue (TException _ _loc) = protocolFun "buildStruct"
genBuildValue (TUnion _ _loc) = protocolFun "buildStruct"
genBuildValue (TEnum _ _loc _) =
protocolFun "genI32" `compose`
qvar "Prelude" "fromIntegral" `compose`
qvar "Thrift" "fromThriftEnum"
genBuildPrim :: PrimType -> Exp ()
genBuildPrim P_I8 = protocolFun "genBytePrim"
genBuildPrim P_I16 = protocolFun "genI16Prim"
genBuildPrim P_I32 = protocolFun "genI32Prim"
genBuildPrim P_I64 = protocolFun "genI64Prim"
genBuildPrim P_Bool = protocolFun "genBoolPrim"
genBuildList :: HSType t -> Exp ()
genBuildList ty =
case getPrim ty of
Just primTy ->
protocolFun "genListPrim" `app`
genThriftType ty `app`
genBuildPrim primTy
Nothing ->
protocolFun "genList" `app`
genThriftType ty `app`
genBuildValue ty
genBuildMap :: HSType k -> HSType v -> Exp ()
genBuildMap k v =
case (getPrim k, getPrim v) of
(Just primK, Just primV) ->
protocolFun "genMapPrim" `app`
genThriftType k `app`
genThriftType v `app`
qcon "Prelude" (if isStringType k then "True" else "False") `app`
genBuildPrim primK `app`
genBuildPrim primV
_ ->
protocolFun "genMap" `app`
genThriftType k `app`
genThriftType v `app`
qcon "Prelude" (if isStringType k then "True" else "False") `app`
genBuildValue k `app`
genBuildValue v
isStringType :: HSType t -> Bool
isStringType (TSpecial HsString) = True
isStringType (TSpecial HsByteString) = True
isStringType TText = True
isStringType TBytes = True
isStringType (TTypedef _ t _loc) = isStringType t
isStringType (TNewtype _ t _loc) = isStringType t
isStringType _ = False
genFieldParser
:: [HS (Field u)] -> Text -> (Exp () -> Exp ()) -> Rhs ()
genFieldParser fields constructorName constructorWrapper = UnGuardedRhs () $
qvar "ST" "runSTT" `app`
Do ()
-- We need this because of some issue in runST (t10447741)
( Qualifier () (qvar "Prelude" "return" `app` unit_con ()) :
-- field <- newSTRef Nothing
map
(\field@Field{..} ->
Generator () (pvar ("__field__" <> fieldName))
(qvar "ST" "newSTRef" `app`
case fieldRequiredness of
Default -> genFieldDefault field
_ -> qcon "Prelude" "Nothing"))
fields ++
-- let __parse = do {..}
[ LetStmt () $
BDecls ()
[ FunBind ()
-- the __parse function recursively builds the output and stores the
-- parsed values in STRefs that are initialized in the outer scope
[ Match () (textToName "_parse") [ pvar "_lastId" ]
(UnGuardedRhs () $ Do ()
-- Field Case: pattern match on parsed field id
[ Generator () (pvar "_fieldBegin") $
qvar "Trans" "lift" `app`
(protocolFun "parseFieldBegin" `app`
var "_lastId" `app`
var "_idMap")
, Qualifier () $ Case () (var "_fieldBegin")
[ Alt ()
(PApp () (qualSym "Thrift" "FieldBegin")
[ pvar "_type", pvar "_id", pvar "_bool" ])
(UnGuardedRhs () $ Do ()
[ Qualifier () $ Case () (var "_id") $
map genParseValue fields ++
[ Alt () (PWildCard ())
(UnGuardedRhs () $
qvar "Trans" "lift" `app`
(protocolFun "parseSkip" `app`
var "_type" `app`
(qcon "Prelude" "Just" `app` var "_bool")))
Nothing
]
, Qualifier () $ var "_parse" `app` var "_id"
])
Nothing
, Alt () (PApp () (qualSym "Thrift" "FieldEnd") [])
(UnGuardedRhs () $ Do () $
-- Get the values from the STRefs
map (\Field{..} ->
Generator ()
(PBangPat () $ case fieldRequiredness of
Required{} -> pvar $ "__maybe__" <> fieldName
_ -> pvar $ "__val__" <> fieldName) $
qvar "ST" "readSTRef" `app` var ("__field__" <> fieldName))
fields ++
[ Qualifier () $
foldr matchArg buildOutput fields
])
Nothing
]
])
Nothing
]
, PatBind () (pvar "_idMap")
(UnGuardedRhs () $
qvar "HashMap" "fromList" `app`
HS.List ()
(map (\Field{..} ->
Tuple () Boxed [ stringLit fieldName, intLit fieldId ])
fields))
Nothing
]
-- call _parse
, Qualifier () $ var "_parse" `app` intLit (0 :: Int)
])
where
buildOutput =
qvar "Prelude" "pure" `app` constructorWrapper
(foldl app (con constructorName) (map mkFieldName fields))
mkFieldName Field{..} = var $ "__val__" <> fieldName
matchArg :: HS (Field u) -> Exp () -> Exp ()
matchArg Field{..} exp =
case fieldRequiredness of
Required{} ->
Case () (var $ "__maybe__" <> fieldName)
[ Alt () (PApp () (qualSym "Prelude" "Nothing") [])
(UnGuardedRhs () $
qvar "Prelude" "fail" `app`
stringLit
("Error parsing type "
<> constructorName
<> ": missing required field " <> fieldName
<> " of type " <> Text.pack (
prettyPrint $ genType fieldResolvedType)
))
Nothing
, Alt () (PApp () (qualSym "Prelude" "Just")
[ pvar ("__val__" <> fieldName) ])
(UnGuardedRhs () exp)
Nothing
]
_ -> exp
genParser :: HS Struct -> HS.Decl ()
genParser Struct{..} =
FunBind ()
[ Match ()
(textToName "parseStruct")
[ pvar "_proxy" ]
(genFieldParser structMembers structResolvedName (Paren ()))
Nothing
]
genParseValue :: HS (Field u) -> Alt ()
genParseValue Field{..} =
Alt ()
(PLit ()
(if fieldId < 0 then Negative () else Signless ())
(Int () (abs $ fromIntegral fieldId) (show fieldId)))
(GuardedRhss ()
-- check that the parsed type is correct
[ GuardedRhs ()
[ Qualifier () $
infixApp "==" (var "_type") (genThriftType fieldResolvedType)
] $
Do ()
[ Generator () (PBangPat () $ pvar "_val") $
qvar "Trans" "lift" `app` genParseType P_FieldMode fieldResolvedType
, Qualifier () $
qvar "ST" "writeSTRef" `app`
var ("__field__" <> fieldName) `app`
case fieldRequiredness of
Default -> var "_val"
_ -> qcon "Prelude" "Just" `app` var "_val"
]
])
Nothing
genParseType :: ParseMode -> HSType t -> Exp ()
-- Base types
genParseType _ I8 = protocolFun "parseByte"
genParseType _ I16 = protocolFun "parseI16"
genParseType _ I32 = protocolFun "parseI32"
genParseType _ I64 = protocolFun "parseI64"
genParseType m (TSpecial HsInt) = insertParens m $
infixApp "<$>" (qvar "Prelude" "fromIntegral") (protocolFun "parseI64")
genParseType _ TFloat = protocolFun "parseFloat"
genParseType _ TDouble = protocolFun "parseDouble"
genParseType P_FieldMode TBool = protocolFun "parseBoolF" `app` var "_bool"
genParseType P_ListMode TBool = protocolFun "parseBool"
genParseType _ TText = protocolFun "parseText"
genParseType m (TSpecial HsString) = insertParens m $
infixApp "<$>" (qvar "Text" "unpack") (protocolFun "parseText")
genParseType _ (TSpecial HsByteString) = protocolFun "parseByteString"
genParseType _ TBytes = protocolFun "parseBytes"
-- Containers
genParseType _ (TList ty) =
infixApp "<$>" (qvar "Prelude" "snd") (genParseList ty)
genParseType m (TSpecial (HsVector vec ty)) = insertParens m $
infixApp "<$>"
(qvar "Prelude" "uncurry" `app` qvar (hsVectorQual vec) "fromListN")
(genParseList ty)
genParseType m (TSet ty) = insertParens m $
infixApp "<$>"
(qvar "Set" "fromList" `compose` qvar "Prelude" "snd")
(genParseList ty)
genParseType m (THashSet ty) = insertParens m $
infixApp "<$>"
(qvar "HashSet" "fromList" `compose` qvar "Prelude" "snd")
(genParseList ty)
genParseType m (TMap k v) = insertParens m $
infixApp "<$>" (qvar "Map" "fromList") (genParseMap k v)
genParseType m (THashMap k v) = insertParens m $
infixApp "<$>" (qvar "HashMap" "fromList") (genParseMap k v)
-- Named Types
genParseType m (TTypedef _ ty _loc) = genParseType m ty
genParseType m (TNewtype name ty _loc) =
qvar "Prelude" "fmap" `app` Con () (nameToQName name) `app` genParseType m ty
genParseType _ TStruct{} = protocolFun "parseStruct"
genParseType _ TException{} = protocolFun "parseStruct"
genParseType _ TUnion{} = protocolFun "parseStruct"
genParseType _ (TEnum Name{..} _loc nounknown) =
qvar "Thrift" (parseEnumFun nounknown) `app`
var "_proxy" `app`
stringLit (localName resolvedName)
where
parseEnumFun :: Bool -> Text
parseEnumFun True = "parseEnumNoUnknown"
parseEnumFun False = "parseEnum"
genParseList :: HSType t -> Exp ()
genParseList ty = protocolFun "parseList" `app` genParseType P_ListMode ty
genParseMap :: HSType k -> HSType v -> Exp ()
genParseMap k v =
protocolFun "parseMap" `app`
genParseType P_ListMode k `app`
genParseType P_ListMode v `app`
qcon "Prelude" (if isStringType k then "True" else "False")
-- Generate NFData Instance ----------------------------------------------------
genNFData :: HS Struct -> HS.Decl ()
genNFData Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp ()
(IHCon () $ qualSym "DeepSeq" "NFData")
(TyCon () $ unqualSym structResolvedName))
(Just $ map (InsDecl ())
[ FunBind ()
[ Match () (textToName "rnf")
[ PApp () (unqualSym structResolvedName) $ map mkPattern structMembers ]
(UnGuardedRhs () $
foldr seqify (Con () (Special () (UnitCon ()))) structMembers)
Nothing
]
])
where
seqify field = InfixApp () (forcedField field) infixSeq
infixSeq = QVarOp () $ qualSym "Prelude" "seq"
forcedField Field{..} =
qvar "DeepSeq" "rnf" `app` var ("__field__" <> fieldName)
mkPattern :: HS (Field u) -> Pat ()
mkPattern Field{..} = pvar $ "__field__" <> fieldName
-- Generate Default Instance ---------------------------------------------------
genDefault :: HS Struct -> HS.Decl ()
genDefault Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp ()
(IHCon () $ qualSym "Default" "Default")
(TyCon () $ unqualSym structResolvedName))
(Just $ map (InsDecl ())
[ FunBind ()
[ Match () (textToName "def") []
(UnGuardedRhs () $
foldl app (con structResolvedName) $ map genFieldDefault structMembers)
Nothing
]
])
genFieldDefault :: HS (Field u) -> Exp ()
genFieldDefault Field{..} =
case fieldRequiredness of
Optional{} -> qcon "Prelude" "Nothing"
_ -> case fieldResolvedVal of
Just val -> genConst fieldResolvedType val
Nothing -> typeToDefault fieldResolvedType
-- Generate Hashable Instance --------------------------------------------------
genHashable :: HS Struct -> HS.Decl ()
genHashable Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp () (IHCon () (qualSym "Hashable" "Hashable")) $
simpleType structResolvedName)
(Just
[ InsDecl () $ FunBind ()
[ Match () (textToName "hashWithSalt")
[ pvar "__salt"
, PApp () (unqualSym structResolvedName) $
map (\Field{..} -> pvar $ "_" <> fieldName) structMembers
]
(UnGuardedRhs () $ foldl
(\salt Field{..} ->
qvar "Hashable" "hashWithSalt" `app`
salt `app`
transformValue mkHashable fieldRequiredness fieldResolvedType
(var $ "_" <> fieldName))
(var "__salt")
structMembers)
Nothing
]
])
-- Some thrift types aren't hashable, so we need to modify them before passing
-- them to hashWithSalt
mkHashable :: HSType t -> Maybe (Exp ())
mkHashable = \case
I8 -> Nothing
I16 -> Nothing
I32 -> Nothing
I64 -> Nothing
(TSpecial HsInt) -> Nothing
TFloat -> Nothing
TDouble -> Nothing
TText -> Nothing
TBool -> Nothing
(TSpecial HsString) -> Nothing
(TSpecial HsByteString) -> Nothing
TBytes -> Nothing
-- elems gives the set elements in ascending order, so we do not need to
-- sort the result
(TSet u) -> Just $ mapTransform mkHashable u $ qvar "Set" "elems"
(THashSet u) ->
Just $ qvar "List" "sort" `compose`
mapTransform mkHashable u (qvar "HashSet" "toList")
(TList u) -> (qvar "Prelude" "map" `app`) <$> mkHashable u
(TSpecial (HsVector vec u)) ->
Just $ mapTransform mkHashable u $ qvar (hsVectorQual vec) "toList"
(TMap k v) -> Just $ mapTransformPair mkHashable k v $ qvar "Map" "toAscList"
(THashMap k v) ->
Just $ qvar "List" "sort" `compose`
mapTransformPair mkHashable k v (qvar "HashMap" "toList")
TStruct{} -> Nothing
TException{} -> Nothing
TUnion{} -> Nothing
TEnum{} -> Nothing
(TTypedef _ u _loc) -> mkHashable u
TNewtype{} -> Nothing
transformValue
:: (HSType t -> Maybe (Exp ()))
-> Requiredness u a
-> HSType t
-> Exp ()
-> Exp ()
transformValue transform req ty exp =
case (req, transform ty) of
(_, Nothing) -> exp
(Optional{}, Just f) -> qvar "Prelude" "fmap" `app` f `app` exp
(_, Just f) -> f `app` exp
mapTransform
:: (HSType t -> Maybe (Exp ())) -> HSType t -> Exp () -> Exp ()
mapTransform transform u =
case transform u of
Nothing -> id
Just f -> compose $ qvar "Prelude" "map" `app` f
mapTransformPair
:: (forall t. HSType t -> Maybe (Exp ()))
-> HSType k
-> HSType v
-> Exp ()
-> Exp ()
mapTransformPair transform k v = compose $
qvar "Prelude" "map" `app`
Lambda () [ PTuple () Boxed [ pvar "_k", pvar "_v" ] ]
(Tuple () Boxed [ applyT transform k "_k", applyT transform v "_v" ])
applyT :: (forall u. HSType u -> Maybe (Exp ())) -> HSType t -> Text -> Exp ()
applyT transform u v =
case transform u of
Nothing -> var v
Just f -> f `app` var v
canDerive :: (forall t. HSType t -> Maybe a) -> HS Struct -> Bool
canDerive f Struct{..} =
all (\Field{..} -> isNothing $ f fieldResolvedType) structMembers
-- Generate Hashable Instance --------------------------------------------------
genOrd :: HS Struct -> HS.Decl ()
genOrd Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp () (IHCon () (qualSym "Ord" "Ord")) $
simpleType structResolvedName)
(Just
[ InsDecl () $ FunBind ()
[ Match () (textToName "compare")
[ pvar "__a"
, pvar "__b"
]
(UnGuardedRhs () $ case structMembers of
[] -> qcon "Ord" "EQ"
_:_ -> foldr1
(\scrutinee continue ->
Case () scrutinee
[ Alt () (PApp () (qualSym "Ord" c) [])
(UnGuardedRhs () result)
Nothing
| (c, result) <-
[ ("LT", qcon "Ord" "LT")
, ("GT", qcon "Ord" "GT")
, ("EQ", continue)
]
])
[ qvar "Ord" "compare" `app`
f (var fieldResolvedName `app` var "__a") `app`
f (var fieldResolvedName `app` var "__b")
| Field{..} <- structMembers
, let f = transformValue mkOrd fieldRequiredness fieldResolvedType
])
Nothing
]
])
mkOrd :: HSType t -> Maybe (Exp ())
mkOrd = \case
I8 -> Nothing
I16 -> Nothing
I32 -> Nothing
I64 -> Nothing
(TSpecial HsInt) -> Nothing
TFloat -> Nothing
TDouble -> Nothing
TText -> Nothing
TBool -> Nothing
(TSpecial HsString) -> Nothing
TBytes -> Nothing
(TSpecial HsByteString) -> Nothing
(TSet u) -> (qvar "Set" "map" `app`) <$> mkOrd u
(THashSet u) ->
Just $ qvar "List" "sort" `compose`
mapTransform mkOrd u (qvar "HashSet" "toList")
(TList u) -> (qvar "Prelude" "map" `app`) <$> mkOrd u
(TSpecial (HsVector vec u)) ->
(qvar (hsVectorQual vec) "map" `app`) <$> mkOrd u
(TMap k v) -> case (mkOrd k, mkOrd v) of
(Nothing, Nothing) -> Nothing
_ -> Just $ mapTransformPair mkOrd k v $ qvar "Map" "toAscList"
(THashMap k v) -> Just $ qvar "List" "sort" `compose`
mapTransformPair mkOrd k v (qvar "HashMap" "toList")
TStruct{} -> Nothing
TException{} -> Nothing
TUnion{} -> Nothing
TEnum{} -> Nothing
(TTypedef _ u _loc) -> mkOrd u
TNewtype{} -> Nothing
canDeriveOrd :: HS Struct -> Bool
canDeriveOrd = canDerive mkOrd
-- Generate Exception Instance -------------------------------------------------
genException :: HS Struct -> HS.Decl ()
genException Struct{..} =
InstDecl () Nothing
(IRule () Nothing Nothing $
IHApp ()
(IHCon () $ qualSym "Exception" "Exception")
(TyCon () $ unqualSym structResolvedName))
Nothing
-- Generate Extra HasField Instances -------------------------------------------
genExtraHasFields :: HS Struct -> [HS.Decl ()]
genExtraHasFields Struct{..} = genHasField structResolvedName <$> structMembers
genHasField :: Text -> HS (Field u) -> HS.Decl ()
genHasField name field@Field{..} = InstDecl ()
Nothing
(IRule () Nothing Nothing ihead)
(Just [InsDecl () getFieldDecl])
where
ihead =
IHApp ()
(IHApp ()
(IHApp () (IHCon () $ qualSym "Thrift" "HasField") promotedName)
(TyCon () $ unqualSym name)
)
(TyParen () $ genFieldType field)
promotedName = promoteText fieldName
getFieldDecl = FunBind () . (:[]) $
Match ()
(textToName "getField")
mempty
(UnGuardedRhs () (var fieldResolvedName))
Nothing
promoteText :: Text -> HS.Type ()
promoteText s = TyPromoted ()
$ PromotedString () fieldNameString fieldNameString
where
-- We need the thrift_ prefix in order to prevent naming conflicts between
-- fields like struct.val and struct.struct_val
fieldNameString = Text.unpack s