language-thrift 0.6.1.0 → 0.6.2.0
raw patch · 4 files changed
+262/−31 lines, 4 filesdep +template-haskell
Dependencies added: template-haskell
Files
- CHANGES.md +5/−0
- Language/Thrift/Internal/TH.hs +45/−0
- Language/Thrift/Internal/Types.hs +209/−30
- language-thrift.cabal +3/−1
CHANGES.md view
@@ -1,3 +1,8 @@+0.6.2.0+=======++- Use more concrete types for lenses which don't need overloading.+ 0.6.1.0 =======
+ Language/Thrift/Internal/TH.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Language.Thrift.Internal.TH+ ( makeFieldsFor+ , accessorLens+ ) where++import Control.Lens (lens, (%~), (&))+import Control.Lens.TH (LensRules, defaultFieldRules, lensField,+ makeLensesWith)+import Language.Haskell.TH++-- | A version of 'Control.Lens.makeFields' that declares lenses only for the+-- given selectors.+makeFieldsFor :: [String] -> Name -> DecsQ+makeFieldsFor fields = makeLensesWith (fieldRulesFor fields)++fieldRulesFor :: [String] -> LensRules+fieldRulesFor fields = defaultFieldRules & lensField %~ mkLookup+ where+ mkLookup go t fs f+ | nameBase f `elem` fields = go t fs f+ | otherwise = []++-- | A template haskell function to generate a simple lens for a record+-- accessor.+--+-- > $(accessorLens 'someAccessor)+--+-- Generates+--+-- > lens someAccessor (\s a -> s { someAccessor = a })+accessorLens :: Name -> ExpQ+accessorLens name = do+ s <- newName "s"+ a <- newName "a"++ let getter = appE [| lens |] (varE name) -- lens $name+ setter =+ -- \s a -> s { name = a }+ lamE [varP s, varP a] $+ -- s { name = a }+ recUpdE (varE s) [fieldExp name (varE a)]++ appE getter setter
Language/Thrift/Internal/Types.hs view
@@ -5,14 +5,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Language.Thrift.Internal.Types- ( Program(..)+ (+ -- * AST + Program(..)+ , headers+ , definitions+ , Header(..) , _Include , _Namespace , Include(..)+ , path+ , Namespace(..)+ , language , Definition(..) , _Const@@ -21,6 +29,8 @@ , Const(..) , Service(..)+ , functions+ , extends , Type(..) , _Typedef@@ -31,6 +41,8 @@ , _Senum , Typedef(..)+ , targetType+ , Enum(..) , Struct(..) , Union(..)@@ -42,6 +54,10 @@ , _Optional , Field(..)+ , identifier+ , requiredness+ , defaultValue+ , EnumDef(..) , ConstValue(..)@@ -68,28 +84,21 @@ , _ListType , Function(..)+ , oneWay+ , returnType+ , parameters+ , exceptions+ , TypeAnnotation(..) , Docstring + -- * Typeclasses+ , HasAnnotations(..)- , HasDefaultValue(..)- , HasDefinitions(..) , HasDocstring(..)- , HasExceptions(..)- , HasExtends(..) , HasFields(..)- , HasFunctions(..)- , HasHeaders(..)- , HasIdentifier(..)- , HasLanguage(..) , HasName(..)- , HasOneWay(..)- , HasParameters(..)- , HasPath(..)- , HasRequiredness(..)- , HasReturnType(..) , HasSrcAnnot(..)- , HasTargetType(..) , HasValue(..) , HasValues(..) , HasValueType(..)@@ -100,9 +109,16 @@ import GHC.Generics (Generic) import Prelude hiding (Enum) +import Language.Thrift.Internal.TH+ import qualified Control.Lens as L +class HasSrcAnnot t where+ srcAnnot :: L.Lens' (t a) a +class HasName t where+ name :: L.Lens' t Text+ -- | Type annoations may be added in various places in the form, -- -- > (foo = "bar", baz, qux = "quux")@@ -117,9 +133,14 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''TypeAnnotation+makeFieldsFor ["typeAnnotationValue"] ''TypeAnnotation +instance HasName TypeAnnotation where+ name = $(accessorLens 'typeAnnotationName) +class HasAnnotations t where+ annotations :: L.Lens' t [TypeAnnotation]+ -- | Docstrings are Javadoc-style comments attached various defined objects. -- -- > /**@@ -128,6 +149,8 @@ -- > Item getItem() type Docstring = Maybe Text +class HasDocstring t where+ docstring :: L.Lens' t Docstring -- | A constant literal value in the IDL. Only a few basic types, lists, and -- maps can be presented in Thrift files as literals.@@ -190,7 +213,10 @@ L.makePrisms ''TypeReference +class HasValueType t where+ valueType :: L.Lens' (t a) (TypeReference a) + -- | Whether a field is required or optional. data FieldRequiredness = Required -- ^ The field is @required@.@@ -226,9 +252,30 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Field+L.makeLensesFor+ [ ("fieldIdentifier", "identifier")+ , ("fieldRequiredness", "requiredness")+ , ("fieldDefaultValue", "defaultValue")+ ] ''Field +instance HasName (Field a) where+ name = $(accessorLens 'fieldName) +instance HasValueType Field where+ valueType = $(accessorLens 'fieldValueType)++instance HasSrcAnnot Field where+ srcAnnot = $(accessorLens 'fieldSrcAnnot)++instance HasDocstring (Field a) where+ docstring = $(accessorLens 'fieldDocstring)++instance HasAnnotations (Field a) where+ annotations = $(accessorLens 'fieldAnnotations)++class HasFields t where+ fields :: L.Lens' (t a) [Field a]+ -- | A function defined inside a service. data Function srcAnnot = Function { functionOneWay :: Bool@@ -250,9 +297,25 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Function+L.makeLensesFor+ [ ("functionOneWay", "oneWay")+ , ("functionReturnType", "returnType")+ , ("functionParameters", "parameters")+ , ("functionExceptions", "exceptions")+ ] ''Function +instance HasName (Function a) where+ name = $(accessorLens 'functionName) +instance HasSrcAnnot Function where+ srcAnnot = $(accessorLens 'functionSrcAnnot)++instance HasDocstring (Function a) where+ docstring = $(accessorLens 'functionDocstring)++instance HasAnnotations (Function a) where+ annotations = $(accessorLens 'functionAnnotations)+ -- | A service definition. -- -- > service MyService {@@ -273,8 +336,23 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Service+L.makeLensesFor+ [ ("serviceExtends", "extends")+ , ("serviceFunctions", "functions")+ ] ''Service +instance HasName (Service a) where+ name = $(accessorLens 'serviceName)++instance HasSrcAnnot Service where+ srcAnnot = $(accessorLens 'serviceSrcAnnot)++instance HasDocstring (Service a) where+ docstring = $(accessorLens 'serviceDocstring)++instance HasAnnotations (Service a) where+ annotations = $(accessorLens 'serviceAnnotations)+ -- | A declared constant. -- -- > const i32 code = 1;@@ -291,9 +369,20 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Const+makeFieldsFor ["constValue"] ''Const +instance HasName (Const a) where+ name = $(accessorLens 'constName) +instance HasSrcAnnot Const where+ srcAnnot = $(accessorLens 'constSrcAnnot)++instance HasValueType Const where+ valueType = $(accessorLens 'constValueType)++instance HasDocstring (Const a) where+ docstring = $(accessorLens 'constDocstring)+ -- | A typedef is just an alias for another type. -- -- > typedef common.Foo Bar@@ -310,9 +399,20 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Typedef+L.makeLensesFor [("typedefTargetType", "targetType")] ''Typedef +instance HasName (Typedef a) where+ name = $(accessorLens 'typedefName) +instance HasSrcAnnot Typedef where+ srcAnnot = $(accessorLens 'typedefSrcAnnot)++instance HasDocstring (Typedef a) where+ docstring = $(accessorLens 'typedefDocstring)++instance HasAnnotations (Typedef a) where+ annotations = $(accessorLens 'typedefAnnotations)+ -- | A named value inside an enum. data EnumDef srcAnnot = EnumDef { enumDefName :: Text@@ -327,9 +427,20 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''EnumDef+makeFieldsFor ["enumDefValue"] ''EnumDef +instance HasName (EnumDef a) where+ name = $(accessorLens 'enumDefName) +instance HasSrcAnnot EnumDef where+ srcAnnot = $(accessorLens 'enumDefSrcAnnot)++instance HasDocstring (EnumDef a) where+ docstring = $(accessorLens 'enumDefDocstring)++instance HasAnnotations (EnumDef a) where+ annotations = $(accessorLens 'enumDefAnnotations)+ -- | Enums are sets of named integer values. -- -- > enum Role {@@ -348,9 +459,20 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Enum+makeFieldsFor ["enumValues"] ''Enum +instance HasName (Enum a) where+ name = $(accessorLens 'enumName) +instance HasSrcAnnot Enum where+ srcAnnot = $(accessorLens 'enumSrcAnnot)++instance HasDocstring (Enum a) where+ docstring = $(accessorLens 'enumDocstring)++instance HasAnnotations (Enum a) where+ annotations = $(accessorLens 'enumAnnotations)+ -- | A struct definition -- -- > struct User {@@ -369,9 +491,21 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Struct+instance HasName (Struct a) where+ name = $(accessorLens 'structName) +instance HasFields Struct where+ fields = $(accessorLens 'structFields) +instance HasSrcAnnot Struct where+ srcAnnot = $(accessorLens 'structSrcAnnot)++instance HasDocstring (Struct a) where+ docstring = $(accessorLens 'structDocstring)++instance HasAnnotations (Struct a) where+ annotations = $(accessorLens 'structAnnotations)+ -- | A union of other types. -- -- > union Value {@@ -391,9 +525,21 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Union+instance HasName (Union a) where+ name = $(accessorLens 'unionName) +instance HasFields Union where+ fields = $(accessorLens 'unionFields) +instance HasSrcAnnot Union where+ srcAnnot = $(accessorLens 'unionSrcAnnot)++instance HasDocstring (Union a) where+ docstring = $(accessorLens 'unionDocstring)++instance HasAnnotations (Union a) where+ annotations = $(accessorLens 'unionAnnotations)+ -- | Exception types. -- -- > exception UserDoesNotExist {@@ -413,9 +559,21 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Exception+instance HasName (Exception a) where+ name = $(accessorLens 'exceptionName) +instance HasFields Exception where+ fields = $(accessorLens 'exceptionFields) +instance HasSrcAnnot Exception where+ srcAnnot = $(accessorLens 'exceptionSrcAnnot)++instance HasDocstring (Exception a) where+ docstring = $(accessorLens 'exceptionDocstring)++instance HasAnnotations (Exception a) where+ annotations = $(accessorLens 'exceptionAnnotations)+ -- | An string-only enum. These are a deprecated feature of Thrift and -- shouldn't be used. data Senum srcAnnot = Senum@@ -429,9 +587,20 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Senum+makeFieldsFor ["senumValues"] ''Senum +instance HasName (Senum a) where+ name = $(accessorLens 'senumName) +instance HasSrcAnnot Senum where+ srcAnnot = $(accessorLens 'senumSrcAnnot)++instance HasDocstring (Senum a) where+ docstring = $(accessorLens 'senumDocstring)++instance HasAnnotations (Senum a) where+ annotations = $(accessorLens 'senumAnnotations)+ -- | Defines the various types that can be declared in Thrift. data Type srcAnnot = -- | @typedef@@@ -530,9 +699,14 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Namespace+L.makeLensesFor [("namespaceLanguage", "language")] ''Namespace +instance HasName (Namespace a) where+ name = $(accessorLens 'namespaceName) +instance HasSrcAnnot Namespace where+ srcAnnot = $(accessorLens 'namespaceSrcAnnot)+ -- | The IDL includes another Thrift file. -- -- > include "common.thrift"@@ -546,8 +720,10 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Include+L.makeLensesFor [("includePath", "path")] ''Include +instance HasSrcAnnot Include where+ srcAnnot = $(accessorLens 'includeSrcAnnot) -- | Headers for a program. data Header srcAnnot@@ -579,4 +755,7 @@ } deriving (Show, Ord, Eq, Data, Typeable, Generic) -L.makeFields ''Program+L.makeLensesFor+ [ ("programHeaders", "headers")+ , ("programDefinitions", "definitions")+ ] ''Program
language-thrift.cabal view
@@ -1,5 +1,5 @@ name: language-thrift-version: 0.6.1.0+version: 0.6.2.0 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -35,12 +35,14 @@ lens >=4.0 && <5.0, parsers >=0.12 && <0.13, text >=1.2,+ template-haskell -any, transformers -any, trifecta >=1.5 && <1.6, wl-pprint >=1.1 default-language: Haskell2010 other-modules: Language.Thrift.Pretty.Types+ Language.Thrift.Internal.TH Language.Thrift.Internal.Types ghc-options: -Wall