diff --git a/proto-lens-protoc.cabal b/proto-lens-protoc.cabal --- a/proto-lens-protoc.cabal +++ b/proto-lens-protoc.cabal @@ -1,5 +1,5 @@ name: proto-lens-protoc -version: 0.1.0.5 +version: 0.2.0.0 synopsis: Protocol buffer compiler for the proto-lens library. description: Turn protocol buffer files (.proto) into Haskell files (.hs) which @@ -10,7 +10,7 @@ license: BSD3 license-file: LICENSE author: Judah Jacobson -maintainer: judahjacobson@google.com +maintainer: proto-lens@googlegroups.com copyright: Google Inc. category: Data build-type: Simple @@ -41,13 +41,14 @@ , bytestring == 0.10.* , containers == 0.5.* , data-default-class >= 0.0 && < 0.2 - , directory == 1.2.* + , directory >= 1.2 && < 1.4 , filepath == 1.4.* - , haskell-src-exts == 1.17.* + , haskell-src-exts >= 1.17 && < 1.19 , lens-family == 1.2.* + , lens-labels == 0.1.* , process >= 1.2 && < 1.5 - , proto-lens == 0.1.0.5 - , proto-lens-descriptors == 0.1.0.5 + , proto-lens == 0.2.0.0 + , proto-lens-descriptors == 0.2.0.0 , text == 1.2.* reexported-modules: -- Modules that are needed by the generated Haskell files. @@ -62,6 +63,7 @@ , Data.Text as Data.ProtoLens.Reexport.Data.Text , Lens.Family2 as Data.ProtoLens.Reexport.Lens.Family2 , Lens.Family2.Unchecked as Data.ProtoLens.Reexport.Lens.Family2.Unchecked + , Lens.Labels as Data.ProtoLens.Reexport.Lens.Labels } executable proto-lens-protoc @@ -73,12 +75,12 @@ , containers == 0.5.* , data-default-class >= 0.0 && < 0.2 , filepath == 1.4.* - , haskell-src-exts == 1.17.* + , haskell-src-exts >= 1.17 && < 1.19 , lens-family == 1.2.* -- Specify an exact version of `proto-lens`, since it's tied closely -- to the generated code. - , proto-lens == 0.1.0.5 - , proto-lens-descriptors == 0.1.0.5 + , proto-lens == 0.2.0.0 + , proto-lens-descriptors == 0.2.0.0 , text == 1.2.* hs-source-dirs: src other-modules: diff --git a/src/Data/ProtoLens/Compiler/Combinators.hs b/src/Data/ProtoLens/Compiler/Combinators.hs --- a/src/Data/ProtoLens/Compiler/Combinators.hs +++ b/src/Data/ProtoLens/Compiler/Combinators.hs @@ -5,20 +5,220 @@ -- https://developers.google.com/open-source/licenses/bsd {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Some utility functions, classes and instances for nicer code generation --- with haskell-src-exts. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Some utility functions, classes and instances for nicer code generation. -- --- In particular, we define orphan instances of IsString for various syntax +-- Re-exports simpler versions of the types and constructors from +-- @haskell-src-exts@. +-- +-- We define orphan instances of IsString for various syntax -- datatypes, with some intelligence about Haskell names. For example, @"foo" -- :: Exp@ is treated as a variable and @"Foo" :: Exp@ is treated as a -- constructor. -module Data.ProtoLens.Compiler.Combinators where +module Data.ProtoLens.Compiler.Combinators + ( module Data.ProtoLens.Compiler.Combinators + -- Since ImportDecl is a record type, for simplicity we just export it + -- directly. + , Syntax.ImportDecl(..) + ) where import Data.Char (isAlphaNum, isUpper) import Data.String (IsString(..)) -import Language.Haskell.Exts.SrcLoc (noLoc) -import Language.Haskell.Exts.Syntax as Syntax +#if MIN_VERSION_haskell_src_exts(1,18,0) +import qualified Language.Haskell.Exts.Syntax as Syntax +import qualified Language.Haskell.Exts.Pretty as Pretty +#else +import qualified Language.Haskell.Exts.Annotated.Syntax as Syntax +import qualified Language.Haskell.Exts.Pretty as Pretty +import Language.Haskell.Exts.SrcLoc (SrcLoc, noLoc) +#endif +#if MIN_VERSION_haskell_src_exts(1,18,0) +prettyPrint :: Pretty.Pretty a => a -> String +prettyPrint = Pretty.prettyPrint +#else +prettyPrint :: (Functor m, Pretty.Pretty (m SrcLoc)) => m () -> String +prettyPrint = Pretty.prettyPrint . fmap (const noLoc) +#endif + +type Asst = Syntax.Asst () + +classA :: QName -> [Type] -> Asst +classA = Syntax.ClassA () + +equalP :: Type -> Type -> Asst +equalP = Syntax.EqualP () + + +type ConDecl = Syntax.ConDecl () + +conDecl :: Name -> [Type] -> ConDecl +conDecl = Syntax.ConDecl () + +recDecl :: Name -> [(Name, Type)] -> ConDecl +recDecl dataName fields + = Syntax.RecDecl () dataName + [Syntax.FieldDecl () [n] (tyBang t) | (n,t) <- fields] + + +type Decl = Syntax.Decl () + +patSynSig :: Name -> Type -> Decl +patSynSig n t = Syntax.PatSynSig () n Nothing Nothing Nothing t + +patSyn :: Pat -> Pat -> Decl +patSyn p1 p2 = Syntax.PatSyn () p1 p2 Syntax.ImplicitBidirectional + +dataDecl :: Name -> [ConDecl] -> [QName] -> Decl +dataDecl name conDecls derives + = Syntax.DataDecl () (Syntax.DataType ()) Nothing + (Syntax.DHead () name) + [Syntax.QualConDecl () Nothing Nothing q | q <- conDecls] + $ Just $ Syntax.Deriving () + [ Syntax.IRule () Nothing Nothing (Syntax.IHCon () c) + | c <- derives + ] + +funBind :: [Match] -> Decl +funBind = Syntax.FunBind () + +instDecl :: [Asst] -> InstHead -> [[Match]] -> Decl +instDecl ctx instHead matches + = Syntax.InstDecl () Nothing + (Syntax.IRule () Nothing ctx' instHead) + $ Just [Syntax.InsDecl () $ funBind m | m <- matches] + where + ctx' = case ctx of + [] -> Nothing + [c] -> Just $ Syntax.CxSingle () c + cs -> Just $ Syntax.CxTuple () cs + +typeSig :: [Name] -> Type -> Decl +typeSig = Syntax.TypeSig () + + +type Exp = Syntax.Exp () + +let' :: [Decl] -> Exp -> Exp +let' ds e = Syntax.Let () (Syntax.BDecls () ds) e + +stringExp :: String -> Exp +stringExp = Syntax.Lit () . string + +tuple :: [Exp] -> Exp +tuple = Syntax.Tuple () Syntax.Boxed + +lambda :: [Pat] -> Exp -> Exp +lambda = Syntax.Lambda () + +(@::@) :: Exp -> Type -> Exp +(@::@) = Syntax.ExpTypeSig () +infixl 2 @::@ + +recConstr :: QName -> [FieldUpdate] -> Exp +recConstr = Syntax.RecConstr () + +recUpdate :: Exp -> [FieldUpdate] -> Exp +recUpdate = Syntax.RecUpdate () + +var, con :: QName -> Exp +var = Syntax.Var () +con = Syntax.Con () + +list :: [Exp] -> Exp +list = Syntax.List () + + +type FieldUpdate = Syntax.FieldUpdate () + +fieldUpdate :: QName -> Exp -> FieldUpdate +fieldUpdate = Syntax.FieldUpdate () + +type InstHead = Syntax.InstHead () + +ihApp :: InstHead -> [Type] -> InstHead +ihApp = foldl (Syntax.IHApp ()) + + +type Match = Syntax.Match () + +-- | A simple clause of a function binding. +match :: Name -> [Pat] -> Exp -> Syntax.Match () +match n ps e = Syntax.Match () n ps (Syntax.UnGuardedRhs () e) Nothing + +type Module = Syntax.Module () + +module' :: ModuleName -> [ModulePragma] -> [Syntax.ImportDecl ()] -> [Decl] -> Module +module' modName + = Syntax.Module () + (Just $ Syntax.ModuleHead () modName + -- no warning text + Nothing + -- no explicit exports; we export everything. + -- TODO: Also export public imports, taking care not to + -- cause a name conflict between field accessors. + Nothing) + +type ModuleName = Syntax.ModuleName () +type ModulePragma = Syntax.ModulePragma () + +languagePragma :: [Name] -> ModulePragma +languagePragma = Syntax.LanguagePragma () + +optionsGhcPragma :: String -> ModulePragma +optionsGhcPragma = Syntax.OptionsPragma () (Just Syntax.GHC) + +type Name = Syntax.Name () + +type Pat = Syntax.Pat () + +pApp :: QName -> [Pat] -> Pat +pApp = Syntax.PApp () + +pVar :: Name -> Pat +pVar = Syntax.PVar () + +pWildCard :: Pat +pWildCard = Syntax.PWildCard () + +stringPat :: String -> Pat +stringPat = Syntax.PLit () (Syntax.Signless ()) . string + + +type QName = Syntax.QName () + +qual :: ModuleName -> Name -> QName +qual = Syntax.Qual () + +unQual :: Name -> QName +unQual = Syntax.UnQual () + + +type TyVarBind = Syntax.TyVarBind () +type Type = Syntax.Type () + +tyCon :: QName -> Type +tyCon = Syntax.TyCon () + +tyList :: Type -> Type +tyList = Syntax.TyList () + +tyPromotedString :: String -> Type +tyPromotedString s = Syntax.TyPromoted () $ Syntax.PromotedString () s s + +tyForAll :: [TyVarBind] -> [Asst] -> Type -> Type +tyForAll vars ctx t = Syntax.TyForall () (Just vars) + (Just $ Syntax.CxTuple () ctx) + t + +tyBang :: Type -> Type +#if MIN_VERSION_haskell_src_exts(1,18,0) +tyBang = Syntax.TyBang () (Syntax.BangedTy ()) (Syntax.NoUnpackPragma ()) +#else +tyBang = Syntax.TyBang () (Syntax.BangedTy ()) +#endif + -- | Application of a Haskell type or expression to an argument. -- For example, to represent @f x y@, you can write -- @@ -28,16 +228,16 @@ infixl 2 @@ instance App Type where - (@@) = TyApp + (@@) = Syntax.TyApp () instance App Exp where - (@@) = App + (@@) = Syntax.App () instance IsString Name where fromString s -- TODO: better handle the case of mixed ident and symbol characters. - | all isIdentChar s = Ident s - | otherwise = Symbol s + | all isIdentChar s = Syntax.Ident () s + | otherwise = Syntax.Symbol () s -- | Whether this character belongs to an Ident (e.g., "foo") or a symbol -- (e.g., "<$>"). @@ -45,7 +245,7 @@ isIdentChar c = isAlphaNum c || c `elem` "_'" instance IsString ModuleName where - fromString = ModuleName + fromString = Syntax.ModuleName () instance IsString QName where fromString f @@ -55,44 +255,47 @@ | isIdentChar (last f), '.' `elem` f -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz") , (f', '.':f'') <- span (/='.') (reverse f) - = Qual (fromString $ reverse f'') (fromString $ reverse f') - | otherwise = UnQual $ fromString f + = Syntax.Qual () (fromString $ reverse f'') (fromString $ reverse f') + | otherwise = Syntax.UnQual () $ fromString f instance IsString Type where fromString fs@(f:_) - | isUpper f = TyCon $ fromString fs - fromString fs = TyVar $ fromString fs + | isUpper f = Syntax.TyCon () $ fromString fs + fromString fs = Syntax.TyVar () $ fromString fs instance IsString Exp where fromString fs@(f:_) - | isUpper f = Con $ fromString fs - fromString fs = Var $ fromString fs + | isUpper f = Syntax.Con () $ fromString fs + fromString fs = Syntax.Var () $ fromString fs instance IsString Pat where - fromString = PVar . fromString + fromString = Syntax.PVar () . fromString instance IsString TyVarBind where - fromString = UnkindedVar . fromString + fromString = Syntax.UnkindedVar () . fromString +instance IsString InstHead where + fromString = Syntax.IHCon () . fromString -- Helper functions for literal numbers, since haskell-src-exts doesn't -- put parentheses around negative numbers automatically. litInt :: Integer -> Exp litInt n - | n >= 0 = Lit $ Int n - | otherwise = NegApp $ Lit $ Int $ negate n + | n >= 0 = Syntax.Lit () $ Syntax.Int () n (show n) + | otherwise = Syntax.NegApp () $ litInt $ negate n litFrac :: Rational -> Exp litFrac x - | x >= 0 = Lit $ Frac x - | otherwise = NegApp $ Lit $ Frac $ negate x + | x >= 0 = Syntax.Lit () $ Syntax.Frac () x (show x) + | otherwise = Syntax.NegApp () $ litFrac $ negate x pLitInt :: Integer -> Pat -pLitInt n - | n >= 0 = PLit Signless $ Int n - | otherwise = PLit Negative $ Int $ negate n +pLitInt n = Syntax.PLit () sign $ Syntax.Int () n' (show n') + where + (n', sign) + | n >= 0 = (n, Syntax.Signless ()) + | otherwise = (negate n, Syntax.Negative ()) --- | A simple clause of a function binding. -match :: Name -> [Pat] -> Exp -> Match -match n ps e = Match noLoc n ps Nothing (UnGuardedRhs e) Nothing +string :: String -> Syntax.Literal () +string s = Syntax.String () s (show s) diff --git a/src/Data/ProtoLens/Compiler/Definitions.hs b/src/Data/ProtoLens/Compiler/Definitions.hs --- a/src/Data/ProtoLens/Compiler/Definitions.hs +++ b/src/Data/ProtoLens/Compiler/Definitions.hs @@ -21,16 +21,16 @@ , definedFieldType ) where -import Data.Char (toUpper) +import Data.Char (isUpper, toUpper) import Data.Int (Int32) import Data.List (mapAccumL) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Set as Set +import Data.String (fromString) import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) import qualified Data.Text as T -import Language.Haskell.Exts.Syntax (Name(..), QName(..), ModuleName(..)) import Lens.Family2 ((^.)) import Proto.Google.Protobuf.Descriptor ( DescriptorProto @@ -49,6 +49,14 @@ , value ) +import Data.ProtoLens.Compiler.Combinators + ( Name + , QName + , ModuleName + , qual + , unQual + ) + -- | 'Env' contains a mapping of proto names (as specified in the .proto file) -- to Haskell names. The keys are fully-qualified names, for example, -- ".package.Message.Submessage". (The protocol_compiler tool emits all @@ -105,11 +113,11 @@ -- Lift a set of local definitions into references to a specific module. qualifyEnv :: ModuleName -> Env Name -> Env QName -qualifyEnv m = mapEnv (Qual m) +qualifyEnv m = mapEnv (qual m) -- Lift a set of local definitions into references to the current module. unqualifyEnv :: Env Name -> Env QName -unqualifyEnv = mapEnv UnQual +unqualifyEnv = mapEnv unQual -- | Look up the type definition for a given field. definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName @@ -145,12 +153,12 @@ hsName = unpack $ capitalize $ d ^. name thisDef = (protoPrefix <> protoName , Message MessageInfo - { messageName = Ident $ hsPrefix ++ hsName + { messageName = fromString $ hsPrefix ++ hsName , messageDescriptor = d , messageFields = [ FieldInfo { overloadedField = n - , recordFieldName = Ident $ "_" ++ hsPrefix' ++ n + , recordFieldName = fromString $ "_" ++ hsPrefix' ++ n , fieldDescriptor = f } | f <- d ^. field @@ -171,16 +179,25 @@ -- TODO: use a more comprehensive blacklist of Haskell keywords. | s `Set.member` reservedKeywords = s <> "'" | otherwise = s - camelCase s - -- Preserve any initial underlines (e.g., "_foo_bar" -> "_fooBar"). - | (underlines, rest) <- T.span (== '_') s - = case splitOn "_" rest of - -- splitOn always returns a list with at least one element. - [] -> error $ "camelCase: splitOn returned empty list: " - ++ show rest - [""] -> error "camelCase: name consists only of underscores" - s':ss -> T.concat $ underlines : toLower s' : map capitalize ss +camelCase :: Text -> Text +camelCase s = + -- Preserve any initial underlines (e.g., "_foo_bar" -> "_fooBar"). + let (underlines, rest) = T.span (== '_') s + in case splitOn "_" rest of + -- splitOn always returns a list with at least one element. + [] -> error $ "camelCase: splitOn returned empty list: " + ++ show rest + [""] -> error $ "camelCase: name consists only of underscores: " + ++ show s + s':ss -> T.concat $ underlines : lowerInitialChars s' : map capitalize ss + +-- | Lower-case all initial upper-case characters. +-- For example: "Foo" -> "foo", "FooBar" -> "fooBar", "FOObar" -> "foobar" +lowerInitialChars :: Text -> Text +lowerInitialChars s = toLower pre <> post + where (pre, post) = T.span isUpper s + -- | A list of reserved keywords that aren't valid as variable names. reservedKeywords :: Set.Set Text reservedKeywords = Set.fromList $ @@ -223,7 +240,7 @@ -> (Text, Definition Name) enumDef protoPrefix hsPrefix d = let mkText n = protoPrefix <> n - mkHsName n = Ident $ hsPrefix ++ unpack n + mkHsName n = fromString $ hsPrefix ++ unpack n in (mkText (d ^. name) , Enum EnumInfo { enumName = mkHsName (d ^. name) diff --git a/src/Data/ProtoLens/Compiler/Generate.hs b/src/Data/ProtoLens/Compiler/Generate.hs --- a/src/Data/ProtoLens/Compiler/Generate.hs +++ b/src/Data/ProtoLens/Compiler/Generate.hs @@ -27,8 +27,6 @@ import Data.Text (unpack) import qualified Data.Text as T import Data.Tuple (swap) -import Language.Haskell.Exts.Syntax as Syntax -import Language.Haskell.Exts.SrcLoc (noLoc) import Lens.Family2 ((^.)) import Proto.Google.Protobuf.Descriptor ( EnumValueDescriptorProto @@ -78,19 +76,16 @@ -> Env QName -- ^ Definitions in the imported modules -> Module generateModule modName imports syntaxType modifyImport definitions importedEnv - = Module noLoc modName - [ LanguagePragma noLoc $ map Ident + = module' modName + [ languagePragma $ map fromString ["ScopedTypeVariables", "DataKinds", "TypeFamilies", + "UndecidableInstances", "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances", - "PatternSynonyms"] + "PatternSynonyms", "MagicHash"] -- Allow unused imports in case we don't import anything from -- Data.Text, Data.Int, etc. - , OptionsPragma noLoc (Just GHC) "-fno-warn-unused-imports" + , optionsGhcPragma "-fno-warn-unused-imports" ] - Nothing -- no warning text - Nothing -- no explicit exports; we export everything. - -- TODO: Also export public imports, taking care not to - -- cause a name conflict between field accessors. (map importSimple -- Note: we import Prelude explicitly to make it qualified. [ "Prelude", "Data.Int", "Data.Word"] @@ -98,6 +93,7 @@ [ "Data.ProtoLens", "Data.ProtoLens.Message.Enum" , "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class" , "Data.Text", "Data.Map" , "Data.ByteString" + , "Lens.Labels" ] ++ map importSimple imports) (concatMap generateDecls (Map.elems definitions) @@ -113,9 +109,9 @@ , i <- fieldInstances (lensInfo syntaxType env f) ] -importSimple :: ModuleName -> ImportDecl +importSimple :: ModuleName -> ImportDecl () importSimple m = ImportDecl - { importLoc = noLoc + { importAnn = () , importModule = m -- Import qualified to avoid clashes with names defined in this module. , importQualified = True @@ -126,84 +122,75 @@ , importSpecs = Nothing } -type ModifyImports = ImportDecl -> ImportDecl +type ModifyImports = ImportDecl () -> ImportDecl () reexported :: ModifyImports -reexported imp@ImportDecl {importModule = m@(ModuleName s)} +reexported imp@ImportDecl {importModule = m} = imp { importAs = Just m, importModule = m' } where - m' = ModuleName $ "Data.ProtoLens.Reexport." ++ s + m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m generateMessageDecls :: SyntaxType -> Env QName -> MessageInfo Name -> [Decl] generateMessageDecls syntaxType env info = -- data Bar = Bar { -- foo :: Baz -- } - [ DataDecl noLoc DataType [] dataName [] - [QualConDecl noLoc [] [] $ RecDecl dataName - [([recordFieldName f], - TyBang BangedTy $ internalType (lensInfo syntaxType env f)) + [ dataDecl dataName + [recDecl dataName + [ (recordFieldName f, internalType (lensInfo syntaxType env f)) | f <- fields ] ] - [("Prelude.Show", []), ("Prelude.Eq", [])] - ] - ++ - -- type instance Field.Field "foo" Bar = Baz - -- instance Field.HasField "foo" Bar where - -- field _ = ... + ["Prelude.Show", "Prelude.Eq"] + ] ++ + -- type instance (Functor f, a ~ Baz, b ~ Baz) + -- => HasLens "foo" f Bar Bar a b where + -- lensOf _ = ... -- Note: for optional fields, this generates an instance both for "foo" and -- for "maybe'foo" (see lensInfo below). - concat - [ [ TypeInsDecl noLoc - ("Data.ProtoLens.Field" @@ sym @@ dataType) - (fieldTypeInstance i) - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.HasField" - [sym, dataType, dataType] - [InsDecl $ FunBind [match "field" [PWildCard] $ fieldAccessor i]] - ] - | f <- fields - , i <- fieldInstances (lensInfo syntaxType env f) - , let sym = TyPromoted $ PromotedString $ fieldSymbol i - ] + [ instDecl [equalP "a" t, equalP "b" t, classA "Prelude.Functor" ["f"]] + ("Lens.Labels.HasLens" `ihApp` + [sym, "f", dataType, dataType, "a", "b"]) + [[match "lensOf" [pWildCard] $ fieldAccessor i]] + | f <- fields + , i <- fieldInstances (lensInfo syntaxType env f) + , let t = fieldTypeInstance i + , let sym = tyPromotedString $ fieldSymbol i + ] ++ -- instance Data.Default.Class.Default Bar where - [ InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] + [ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) -- def = Bar { _Bar_foo = 0 } - [ InsDecl $ FunBind + [ [ match "def" [] - $ RecConstr (UnQual dataName) - [ FieldUpdate (UnQual $ recordFieldName f) + $ recConstr (unQual dataName) + [ fieldUpdate (unQual $ recordFieldName f) (hsFieldDefault syntaxType env (fieldDescriptor f)) | f <- fields ] ] ] -- instance Message.Message Bar where - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.Message" [dataType] - [ InsDecl $ FunBind - [ match "descriptor" [] $ descriptorExpr syntaxType env info] - ] + , instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType]) + [[match "descriptor" [] $ descriptorExpr syntaxType env info]] ] where - dataType = TyCon $ UnQual dataName + dataType = tyCon $ unQual dataName MessageInfo { messageName = dataName, messageFields = fields} = info generateEnumDecls :: EnumInfo Name -> [Decl] generateEnumDecls info = - [ DataDecl noLoc DataType [] dataName [] - [QualConDecl noLoc [] [] $ ConDecl n [] | n <- constructorNames] - [(c, []) | c <- ["Prelude.Show", "Prelude.Eq"]] + [ dataDecl dataName + [conDecl n [] | n <- constructorNames] + ["Prelude.Show", "Prelude.Eq"] -- instance Data.Default.Class.Default Foo where -- def = FirstEnumValue - , InstDecl noLoc Nothing [] [] "Data.Default.Class.Default" [dataType] - [ InsDecl $ FunBind [match "def" [] defaultCon] - ] + , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) + [[match "def" [] defaultCon]] -- instance Data.ProtoLens.FieldDefault Foo where -- fieldDefault = FirstEnumValue - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.FieldDefault" [dataType] - [ InsDecl $ FunBind [match "fieldDefault" [] defaultCon] - ] + , instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType]) + [[match "fieldDefault" [] defaultCon]] -- instance MessageEnum Foo where -- maybeToEnum 1 = Just Foo1 -- maybeToEnum 2 = Just Foo2 @@ -216,27 +203,26 @@ -- readEnum "Foo2" = Just Foo2 -- ... -- readEnum _ = Nothing - , InstDecl noLoc Nothing [] [] "Data.ProtoLens.MessageEnum" [dataType] - [ InsDecl $ FunBind $ + , instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType]) + [ [ match "maybeToEnum" [pLitInt k] - $ "Prelude.Just" @@ Con (UnQual n) + $ "Prelude.Just" @@ con (unQual n) | (n, k) <- constructorNumbers ] ++ - [ match "maybeToEnum" [PWildCard] "Prelude.Nothing" + [ match "maybeToEnum" [pWildCard] "Prelude.Nothing" ] ++ - [ match "showEnum" [PVar n] $ Lit $ Syntax.String $ T.unpack pn + [ match "showEnum" [pVar n] $ stringExp $ T.unpack pn | (n, pn) <- constructorProtoNames ] ++ - [ match "readEnum" - [PLit Signless . Syntax.String $ T.unpack pn] - $ "Prelude.Just" @@ Con (UnQual n) + [ match "readEnum" [stringPat $ T.unpack pn] + $ "Prelude.Just" @@ con (unQual n) | (n, pn) <- constructorProtoNames ] ++ - [ match "readEnum" [PWildCard] "Prelude.Nothing" + [ match "readEnum" [pWildCard] "Prelude.Nothing" ] ] -- instance Enum Foo where @@ -258,16 +244,13 @@ -- enumFromTo = messageEnumFromTo -- enumFromThen = messageEnumFromThen -- enumFromThenTo = messageEnumFromThenTo - , InstDecl noLoc Nothing [] [] "Prelude.Enum" [dataType] - [ InsDecl $ FunBind - [ match "toEnum" ["k__"] + , instDecl [] ("Prelude.Enum" `ihApp` [dataType]) + [[match "toEnum" ["k__"] $ "Prelude.maybe" @@ errorMessageExpr @@ "Prelude.id" - @@ ("Data.ProtoLens.maybeToEnum" @@ "k__") - ] - , InsDecl $ FunBind - [ match "fromEnum" [PApp (UnQual c) []] $ litInt k - | (c, k) <- constructorNumbers - ] + @@ ("Data.ProtoLens.maybeToEnum" @@ "k__")] + , [ match "fromEnum" [pApp (unQual c) []] $ litInt k + | (c, k) <- constructorNumbers + ] , succDecl "succ" maxBoundName succPairs , succDecl "pred" minBoundName $ map swap succPairs , alias "enumFrom" "Data.ProtoLens.Message.Enum.messageEnumFrom" @@ -279,20 +262,17 @@ -- instance Bounded Foo where -- minBound = Foo1 -- maxBound = FooN - , InstDecl noLoc Nothing [] [] "Prelude.Bounded" [dataType] - [ InsDecl $ FunBind - [ match "minBound" [] $ Con $ UnQual minBoundName - , match "maxBound" [] $ Con $ UnQual maxBoundName - ] - ] + , instDecl [] ("Prelude.Bounded" `ihApp` [dataType]) + [[ match "minBound" [] $ con $ unQual minBoundName + , match "maxBound" [] $ con $ unQual maxBoundName + ]] ] ++ -- pattern FooAlias :: Foo -- pattern FooAlias = FooConstructor concat - [ [ PatSynSig noLoc aliasName Nothing [] [] dataType - , PatSyn noLoc (PVar aliasName) (PVar originalName) - ImplicitBidirectional + [ [ patSynSig aliasName dataType + , patSyn (pVar aliasName) (pVar originalName) ] | EnumValueInfo { enumValueName = aliasName @@ -300,7 +280,7 @@ } <- enumValues info ] where - dataType = TyCon $ UnQual dataName + dataType = tyCon $ unQual dataName EnumInfo { enumName = dataName, enumDescriptor = ed } = info constructors :: [(Name, EnumValueDescriptorProto)] constructors = List.sortBy (comparing ((^. number) . snd)) @@ -319,46 +299,46 @@ constructors succPairs = zip constructorNames $ tail constructorNames - succDecl funName boundName thePairs = InsDecl $ FunBind $ - match funName [PApp (UnQual boundName) []] ( - "Prelude.error" @@ Lit (Syntax.String $ concat - [ show dataName, ".", show funName, ": bad argument " - , show boundName, ". This value would be out of bounds." + succDecl funName boundName thePairs = + match funName [pApp (unQual boundName) []] + ("Prelude.error" @@ stringExp (concat + [ prettyPrint dataName, ".", prettyPrint funName, ": bad argument " + , prettyPrint boundName, ". This value would be out of bounds." ])) : - [ match funName [PApp (UnQual from) []] $ Con $ UnQual to + [ match funName [pApp (unQual from) []] $ con $ unQual to | (from, to) <- thePairs ] - alias funName implName = InsDecl $ FunBind [match funName [] implName] + alias funName implName = [match funName [] implName] - defaultCon = Con $ UnQual $ head constructorNames + defaultCon = con $ unQual $ head constructorNames errorMessageExpr = "Prelude.error" - @@ ("Prelude.++" @@ Lit (Syntax.String errorMessage) + @@ ("Prelude.++" @@ stringExp errorMessage @@ ("Prelude.show" @@ "k__")) errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name) ++ ": " generateFieldDecls :: String -> [Decl] -generateFieldDecls fStr = - -- foo :: forall msg msg' . Field.HasField "foo" msg msg' - -- => Lens.Lens msg msg' (Field.Field "foo" msg) - -- (Field.Field "foo" msg') - -- foo = Field.field (Field.ProxySym :: Field.Proxy "foo") - [ TypeSig noLoc [f] - $ TyForall (Just ["msg", "msg'"]) - [ClassA "Data.ProtoLens.HasField" [fSym, "msg", "msg'"]] - $ "Lens.Family2.Lens" @@ "msg" @@ "msg'" - @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg") - @@ ("Data.ProtoLens.Field" @@ fSym @@ "msg'") - , FunBind [match f [] - $ "Data.ProtoLens.field" - @@ ExpTypeSig noLoc "Data.ProtoLens.ProxySym" - ("Data.ProtoLens.ProxySym" @@ fSym) +generateFieldDecls xStr = + -- foo :: forall x f s t a b + -- . (Functor f, HasLens x f s t a b) + -- => LensLike f s t a b + -- foo = lensOf (Proxy# :: Proxy# x) + [ typeSig [x] + $ tyForAll ["x", "f", "s", "t", "a", "b"] + [ classA "Prelude.Functor" ["f"] + , classA "Lens.Labels.HasLens" [xSym, "f", "s", "t", "a", "b"] + ] + $ "Lens.Family2.LensLike" @@ "f" @@ "s" @@ "t" @@ "a" @@ "b" + , funBind [match x [] + $ "Lens.Labels.lensOf" + @@ ("Lens.Labels.proxy#" @::@ + ("Lens.Labels.Proxy#" @@ xSym)) ] ] where - f = Ident fStr - fSym = TyPromoted $ PromotedString fStr + x = fromString xStr + xSym = tyPromotedString xStr ------------------------------------------ @@ -439,13 +419,13 @@ baseName = overloadedField f fd = fieldDescriptor f baseType = hsFieldType env fd - listType = TyList baseType + listType = tyList baseType maybeType = "Prelude.Maybe" @@ baseType maybeName = "maybe'" ++ baseName maybeAccessor = "Prelude.." @@ fromString maybeName @@ ("Data.ProtoLens.maybeLens" @@ hsFieldValueDefault env fd) - rawAccessor = rawFieldAccessor $ UnQual $ recordFieldName f + rawAccessor = rawFieldAccessor $ unQual $ recordFieldName f -- Get the key/value types of this type, if it is really a map. getMapFields :: Env QName -> FieldDescriptorProto @@ -469,17 +449,17 @@ FieldDescriptorProto'TYPE_BOOL -> "Prelude.Bool" FieldDescriptorProto'TYPE_STRING -> "Data.Text.Text" FieldDescriptorProto'TYPE_GROUP - | Message m <- definedFieldType fd env -> TyCon $ messageName m + | Message m <- definedFieldType fd env -> tyCon $ messageName m | otherwise -> error $ "expected TYPE_GROUP for type name" ++ unpack (fd ^. typeName) FieldDescriptorProto'TYPE_MESSAGE - | Message m <- definedFieldType fd env -> TyCon $ messageName m + | Message m <- definedFieldType fd env -> tyCon $ messageName m | otherwise -> error $ "expected TYPE_MESSAGE for type name" ++ unpack (fd ^. typeName) FieldDescriptorProto'TYPE_BYTES -> "Data.ByteString.ByteString" FieldDescriptorProto'TYPE_UINT32 -> "Data.Word.Word32" FieldDescriptorProto'TYPE_ENUM - | Enum e <- definedFieldType fd env -> TyCon $ enumName e + | Enum e <- definedFieldType fd env -> tyCon $ enumName e | otherwise -> error $ "expected TYPE_ENUM for type name" ++ unpack (fd ^. typeName) FieldDescriptorProto'TYPE_SFIXED32 -> "Data.Int.Int32" @@ -495,7 +475,7 @@ | otherwise -> "Prelude.Nothing" FieldDescriptorProto'LABEL_REPEATED | Just _ <- getMapFields env fd -> "Data.Map.empty" - | otherwise -> List [] + | otherwise -> list [] -- TODO: More sensible initialization of required fields. FieldDescriptorProto'LABEL_REQUIRED -> hsFieldValueDefault env fd @@ -509,7 +489,7 @@ , Just v <- List.lookup def [ (enumValueDescriptor v ^. name, enumValueName v) | v <- enumValues e ] - -> Con v + -> con v | otherwise -> errorMessage "enum" -- The rest of the cases are for scalar fields that have a fieldDefault -- instance. @@ -519,10 +499,10 @@ | def == "false" -> "Prelude.False" | otherwise -> errorMessage "bool" FieldDescriptorProto'TYPE_STRING - -> "Data.Text.pack" @@ Lit (String $ T.unpack def) + -> "Data.Text.pack" @@ stringExp (T.unpack def) FieldDescriptorProto'TYPE_BYTES -> "Data.ByteString.pack" - @@ List ((mkByte . fromEnum) <$> T.unpack def) + @@ list ((mkByte . fromEnum) <$> T.unpack def) where mkByte c | c > 0 && c < 255 = litInt $ fromIntegral c | otherwise = errorMessage "bytes" @@ -555,9 +535,9 @@ rawFieldAccessor :: QName -> Exp rawFieldAccessor f = "Lens.Family2.Unchecked.lens" @@ getter @@ setter where - getter = Var f - setter = Lambda noLoc ["x__", "y__"] - $ RecUpdate "x__" [FieldUpdate f "y__"] + getter = var f + setter = lambda ["x__", "y__"] + $ recUpdate "x__" [fieldUpdate f "y__"] descriptorExpr :: SyntaxType -> Env QName -> MessageInfo Name -> Exp descriptorExpr syntaxType env m @@ -569,13 +549,13 @@ -- -- (Note that the two maps have the same elements but different keys. We -- use the "let" expression to share elements between the two maps.) - = Let (BDecls $ map fieldDescriptorVarBind $ messageFields m) + = let' (map (fieldDescriptorVarBind $ messageName m) $ messageFields m) $ "Data.ProtoLens.MessageDescriptor" - @@ ("Data.Map.fromList" @@ List fieldsByTag) - @@ ("Data.Map.fromList" @@ List fieldsByTextFormatName) + @@ ("Data.Map.fromList" @@ list fieldsByTag) + @@ ("Data.Map.fromList" @@ list fieldsByTextFormatName) where fieldsByTag = - [Tuple Boxed + [tuple [ t, fieldDescriptorVar f ] | f <- messageFields m , let t = "Data.ProtoLens.Tag" @@ -583,19 +563,19 @@ $ fieldDescriptor f ^. number) ] fieldsByTextFormatName = - [Tuple Boxed + [tuple [ t, fieldDescriptorVar f ] | f <- messageFields m - , let t = Lit $ Syntax.String $ T.unpack - $ textFormatFieldName env (fieldDescriptor f) + , let t = stringExp $ T.unpack $ textFormatFieldName env + (fieldDescriptor f) ] fieldDescriptorVar = fromString . fieldDescriptorName fieldDescriptorName f = fromString $ overloadedField f ++ "__field_descriptor" - fieldDescriptorVarBind f - = FunBind + fieldDescriptorVarBind n f + = funBind [match (fromString $ fieldDescriptorName f) [] - $ fieldDescriptorExpr syntaxType env f + $ fieldDescriptorExpr syntaxType env n f ] -- | Get the name of the field when used in a text format proto. Groups are @@ -610,24 +590,28 @@ ++ T.unpack (descr ^. typeName) _ -> descr ^. name -fieldDescriptorExpr :: SyntaxType -> Env QName -> FieldInfo +fieldDescriptorExpr :: SyntaxType -> Env QName -> Name -> FieldInfo -> Exp -fieldDescriptorExpr syntaxType env f - = "Data.ProtoLens.FieldDescriptor" - -- Record the .proto field name as used in text format - @@ Lit (Syntax.String $ T.unpack $ textFormatFieldName env fd) +fieldDescriptorExpr syntaxType env n f = + ("Data.ProtoLens.FieldDescriptor" + -- Record the original .proto name for text format + @@ stringExp (T.unpack $ textFormatFieldName env fd) -- Force the type signature since it can't be inferred for Map entry -- types. - @@ ExpTypeSig noLoc (fieldTypeDescriptorExpr (fd ^. type')) - ("Data.ProtoLens.FieldTypeDescriptor" - @@ hsFieldType env fd) - @@ fieldAccessorExpr syntaxType env f + @@ (fieldTypeDescriptorExpr (fd ^. type') + @::@ + ("Data.ProtoLens.FieldTypeDescriptor" + @@ hsFieldType env fd)) + @@ fieldAccessorExpr syntaxType env f) + -- TODO: why is this type sig needed? + @::@ + ("Data.ProtoLens.FieldDescriptor" @@ tyCon (unQual n)) where fd = fieldDescriptor f fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp -- (PlainField Required foo), (OptionalField foo), etc... -fieldAccessorExpr syntaxType env f = accessorCon @@ Var (UnQual hsFieldName) +fieldAccessorExpr syntaxType env f = accessorCon @@ var (unQual hsFieldName) where fd = fieldDescriptor f accessorCon = case fd ^. label of @@ -647,7 +631,7 @@ then "Data.ProtoLens.Packed" else "Data.ProtoLens.Unpacked" hsFieldName - = Ident $ case fd ^. label of + = fromString $ case fd ^. label of FieldDescriptorProto'LABEL_OPTIONAL | not (isDefaultingOptional syntaxType fd) -> "maybe'" ++ overloadedField f diff --git a/src/Data/ProtoLens/Compiler/Plugin.hs b/src/Data/ProtoLens/Compiler/Plugin.hs --- a/src/Data/ProtoLens/Compiler/Plugin.hs +++ b/src/Data/ProtoLens/Compiler/Plugin.hs @@ -22,9 +22,9 @@ import qualified Data.Map.Strict as Map import Data.Map.Strict (Map, unions, (!)) import Data.Monoid ((<>)) +import Data.String (fromString) import qualified Data.Text as T import Data.Text (Text) -import Language.Haskell.Exts.Syntax (ModuleName(..), Name(..), QName(..)) import Lens.Family2 import Proto.Google.Protobuf.Descriptor (FileDescriptorProto, name, dependency, publicDependency) @@ -32,6 +32,7 @@ import Data.ProtoLens.Compiler.Definitions +import Data.ProtoLens.Compiler.Combinators (ModuleName, Name, QName) -- | The filename of an input .proto file. type ProtoFileName = Text @@ -84,7 +85,7 @@ -- | Get the Haskell 'ModuleName' corresponding to a given .proto file. moduleName :: Text -> FileDescriptorProto -> ModuleName -moduleName modulePrefix fd = ModuleName (moduleNameStr modulePrefix fd) +moduleName modulePrefix fd = fromString (moduleNameStr modulePrefix fd) -- | Get the Haskell module name corresponding to a given .proto file. moduleNameStr :: Text -> FileDescriptorProto -> String diff --git a/src/protoc-gen-haskell.hs b/src/protoc-gen-haskell.hs --- a/src/protoc-gen-haskell.hs +++ b/src/protoc-gen-haskell.hs @@ -5,6 +5,7 @@ -- https://developers.google.com/open-source/licenses/bsd {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Main where import qualified Data.ByteString as B @@ -17,8 +18,6 @@ import qualified Data.Text as T import Data.Text (Text, pack) import Data.ProtoLens (decodeMessage, def, encodeMessage) -import Language.Haskell.Exts.Pretty (prettyPrint) -import Language.Haskell.Exts.Syntax (ModuleName(..), Name(..), QName(..)) import Lens.Family2 import Proto.Google.Protobuf.Compiler.Plugin ( CodeGeneratorRequest @@ -37,6 +36,11 @@ import System.FilePath (dropExtension, replaceExtension, splitDirectories) import Text.Read (readEither) +import Data.ProtoLens.Compiler.Combinators + ( ModuleName + , Name + , QName + , prettyPrint) import Data.ProtoLens.Compiler.Definitions import Data.ProtoLens.Compiler.Generate import Data.ProtoLens.Compiler.Plugin @@ -87,7 +91,7 @@ modifyImports (definitions file) (collectEnvFromDeps deps filesByName) - in [ ( outputFilePath . (\(ModuleName n) -> n) . haskellModule $ file + in [ ( outputFilePath . prettyPrint . haskellModule $ file , header (descriptor file) <> pack (prettyPrint $ buildFile file) ) | fileName <- toGenerate