{-# LANGUAGE NamedFieldPuns, RecordWildCards, ViewPatterns, CPP #-}
-- 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,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(..))

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 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)
import Data.List (dropWhileEnd)
import           Data.Sequence (ViewL(..),(><))
import qualified Data.Sequence as Seq(null,length,viewl)
import qualified Data.Set as S
import System.FilePath(joinPath)

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)
      iabs = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn)))
      ans = if m1 == selfMod && part /= KeyFile then Nothing
              else Just $ ImportDecl () m1 True fromSource False Nothing (Just m2)
                            (Just (ImportSpecList () False [iabs]))
  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]))
      m2 = ModuleName () (joinMod (parentModule pn))
      m3 = ModuleName () (joinMod (parentModule pn ++ [baseName pn]))
      fromSource = S.member (FMName self,part,o) (rIBoot r)
      iabs1 = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn)))
      iabsget = map (IAbs () (NoNamespace ()) . Ident () . fst . oneofGet) . F.toList .  oneofFields $ oi
      ithall = IThingAll () (Ident () (mName (baseName pn)))

      ans1 = ImportDecl () m1 True fromSource False Nothing (Just m2)
                (Just (ImportSpecList () False [iabs1]))
      ans2 = ImportDecl () m1 True fromSource False Nothing (Just m3)
                (Just (ImportSpecList () False (ithall:iabsget)))
  in  if m1 == selfMod && part /= KeyFile
        then Nothing
        else Just [ans1,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","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))

--------------------------------------------
-- 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)
        exportKeys :: [ExportSpec ()]
        exportKeys = map (EVar () . unqualFName . fieldName) myKeys
        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))) ]
        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))))))
              (modulePragmas $ makeLenses di)
              imports
              (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di)

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.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.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
        con = RecDecl () name eFields
                where eFields = map (\(ns, t) -> FieldDecl () ns t) $ F.foldr ((:) . fieldX) end (fields di)
                      end = (if hasExt di then pure extfield else mempty) <>
                            eOneof <>
                            (if storeUnknown di then pure unknownField else mempty)
                      eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di)

        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 typed = qualName (oneofName oi)

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 = if canRepeat fi then pvar "append" $$ Paren () (lvar funcname $$ lvar "o") $$ lvar "v" else lvar "v"
            in pvar "try" $$ Do () [
                Generator () (patvar "v") $ pvar "getT" $$ litStr printname,
                Qualifier () $ (preludevar "return")
                    $$ Paren () (Lambda () [patvar "o"]
                        (RecUpdate () (lvar "o") [ FieldUpdate () (local funcname) update]))
            ]

        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
    in pvar "tellT" $$ litStr printname $$ 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]
                             (foldl' (App ()) (Con () un) (zipWith append vars1 vars2))
        ]
  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)..]
        append x y = Paren () $ 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

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 Left fieldInfos >< fmap Right oneofInfos
        toSize var (Left fi)
          = let f = if isPacked fi then "wireSizePacked"
                    else if isRequired fi then "wireSizeReq"
                         else if canRepeat fi then "wireSizeRep"
                              else "wireSizeOpt"
            in [foldl' (App ()) (pvar f) [ litInt (wireTagLength fi)
                                    , litInt (getFieldType (typeCode fi))
                                    , var]]
        toSize var (Right oi) = map (toSize' var) . F.toList . oneofFields $ oi
          where toSize' var r@(n,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 Left fieldInfos >< fmap Right oneofInfos
        toPut var (Left fi)
          = let f = if isPacked fi then "wirePutPackedWithSize"
                    else if isRequired fi then "wirePutReqWithSize"
                         else if canRepeat fi then "wirePutRepWithSize"
                              else "wirePutOptWithSize"
            in [(fieldNumber fi,
                   foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi))
                                       , litInt (getFieldType (typeCode fi))
                                       , var]
                 )]
        toPut var (Right 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 | 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 ()
#if MIN_VERSION_haskell_src_exts(1, 20, 0)
mkDeriving xs = Deriving () Nothing (map (\x -> mkSimpleIRule x []) xs)
#else
mkDeriving xs = Deriving () (map (\x -> mkSimpleIRule x []) xs)
#endif

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