content: {-# LANGUAGE NamedFieldPuns, RecordWildCards, ViewPatterns, CPP, MultiWayIf #-}
  -- This module uses the Reflection data structures (ProtoInfo,EnumInfo,DescriptorInfo) to
  -- build an AST using Language.Haskell.Syntax.  This get quite verbose, so a large number
  -- of helper functions (and operators) are defined to aid in specifying the output code.
  --
  -- Note that this may eventually also generate hs-boot files to allow
  -- for breaking mutual recursion.
  --
  -- Mangling: For the current moment, assume the mangling is done in a prior pass:
  --   (*) Uppercase all module names and type names and enum constants
  --   (*) lowercase all field names
  --   (*) add a prime after all field names than conflict with reserved words
  --
  -- The names are also assumed to have become fully-qualified, and all
  -- the optional type codes have been set.
  --
  module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,oneofModule,serviceModule,prettyPrint) where
  
  import Text.DescriptorProtos.FieldDescriptorProto.Type hiding (Type)
  
  import Text.ProtocolBuffers.Basic
  import Text.ProtocolBuffers.Identifiers
  import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),SomeRealFloat(..),DescriptorInfo(..),ProtoInfo(..),OneofInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),FieldInfo(..),ServiceInfo(..),MethodInfo(..))
  
  import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(Result(..),VertexKind(..),pKey,pfKey,getKind,Part(..))
  
  import Data.Monoid ((<>))
  import qualified Data.ByteString.Lazy.Char8 as LC(unpack)
  import qualified Data.Foldable as F(foldr,toList)
  import Data.List(sortBy,foldl',foldl1',group,sort,union)
  import Data.Function(on)
  import qualified Data.Char as Char
  import Language.Haskell.Exts.Pretty(prettyPrint)
  import Language.Haskell.Exts.Syntax hiding (Int,String)
  import Language.Haskell.Exts.Syntax as Hse
  import Data.Char(isLower,isUpper)
  import qualified Data.Map as M
  import Data.Maybe(mapMaybe,catMaybes,fromJust)
  import Data.List (dropWhileEnd, nub)
  import           Data.Sequence (ViewL(..),(><),empty,singleton)
  import qualified Data.Sequence as Seq
  import qualified Data.Set as S
  import System.FilePath(joinPath)
  import Data.Char (toLower)
  
  ecart :: String -> a -> a
  ecart _ x = x
  
  default (Int)
  
  -- -- -- -- Helper functions
  
  imp :: String -> a
  imp s = error ("Impossible? Text.ProtocolBuffers.ProtoCompile.Gen."++s)
  
  nubSort :: Ord a => [a] -> [a]
  nubSort = map head . group . sort
  
  noWhere :: Maybe (Binds ())
  noWhere = Nothing
  
  whereBinds :: Binds () -> Maybe (Binds ())
  whereBinds = Just
  
  
  ($$) :: Exp () -> Exp () -> Exp ()
  ($$) = App ()
  
  infixl 1 $$
  
  litStr :: String -> Exp ()
  litStr s = Lit () $ Hse.String () s s
  
  litIntP :: Integral x => x -> Pat ()
  litIntP (toInteger -> x)
      | x<0 = PParen () $ PLit () (Signless ()) (Hse.Int () x (show x))
      | otherwise = PLit () (Signless ()) (Hse.Int () x (show x))
  
  -- Pin down the type inference
  litIntP' :: Int -> Pat ()
  litIntP' = litIntP
  
  litInt :: Integral x => x -> Exp ()
  litInt (toInteger -> x)
      | x<0 = Paren () $ Lit () (Hse.Int () x (show x))
      | otherwise = Lit () (Hse.Int () x (show x))
  
  litInt' :: Int -> Exp ()
  litInt' = litInt
  
  typeApp :: String -> Type () -> Type ()
  typeApp s = TyApp () (TyCon () (private s))
  
  -- private is for Text.ProtocolBuffers.Header, prelude is for Prelude, local is unqualified
  private :: String -> QName ()
  private t = Qual () (ModuleName () "P'") (Ident () t)
  
  prelude :: String -> QName ()
  prelude t = Qual () (ModuleName () "Prelude'") (Ident () t)
  
  local :: String -> QName ()
  local t = UnQual () (Ident () t)
  
  localField :: DescriptorInfo -> String -> QName ()
  localField di t = UnQual () (fieldIdent di t)
  
  -- pvar and preludevar and lvar are for lower-case identifiers
  isVar :: String -> Bool
  isVar (x:_) = isLower x || x == '_' || x == '<' || x == '+'
  isVar _ = False
  
  isCon :: String -> Bool
  isCon (x:_) = isUpper x
  isCon _ = False
  
  pvar :: String -> Exp ()
  pvar t | isVar t = Var () (private t)
         | otherwise = error $ "hprotoc Gen.hs assertion failed: pvar expected lower-case first letter in " ++ show t
  
  preludevar :: String -> Exp ()
  preludevar t | isVar t = Var () (prelude t)
               | otherwise = error $ "hprotoc Gen.hs assertion failed: preludevar expected lower-case first letter in " ++ show t
  
  lvar :: String -> Exp ()
  lvar t | isVar t = Var () (local t)
         | otherwise = error $ "hprotoc Gen.hs assertion failed: lvar expected lower-case first letter in " ++ show t
  
  -- pcon and preludecon and lcon are for upper-case identifiers
  pcon :: String -> Exp ()
  pcon t | isCon t = Con () (private t)
         | otherwise = error $ "hprotoc Gen.hs assertion failed: pcon expected upper-case first letter in " ++ show t
  
  preludecon :: String -> Exp ()
  preludecon t | isCon t = Con () (prelude t)
               | otherwise = error $ "hprotoc Gen.hs assertion failed: preludecon expected upper-case first letter in " ++ show t
  
  lcon :: String -> Exp ()
  lcon t | isCon t = Con () (local t)
         | otherwise = error $ "hprotoc Gen.hs assertion failed: lcon expected upper-case first letter in " ++ show t
  
  -- patvar is a pattern that binds a new lower-case variable name
  patvar :: String -> Pat ()
  patvar t | isVar t = PVar () (Ident () t)
           | otherwise = error $ "hprotoc Gen.hs assertion failed: patvar expected lower-case first letter in " ++ show t
  
  match :: String -> [Pat ()] -> Exp () -> Match ()
  match s p r = Match () (Ident () s) p (UnGuardedRhs () r) noWhere
  
  inst :: String -> [Pat ()] -> Exp () -> InstDecl ()
  inst s p r  = InsDecl () $ FunBind () [match s p r]
  
  defun :: String -> [Pat ()] -> Exp () -> Decl ()
  defun s p r  = FunBind () [match s p r]
  
  mkOp :: String -> Exp () -> Exp () -> Exp ()
  mkOp s a b = InfixApp () a (QVarOp () (UnQual () (Symbol () s))) b
  
  compose :: Exp () -> Exp () -> Exp ()
  compose = mkOp "."
  
  fqMod :: ProtoName -> String
  fqMod (ProtoName _ a b c) = joinMod $ a++b++[c]
  
  -- importPN takes the Result to look up the target info, it takes the
  -- current MKey (pKey of protoName, no 'Key appended), and Part to
  -- identify the module being created.  The ProtoName is the target
  -- TYPE that is needed.
  importPN :: Result -> ModuleName () -> Part -> ProtoName -> Maybe (ImportDecl ())
  importPN r selfMod@(ModuleName () self) part pn =
    let o = pKey pn
        m1 = ModuleName () (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))
        m2 = ModuleName () (joinMod (parentModule pn))
        fromSource = S.member (FMName self,part,o) (rIBoot r)
        ans = if m1 == selfMod && part /= KeyFile then Nothing
                else Just $ ImportDecl () m1 True fromSource False Nothing (Just m2) Nothing
    in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $
                   [("selfMod",show selfMod)
                   ,("part",show part)
                   ,("pn",show pn)
                   ,("o",show o)
                   ,("m1",show m1)
                   ,("m2",show m2)
                   ,("fromSource",show fromSource)
                   ,("ans",show ans)]) $
       ans
  
  importPFN :: Result -> ModuleName () -> ProtoFName -> Maybe (ImportDecl ())
  importPFN r m@(ModuleName () self) pfn =
    let o@(FMName _other) = pfKey pfn
        m1@(ModuleName () m1') = ModuleName () (joinMod (haskellPrefix' pfn ++ parentModule' pfn))
        m2 = ModuleName () (joinMod (parentModule' pfn))
        spec = Just (ImportSpecList () False [IVar () (Ident () (fName (baseName' pfn)))])
        kind = getKind r o
        fromAlt = S.member (FMName self,FMName m1') (rIKey r)
        m1key = if kind == SplitKeyTypeBoot && fromAlt
                  then keyFile m1
                  else m1
        qualifiedFlag = (m1 /= m)
        qualifiedName | qualifiedFlag = if m2/=m1key then Just m2 else Nothing
                      | otherwise = Nothing
        sourceFlag = (kind == KeyTypeBoot) && fromAlt
        ans = if not qualifiedFlag && kind /= SplitKeyTypeBoot then Nothing else Just $
                ImportDecl () m1key qualifiedFlag sourceFlag False Nothing qualifiedName spec
    in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $
                  [("m",show m)
                  ,("pfn",show pfn)
                  ,("o",show o)
                  ,("m1",show m1)
                  ,("m2",show m2)
                  ,("kind",show kind)
                  ,("ans",show ans)]) $
       ans
  
  
  importO :: Result -> ModuleName () -> Part -> OneofInfo -> Maybe [ImportDecl ()]
  importO r selfMod@(ModuleName () self) part oi =
    let pn = oneofName oi
        o = pKey pn
        m1 = ModuleName () (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))
        m3 = ModuleName () (joinMod (parentModule pn ++ [baseName pn]))
        fromSource = S.member (FMName self,part,o) (rIBoot r)
        iabsget = map (IAbs () (NoNamespace ()) . Ident () . fst . oneofGet) . F.toList .  oneofFields $ oi
        ithall = IThingAll () (Ident () (mName (baseName pn)))
  
        ans2 = ImportDecl () m1 True fromSource False Nothing (Just m3)
                  (Just (ImportSpecList () False (ithall:iabsget)))
    in  if m1 == selfMod && part /= KeyFile
          then Nothing
          else Just [ans2]
  
  -- Several items might be taken from the same module, combine these statements
  mergeImports :: [ImportDecl ()] -> [ImportDecl ()]
  mergeImports importsIn =
    let idKey ImportDecl{..} = (importModule,importQualified,importSrc,importAs,fmap (\(ImportSpecList _ _ xs) -> xs) importSpecs)
        mergeImports' ImportDecl{importSpecs=Just (ImportSpecList () hiding xs), ..} ImportDecl{importSpecs=Just (ImportSpecList () _ ys)} =
            ImportDecl{importSpecs=Just (ImportSpecList () hiding (xs `union` ys)), ..}
        mergeImports' i _ = i -- identical, so drop one
        combined = M.fromListWith mergeImports' . map (\ i -> (idKey i,i)) $ importsIn
    in M.elems combined
  
  keyFile :: ModuleName () -> ModuleName ()
  keyFile (ModuleName () s) = ModuleName () (s++"'Key")
  
  joinMod :: [MName String] -> String
  joinMod [] = ""
  joinMod ms = fmName $ foldr1 dotFM . map promoteFM $ ms
  
  baseIdent :: ProtoName -> Name ()
  baseIdent = Ident () . mName . baseName
  baseIdent' :: ProtoFName -> Name ()
  baseIdent' pfn = Ident () $ baseNamePrefix' pfn ++ fName (baseName' pfn)
  
  fieldIdent :: DescriptorInfo -> String -> Name ()
  fieldIdent di str | makeLenses di = Ident () ('_':str)
                    | otherwise = Ident () str
  
  qualName :: ProtoName -> QName ()
  qualName p@(ProtoName _ _prefix [] _base) = UnQual () (baseIdent p)
  qualName p@(ProtoName _ _prefix (parents) _base) = Qual () (ModuleName () (joinMod parents)) (baseIdent p)
  
  qualFName :: ProtoFName -> QName ()
  qualFName p@(ProtoFName _ _prefix [] _base _basePrefix) = UnQual () (baseIdent' p)
  qualFName p@(ProtoFName _ _prefix parents _base _basePrefix) = Qual () (ModuleName () (joinMod parents)) (baseIdent' p)
  
  unqualName :: ProtoName -> QName ()
  unqualName p = UnQual () (baseIdent p)
  
  unqualFName :: ProtoFName -> QName ()
  unqualFName p = UnQual () (baseIdent' p)
  
  mayQualName :: ProtoName -> ProtoFName -> QName ()
  mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base _basePrefix) =
    if joinMod (c'prefix++c'parents++[c'base]) == joinMod (prefix++parents)
      then UnQual () (baseIdent' name) -- name is local, make UnQual
      else qualFName name           -- name is imported, make Qual
  
  
  --------------------------------------------
  -- utility for OneofInfo
  --------------------------------------------
  
  oneofCon :: (ProtoName,FieldInfo) -> Exp ()
  oneofCon (name,_) = Con () (qualName name)
  
  oneofPat :: (ProtoName,FieldInfo) -> (Pat (),Pat ())
  oneofPat (name,fi) =
    let fName@(Ident () _fname) = baseIdent' (fieldName fi)
    in (PApp () (qualName name) [PVar () fName],PApp () (unqualName name) [PVar () fName])
  
  oneofRec :: (ProtoName,FieldInfo) -> (Exp (),Exp ())
  oneofRec (_,fi) =
    let (Ident () fname) = baseIdent' (fieldName fi)
    in (litStr fname,lvar fname)
  
  oneofGet :: (ProtoName,FieldInfo) -> (String,ProtoName)
  oneofGet (p,fi) =
    let Ident () fname = baseIdent' (fieldName fi)
        unqual = "get'" ++ fname
        p' = p { baseName = MName unqual }
    in (unqual,p')
  
  --------------------------------------------
  -- Define LANGUAGE options as [ModulePramga]
  --------------------------------------------
  modulePragmas :: Bool -> [ModulePragma ()]
  modulePragmas templateHaskell =
    [ LanguagePragma () (map (Ident ()) $
        thPragma ++ ["BangPatterns", "DataKinds","DeriveDataTypeable","DeriveGeneric","FlexibleInstances","MultiParamTypeClasses","OverloadedStrings"]
      )
    , OptionsPragma () (Just GHC) " -w "
    ]
    where thPragma | templateHaskell = ["TemplateHaskell"]
                   | otherwise       = []
  
  --------------------------------------------
  -- OneofDescriptorProto module creation
  --------------------------------------------
  oneofModule :: Result -> OneofInfo -> Module ()
  oneofModule result oi
    = Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing Nothing)) (modulePragmas $ oneofMakeLenses oi)
           imports (oneofDecls oi)
    where protoName = oneofName oi
          typs = mapMaybe typeName . F.toList . fmap snd . oneofFields $ oi
          imports = (standardImports False False (oneofMakeLenses oi))
                    ++ (mergeImports (mapMaybe (importPN result (ModuleName () (fqMod protoName)) Normal) typs))
  
  
  oneofDecls :: OneofInfo -> [Decl ()]
  oneofDecls oi = (oneofX oi : oneofFuncs oi) ++ lenses ++ instances
    where
      mkPrisms = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makePrisms"))
      lenses | oneofMakeLenses oi = [SpliceDecl () (mkFun $$ TypQuote () (unqualName (oneofName oi))) |
                                     mkFun <- [mkLenses, mkPrisms]]
             | otherwise = []
      instances = [ instanceDefaultOneof oi
                  , instanceMergeableOneof oi
                  ]
  
  oneofX :: OneofInfo -> Decl ()
  oneofX oi = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (oneofName oi)))
                (map oneofValueX (F.toList (oneofFields oi) ))
                (return derives)
    where oneofValueX (pname,fi) = QualConDecl () Nothing Nothing con
            where con = RecDecl () (baseIdent pname) [fieldX]
                  fieldX = FieldDecl () [baseIdent' . fieldName $ fi] (TyParen () (TyCon () typed ))
                  typed = case useType (getFieldType (typeCode fi)) of
                            Just s -> private s
                            Nothing -> case typeName fi of
                                         Just s -> qualName s
                                         Nothing -> imp $ "No Name for Field!\n" ++ show fi
  
  oneofFuncs :: OneofInfo -> [Decl ()]
  oneofFuncs oi = map mkfuns (F.toList (oneofFields oi))
    where mkfuns f = defun (fst (oneofGet f)) [patvar "x"] $
                       Case () (lvar "x")
                         [ Alt () (snd (oneofPat f))
                           (UnGuardedRhs () (preludecon "Just" $$ snd (oneofRec f))) noWhere
                         , Alt () (PWildCard ())
                           (UnGuardedRhs () (preludecon "Nothing")) noWhere
                         ]
  
  
  
  {- oneof field does not have to have a default value, but for convenience
     (to make all messages an instance of Default and Mergeable), we make
     the first case as default like enum. -}
  
  instanceDefaultOneof :: OneofInfo -> Decl ()
  instanceDefaultOneof oi
      =  InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (oneofName oi))]) . Just $
        [ inst "defaultValue" [] firstValue ]
    where firstValue :: Exp ()
          firstValue = case Seq.viewl (oneofFields oi) of
                         EmptyL -> imp ("instanceDefaultOneof: empty in " ++ show oi)
                         (n,_) :< _ -> case (baseIdent n) of
                                         Ident () str -> App () (lcon str) (pvar "defaultValue")
                                         Symbol () _ -> imp ("instanceDefaultOneof: " ++ show n)
  
  instanceMergeableOneof :: OneofInfo -> Decl ()
  instanceMergeableOneof oi
    = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (oneofName oi))]) Nothing
  
  
  --------------------------------------------
  -- EnumDescriptorProto module creation
  --------------------------------------------
  enumModule :: EnumInfo -> Module ()
  enumModule ei
      = let protoName = enumName ei
            exportList =
                (Just (ExportSpecList () [EThingWith () (EWildcard () 0) (unqualName protoName) []]))
        in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing exportList)) (modulePragmas False)
             (standardImports True False False) (enumDecls ei)
  
  enumDecls :: EnumInfo -> [Decl ()]
  enumDecls ei = map ($ ei) [ enumX
                             , instanceMergeableEnum
                             , instanceBounded
                             , instanceDefaultEnum ]
                  ++ declToEnum ei ++
                  map ($ ei) [ instanceEnum
                             , instanceWireEnum
                             , instanceGPB . enumName
                             , instanceMessageAPI . enumName
                             , instanceReflectEnum
                             , instanceTextTypeEnum
                             ] ++
                  filter (const (enumJsonInstances ei))
                             [ instanceToJSONEnum ei
                             , instanceFromJSONEnum ei
                             ]
  
  enumX :: EnumInfo -> Decl ()
  enumX ei = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (enumName ei))) (map enumValueX (enumValues ei)) (return derivesEnum)
    where enumValueX (_,name) = QualConDecl () Nothing Nothing (ConDecl () (Ident () name) [])
  
  instanceToJSONEnum :: EnumInfo -> Decl ()
  instanceToJSONEnum ei
    = InstDecl () Nothing (mkSimpleIRule (private "ToJSON") [TyCon () (unqualName (enumName ei))]) . Just $
        [ inst "toJSON" [patvar "msg'"] (pcon "String" $$ Paren () (Case () (lvar "msg'") alts))
        ]
        where
          mkAlt :: String -> Alt ()
          mkAlt alt = Alt () (PApp () (UnQual () (Ident () alt)) []) (UnGuardedRhs () $ litStr alt) Nothing
          alts = map (mkAlt . snd) (enumValues ei)
  
  instanceFromJSONEnum :: EnumInfo -> Decl ()
  instanceFromJSONEnum ei
    = InstDecl () Nothing (mkSimpleIRule (private "FromJSON") [TyCon () (unqualName name)]) . Just $
        [ inst "parseJSON" [] (pvar "withText" $$ litStr name' $$ Paren () (Lambda () [patvar "msg'"] body))
        ]
        where
          name = enumName $ ei
          name' = joinMod (haskellPrefix name ++ parentModule name ++ [baseName name, baseName name])
          body = Case () (lvar "msg'") alts
          mkAlt (_, alt) = Alt () (PLit () (Signless ()) (String () alt alt)) (UnGuardedRhs () (preludevar "return" $$ lcon alt)) Nothing
          alts =
              map mkAlt (enumValues ei) ++
              [ Alt () (PWildCard ()) (UnGuardedRhs () $ preludevar "fail" $$ Paren () (litStr "Invalid value " $$ preludevar "++" $$ preludevar "show" $$ lvar "msg'" $$ preludevar "++" $$ litStr (" for enum "++name'))) Nothing ]
  
  instanceTextTypeEnum :: EnumInfo -> Decl ()
  instanceTextTypeEnum ei
    = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (enumName ei))]) . Just $
        [ inst "tellT" [] (pvar "tellShow")
        , inst "getT" [] (pvar "getRead")
        ]
  
  instanceMergeableEnum :: EnumInfo -> Decl ()
  instanceMergeableEnum ei
    = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (enumName ei))]) Nothing
  
  instanceBounded :: EnumInfo -> Decl ()
  instanceBounded ei
      = InstDecl () Nothing (mkSimpleIRule (prelude "Bounded") [TyCon () (unqualName (enumName ei))]) .Just $
           [set "minBound" (head values),set "maxBound" (last values)] -- values cannot be null in a well formed enum
    where values = enumValues ei
          set f (_,n) = inst f [] (lcon n)
  
  {- from google's descriptor.h, about line 346:
  
    // Get the field default value if cpp_type() == CPPTYPE_ENUM.  If no
    // explicit default was defined, the default is the first value defined
    // in the enum type (all enum types are required to have at least one value).
    // This never returns NULL.
  
  -}
  instanceDefaultEnum :: EnumInfo -> Decl ()
  instanceDefaultEnum ei
      = InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (enumName ei))]) . Just $
        [ inst "defaultValue" [] firstValue ]
    where firstValue :: Exp ()
          firstValue = case enumValues ei of
                         (:) (_,n) _ -> lcon n
                         [] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei
  
  declToEnum :: EnumInfo -> [Decl ()]
  declToEnum ei = [ TypeSig () [Ident () "toMaybe'Enum"]
                      (TyFun () (TyCon () (prelude "Int"))
                             (typeApp "Maybe" (TyCon () (unqualName (enumName ei)))))
                  , FunBind () (map toEnum'one values ++ [final]) ]
    where values = enumValues ei
          toEnum'one (v,n) = match "toMaybe'Enum" [litIntP (getEnumCode v)] (preludecon "Just" $$ lcon n)
          final = match "toMaybe'Enum" [PWildCard ()] (preludecon "Nothing")
  
  instanceEnum :: EnumInfo -> Decl ()
  instanceEnum ei
      = InstDecl () Nothing (mkSimpleIRule (prelude "Enum") [TyCon () (unqualName (enumName ei))]) . Just $
          (map (InsDecl () . FunBind ()) [fromEnum',toEnum',succ',pred'])
    where values = enumValues ei
          fromEnum' = map fromEnum'one values
          fromEnum'one (v,n) = match "fromEnum" [PApp () (local n) []] (litInt (getEnumCode v))
          toEnum' = [ match "toEnum" [] (compose mayErr (lvar "toMaybe'Enum")) ]
          mayErr = pvar "fromMaybe" $$ (Paren () (preludevar "error" $$  (litStr $
                     "hprotoc generated code: toEnum failure for type "++ fqMod (enumName ei))))
          succ' = zipWith (equate "succ") values (tail values) ++
                  [ match "succ" [PWildCard ()] (preludevar "error" $$  (litStr $
                     "hprotoc generated code: succ failure for type "++ fqMod (enumName ei))) ]
          pred' = zipWith (equate "pred") (tail values) values ++
                  [ match "pred" [PWildCard ()] (preludevar "error" $$  (litStr $
                     "hprotoc generated code: pred failure for type "++ fqMod (enumName ei))) ]
          equate f (_,n1) (_,n2) = match f [PApp () (local n1) []] (lcon n2)
  
  -- fromEnum TYPE_ENUM == 14 :: Int
  instanceWireEnum :: EnumInfo -> Decl ()
  instanceWireEnum ei
      = InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () (unqualName (enumName ei))]) . Just $
          [ withName "wireSize", withName "wirePut", withGet, withGetErr,withGetPacked,withGetPackedErr ]
    where withName foo = inst foo [patvar "ft'",patvar "enum"] rhs
            where rhs = pvar foo $$ lvar "ft'" $$
                          (Paren () $ preludevar "fromEnum" $$ lvar "enum")
          withGet = inst "wireGet" [litIntP' 14] rhs
            where rhs = pvar "wireGetEnum" $$ lvar "toMaybe'Enum"
          withGetErr = inst "wireGet" [patvar "ft'"] rhs
            where rhs = pvar "wireGetErr" $$ lvar "ft'"
          withGetPacked = inst "wireGetPacked" [litIntP' 14] rhs
            where rhs = pvar "wireGetPackedEnum" $$ lvar "toMaybe'Enum"
          withGetPackedErr = inst "wireGetPacked" [patvar "ft'"] rhs
            where rhs = pvar "wireGetErr" $$ lvar "ft'"
  
  instanceGPB :: ProtoName -> Decl ()
  instanceGPB protoName
      = InstDecl () Nothing (mkSimpleIRule (private "GPB") [TyCon () (unqualName protoName)]) Nothing
  
  instanceReflectEnum :: EnumInfo -> Decl ()
  instanceReflectEnum ei
      = InstDecl () Nothing (mkSimpleIRule (private "ReflectEnum") [TyCon () (unqualName (enumName ei))]) . Just $
          [ inst "reflectEnum" [] ascList
          , inst "reflectEnumInfo" [ PWildCard () ] ei' ]
    where (ProtoName xxx a b c) = enumName ei
          xxx'Exp = Paren () $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx)))
          values = enumValues ei
          ascList,ei',protoNameExp :: Exp ()
          ascList = List () (map one values)
            where one (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns,lcon ns]
          ei' = foldl' (App ()) (pcon "EnumInfo") [protoNameExp
                                               ,List () $ map litStr (enumFilePath ei)
                                               ,List () (map two values)
                                               ,preludecon (show (enumJsonInstances ei))
                                               ]
            where two (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns]
          protoNameExp = Paren () $ foldl' (App ()) (pvar "makePNF")
                                          [ xxx'Exp, mList a, mList b, litStr (mName c) ]
            where mList = List () . map (litStr . mName)
  
  hasExt :: DescriptorInfo -> Bool
  hasExt di = not (null (extRanges di))
  
  --------------------------------------------
  -- ServiceDescriptor module creation
  --------------------------------------------
  
  serviceModule :: Result -> ServiceInfo -> Module ()
  serviceModule result si =
    Module () (Just (ModuleHead () moduleName Nothing (Just exports))) (modulePragmas False)
      (nub imports)
      (serviceDecls si)
    where
      moduleName = ModuleName () (fqMod (serviceName si))
      imports =
        standardImports True False False ++
        mapMaybe (importPN result moduleName Normal) (fmap methodInput (serviceMethods si)) ++
        mapMaybe (importPN result moduleName Normal) (fmap methodOutput (serviceMethods si))
  
      exports :: ExportSpecList ()
      exports =
        ExportSpecList () (
           [ mkAbs (UnQual () (serviceTypeName si))
           , mkEvar (UnQual () (serviceProxyName si))
           ]
           ++ fmap (\mi -> mkAbs (UnQual () (methodTypeName mi))) (serviceMethods si)
           ++ fmap (\mi -> mkEvar (UnQual () (methodProxyName mi))) (serviceMethods si)
          )
  
      mkAbs = EAbs () (NoNamespace ())
      mkEvar = EVar ()
  
  
  serviceTypeName :: ServiceInfo -> Name ()
  serviceTypeName si = baseIdent (serviceName si)
  
  serviceProxyName :: ServiceInfo -> Name ()
  serviceProxyName si = Ident () (toLower s : sx)
    where Ident () (s:sx) = baseIdent (serviceName si)
  
  methodProxyName :: MethodInfo -> Name ()
  methodProxyName mi = Ident () (toLower s : sx)
    where Ident () (s:sx) = baseIdent (methodName mi)
  
  methodTypeName :: MethodInfo -> Name ()
  methodTypeName mi = Ident () s
    where Ident _ s = baseIdent (methodName mi)
  
  serviceDecls :: ServiceInfo -> [Decl ()]
  serviceDecls si' =
    [ serviceDecl si']
    ++ serviceProxy si'
    ++ fmap (methodDecl si') (serviceMethods si')
    ++ concatMap (methodProxy si') (serviceMethods si')
    where
      serviceDecl si =
        TypeDecl () (DHead () (serviceTypeName si)) (TyApp ()
          (TyApp ()
            (TyCon () (private "Service"))
            (let s = drop 1 $ toString (fiName (protobufName (serviceName si))) in TyPromoted () (PromotedString () s (show s))))
          (TyPromoted () (
              PromotedList () True (fmap (\mx -> TyPromoted () (PromotedCon () False (UnQual () (methodTypeName mx)))) (serviceMethods si))
                     )
          ))
  
      serviceProxy si =
        [ TypeSig () [serviceProxyName si] (TyCon () (UnQual () (serviceTypeName si)))
        , PatBind () (PVar () (serviceProxyName si)) (UnGuardedRhs () (Con () (private "Service"))) Nothing
        ]
  
      methodDecl _si mi =
        TypeDecl () (DHead () (methodTypeName mi)) $
        foldl' (TyApp ()) (TyCon () (private "Method"))
          [ let Ident _ s = baseIdent (methodName mi) in TyPromoted () (PromotedString () s (show s))
          , mkStreaming (methodClientStream mi) (methodInput mi)
          , mkStreaming (methodServerStream mi) (methodOutput mi)
          ]
  
      mkStreaming streamFlag ty =
        let streamTy = TyPromoted () (PromotedCon () False (private (if streamFlag then "StreamOf" else "Single")))
            ty' = TyCon () (qualName ty)
        in TyParen () (TyApp () streamTy ty')
  
      methodProxy _si mi =
        [ TypeSig () [methodProxyName mi] (TyCon () (UnQual () (methodTypeName mi)))
        , PatBind () (PVar () (methodProxyName mi)) (UnGuardedRhs () (Con () (private "Method"))) Nothing -- (BDecls [])
        ]
  
  --------------------------------------------
  -- FileDescriptorProto module creation
  --------------------------------------------
  
  protoModule :: Result -> ProtoInfo -> ByteString -> Module ()
  protoModule result pri fdpBS
    = let protoName = protoMod pri
          (extendees,myKeys) = unzip $ F.toList (extensionKeys pri)
          m = ModuleName () (fqMod protoName)
          exportKeys = map (EVar () . unqualFName . fieldName) myKeys
          exportNames = map (EVar () . UnQual () . Ident ()) ["protoInfo","fileDescriptorProto"]
          imports = (protoImports ++) . mergeImports $
                      mapMaybe (importPN result m Normal) $
                        extendees ++ mapMaybe typeName myKeys
      in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exportKeys++exportNames))))) (modulePragmas False) imports
           (keysXTypeVal protoName (extensionKeys pri) ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)
   where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) False ++
           [ ImportDecl () (ModuleName () "Text.DescriptorProtos.FileDescriptorProto") False False False Nothing Nothing
                          (Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "FileDescriptorProto")]))
           , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Reflections") False False False Nothing Nothing
                          (Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "ProtoInfo")]))
           , ImportDecl () (ModuleName () "Text.ProtocolBuffers.WireMessage") True False False Nothing (Just (ModuleName () "P'"))
                          (Just (ImportSpecList () False [IVar () (Ident () "wireGet,getFromBS")]))
           ]
  
  embed'ProtoInfo :: ProtoInfo -> [Decl ()]
  embed'ProtoInfo pri = [ myType, myValue ]
    where myType = TypeSig () [ Ident () "protoInfo" ] (TyCon () (local "ProtoInfo"))
          myValue = PatBind () (PApp () (local "protoInfo") []) (UnGuardedRhs () $
                      preludevar "read" $$ litStr (show pri)) noWhere
  
  embed'fdpBS :: ByteString -> [Decl ()]
  embed'fdpBS bs = [ myType, myValue ]
    where myType = TypeSig () [ Ident () "fileDescriptorProto" ] (TyCon () (local "FileDescriptorProto"))
          myValue = PatBind () (PApp () (local "fileDescriptorProto") []) (UnGuardedRhs () $
                      pvar "getFromBS" $$
                        Paren () (pvar "wireGet" $$ litInt' 11) $$
                        Paren () (pvar "pack" $$ litStr (LC.unpack bs))) noWhere
  
  --------------------------------------------
  -- DescriptorProto module creation
  --------------------------------------------
  descriptorModules :: Result -> DescriptorInfo -> [(FilePath,Module ())]
  descriptorModules result di
   = let mainPath = joinPath (descFilePath di)
         bootPath = joinPath (descFilePath di) ++ "-boot"
         keyfilePath = take (length mainPath - 3) mainPath ++ "'Key.hs"
     in (mainPath,descriptorNormalModule result di) :
        case getKind result (pKey (descName di)) of
          TopProtoInfo -> imp $ "descriptorModules was given a TopProtoInfo kinded DescriptorInfo!"
          Simple -> []
          TypeBoot -> [(bootPath,descriptorBootModule di)]
          KeyTypeBoot -> [(bootPath,descriptorKeyBootModule result di)]
          SplitKeyTypeBoot -> [(bootPath,descriptorBootModule di)
                             ,(keyfilePath,descriptorKeyfileModule result di)]
  
  -- This build a hs-boot that declares the type of the data type only
  descriptorBootModule :: DescriptorInfo -> Module ()
  descriptorBootModule di
    = let protoName = descName di
          un = unqualName protoName
          classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Data", prelude "Generic"
                    ,private "Mergeable",private "Default"
                    ,private "Wire",private "GPB",private "ReflectDescriptor"
                    ,private "TextType", private "TextMsg"
                    ]
                    ++ (if hasExt di then [private "ExtendMessage"] else [])
                    ++ (if storeUnknown di then [private "UnknownMessage"] else [])
                    ++ (if jsonInstances di then [private "FromJSON", private "ToJSON"] else [])
          instMesAPI = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI")
                         [TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) Nothing
          dataDecl = DataDecl () (DataType ()) Nothing (DHead () (baseIdent protoName)) [] $
              pure derivesTypeable
          mkInst s = InstDecl () Nothing (mkSimpleIRule s [TyCon () un]) Nothing
          eabs = EAbs () (NoNamespace ()) un
      in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing (Just (ExportSpecList () [eabs])))) (modulePragmas $ makeLenses di) minimalImports
           (dataDecl : instMesAPI : map mkInst classes)
  
  -- This builds on the output of descriptorBootModule and declares a hs-boot that
  -- declares the data type and the keys
  descriptorKeyBootModule :: Result -> DescriptorInfo -> Module ()
  descriptorKeyBootModule result di
    = let Module () (Just (ModuleHead () m _ (Just (ExportSpecList () exports)))) pragmas imports decls = descriptorBootModule di
          (extendees,myKeys) = unzip $ F.toList (keys di)
          exportKeys = map (EVar () . unqualFName . fieldName) myKeys
          importTypes = mergeImports . mapMaybe (importPN result m Source) . nubSort $
                          extendees ++ mapMaybe typeName myKeys
          declKeys = keysXType (descName di) (keys di)
      in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exports++exportKeys))))) pragmas (imports++importTypes) (decls++declKeys)
  
  -- This build the 'Key module that defines the keys only
  descriptorKeyfileModule :: Result -> DescriptorInfo -> Module ()
  descriptorKeyfileModule result di
    = let protoName'Key = (descName di) { baseName = MName . (++"'Key") . mName $ (baseName (descName di)) }
          (extendees,myKeys) = unzip $ F.toList (keys di)
          mBase = ModuleName () (fqMod (descName di))
          m = ModuleName () (fqMod protoName'Key)
          exportKeys = map (EVar () . unqualFName . fieldName) myKeys
          importTypes = mergeImports . mapMaybe (importPN result mBase KeyFile) . nubSort $
                          extendees ++ mapMaybe typeName myKeys
          declKeys = keysXTypeVal protoName'Key (keys di)
      in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () exportKeys)) )) (modulePragmas $ makeLenses di) (minimalImports++importTypes) declKeys
  
  -- This builds the normal module
  descriptorNormalModule :: Result -> DescriptorInfo -> Module ()
  descriptorNormalModule result di
    = let protoName = descName di
          un = unqualName protoName
          myKind = getKind result (pKey protoName)
          sepKey = myKind == SplitKeyTypeBoot
          (extendees,myKeys) = unzip $ F.toList (keys di)
          extendees' = if sepKey then [] else extendees
          myKeys' = if sepKey then [] else myKeys
          m = ModuleName () (fqMod protoName)
          -- need to import KEY and VALUE types for each map<KEY,VALUE> field
          map_field_imports =
              map
                  (\FieldInfo{mapKeyVal = Just (kt, vt)} ->
                      catMaybes [mapFieldImportDecl kt, mapFieldImportDecl vt])
                  (F.toList $ Seq.filter isMapField (fields di))
          exportKeys :: [ExportSpec ()]
          exportKeys = map (EVar () . unqualFName . fieldName) myKeys
          -- MapField_Entry modules ((key,value) wrappers) also export their
          -- helper functions to convert from record to pair and from Map to
          -- Sequence
          map_field_exports =
              if mapEntry di then
                  [ EVar () $ mapFieldHelperFn (descName di) "ToPair" False
                  , EVar () $ mapFieldHelperFn (descName di) "ToSeq" False
                  ]
              else
                  []
          imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $
                      [ mapMaybe (importPN result m Normal) $
                          extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di)))
                      , concat . mapMaybe (importO result m Normal) $ F.toList (descOneofs di)
                      , mapMaybe (importPFN result m) (map fieldName (myKeys ++ F.toList (knownKeys di))) ]
                      ++ F.toList map_field_imports
          mkLenses = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makeLenses"))
          lenses | makeLenses di = [SpliceDecl () (mkLenses $$ TypQuote () (unqualName protoName))]
                 | otherwise = []
          declKeys | sepKey = []
                   | otherwise = keysXTypeVal (descName di) (keys di)
      in Module ()
                (Just (ModuleHead () m Nothing (Just (ExportSpecList () ((EThingWith () (EWildcard () 0) un [] : exportLenses di ++ exportKeys ++ map_field_exports))))))
                (modulePragmas $ makeLenses di)
                imports
                (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di ++ declMapHelpers di)
  
  -- | Generate imports for map field helper functions
  mapFieldImportDecl :: (FieldType, Maybe ProtoName) -> Maybe (ImportDecl ())
  mapFieldImportDecl = fmap makeImportDecl . makeModNames
      where
          makeImportDecl :: (ModuleName (), ModuleName ()) -> ImportDecl ()
          makeImportDecl (mn, as) =
              ImportDecl
                  ()        {-location-}
                  mn        {-module name-}
                  True      {-qualified-}
                  False     {-with SOURCE-}
                  False     {-SAFE-}
                  Nothing   {-package name (package imports)-}
                  (Just as) {-... as name-}
                  Nothing   {-import list-}
  
          makeModNames :: (FieldType, Maybe ProtoName) -> Maybe (ModuleName (), ModuleName ())
          makeModNames (ft, tn) =
              case useType (getFieldType ft) of
                  -- no need to import anything
                  Just _ -> Nothing
                  Nothing -> case tn of
                      Just s -> Just
                          ( ModuleName () $ fqMod s
                          , ModuleName () $ joinMod (parentModule s)
                          )
                      Nothing -> Nothing
  
  -- | Generate helper functions to convert between Map and Sequence of records
  -- representations of the message
  declMapHelpers :: DescriptorInfo -> [Decl ()]
  declMapHelpers di
      | not (mapEntry di) = []
      | otherwise         = [toPair, toSeq]
      where
          -- toPair :: MOD -> (KEY, VAL)
          -- toPair (MOD k v) = (k,v)
          toPair = FunBind ()
              [ Match ()
                  (mapFieldHelperName (descName di) "ToPair") {-name-}
                  [PVar () (Ident () "entry")]
                  (Hse.UnGuardedRhs () $           {-rhs-}
                      Hse.Tuple () Hse.Boxed [App () (lvar "key") (lvar "entry"), App () (lvar "value") (lvar "entry")])
                  Nothing                       {-binds-}
              ]
          -- toSeq :: Map.Map KEY VAL -> Seq MOD
          -- toSeq x = Seq.fromList (Prelude'.map (Prelude'.uncurry Map_field_Entry) (Map.toList x))
          toSeq = FunBind ()
              [ Match ()
                  (mapFieldHelperName (descName di) "ToSeq")
                  [PVar () (Ident () "x")]
                  (Hse.UnGuardedRhs () $
                      App () (pvar "seqFromList")
                          (App ()
                              (App ()
                                  (preludevar "map")
                                  (Paren () (Lambda ()
                                    [PTuple () Boxed [PVar () (Ident () "k"), PVar () (Ident () "v")]]
                                    (RecUpdate ()
                                      (pvar "defaultValue")
                                      [ FieldUpdate () (local "key") (lvar "k")
                                      , FieldUpdate () (local "value") (lvar "v")
                                      ])
                                  )))
                              (App () (pvar "mapToList") (lvar "x")))
                  )
                  noWhere
              ]
  
  mkLenses :: Exp ()
  mkLenses = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makeLenses"))
  
  exportLenses :: DescriptorInfo -> [ExportSpec ()]
  exportLenses di =
    if makeLenses di
      then map (EVar () . unqualFName . stripPrefix) lensFieldNames
      else []
    where stripPrefix pfn = pfn { baseNamePrefix' = "" }
          lensFieldNames = map fieldName (F.toList (fields di))
                           ++ map oneofFName (F.toList (descOneofs di))
  
  minimalImports :: [ImportDecl ()]
  minimalImports =
    [ ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.List") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing ]
  
  standardImports :: Bool -> Bool -> Bool -> [ImportDecl ()]
  standardImports isEnumMod ext lenses =
    [ ImportDecl () (ModuleName () "Prelude") False False False Nothing Nothing (Just (ImportSpecList () False ops))
    , ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.List") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
    , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing
    ] ++ lensTH
   where
         ops | ext = map (IVar () . Symbol ()) $ base ++ ["==","<=","&&"]
             | otherwise = map (IVar () . Symbol ()) base
         base | isEnumMod = ["+","/","."]
              | otherwise = ["+","/","++","."]
         lensTH | lenses = [ImportDecl () (ModuleName () "Control.Lens.TH") True False False Nothing Nothing Nothing]
                | otherwise = []
  
  keysXType :: ProtoName -> Seq KeyInfo -> [Decl ()]
  keysXType self ks = map (makeKeyType self) . F.toList $ ks
  
  keysXTypeVal :: ProtoName -> Seq KeyInfo -> [Decl ()]
  keysXTypeVal self ks = concatMap (\ ki -> [makeKeyType self ki,makeKeyVal self ki]) . F.toList $ ks
  
  makeKeyType :: ProtoName -> KeyInfo -> Decl ()
  makeKeyType self (extendee,f) = keyType
    where keyType = TypeSig () [ baseIdent' . fieldName $ f ] (foldl1 (TyApp ()) . map (TyCon ()) $
                      [ private "Key", private labeled
                      , if extendee /= self then qualName extendee else unqualName extendee
                      , typeQName ])
          labeled | isPacked f = "PackedSeq"
                  | canRepeat f = "Seq"
                  | otherwise = "Maybe"
          typeNumber = getFieldType . typeCode $ f
          typeQName :: QName ()
          typeQName = case useType typeNumber of
                        Just s -> private s
                        Nothing -> case typeName f of
                                     Just s | self /= s -> qualName s
                                            | otherwise -> unqualName s
                                     Nothing -> error $  "No Name for Field!\n" ++ show f
  
  makeKeyVal :: ProtoName -> KeyInfo -> Decl ()
  makeKeyVal _self (_extendee,f) = keyVal
    where typeNumber = getFieldType . typeCode $ f
          keyVal = PatBind () (PApp () (unqualFName . fieldName $ f) []) (UnGuardedRhs ()
                     (pcon "Key" $$ litInt (getFieldId (fieldNumber f))
                                 $$ litInt typeNumber
                                 $$ maybe (preludecon "Nothing")
                                          (Paren () . (preludecon "Just" $$) . (defToSyntax (typeCode f)))
                                          (hsDefault f)
                     )) noWhere
  
  defToSyntax :: FieldType -> HsDefault -> Exp ()
  defToSyntax tc x =
    case x of
      HsDef'Bool b -> preludecon (show b)
      HsDef'ByteString bs -> (if tc == 9 then (\ xx -> Paren () (pcon "Utf8" $$ xx)) else id) $
                             (Paren () $ pvar "pack" $$ litStr (LC.unpack bs))
      HsDef'RealFloat (SRF'Rational r) | r < 0 -> Paren () $ Lit () (Frac () r (show r))
                                       | otherwise -> Lit () (Frac () r (show r))
      HsDef'RealFloat SRF'nan  -> litInt'   0  /! litInt' 0
      HsDef'RealFloat SRF'ninf -> litInt'   1  /! litInt' 0
      HsDef'RealFloat SRF'inf  -> litInt' (-1) /! litInt' 0
      HsDef'Integer i -> litInt i
      HsDef'Enum s -> Paren () $ preludevar "read" $$ litStr s
   where (/!) a b = Paren () (mkOp "/" a b)
  
  descriptorX :: DescriptorInfo -> Decl ()
  descriptorX di = DataDecl () (DataType ()) Nothing (DHead () name) [QualConDecl () Nothing Nothing con] (return derives)
    where self = descName di
          name = baseIdent self
          (map_fields, normal_fields) = Seq.partition isMapField (fields di)
          con = RecDecl () name eFields
                  where eFields = map (\(ns, t) -> FieldDecl () ns t) $ F.foldr ((:) . fieldX) end normal_fields
                        end = (if hasExt di then pure extfield else mempty) <>
                              eOneof <>
                              eMaps <>
                              (if storeUnknown di then pure unknownField else mempty)
                        eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di)
                        eMaps  = F.foldr ((:) . fieldMapX) [] map_fields
  
          bangType = if lazyFields di then TyParen () {- UnBangedTy -} else TyBang () (BangedTy ()) (NoUnpackPragma ()) . TyParen ()
          -- extfield :: ([Name],BangType)
          extfield = ([fieldIdent di "ext'field"], bangType (TyCon () (private "ExtField")))
          -- unknownField :: ([Name],BangType)
          unknownField = ([fieldIdent di "unknown'field"], bangType (TyCon () (private  "UnknownField")))
          -- fieldX :: FieldInfo -> ([Name],BangType)
          fieldX fi = ([baseIdent' . fieldName $ fi], bangType (labeled (TyCon () typed)))
            where labeled | canRepeat fi = typeApp "Seq"
                          | isRequired fi = id
                          | otherwise = typeApp "Maybe"
                  typed :: QName ()
                  typed = case useType (getFieldType (typeCode fi)) of
                            Just s -> private s
                            Nothing -> case typeName fi of
                                         Just s | self /= s -> qualName s
                                                | otherwise -> unqualName s
                                         Nothing -> error $  "No Name for Field!\n" ++ show fi
          fieldOneofX :: OneofInfo -> ([Name ()],Type ())
          fieldOneofX oi = ([baseIdent' . oneofFName $ oi], typeApp "Maybe" (TyParen () (TyCon () typed)))
            where
              pn = oneofName oi
              typed = local (joinMod (parentModule pn ++ [baseName pn, baseName pn]))
  
          fieldMapX :: FieldInfo -> ([Name ()], Type ())
          fieldMapX fi = ([baseIdent' . fieldName $ fi], ty)
              where
                  (ki, vi) = case mapKeyVal fi of
                      Just x  -> x
                      Nothing -> error $ "Map FieldInfo without key/value types"
                  ty :: Type ()
                  ty =
                      TyApp ()
                          (TyApp ()
                              (TyCon () (private "Map"))
                              (TyParen () (TyCon () (typed ki))))
                          (TyParen () (TyCon () (typed vi)))
                  typed :: (FieldType, Maybe ProtoName) -> QName ()
                  typed t@(ft, tn) = case useType (getFieldType ft) of
                            Just s -> private s
                            Nothing -> case tn of
                              Just s
                                  | self /= s -> qualName s
                                  | otherwise -> unqualName s
                              Nothing -> error $ "No Name for Field!\n" ++ show t
  
  instancesDescriptor :: DescriptorInfo -> [Decl ()]
  instancesDescriptor di = map ($ di) $
     (if hasExt di then (instanceExtendMessage:) else id) $
     (if storeUnknown di then (instanceUnknownMessage:) else id) $
     (if jsonInstances di then ([instanceToJSON,instanceFromJSON]++) else id) $
     [ instanceMergeable
     , instanceDefault
     , instanceWireDescriptor
     , instanceMessageAPI . descName
     , instanceGPB . descName
     , instanceReflectDescriptor
     , instanceTextType
     , instanceTextMsg
     ]
  
  instanceExtendMessage :: DescriptorInfo -> Decl ()
  instanceExtendMessage di
      = InstDecl () Nothing (mkSimpleIRule (private "ExtendMessage") [TyCon () (unqualName (descName di))]) . Just $
          [ inst "getExtField" [] (Var () (localField di "ext'field"))
          , inst "putExtField" [patvar "e'f", patvar "msg"] putextfield
          , inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren () $ pvar "reflectDescriptorInfo" $$ lvar "msg"))
          ]
    where putextfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "ext'field") (lvar "e'f") ]
  
  instanceUnknownMessage :: DescriptorInfo -> Decl ()
  instanceUnknownMessage di
      = InstDecl () Nothing (mkSimpleIRule (private "UnknownMessage") [TyCon () (unqualName (descName di))]) . Just $
          [ inst "getUnknownField" [] (Var () (localField di "unknown'field"))
          , inst "putUnknownField" [patvar "u'f",patvar "msg"] putunknownfield
          ]
    where putunknownfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "unknown'field") (lvar "u'f") ]
  
  instanceToJSON :: DescriptorInfo -> Decl ()
  instanceToJSON di
    = InstDecl () Nothing (mkSimpleIRule (private "ToJSON") [TyCon () (unqualName (descName di))]) . Just $
        [ inst "toJSON" [patvar msgVar] serializeFun
        ]
    where
          flds = F.toList (fields di)
          os = F.toList (descOneofs di)
          msgVar = distinctVar "msg"
          reservedVars = map toPrintName flds
          distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var
          getFname fld = fName $ baseName' $ fieldName fld
          toJSONFun fld = case toEnum (getFieldType (typeCode fld)) of
              TYPE_INT64 -> pvar "toJSONShowWithPayload"
              TYPE_UINT64 -> pvar "toJSONShowWithPayload"
              TYPE_BYTES -> pvar "toJSONByteString"
              _ -> pvar "toJSON"
          makeOneOfPair oi =
              let Ident () funcname = baseIdent' (oneofFName oi)
                  oneOfFlds = F.toList (oneofFields oi)
                  caseAlt :: (ProtoName,FieldInfo) -> Alt ()
                  caseAlt f = Alt () patt (UnGuardedRhs () rhs) noWhere
                    where patt = PApp () (prelude "Just") [fst (oneofPat f)]
                          (rstr,rvar) = oneofRec f
                          rhs = List () [Tuple () Boxed [ rstr, toJSONFun (snd f) $$ rvar ] ]
                  caseAltNothing :: Alt ()
                  caseAltNothing = Alt () (PApp () (prelude "Nothing") []) (UnGuardedRhs () rhs) noWhere
                    where rhs = List () []
              in Case () (Paren () (lvar funcname $$ lvar msgVar)) (map caseAlt oneOfFlds ++ [caseAltNothing])
          makePair fld =
              let fldName = getFname fld
                  fldName' = dropWhileEnd (== '\'') fldName
                  arg = Paren () (lvar fldName $$ lvar msgVar)
                  toJSONCall = case (isRequired fld, canRepeat fld) of
                      (True, False) -> toJSONFun fld $$ arg
                      (_, _) -> pvar "toJSON" $$ Paren () (preludevar "fmap" $$ toJSONFun fld $$ arg)
              in Tuple () Boxed
                    [ Lit () (String () fldName' (show fldName'))
                    , toJSONCall
                    ]
          serializeFun =
              pvar "objectNoEmpty" $$ Paren () (mkOp "++" (List () (map makePair flds)) (preludevar "concat" $$ List () (map makeOneOfPair os)))
  
  instanceFromJSON :: DescriptorInfo -> Decl ()
  instanceFromJSON di
    = InstDecl () Nothing (mkSimpleIRule (private "FromJSON") [TyCon () (unqualName (descName di))]) . Just $
        [ inst "parseJSON" [] (pvar "withObject" $$ Lit () (String () name (show name)) $$ Paren () parseFun)
        ]
    where
          name = mName $ baseName $ descName di
          flds = F.toList (fields di)
          os = F.toList (descOneofs di)
          reservedVars = map toPrintName flds
          distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var
          objVar = distinctVar "o"
          getFname fld = fName $ baseName' $ fieldName fld
          getOneofFname oi = fName $ baseName' $ oneofFName oi
          parseJSONFun fld = case toEnum (getFieldType (typeCode fld)) of
              TYPE_INT64 -> pvar "parseJSONReadWithPayload" $$ Lit () (String () "int64" (show "int64"))
              TYPE_UINT64 -> pvar "parseJSONReadWithPayload" $$ Lit () (String () "uint64" (show "uint64"))
              TYPE_BOOL -> pvar "parseJSONBool"
              TYPE_BYTES -> pvar "parseJSONByteString"
              _ -> pvar "parseJSON"
          getOption r@(_, fi) =
              let fldName = getFname fi
              in preludevar "fmap" $$ Paren () (preludevar "fmap" $$ oneofCon r) $$
                    Paren () (pvar "explicitParseFieldMaybe" $$ parseJSONFun fi $$ lvar objVar $$ litStr fldName)
          getOneofValue oi =
              let fldName = getOneofFname oi
              in Generator () (patvar fldName) (preludevar "fmap" $$ pvar "msum" $$ Paren () (preludevar "sequence" $$ List () ((map getOption (F.toList (oneofFields oi)) ++ [preludevar "return" $$ preludecon "Nothing"]))))
          getFieldValue fld =
              let fldName = getFname fld
                  fldName' = dropWhileEnd (== '\'') fldName
                  parseFieldFun = case (hsDefault fld, isRequired fld) of
                    (Nothing, True) -> pvar "explicitParseField"
                    _ -> pvar "explicitParseFieldMaybe"
                  parseJSONFun' = case canRepeat fld of
                    False -> parseJSONFun fld
                    True -> Paren () (preludevar "mapM" $$ parseJSONFun fld $$ pvar "<=<" $$ pvar "parseJSON")
                  parseFieldCall = parseFieldFun $$ parseJSONFun' $$ lvar objVar $$ Lit () (String () fldName' (show fldName'))
                  parseFieldCall' = case canRepeat fld of
                    False -> parseFieldCall
                    True -> preludevar "fmap" $$ Paren () (preludevar "maybe" $$ preludevar "mempty" $$ preludevar "id") $$ parseFieldCall
                  parseFieldCall'' = case (hsDefault fld, canRepeat fld) of
                    (_ , True)  -> parseFieldCall'
                    (Nothing, False)  -> parseFieldCall'
                    (Just d, False) ->
                      let defLit = defToSyntax (typeCode fld) d
                          defParse = case isRequired fld of
                            True -> Paren () defLit
                            False -> Paren () (preludecon "Just" $$ Paren () defLit)
                          tmpVar = distinctVar "tmp"
                          modfun = if isRequired fld then preludevar "id" else preludecon "Just"
                      in Do ()
                         [ Generator () (patvar tmpVar) parseFieldCall'
                         , Qualifier () $ preludevar "return" $$ Paren () (preludevar "maybe" $$ defParse $$ modfun $$ lvar tmpVar)
                         ]
              in Generator () (patvar fldName) parseFieldCall''
          updates =
                  (map (\fld -> FieldUpdate () (local (getFname fld)) (lvar (getFname fld))) flds) ++
                  (map (\oi -> FieldUpdate () (local (getOneofFname oi)) (lvar (getOneofFname oi))) os)
          retVal =
              case updates of
                [] -> pvar "defaultValue"
                (_:_) -> RecUpdate () (pvar "defaultValue") updates
          parseFun = Lambda () [patvar objVar] $ Do () $
              map getFieldValue flds ++
              map getOneofValue os ++
              [ Qualifier () $ preludevar "return" $$ retVal ]
  
  instanceTextType :: DescriptorInfo -> Decl ()
  instanceTextType di
    = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (descName di))]) . Just $
        [ inst "tellT" [] (pvar "tellSubMessage")
        , inst "getT" [] (pvar "getSubMessage")
        ]
  
  
  instanceTextMsg :: DescriptorInfo -> Decl ()
  instanceTextMsg di
    = InstDecl () Nothing (mkSimpleIRule (private "TextMsg") [TyCon () (unqualName (descName di))]) . Just $
        [ inst "textPut" [patvar msgVar] genPrint
        , InsDecl () $ FunBind () [Match () (Ident () "textGet") [] (UnGuardedRhs () parser) bdecls]
        ]
    where
          bdecls = Just (BDecls () (subparsers ++ subparsersO))
          flds = F.toList (fields di)
          os = F.toList (descOneofs di)
          msgVar = distinctVar "msg"
          distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var
          reservedVars = map toPrintName flds
          genPrintFields = map (Qualifier () . printField msgVar) flds
          genPrintOneofs = map (Qualifier () . printOneof msgVar) os
          genPrint = if null flds && null os
                     then preludevar "return" $$ Hse.Tuple () Boxed []
                     else Do () $ genPrintFields ++ genPrintOneofs
  
          parser
              | null flds && null os = preludevar "return" $$ pvar "defaultValue"
              | otherwise = Do () [
                  Generator () (patvar "mods")
                      $ pvar "sepEndBy"
                          $$ Paren () (pvar "choice" $$ List () (map (lvar . parserName) flds ++ map (lvar . parserNameO) os))
                          $$ pvar "spaces",
                  Qualifier () $ (preludevar "return")
                      $$ Paren () (preludevar "foldl'"
                          $$ Lambda () [patvar "v", patvar "f"] (lvar "f" $$ lvar "v")
                          $$ pvar "defaultValue"
                          $$ lvar "mods")
               ]
          parserName f = let Ident () fname = baseIdent' (fieldName f) in "parse'" ++ fname
          parserNameO o = let Ident () oname = baseIdent' (oneofFName o) in "parse'" ++ oname
          subparsers = map (\f -> defun (parserName f) [] (getField f)) flds
          getField fi =
              let printname = toPrintName fi
                  Ident () funcname = baseIdent' (fieldName fi)
                  update
                    | isMapField fi =
                        let fn = mapFieldHelperFn (fromJust (typeName fi)) "ToPair" True in
                        pvar "appendMap" $$ Paren () (lvar funcname $$ lvar "o") $$ App () (Var () fn) (lvar "v")
                    | canRepeat fi = pvar "append" $$ Paren () (lvar funcname $$ lvar "o") $$ lvar "v"
                    | otherwise = lvar "v"
              in preludevar "fmap" $$
                  Paren () (Lambda () [patvar "v", patvar "o"] (RecUpdate () (lvar "o") [ FieldUpdate () (local funcname) update])) $$
                  Paren () (pvar "try" $$ Paren () (pvar "getT" $$ litStr printname))
  
          subparsersO = map funbind os
          funbind o = FunBind () [Match () (Ident () (parserNameO o)) [] (UnGuardedRhs () (getOneof)) whereParse]
            where getOneof = pvar "try" $$
                               (pvar "choice" $$ List () (map (Var () . UnQual () . Ident ()) parsefs))
                  oflds = F.toList (oneofFields o)
                  flds = map snd oflds
                  parsefs = map parserName flds
                  whereParse = whereBinds $ BDecls () (map decl oflds)
                    where decl (n,f) = defun (parserName f) [] (getOneofField (n,f))
                          getOneofField p@(n,f) =
                            let Ident () oname = baseIdent' (oneofFName o)
                                printname = toPrintName f
                                update = preludecon "Just" $$ Paren () (oneofCon p $$ lvar "v")
                            in pvar "try" $$ Do () [
                                 Generator () (patvar "v") $ pvar "getT" $$ litStr printname,
                                 Qualifier () $ (preludevar "return")
                                 $$ Paren () (Lambda () [patvar "s"]
                                  (RecUpdate () (lvar "s") [ FieldUpdate () (local oname) update]))
                                 ]
  
  
  printField :: String -> FieldInfo -> Exp ()
  printField msgVar fi
    = let Ident () funcname = baseIdent' (fieldName fi)
          printname = toPrintName fi
          -- if map field, convert to sequence first
          f x | isMapField fi = Paren () (Var () (mapFieldHelperFn (fromJust (typeName fi)) "ToSeq" True) $$ x)
              | otherwise     = x
      in pvar "tellT" $$ litStr printname $$ f (Paren () (lvar funcname $$ lvar msgVar))
  
  toPrintName :: FieldInfo -> String
  toPrintName fi = let IName uname = last $ splitFI $ protobufName' (fieldName fi) in uToString uname
  
  printOneof :: String -> OneofInfo -> Exp ()
  printOneof msgVar oi
      = Case () (Paren () (lvar funcname $$ lvar msgVar)) (map caseAlt flds ++ [caseAltNothing])
    where Ident () funcname = baseIdent' (oneofFName oi)
          flds = F.toList (oneofFields oi)
          caseAlt :: (ProtoName,FieldInfo) -> Alt ()
          caseAlt f = Alt () patt  (UnGuardedRhs () rhs) noWhere
            where patt = PApp () (prelude "Just") [fst (oneofPat f)]
                  (rstr,rvar) = oneofRec f
                  rhs = pvar "tellT" $$ rstr $$ rvar -- litStr fname $$ (lvar fname)
          caseAltNothing :: Alt ()
          caseAltNothing = Alt () (PApp () (prelude "Nothing") []) (UnGuardedRhs () rhs) noWhere
            where rhs = preludevar "return" $$ unit_con ()
  
  instanceMergeable :: DescriptorInfo -> Decl ()
  instanceMergeable di
      = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () un]) . Just $
          [ -- inst "mergeEmpty" [] (foldl' App (Con un) (replicate len (pvar "mergeEmpty"))),
            inst "mergeAppend" [PApp () un patternVars1, PApp () un patternVars2] $
                Let ()
                  (BDecls () (zipWith3 append vars1 vars2 varNames3))
                  (foldl' (App ()) (Con () un) vars3)
          ]
    where un = unqualName (descName di)
          len = (if hasExt di then succ else id)
              $ (if storeUnknown di then succ else id)
              $ Seq.length (fields di) + Seq.length (descOneofs di)
          patternVars1,patternVars2 :: [Pat ()]
          patternVars1 = take len inf
              where inf = map (\ n -> patvar ("x'" ++ show n)) [(1::Int)..]
          patternVars2 = take len inf
              where inf = map (\ n -> patvar ("y'" ++ show n)) [(1::Int)..]
          vars1,vars2 :: [Exp ()]
          vars1 = take len inf
              where inf = map (\ n -> lvar ("x'" ++ show n)) [(1::Int)..]
          vars2 = take len inf
              where inf = map (\ n -> lvar ("y'" ++ show n)) [(1::Int)..]
          vars3 = map lvar varNames3
          varNames3 = take len inf
              where inf = map (\ n -> "z'" ++ show n) [(1::Int)..]
          append x y z = defun ("!" ++ z) [] $ pvar "mergeAppend" $$ x $$ y
  
  instanceDefault :: DescriptorInfo -> Decl ()
  instanceDefault di
      = InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () un]) . Just $
          [ inst "defaultValue" [] (foldl' (App ()) (Con () un) deflistExt) ]
    where un = unqualName (descName di)
          deflistExt = F.foldr ((:) . defX) end (fields di)
          end = (if hasExt di then (pvar "defaultValue":) else id)
              . (if storeUnknown di then (pvar "defaultValue":) else id)
              $ F.foldr ((:) . defOneof) [] (descOneofs di)
  
          defX :: FieldInfo -> Exp ()
          defX fi | isRequired fi = dv1
                  | otherwise = dv2
            where dv1 = case hsDefault fi of
                          Nothing -> pvar "defaultValue"
                          Just hsdef -> defToSyntax (typeCode fi) hsdef
                  dv2 = case hsDefault fi of
                          Nothing -> pvar "defaultValue"
                          Just hsdef -> Paren () $ preludecon "Just" $$ defToSyntax (typeCode fi) hsdef
          defOneof :: OneofInfo -> Exp ()
          defOneof oi= pvar "defaultValue"
  
  
  instanceMessageAPI :: ProtoName -> Decl ()
  instanceMessageAPI protoName
      = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI")
          [TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) . Just $
          [ inst "getVal" [patvar "m'",patvar "f'"] (App () (lvar "f'" ) (lvar "m'")) ]
    where un = unqualName protoName
  
  data WireVars = WVarsField FieldInfo | WVarsExt | WVarsOneof OneofInfo
  
  instanceWireDescriptor :: DescriptorInfo -> Decl ()
  instanceWireDescriptor di@(DescriptorInfo { descName = protoName
                                            , fields = fieldInfos
                                            , descOneofs = oneofInfos
                                            , extRanges = allowedExts
                                            , knownKeys = fieldExts })
    = let me = unqualName protoName
          extensible = not (null allowedExts)
          len = (if extensible then succ else id)
              $ (if storeUnknown di then succ else id)
              $ Seq.length fieldInfos + Seq.length oneofInfos
          mine = PApp () me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [(1::Int)..]
          vars = take len . map (\ n -> lvar ("x'" ++ show n)) $ [(1::Int)..]
          mExt | extensible = Just (vars !! Seq.length fieldInfos)
               | otherwise = Nothing
          mUnknown | storeUnknown di = Just (last vars)
                   | otherwise = Nothing
  
  -- reusable 'cases' generator
          -- first case is for Group behavior, second case is for Message behavior, last is error handler
          cases g m e = Case () (lvar "ft'") [ Alt () (litIntP' 10) (UnGuardedRhs () g) noWhere
                                          , Alt () (litIntP' 11) (UnGuardedRhs () m) noWhere
                                          , Alt () (PWildCard ())     (UnGuardedRhs () e) noWhere
                                          ]
  
  -- wireSize generation
          sizeCases = UnGuardedRhs () $ cases (lvar "calc'Size")
                                           (pvar "prependMessageSize" $$ lvar "calc'Size")
                                           (pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")
          whereCalcSize = Just (BDecls () [defun "calc'Size" [] sizes])
          sizes | null sizesList = Lit () (Hse.Int () 0 "0")
                | otherwise = Paren () (foldl1' (+!) sizesList)
            where (+!) = mkOp "+"
                  sizesList | Just v <- mUnknown = sizesListExt ++ [ pvar "wireSizeUnknownField" $$ v ]
                            | otherwise = sizesListExt
                  sizesListExt | Just v <- mExt = sizesListFields ++ [ pvar "wireSizeExtField" $$ v ]
                               | otherwise = sizesListFields
                  sizesListFields =  concat . zipWith toSize vars . F.toList $
                                       fmap WVarsField fieldInfos >< extWVars >< fmap WVarsOneof oneofInfos
                    where extWVars = if extensible then singleton WVarsExt else empty
          toSize var0 (WVarsField fi)
            = let f = if | isPacked   fi -> "wireSizePacked"
                         | isRequired fi -> "wireSizeReq"
                         | canRepeat  fi -> "wireSizeRep"
                         | otherwise     -> "wireSizeOpt"
              in
              -- Map -> Seq
              let fn  = mapFieldHelperFn (fromJust $ typeName fi) "ToSeq" True in
              -- map fields are convereted to sequence first
              let var = if isMapField fi then Var () fn $$ var0 else var0 in
              [foldl' (App ()) (pvar f) [ litInt (wireTagLength fi)
                                   , litInt (getFieldType (typeCode fi))
                                   , var]]
          toSize _ WVarsExt = []
          toSize var_ (WVarsOneof oi) = map (toSize' var_) . F.toList . oneofFields $ oi
            where toSize' var r@(_,fi)
                    = let f = "wireSizeOpt"
                          var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var
                      in foldl' (App ()) (pvar f) [ litInt (wireTagLength fi)
                                             , litInt (getFieldType (typeCode fi))
                                             , var']
  
  
  -- wirePut generation
          putCases = UnGuardedRhs () $ cases
            (lvar "put'Fields")
            (lvar "put'FieldsSized")
            (pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")
          wherePutFields = Just (BDecls ()
              [ defun "put'Fields" [] (pvar "sequencePutWithSize" $$ List () putStmts)
              , defun "put'FieldsSized" [] $
                Let () (BDecls ()
                        [ defun "size'" [] (preludevar "fst" $$ Paren () (pvar "runPutM" $$ lvar "put'Fields"))
                        , defun "put'Size" []
                           (Do () [ Qualifier () $ pvar "putSize" $$ lvar "size'"
                                  , Qualifier () $ preludevar "return" $$ Paren () (pvar "size'WireSize" $$ lvar "size'")
                                  ])
                        ])
                (pvar "sequencePutWithSize" $$ List () [lvar "put'Size", lvar "put'Fields"])
              ])
          putStmts = putStmtsAll
            where putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ pvar "wirePutUnknownFieldWithSize" $$ v ]
                              | otherwise = putStmtsListExt
                  putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ pvar "wirePutExtFieldWithSize" $$ v ]
                                  | otherwise = sortedPutStmtsList
                  sortedPutStmtsList = map snd                                          -- remove number
                                       . sortBy (compare `on` fst)                      -- sort by number
                                       $ putStmtsList
                  putStmtsList = concat . zipWith toPut vars . F.toList $
                                   fmap WVarsField fieldInfos >< extWVars >< fmap WVarsOneof oneofInfos
                    where extWVars = if extensible then singleton WVarsExt else empty
          toPut var0 (WVarsField fi)
            = let f = if | isPacked   fi -> "wirePutPackedWithSize"
                         | isRequired fi -> "wirePutReqWithSize"
                         | canRepeat  fi -> "wirePutRepWithSize"
                         | otherwise     -> "wirePutOptWithSize"
              in
              -- Map -> Seq
              let fn = mapFieldHelperFn (fromJust $ typeName fi) "ToSeq" True in
              -- map fields are convereted to sequence first
              let var1 = if isMapField fi then Var () fn $$ var0 else var0 in
              [( fieldNumber fi
               , foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi))
                                         , litInt (getFieldType (typeCode fi))
                                         , var1]
                   )]
          toPut _ WVarsExt = []
          toPut var (WVarsOneof oi) = map toPut' . F.toList . oneofFields $ oi
            where toPut' r@(_n,fi)
                    = let f = "wirePutOptWithSize"
                          var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var
                      in (fieldNumber fi
                         , foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi))
                                                , litInt (getFieldType (typeCode fi))
                                                , var']
                         )
  
  -- wireGet generation
  -- new for 1.5.7, rewriting this a great deal!
          getCases = let handleUnknown = if storeUnknown di
                                           then pvar "loadUnknown"
                                           else pvar "discardUnknown"
                         param = Paren () (pvar "catch'Unknown'" $$ handleUnknown $$ lvar "update'Self")
                     in UnGuardedRhs () $ cases (pvar "getBareMessageWith" $$ param)
                                             (pvar "getMessageWith" $$ param)
                                             (pvar "wireGetErr" $$ lvar "ft'")
          whereDecls = Just (BDecls () [whereUpdateSelf])
          whereUpdateSelf = defun "update'Self" [patvar "wire'Tag", patvar "old'Self"]
                                  (Case () (lvar "wire'Tag") updateAlts)
          -- update cases are all normal fields then all known extensions then wildcard
          updateAlts = concatMap toUpdate (F.toList fieldInfos)
                       ++ (do -- in list monad
                            o <- F.toList oneofInfos
                            f <- F.toList (oneofFields o)
                            toUpdateO o f)
                       ++ (if extensible then concatMap toUpdateExt (F.toList fieldExts) else [])
                       ++ [Alt () (PWildCard ()) (UnGuardedRhs () wildcardAlt) noWhere]
          -- the wildcard alternative handles new extensions and
          wildcardAlt = letPair extBranch
            where letPair = Let () (BDecls () [PatBind () (PTuple () Boxed [patvar "field'Number",patvar "wire'Type"])
                                           (UnGuardedRhs () (pvar "splitWireTag" $$ lvar "wire'Tag")) bdecls])
                  extBranch | extensible = If () (isAllowedExt (lvar "field'Number"))
                                              (argPair (pvar "loadExtension"))
                                              unknownBranch
                            | otherwise = unknownBranch
                  unknownBranch = argPair (pvar "unknown")
                  argPair x = x $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self"
          bdecls = Nothing
          isAllowedExt x = preludevar "or" $$ List () ranges where
            (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp "=="; (FieldId maxHi) = maxBound
            ranges = map (\ (FieldId lo,FieldId hi) ->
                              if hi < maxHi
                                then if lo == hi
                                       then (x ==! litInt lo)
                                       else (litInt lo <=! x) &&! (x <=! litInt hi)
                                else litInt lo <=! x )
                         allowedExts
  
  -- wireGetErr for known extensions
  -- need to check isPacked and call appropriate wireGetKey[Un]Packed substitute function
          toUpdateExt fi | Just (wt1,wt2) <- packedTag fi = [toUpdateExtUnpacked wt1, toUpdateExtPacked wt2]
                         | otherwise = [toUpdateExtUnpacked (wireTag fi)]
            where (getUnP,getP) | isPacked fi = (pvar "wireGetKeyToPacked",pvar "wireGetKey")
                                | otherwise = (pvar "wireGetKey",pvar "wireGetKeyToUnPacked")
                  toUpdateExtUnpacked wt1 =
                    Alt () (litIntP . getWireTag $ wt1)
                        (UnGuardedRhs () $ getUnP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")
                        noWhere
                  toUpdateExtPacked wt2 =
                    Alt () (litIntP . getWireTag $ wt2)
                        (UnGuardedRhs () $ getP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")
                        noWhere
  
  -- wireGet without extensions
          toUpdate fi | Just (wt1,wt2) <- packedTag fi = [toUpdateUnpacked wt1 fi, toUpdatePacked wt2 fi]
                      | otherwise                      = [toUpdateUnpacked (wireTag fi) fi]
  
  
          toUpdateUnpacked wt1 fi =
            Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $
              preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
                                RecUpdate () (lvar "old'Self")
                                          [FieldUpdate () (unqualFName . fieldName $ fi)
                                                       (labelUpdateUnpacked fi)])
                          $$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
          labelUpdateUnpacked fi
              | isMapField fi =
                  pvar "appendMap" $$
                      Paren () ((Var () . unqualFName . fieldName $ fi) $$ lvar "old'Self") $$
                          -- convert a record to (k,v) pair
                          App () (Var () (mapFieldHelperFn (fromJust (typeName fi)) "ToPair" True))
                              (lvar "new'Field")
              | canRepeat fi =
                  pvar "append" $$
                    Paren () ((Var () . unqualFName . fieldName $ fi) $$ lvar "old'Self") $$
                    lvar "new'Field"
              | isRequired fi = qMerge (lvar "new'Field")
              | otherwise = qMerge (preludecon "Just" $$ lvar "new'Field")
              where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =
                                 pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . fieldName $ fi)
                                                                 $$ lvar "old'Self" )
                                                    $$ Paren () x
                             | otherwise = x
          toUpdatePacked wt2 fi =
            Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $
              preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
                                RecUpdate () (lvar "old'Self")
                                          [FieldUpdate () (unqualFName . fieldName $ fi)
                                                       (labelUpdatePacked fi)])
                          $$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
          labelUpdatePacked fi = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . fieldName $ fi)
                                                                   $$ lvar "old'Self")
                                                    $$ lvar "new'Field"
  
          -- in the above, the [10,11] check optimizes using the
          -- knowledge that only TYPE_MESSAGE and TYPE_GROUP have merges
          -- that are not right-biased replacements.  The "mergeAppend" uses
          -- knowledge of how all repeated fields get merged.
  
  
          -- for fields in OneofInfo
          toUpdateO oi f@(_n,fi)
            | Just (wt1,wt2) <- packedTag fi = [toUpdateUnpackedO oi wt1 f, toUpdatePackedO oi wt2 f]
            | otherwise                      = [toUpdateUnpackedO oi (wireTag fi) f]
  
          toUpdateUnpackedO oi wt1 f@(_,fi) =
            Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $
              preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
                                RecUpdate () (lvar "old'Self")
                                          [FieldUpdate () (unqualFName . oneofFName $ oi)
                                                       (labelUpdateUnpackedO oi f)])
                          $$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
          labelUpdateUnpackedO oi f@(_,fi) = qMerge (preludecon "Just" $$
                                                 (oneofCon f $$ lvar "new'Field")
                                              )
              where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =
                                 pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . oneofFName $ oi)
                                                                 $$ lvar "old'Self" )
                                                    $$ Paren () x
                             | otherwise = x
          toUpdatePackedO oi wt2 f@(_,fi) =
            Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $
              preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
                                RecUpdate () (lvar "old'Self")
                                          [FieldUpdate () (unqualFName . oneofFName $ oi)
                                                       (labelUpdatePackedO oi f)])
                          $$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
          labelUpdatePackedO oi f@(_,fi) = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . oneofFName $ oi)
                                                                   $$ lvar "old'Self")
                                                    $$ Paren () (preludecon "Just" $$
                                                                (oneofCon f $$ lvar "new'Field"))
  
      in InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () me]) . Just . map (InsDecl ()) $
          [ FunBind () [Match () (Ident () "wireSize") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] sizeCases whereCalcSize]
          , FunBind () [Match () (Ident () "wirePutWithSize")  [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] putCases wherePutFields]
          , FunBind () [Match () (Ident () "wireGet") [patvar "ft'"] getCases whereDecls]
          ]
  
  instanceReflectDescriptor :: DescriptorInfo -> Decl ()
  instanceReflectDescriptor di
      = InstDecl () Nothing (mkSimpleIRule (private "ReflectDescriptor") [TyCon () (unqualName (descName di))]) . Just $
          [ inst "getMessageInfo" [PWildCard ()] gmi
          , inst "reflectDescriptorInfo" [PWildCard ()] rdi ]
    where -- massive shortcut through show and read
          rdi :: Exp ()
          rdi = preludevar "read" $$ litStr (show di)
          gmi,reqId,allId :: Exp ()
          gmi = pcon "GetMessageInfo" $$ Paren () reqId $$ Paren () allId
          reqId = pvar "fromDistinctAscList" $$
                  List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di), isRequired fi])
          allId = pvar "fromDistinctAscList" $$
                  List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di)] ++
                                                     [ allowedList fi | fi <- F.toList (knownKeys di)])
          allowedList fi | Just (wt1,wt2) <- packedTag fi = [getWireTag wt1,getWireTag wt2]
                         | otherwise = [getWireTag (wireTag fi)]
  
  ------------------------------------------------------------------
  
  mkSimpleIRule :: QName () -> [Type ()] -> InstRule ()
  mkSimpleIRule con args =
      let instHead = foldl' (IHApp ()) (IHCon () con) args
      in IRule () Nothing Nothing instHead
  
  mkDeriving :: [QName ()] -> Deriving ()
  mkDeriving xs = Deriving () Nothing (map (\x -> mkSimpleIRule x []) xs)
  
  derives,derivesEnum,derivesTypeable :: Deriving ()
  derives = mkDeriving $ map prelude ["Show","Eq","Ord","Typeable","Data","Generic"]
  derivesEnum = mkDeriving $ map prelude ["Read","Show","Eq","Ord","Typeable","Data","Generic"]
  derivesTypeable = mkDeriving $ [prelude "Typeable"]
  
  -- All of these type names are also exported by Text.ProtocolBuffers.Header via Text.ProtocolBuffers.Basic
  useType :: Int -> Maybe String
  useType  1 = Just "Double"
  useType  2 = Just "Float"
  useType  3 = Just "Int64"
  useType  4 = Just "Word64"
  useType  5 = Just "Int32"
  useType  6 = Just "Word64"
  useType  7 = Just "Word32"
  useType  8 = Just "Bool"
  useType  9 = Just "Utf8"
  useType 10 = Nothing
  useType 11 = Nothing
  useType 12 = Just "ByteString"
  useType 13 = Just "Word32"
  useType 14 = Nothing
  useType 15 = Just "Int32"
  useType 16 = Just "Int64"
  useType 17 = Just "Int32"
  useType 18 = Just "Int64"
  useType  x = imp $ "useType: Unknown type code (expected 1 to 18) of "++show x
  
  -- | Generate a name of map field helper functions: ModToPair and ModToSeq
  mapFieldHelperFn :: ProtoName -> String -> Bool -> QName ()
  mapFieldHelperFn tn suffix qual =
      let ident = mapFieldHelperName tn suffix in
      let mn = joinMod (parentModule tn) in
      if   qual
      -- output of the form: MyProto.MyMessage.map_field_Entry{ToPair, ToSeq}
      then Qual () (ModuleName () mn) ident
      -- or unqualified (for export lists)
      else UnQual () ident
  
  mapFieldHelperName :: ProtoName -> String -> Name ()
  mapFieldHelperName tn suffix =
      -- need to change the first letter of module name to lowercase becuase we
      -- use it as a prefix for a function name
      let ident0 = lowercase $ mName $ baseName tn in
      Ident () (ident0 ++ suffix)
  
  -- | Convert first letter in a stirng to lowercase
  lowercase :: String -> String
  lowercase xs = case xs of
      []   -> []
      y:ys -> Char.toLower y : ys
  