language-thrift 0.6.2.0 → 0.7.0.0
raw patch · 7 files changed
+191/−79 lines, 7 files
Files
- CHANGES.md +7/−0
- Language/Thrift/Internal/Types.hs +121/−16
- Language/Thrift/Parser.hs +9/−8
- Language/Thrift/Pretty/PrettyInc.hs +18/−18
- examples/generateHaskellTypes.hs +16/−16
- language-thrift.cabal +1/−1
- test/Language/Thrift/Arbitrary.hs +19/−20
CHANGES.md view
@@ -1,3 +1,10 @@+0.7.0.0+=======++- Added source annotations to all `TypeReference` and `ConstValue`+ constructors.+- Added a `name` and `srcAnnot` lenses for `Type` and `Definition`.+ 0.6.2.0 =======
Language/Thrift/Internal/Types.hs view
@@ -157,46 +157,62 @@ -- -- Constants are used for IDL-level constants and default values for fields. data ConstValue srcAnnot- = ConstInt Integer+ = ConstInt Integer srcAnnot -- ^ An integer. @42@- | ConstFloat Double+ | ConstFloat Double srcAnnot -- ^ A float. @4.2@- | ConstLiteral Text+ | ConstLiteral Text srcAnnot -- ^ A literal string. @"hello"@ | ConstIdentifier Text srcAnnot -- ^ A reference to another constant. @Foo.bar@- | ConstList [ConstValue srcAnnot]+ | ConstList [ConstValue srcAnnot] srcAnnot -- ^ A literal list containing other constant values. @[42]@- | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)]+ | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)] srcAnnot -- ^ A literal list containing other constant values. -- @{"hellO": 1, "world": 2}@ deriving (Show, Ord, Eq, Data, Typeable, Generic) L.makePrisms ''ConstValue +instance HasSrcAnnot ConstValue where+ srcAnnot = L.lens getter setter+ where+ getter (ConstInt _ a) = a+ getter (ConstFloat _ a) = a+ getter (ConstLiteral _ a) = a+ getter (ConstIdentifier _ a) = a+ getter (ConstList _ a) = a+ getter (ConstMap _ a) = a + setter (ConstInt x _) a = ConstInt x a+ setter (ConstFloat x _) a = ConstFloat x a+ setter (ConstLiteral x _) a = ConstLiteral x a+ setter (ConstIdentifier x _) a = ConstIdentifier x a+ setter (ConstList x _) a = ConstList x a+ setter (ConstMap x _) a = ConstMap x a+ -- | A reference to a type. data TypeReference srcAnnot = DefinedType Text srcAnnot -- ^ A custom defined type referred to by name. - | StringType [TypeAnnotation]+ | StringType [TypeAnnotation] srcAnnot -- ^ @string@ and annotations.- | BinaryType [TypeAnnotation]+ | BinaryType [TypeAnnotation] srcAnnot -- ^ @binary@ and annotations.- | SListType [TypeAnnotation]+ | SListType [TypeAnnotation] srcAnnot -- ^ @slist@ and annotations.- | BoolType [TypeAnnotation]+ | BoolType [TypeAnnotation] srcAnnot -- ^ @bool@ and annotations.- | ByteType [TypeAnnotation]+ | ByteType [TypeAnnotation] srcAnnot -- ^ @byte@ and annotations.- | I16Type [TypeAnnotation]+ | I16Type [TypeAnnotation] srcAnnot -- ^ @i16@ and annotations.- | I32Type [TypeAnnotation]+ | I32Type [TypeAnnotation] srcAnnot -- ^ @i32@ and annotations.- | I64Type [TypeAnnotation]+ | I64Type [TypeAnnotation] srcAnnot -- ^ @i64@ and annotations.- | DoubleType [TypeAnnotation]+ | DoubleType [TypeAnnotation] srcAnnot -- ^ @double@ and annotations. -- Container types@@ -204,15 +220,47 @@ (TypeReference srcAnnot) (TypeReference srcAnnot) [TypeAnnotation]+ srcAnnot -- ^ @map\<foo, bar\>@ and annotations.- | SetType (TypeReference srcAnnot) [TypeAnnotation]+ | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot -- ^ @set\<baz\>@ and annotations.- | ListType (TypeReference srcAnnot) [TypeAnnotation]+ | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot -- ^ @list\<qux\>@ and annotations. deriving (Show, Ord, Eq, Data, Typeable, Generic) L.makePrisms ''TypeReference +instance HasSrcAnnot TypeReference where+ srcAnnot = L.lens getter setter+ where+ getter (DefinedType _ a) = a+ getter (StringType _ a) = a+ getter (BinaryType _ a) = a+ getter (SListType _ a) = a+ getter (BoolType _ a) = a+ getter (ByteType _ a) = a+ getter (I16Type _ a) = a+ getter (I32Type _ a) = a+ getter (I64Type _ a) = a+ getter (DoubleType _ a) = a+ getter (MapType _ _ _ a) = a+ getter (SetType _ _ a) = a+ getter (ListType _ _ a) = a++ setter (DefinedType x _) a = DefinedType x a+ setter (StringType x _) a = StringType x a+ setter (BinaryType x _) a = BinaryType x a+ setter (SListType x _) a = SListType x a+ setter (BoolType x _) a = BoolType x a+ setter (ByteType x _) a = ByteType x a+ setter (I16Type x _) a = I16Type x a+ setter (I32Type x _) a = I32Type x a+ setter (I64Type x _) a = I64Type x a+ setter (DoubleType x _) a = DoubleType x a+ setter (MapType k v x _) a = MapType k v x a+ setter (SetType t x _) a = SetType t x a+ setter (ListType t x _) a = ListType t x a+ class HasValueType t where valueType :: L.Lens' (t a) (TypeReference a) @@ -617,6 +665,40 @@ SenumType (Senum srcAnnot) deriving (Show, Ord, Eq, Data, Typeable, Generic) +instance HasName (Type a) where+ name = L.lens getter setter+ where+ getter (TypedefType t) = L.view name t+ getter (EnumType t) = L.view name t+ getter (StructType t) = L.view name t+ getter (UnionType t) = L.view name t+ getter (ExceptionType t) = L.view name t+ getter (SenumType t) = L.view name t++ setter (TypedefType t) n = TypedefType $ L.set name n t+ setter (EnumType t) n = EnumType $ L.set name n t+ setter (StructType t) n = StructType $ L.set name n t+ setter (UnionType t) n = UnionType $ L.set name n t+ setter (ExceptionType t) n = ExceptionType $ L.set name n t+ setter (SenumType t) n = SenumType $ L.set name n t++instance HasSrcAnnot Type where+ srcAnnot = L.lens getter setter+ where+ getter (TypedefType t) = L.view srcAnnot t+ getter (EnumType t) = L.view srcAnnot t+ getter (StructType t) = L.view srcAnnot t+ getter (UnionType t) = L.view srcAnnot t+ getter (ExceptionType t) = L.view srcAnnot t+ getter (SenumType t) = L.view srcAnnot t++ setter (TypedefType t) a = TypedefType $ L.set srcAnnot a t+ setter (EnumType t) a = EnumType $ L.set srcAnnot a t+ setter (StructType t) a = StructType $ L.set srcAnnot a t+ setter (UnionType t) a = UnionType $ L.set srcAnnot a t+ setter (ExceptionType t) a = ExceptionType $ L.set srcAnnot a t+ setter (SenumType t) a = SenumType $ L.set srcAnnot a t+ _Typedef :: L.Prism' (Type ann) (Typedef ann) _Typedef = L.prism' TypedefType $ \t -> case t of@@ -664,6 +746,29 @@ | -- | A service definition. ServiceDefinition (Service srcAnnot) deriving (Show, Ord, Eq, Data, Typeable, Generic)++instance HasName (Definition a) where+ name = L.lens getter setter+ where+ getter (ConstDefinition d) = L.view name d+ getter (TypeDefinition d) = L.view name d+ getter (ServiceDefinition d) = L.view name d++ setter (ConstDefinition d) n = ConstDefinition $ L.set name n d+ setter (TypeDefinition d) n = TypeDefinition $ L.set name n d+ setter (ServiceDefinition d) n = ServiceDefinition $ L.set name n d++instance HasSrcAnnot Definition where+ srcAnnot = L.lens getter setter+ where+ getter (ConstDefinition d) = L.view srcAnnot d+ getter (TypeDefinition d) = L.view srcAnnot d+ getter (ServiceDefinition d) = L.view srcAnnot d++ setter (ConstDefinition d) a = ConstDefinition $ L.set srcAnnot a d+ setter (TypeDefinition d) a = TypeDefinition $ L.set srcAnnot a d+ setter (ServiceDefinition d) a = ServiceDefinition $ L.set srcAnnot a d+ _Const :: L.Prism' (Definition ann) (Const ann) _Const = L.prism' ConstDefinition $ \def ->
Language/Thrift/Parser.hs view
@@ -429,12 +429,13 @@ -- | A constant value literal. constantValue :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.ConstValue n)-constantValue = choice [- either T.ConstInt T.ConstFloat <$> integerOrDouble- , T.ConstLiteral <$> literal- , withSrcAnnot (T.ConstIdentifier <$> identifier)- , T.ConstList <$> constList- , T.ConstMap <$> constMap+constantValue = withSrcAnnot $ choice [+ either T.ConstInt T.ConstFloat+ <$> integerOrDouble+ , T.ConstLiteral <$> literal+ , T.ConstIdentifier <$> identifier+ , T.ConstList <$> constList+ , T.ConstMap <$> constMap ] @@ -483,7 +484,7 @@ baseType :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)-baseType =+baseType = withSrcAnnot $ choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases] where bases = [@@ -502,7 +503,7 @@ containerType :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)-containerType =+containerType = withSrcAnnot $ choice [mapType, setType, listType] <*> typeAnnotations where mapType = reserved "map" >>
Language/Thrift/Pretty/PrettyInc.hs view
@@ -239,26 +239,26 @@ typeReference c ft = case ft of T.DefinedType t _ -> text t - T.StringType anns -> reserved "string" <> typeAnnots c anns- T.BinaryType anns -> reserved "binary" <> typeAnnots c anns- T.SListType anns -> reserved "slist" <> typeAnnots c anns- T.BoolType anns -> reserved "bool" <> typeAnnots c anns- T.ByteType anns -> reserved "byte" <> typeAnnots c anns- T.I16Type anns -> reserved "i16" <> typeAnnots c anns- T.I32Type anns -> reserved "i32" <> typeAnnots c anns- T.I64Type anns -> reserved "i64" <> typeAnnots c anns- T.DoubleType anns -> reserved "double" <> typeAnnots c anns+ T.StringType anns _ -> reserved "string" <> typeAnnots c anns+ T.BinaryType anns _ -> reserved "binary" <> typeAnnots c anns+ T.SListType anns _ -> reserved "slist" <> typeAnnots c anns+ T.BoolType anns _ -> reserved "bool" <> typeAnnots c anns+ T.ByteType anns _ -> reserved "byte" <> typeAnnots c anns+ T.I16Type anns _ -> reserved "i16" <> typeAnnots c anns+ T.I32Type anns _ -> reserved "i32" <> typeAnnots c anns+ T.I64Type anns _ -> reserved "i64" <> typeAnnots c anns+ T.DoubleType anns _ -> reserved "double" <> typeAnnots c anns - T.MapType k v anns ->+ T.MapType k v anns _ -> reserved "map" <> enclose langle rangle (typeReference c k <> comma <+> typeReference c v) <> typeAnnots c anns- T.SetType v anns ->+ T.SetType v anns _ -> reserved "set" <> enclose langle rangle (typeReference c v) <> typeAnnots c anns- T.ListType v anns ->+ T.ListType v anns _ -> reserved "list" <> enclose langle rangle (typeReference c v) <> typeAnnots c anns@@ -269,13 +269,13 @@ -- | Pretty print a constant value. constantValue :: Config -> T.ConstValue ann -> Doc constantValue c@Config{indentWidth} value = case value of- T.ConstInt i -> integer i- T.ConstFloat f -> double f- T.ConstLiteral l -> literal l- T.ConstIdentifier i _ -> text i- T.ConstList vs ->+ T.ConstInt i _ -> integer i+ T.ConstFloat f _ -> double f+ T.ConstLiteral l _ -> literal l+ T.ConstIdentifier i _ -> text i+ T.ConstList vs _ -> encloseSep indentWidth lbracket rbracket comma $ map (constantValue c) vs- T.ConstMap vs ->+ T.ConstMap vs _ -> encloseSep indentWidth lbrace rbrace comma $ map (\(k, v) -> constantValue c k <> colon <+> constantValue c v) vs
examples/generateHaskellTypes.hs view
@@ -55,29 +55,29 @@ tupled = encloseSep lparen rparen (text ", ") renderConstValue :: T.ConstValue a -> Doc-renderConstValue (T.ConstInt i) = integer i-renderConstValue (T.ConstFloat f) = double f-renderConstValue (T.ConstLiteral l) = dquotes $ text (unpack l) -- TODO escaping+renderConstValue (T.ConstInt i _) = integer i+renderConstValue (T.ConstFloat f _) = double f+renderConstValue (T.ConstLiteral l _) = dquotes $ text (unpack l) -- TODO escaping renderConstValue (T.ConstIdentifier i _) = text (unpack i)-renderConstValue (T.ConstList l) = list (map renderConstValue l)-renderConstValue (T.ConstMap m) = text "Map.fromList" <+> list (map renderConstTuple m)+renderConstValue (T.ConstList l _) = list (map renderConstValue l)+renderConstValue (T.ConstMap m _) = text "Map.fromList" <+> list (map renderConstTuple m) where renderConstTuple (a, b) = tupled [renderConstValue a, renderConstValue b] renderTypeReference :: Show a => T.TypeReference a -> Doc renderTypeReference (T.DefinedType t _) = text (unpack t)-renderTypeReference (T.StringType _) = text "Text"-renderTypeReference (T.BinaryType _) = text "ByteString"-renderTypeReference (T.BoolType _) = text "Bool"-renderTypeReference (T.ByteType _) = text "Word8"-renderTypeReference (T.I16Type _) = text "Word16"-renderTypeReference (T.I32Type _) = text "Word32"-renderTypeReference (T.I64Type _) = text "Word64"-renderTypeReference (T.DoubleType _) = text "Double"-renderTypeReference (T.MapType k v _) =+renderTypeReference (T.StringType _ _) = text "Text"+renderTypeReference (T.BinaryType _ _) = text "ByteString"+renderTypeReference (T.BoolType _ _) = text "Bool"+renderTypeReference (T.ByteType _ _) = text "Word8"+renderTypeReference (T.I16Type _ _) = text "Word16"+renderTypeReference (T.I32Type _ _) = text "Word32"+renderTypeReference (T.I64Type _ _) = text "Word64"+renderTypeReference (T.DoubleType _ _) = text "Double"+renderTypeReference (T.MapType k v _ _) = parens $ hsep [text "Map", renderTypeReference k, renderTypeReference v]-renderTypeReference (T.SetType i _) = parens $ text "Set" <+> renderTypeReference i-renderTypeReference (T.ListType i _) = brackets $ renderTypeReference i+renderTypeReference (T.SetType i _ _) = parens $ text "Set" <+> renderTypeReference i+renderTypeReference (T.ListType i _ _) = brackets $ renderTypeReference i renderTypeReference t = error $ "Unsupported field type: " ++ show t renderStructField :: Show a => Text -> T.Field a -> Doc
language-thrift.cabal view
@@ -1,5 +1,5 @@ name: language-thrift-version: 0.6.2.0+version: 0.7.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3
test/Language/Thrift/Arbitrary.hs view
@@ -221,23 +221,22 @@ instance Arbitrary (T.TypeReference ()) where shrink = genericShrink arbitrary = oneof- [ T.DefinedType <$> arbitrary <*> pure ()-- , halfSize $ T.StringType <$> arbitrary- , halfSize $ T.BinaryType <$> arbitrary- , halfSize $ T.SListType <$> arbitrary- , halfSize $ T.BoolType <$> arbitrary- , halfSize $ T.ByteType <$> arbitrary- , halfSize $ T.I16Type <$> arbitrary- , halfSize $ T.I32Type <$> arbitrary- , halfSize $ T.I64Type <$> arbitrary- , halfSize $ T.DoubleType <$> arbitrary- , halfSize $ T.MapType <$> arbitrary <*> arbitrary <*> arbitrary- , halfSize $ T.SetType <$> arbitrary <*> arbitrary- , halfSize $ T.ListType <$> arbitrary <*> arbitrary+ [ T.DefinedType <$> arbitrary <*> pure ()+ , halfSize $ T.StringType <$> arbitrary <*> pure ()+ , halfSize $ T.BinaryType <$> arbitrary <*> pure ()+ , halfSize $ T.SListType <$> arbitrary <*> pure ()+ , halfSize $ T.BoolType <$> arbitrary <*> pure ()+ , halfSize $ T.ByteType <$> arbitrary <*> pure ()+ , halfSize $ T.I16Type <$> arbitrary <*> pure ()+ , halfSize $ T.I32Type <$> arbitrary <*> pure ()+ , halfSize $ T.I64Type <$> arbitrary <*> pure ()+ , halfSize $ T.DoubleType <$> arbitrary <*> pure ()+ , halfSize $ T.MapType <$> arbitrary <*> arbitrary <*> arbitrary <*> pure ()+ , halfSize $ T.SetType <$> arbitrary <*> arbitrary <*> pure ()+ , halfSize $ T.ListType <$> arbitrary <*> arbitrary <*> pure () ] -instance Arbitrary (T.FieldRequiredness) where+instance Arbitrary T.FieldRequiredness where shrink = genericShrink arbitrary = elements [T.Required, T.Optional] @@ -254,9 +253,9 @@ instance Arbitrary BasicConstValue where shrink = genericShrink arbitrary = BasicConstValue <$> oneof- [ T.ConstFloat <$> choose (0.0, 10000.0)- , T.ConstInt <$> arbitrary- , T.ConstLiteral <$> arbitrary+ [ T.ConstFloat <$> choose (0.0, 10000.0) <*> pure ()+ , T.ConstInt <$> arbitrary <*> pure ()+ , T.ConstLiteral <$> arbitrary <*> pure () , T.ConstIdentifier <$> arbitrary <*> pure () ] @@ -270,8 +269,8 @@ shrink = genericShrink arbitrary = FiniteConstValue <$> oneof [ basicConsts- , T.ConstList <$> constList- , T.ConstMap <$> constMap+ , T.ConstList <$> constList <*> pure ()+ , T.ConstMap <$> constMap <*> pure () ] where basicConsts = getBasicConstValue <$> arbitrary