proto-lens-protoc 0.1.0.5 → 0.2.0.0

raw patch · 6 files changed

+412/−201 lines, 6 filesdep +lens-labelsdep ~directorydep ~haskell-src-extsdep ~proto-lensPVP ok

version bump matches the API change (PVP)

Dependencies added: lens-labels

Dependency ranges changed: directory, haskell-src-exts, proto-lens, proto-lens-descriptors

API changes (from Hackage documentation)

Files

• proto-lens-protoc.cabal +11/−9
• src/Data/ProtoLens/Compiler/Combinators.hs +232/−29
• src/Data/ProtoLens/Compiler/Definitions.hs +33/−16
• src/Data/ProtoLens/Compiler/Generate.hs +126/−142
• src/Data/ProtoLens/Compiler/Plugin.hs +3/−2
• src/protoc-gen-haskell.hs +7/−3

@@ -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:

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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