diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 ======= diff --git a/Language/Thrift/Internal/Types.hs b/Language/Thrift/Internal/Types.hs --- a/Language/Thrift/Internal/Types.hs +++ b/Language/Thrift/Internal/Types.hs @@ -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\@ and annotations. - | SetType (TypeReference srcAnnot) [TypeAnnotation] + | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot -- ^ @set\@ and annotations. - | ListType (TypeReference srcAnnot) [TypeAnnotation] + | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot -- ^ @list\@ 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 -> diff --git a/Language/Thrift/Parser.hs b/Language/Thrift/Parser.hs --- a/Language/Thrift/Parser.hs +++ b/Language/Thrift/Parser.hs @@ -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" >> diff --git a/Language/Thrift/Pretty/PrettyInc.hs b/Language/Thrift/Pretty/PrettyInc.hs --- a/Language/Thrift/Pretty/PrettyInc.hs +++ b/Language/Thrift/Pretty/PrettyInc.hs @@ -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 diff --git a/examples/generateHaskellTypes.hs b/examples/generateHaskellTypes.hs --- a/examples/generateHaskellTypes.hs +++ b/examples/generateHaskellTypes.hs @@ -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 diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -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 diff --git a/test/Language/Thrift/Arbitrary.hs b/test/Language/Thrift/Arbitrary.hs --- a/test/Language/Thrift/Arbitrary.hs +++ b/test/Language/Thrift/Arbitrary.hs @@ -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