hprotoc 1.2.2 → 1.4.0
raw patch · 5 files changed
+963/−315 lines, 5 filesdep +haskell-src-extsdep −haskell-srcdep ~parsecdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependencies added: haskell-src-exts
Dependencies removed: haskell-src
Dependency ranges changed: parsec, protocol-buffers, protocol-buffers-descriptor
Files
- Text/ProtocolBuffers/ProtoCompile.hs +18/−13
- Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +503/−0
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +435/−295
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +1/−1
- hprotoc.cabal +6/−6
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -1,12 +1,12 @@ -- | This is the Main module for the command line program 'hprotoc' module Main where -import Control.Monad(when)+import Control.Monad(when,forM_) import qualified Data.ByteString.Lazy.Char8 as LC (writeFile) import Data.List(break) import qualified Data.Sequence as Seq (fromList,singleton) import Data.Version(showVersion)-import Language.Haskell.Pretty(prettyPrintStyleMode,Style(..),Mode(..),PPHsMode(..),PPLayout(..))+import Language.Haskell.Exts.Pretty(prettyPrintStyleMode,Style(..),Mode(..),PPHsMode(..),PPLayout(..)) import System.Console.GetOpt(OptDescr(Option),ArgDescr(NoArg,ReqArg) ,usageInfo,getOpt,ArgOrder(ReturnInOrder)) import System.Directory(getCurrentDirectory,createDirectoryIfMissing)@@ -16,7 +16,7 @@ import Text.ProtocolBuffers.Basic(defaultValue) import Text.ProtocolBuffers.Identifiers(MName,checkDIString,mangle)-import Text.ProtocolBuffers.Reflections(ProtoInfo(..),DescriptorInfo(..),EnumInfo(..))+import Text.ProtocolBuffers.Reflections(ProtoInfo(..),EnumInfo(..)) import Text.ProtocolBuffers.WireMessage (messagePut) import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto)@@ -24,10 +24,11 @@ import qualified Text.DescriptorProtos.FileDescriptorSet as D(FileDescriptorSet) import qualified Text.DescriptorProtos.FileDescriptorSet as D.FileDescriptorSet(FileDescriptorSet(..)) -import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModule,enumModule)+import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(makeResult)+import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule)+import Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) import Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,makeNameMaps,getTLS ,LocalFP(..),CanonFP(..),TopLevel(..))-import Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) -- The Paths_hprotoc module is produced by cabal import Paths_hprotoc(version)@@ -176,18 +177,23 @@ run :: Options -> IO () run options = do (env,fdps) <- loadProto (optInclude options) (optProto options)- print "All proto files loaded"+ putStrLn "All proto files loaded" let fdp = either error id . top'FDP . fst . getTLS $ env when (not (optDryRun options)) $ dump (optImports options) (optDesc options) fdp fdps nameMap <- either error return $ makeNameMaps (optPrefix options) (optAs options) env- print "Haskell name mangling done"+ putStrLn "Haskell name mangling done" let protoInfo = makeProtoInfo (optUnknownFields options) nameMap fdp+ result = makeResult protoInfo+ seq result (putStrLn "Recursive modules resolved") let produceMSG di = do- let file = combine (unLocalFP . optTarget $ options) . joinPath . descFilePath $ di- print file when (not (optDryRun options)) $ do- mkdirFor file- writeFile file (prettyPrintStyleMode style myMode (descriptorModule di))+ -- There might be several modules+ let fileModules = descriptorModules result di+ forM_ fileModules $ \ (relPath,modSyn) -> do+ let file = combine (unLocalFP . optTarget $ options) relPath+ print file+ mkdirFor file+ writeFile file (prettyPrintStyleMode style myMode modSyn) produceENM ei = do let file = combine (unLocalFP . optTarget $ options) . joinPath . enumFilePath $ ei print file@@ -196,7 +202,6 @@ writeFile file (prettyPrintStyleMode style myMode (enumModule ei)) mapM_ produceMSG (messages protoInfo) mapM_ produceENM (enums protoInfo)- let file = combine (unLocalFP . optTarget $ options) . joinPath . protoFilePath $ protoInfo print file- writeFile file (prettyPrintStyleMode style myMode (protoModule protoInfo (serializeFDP fdp)))+ writeFile file (prettyPrintStyleMode style myMode (protoModule result protoInfo (serializeFDP fdp)))
+ Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs view
@@ -0,0 +1,503 @@+{-| Analysis and design of this module++If there are SCCs then additional files are inevitable.+Separate files to define the keys are usually avoidable.+Separating Key definitions are needed only if the key imports form a SCC,+and even these may be sometimes avoided by declaring keys in boot files.++Choose to minimize the create of separate Key-desf definitions by+locating and breaking the key SCCs first. Use the "score" to pick a+single vertex at a time to greedily minimize the number of separate+Key-defs. After this initial step the set of separate Key-defs is+fixed.++With this understanding, there are FOUR renderings of a descriptor.+Two renderings have non-separate Key-defs (or no Key-defs at all).+Two renderings have separate Key-defs.++The two non-separate Key-defs renderings are:++"simple" :+ * normal file with the type-def and any Key-defs++"type-boot" :+ * normal file with the type-def and any Key-defs+ - hs-boot file declares the type-def++The other two have separate Key-defs, in ".hs-boot" or "'Key.hs" files:++"key-type-boot" :+ + normal file with the type-def and the Key-defs+ * hs-boot file declares the type-def and the Key-defs++"split-key,type-boot" :+ + normal file with the type-def and maybe imports keyfile+ * keyfile file with the the Key-defs+ - hs-boot file declares the type-def++In general, all nodes without keys could be rendered as "type-boot"+and all nodes with keys as "split-key,type-boot", which would break+all SCCs. But that is wasteful: 2 or 3 files each (2 for root+ProtoInfo file). And this waste will also lead to warnings from ghc+nagging about unneeded {-# SOURCE #-} pragmas.++Only the files marked with * have incoming and outgoing edges and NEED+to be considered. With enough {-# SOURCE #-} pragmas, the + are+just sources and - are just sinks.++Initially all renderings are optimistically Simple. Some are quickly+changed into TypeBoot by observing the modules which import foreign+keys and marking the reciprocal type imports as TypeBoot.++The next task is to break the SCCs which arise just from the foreign+key imports. The algorithm makes a graph of these and breaks all of+them by changing the one with the best score from a TypeBoot node into+a KeyTypeBoot node.++Note: The top protoInfo node will be rendered like "simple" as+TopProtoInfo and never change. The most that happens to the top+protoInfo node is that its targets get changed and some imports get+SOURCE pragmas.++Now considering both type and key imports as links, more SCCs+might arise. These are also scored. The thing to grasp is how+changing a message's rending is allowed to happen:++TopProtoInfo will never change+Simple may become TypeBoot+TypeBoot will never change+KeyTypeBoot may become SplitKeyTypeBoot+SplitKeyTypeBoot will never change++It always possible to choose a vertex in any SCC that can change,+which is not obvious. The deduction is that if all vertices in the+SCC are unchanging then there are no internal type import links; thus+the only loops being created are with foreign key imports. The+initial setup broke all SCCs made only of foreign key imports; thus+this stuck SCC is a contradiction.++The best score is the choice that reduces the size of the scc in the+next round (and secondarily increases the number of sub-SCCs).++The final Result is a Map of names to the non-Simple/TopProtoInfo+renderings and a list of "pairs" (a,p,b) where part 'p' of module 'a'+should import the type defined in 'b' using a SOURCE pragma. Keys+from messages rendered as KeyTypeBoot should be imported using SOURCE+pragmas. Keys from messages rendered as SplitKeyTypeBoot should be+imported from the auxiliary 'Key files.++The code below is more complicated in order to reduce the SOURCE+pragmas and avoid ghc's warnings. All files are tracked and SOURCE+pragmas are added in steps. This is unlikely to be perfect — some+extra SOURCE pragmas might be left over, but I do not have an example+of this happening. This also means a DescriptorInfo may have several+file parts and these may end up in different SCCs. To simplify+processing these different SCCs which share a DescriptorInfo are+merged by 'rejoinVertices'.++-}++module Text.ProtocolBuffers.ProtoCompile.BreakRecursion+ ( makeResult,displayResult,Result(..),VertexKind(..),Part(..),pKey,pfKey,getKind ) where++import Prelude hiding (pi)+import Control.Monad(guard,mplus)+import qualified Data.Foldable as F+import Data.Function(on)+import Data.Graph+import Data.List+import qualified Data.Map as Map+import Data.Map(Map)+import Data.Maybe(mapMaybe)+import Data.Monoid+import qualified Data.Set as Set+import Data.Set(Set)+import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Identifiers+import Text.ProtocolBuffers.Reflections++import Debug.Trace(trace)++ecart :: String -> a -> a+ecart _ a = a++fst3 :: (a,b,c) -> a+fst3 (x,_,_) = x++snd3 :: (a,b,c) -> b+snd3 (_,x,_) = x++imp :: String -> a+imp s = error $ "Inconceivable! Text.ProtocolBuffers.ProtoCompile.BreakRecursion."++s++iguard :: Monad m => Bool -> String -> m ()+iguard True _ = return ()+iguard False s = imp s++-- The Gen.hs module will be working with these String types+type MKey = FMName String++pKey :: ProtoName -> MKey+pKey (ProtoName {haskellPrefix=a,parentModule=b,baseName=c}) = foldr1 dotFM . map promoteFM $ a++b++[c]++pfKey :: ProtoFName -> MKey+pfKey (ProtoFName {haskellPrefix'=a,parentModule'=b}) = foldr1 dotFM . map promoteFM $ a++b++-- Which reprensentation a message currently has+data VertexKind = TopProtoInfo+ | Simple+ | TypeBoot+ | KeyTypeBoot+ | SplitKeyTypeBoot+ deriving (Show,Eq,Ord)++-- Which of the 3 sorts of files (maked with * in analysis) a vertex represents+data Part = Normal | Source | KeyFile deriving (Show,Eq,Ord)++-- Vertex data. A graph may have several nodes with the same value of+-- V and different values of Part.+data V = V { vMKey :: !MKey+ , vNeedsKeys :: !(Set MKey)+ , vKeysNeedsTypes :: !(Set MKey)+ , vTypeNeedsTypes :: !(Set MKey) }+ deriving Show++-- A link to a module's file+data Label = L !Part !MKey deriving (Show,Eq,Ord)++type E = (V,Label,[Label])+type G = [E]+type SCCs = [G]++-- The end product of this module is the Result value+data Result = Result { rKind :: Map MKey VertexKind+ , rIBoot :: Set (MKey,Part,MKey)+ , rIKey :: Set (MKey,MKey) }+ deriving Eq++displayResult :: Result -> String+displayResult (Result {rKind = kv, rIBoot = ab, rIKey=ab'keys }) = unlines $+ [ "--- displayResult ----"+ , "Modules which are not Simple"+ ] ++ map (\(k,v) -> indent . shows (fmName k) . (" has kind "++) $ show v) (Map.assocs kv) +++ [ "Module imports marked with SOURCE for Types"+ ] ++ map (indent . untriple) (Set.toAscList ab) +++ [ "Module imports marked with SOURCE or 'Key for keys"+ ] ++ map (indent . unpair) (Set.toAscList ab'keys)+ where indent = (' ':).(' ':)+ untriple (a,p,b) = fmName a ++ " " ++ show p ++ " : import {-# SOURCE #-} " ++ fmName b+ unpair (a,b) = fmName a ++ " : import {-# SOURCE or 'Key #-} " ++ fmName b++showSCCs :: SCCs -> String+showSCCs gs = concatMap (\ g -> "\n>< SCC Graph ><\n"++concatMap showE g) gs+showG :: G -> String+showG g = '\n':concatMap showE g+showE :: E -> String+showE (v,n,ls) = unlines $ [ "( "++show n, " , "++show v, " , "++show ls, ")" ]++instance Monoid Result where+ mempty = Result mempty mempty mempty+ mappend r1 r2 = Result { rKind = Map.unionWith max (rKind r1) (rKind r2)+ , rIBoot = mappend (rIBoot r1) (rIBoot r2)+ , rIKey = mappend (rIKey r1) (rIKey r2) }++getKind :: Result -> MKey -> VertexKind+getKind r = let m = rKind r in \n -> Map.findWithDefault Simple n m++getType :: VertexKind -> Part+getType TopProtoInfo = imp "getType: TopProtoInfo"+getType Simple = Normal+getType TypeBoot = Source+getType KeyTypeBoot = Source+getType SplitKeyTypeBoot = Source++getKey :: VertexKind -> Part+getKey TopProtoInfo = Normal+getKey Simple = Normal+getKey TypeBoot = Normal+getKey KeyTypeBoot = Source+getKey SplitKeyTypeBoot = KeyFile++-- 'makeResult' is the main function for this module+makeResult :: ProtoInfo -> Result+makeResult protoInfo =+ let pvs@(p,vs) = makeVertices protoInfo+ initResult = breakKeys pvs+ sccs = cycles (makeG (p:vs) initResult)+ answer = cull (p:vs) $ breakGraph initResult sccs+ finalGraph = makeG (p:vs) answer+ remainingProblems = cycles finalGraph+ msg = unlines [ "<!!!!!!!!!!!> KLAXON, RED SPINNING LIGHT, ETC."+ , "! WARNING: hprotoc unexpectedly failed to disentangle all the mutually-recursive message definitions."+ , "! PLEASE REPORT THIS FAILURE ALONG WITH THE PROTO FILE."+ , "! The failed subset is:"+ ] ++ showSCCs remainingProblems ++ "\n</!!!!!!!!!!!>"+ in if null remainingProblems then ecart (showG finalGraph) answer+ else trace msg answer++-- Build the graph using the vertices and the Result so far.+makeG :: [V] -> Result -> G+makeG vs r = concatMap (makeEdgesForV r) vs++-- Returns all as Simple and Normal. The fst V is from the ProtoInfo+-- the snd [V] is from the DescriptorInfo.+makeVertices :: ProtoInfo -> (V,[V])+makeVertices pi = answer where+ answer = ( protoInfoV , map makeV (messages pi) )++ protoInfoV = V { vMKey = pKey (protoMod pi)+ , vNeedsKeys = mempty+ , vKeysNeedsTypes = knt (extensionKeys pi)+ , vTypeNeedsTypes = mempty }++ makeV di = V { vMKey = pKey (descName di)+ , vNeedsKeys = nk (knownKeys di)+ , vKeysNeedsTypes = knt (keys di)+ , vTypeNeedsTypes = tnt (fields di) }++ allK = Set.fromList (pKey (protoMod pi) : map (pKey . descName) (messages pi))+ allT = Set.fromList (map (pKey . descName) (messages pi))++ tnt :: Seq FieldInfo -> Set MKey+ tnt fs = Set.intersection allT $ Set.fromList $ map pKey . mapMaybe typeName . F.toList $ fs++ knt :: Seq KeyInfo -> Set MKey+ knt ks =+ let (pns, fsL) = unzip (F.toList ks)+ fnt :: [FieldInfo] -> Set MKey+ fnt fs = Set.fromList $ (map pKey . mapMaybe typeName $ fs) ++ (map (pfKey . fieldName) fs)+ in Set.intersection allT $ Set.union (Set.fromList (map pKey pns)) (fnt fsL)++ nk :: Seq FieldInfo -> Set MKey+ nk fs = Set.intersection allK $ Set.fromList $ map (pfKey . fieldName) . F.toList $ fs++-- The only need for KeyTypeBoot (and SplitKeyTypeBoot) is to break+-- key-only import cycles. 'breakKeys' finds and breaks these SSCs by+-- marking files as KeyTypeBoot. Since foreign keys implies a+-- reciprocal type import, additional files can get changed to+-- TypeBoot and some incoming links marked to use Source.+breakKeys :: (V,[V]) -> Result+breakKeys (pv,vsOther) =+ let vs = pv : vsOther+ es = map makeInitialEdges vs where+ makeInitialEdges v = (v,L Normal self,[ L Normal b | b <- Set.toList (vNeedsKeys v), b/=self ])+ where self = vMKey v+ -- For 'a'/='b': if 'a' needs key from 'b' then 'b' must need type from 'a'+ -- this recursion means 'a' cannot be Simple so change to TypeBoot+ startingResult = Result { rKind = needTypeBoot, rIBoot = mempty, rIKey = mempty }+ needTypeBoot = Map.singleton (vMKey pv) TopProtoInfo `Map.union`+ ( Map.fromList . map (\(_,L _ a,_) -> (a,TypeBoot))+ . filter (\(_,_,bLs) -> not (null bLs)) $ es )+ -- break always moves things to KeyTypeBoot from TypeBoot (not+ -- Simple) because they are in a Key-import SCC: this means they+ -- are importing foreign keys and thus they are in needTypeBoot+ breakSCCs :: Result -> SCCs -> Result+ breakSCCs r sccs = r `mappend` mconcat (map breakSCC sccs)+ breakSCC :: G -> Result+ breakSCC [] = imp $ "breakKeys.breakSCC: The SCC cannot be empty!"+ breakSCC es' = let (toBust,next'sccs) = snd $ maximumBy (compare `on` fst) (map f (pullEach es'))+ where f ((v,_,_),es'') = let (s,sccs) = score es'' in (s,(v,sccs))+ bk = vMKey toBust -- ZZZ + ik = Set.fromList [ (ek,bk) | ek <- map (vMKey . fst3) es', ek/=bk ] -- ZZZ+ newResult = Result { rKind = Map.singleton bk KeyTypeBoot+ , rIBoot = mempty+ , rIKey = ik } -- ZZZ+ in breakSCCs newResult next'sccs+ -- Init boot marks some incoming links to use SOURCE+ initBoot r = r { rIBoot = Set.fromList . concatMap withParts $ es }+ where withParts (_,L _ a,bLs) = [ withPart a b | L _ b <- bLs ]+ withPart a b = let p = getKey (getKind r b) in (b,p,a)+ in initBoot $ breakSCCs startingResult (cycles es)++score :: G -> ( (Int,Int), SCCs )+score es = ((value,parts),sccs) where+ sccs = cycles es+ -- A length n SCC can be solved by changing at most (n-1) vertices+ -- The value is the difference between the+ -- old graph which required at most (pred . length) ed changes+ -- and the new graphs which require at most (sum (map (pred . length) sccs)) changes+ -- so a larger value is preferred+ value = (pred . length) es - (sum (map (pred . length) sccs))+ -- The number of parts is used as a potential tie breaker, prefering more parts+ parts = length sccs -- # of pieces++-- select the non-trivial sccs from edges+cycles :: G -> SCCs+cycles = filter atLeastTwo . map flattenSCC . stronglyConnCompR+ where atLeastTwo :: [a] -> Bool+ atLeastTwo (_:_:_) = True+ atLeastTwo _ = False++-- pull out each element as candidate and list without the element+pullEach :: [a] -> [(a,[a])]+pullEach = go id where go _ [] = []+ go f (x:xs) = (x,f xs) : go (f . (x:)) xs++-- This builds an edge E from the vertex V and ensures that V has the+-- right vKind from the Result. This must make the same judgements as+-- Gen.hs does in importPN and import PFN+makeEdgesForV :: Result -> V -> [E]+makeEdgesForV r v =+ let me = vMKey v; myKind = getK me+ getK = getKind r; self p = L p me;+ typeL p n = if Set.notMember (me,p,n) (rIBoot r) then L Normal n+ else let checkSource = getType (getK n)+ in if checkSource == Source then L Source n -- sanity check+ else error "makeEdgesForV.typeL.getType.getK of n did not return Source!"+ keyL n = if Set.notMember (me,n) (rIKey r) then L Normal n+ else L (getKey (getK n)) n+ sKNT (L p _) = Set.map (typeL p) (vKeysNeedsTypes v)+ sTNT (L p _) = Set.map (typeL p) (vTypeNeedsTypes v)+ sNK _ = Set.map keyL (vNeedsKeys v)++ notMe set = [ e | e@(L _p o) <- Set.toList set, o/=me ]+ standard = let s = self Normal in (v,s,notMe $ Set.unions [ sKNT s, sTNT s, sNK s])+ source = let s = self Source in (v,s,[])+ sourceKTB = let s = self Source in (v,s,notMe $ sKNT s)+ standardSKTB = let s = self Normal in (v,s,notMe' $ Set.union (sNK s) (sTNT s))+ where notMe' set = [ e | e@(L p o) <- Set.toList set, o/=me || p==KeyFile ]+ keyfileSKTB = let s = self KeyFile in (v,s,Set.toList $ sKNT s)++ in case myKind of -- commented out the purely SOURCE and SINK nodes:+ TopProtoInfo -> [standard]+ Simple -> [standard]+ TypeBoot -> [standard,source]+ KeyTypeBoot -> [standard,sourceKTB]+ SplitKeyTypeBoot -> [standardSKTB,keyfileSKTB,source]++breakGraph :: Result -> SCCs -> Result+breakGraph r [] = ecart ("\nbreakGraph leaf answer\n"++displayResult r) $ r+breakGraph r sccs = ecart ("\nbreakGraph\n"++displayResult r) $+ r `mappend` mconcat (map (breakCycle r) (rejoinVertices sccs))++-- I wonder if there is any input which leads to a module having+-- different parts in different SCCs. Rather than try and+-- over-analyze this wierd edge case this 'rejoinVertices' function+-- will detect it and join the SCCs.+rejoinVertices :: SCCs -> SCCs+rejoinVertices [] = []+rejoinVertices g@([_]) = g+rejoinVertices gs = + let vgs :: [(Set MKey,G)]+ vgs = map (\ g -> (Set.fromList . map (vMKey . fst3) $ g,g)) gs+ process [] = []+ process ((_,g):[]) = [g]+ process ((v,g):rest) = walk id rest where+ walk p [] = g : process (p [])+ walk p (x@(v',g'):rest') | Set.null (Set.intersection v v') = walk (p . (x:)) rest'+ | otherwise = process ((Set.union v v',g++g') : p [])+ in process vgs++{-+breakCycle is a work in progress. The ans' value tries to change+incoming type links to the Source file, then ans'R. The ans'R tries to+change outgoing links to point to Source files. The ans'TB changes+from Simple/Normal to TypeBoot (adding a source file). The ans'SKTB+changes from KeyTypeBoot/Source to SplitKeyTypeBoot.++The reason these changes are done in stages is to try and avoid ghc's+warnings that a {-# SOURCE #-} import is not not needed.+-}+breakCycle :: Result -> G -> Result+breakCycle oldR sccIn = + let bits = map snd3 sccIn -- trace+ -- toCompare should never be null.+ toCompare = mapMaybe f (pullEach sccIn) where+ allV = Set.fromList (map (vMKey . fst3) sccIn)+ f :: (E,[E]) -> Maybe ((Int, Int), (Result, SCCs))+ f (e@(v,L p me,_bLs), es) = ecart (">< picking:\n"++showE e+++ "\nfrom:"++show bits+++ "\nscore: "++show observe++"\n") $+ answer where+ answer = case (getKind oldR me,p) of+ (TopProtoInfo,Normal) -> ans'R+ (Simple,Normal) -> ans'R `mplus` ans'TB -- ans' is part of ans'TB+ (TypeBoot,Normal) -> ans' `mplus` ans'R+ (KeyTypeBoot,Normal) -> ans' `mplus` ans'R+ (KeyTypeBoot,Source) -> ans'RK `mplus` ans'SKTB -- ans' may be redundant+ (SplitKeyTypeBoot,Normal) -> ans' `mplus` ans'R+ (SplitKeyTypeBoot,KeyFile) -> ans'RK -- ans' may be redundant+ (TypeBoot,Source) -> imp $+ "breakCycle.toCompare.f cannot have (TypeBoot,Source) in SCC!" ++ eMsg+ (SplitKeyTypeBoot,Source) -> imp $+ "breakCycle.toCompare.f cannot have (SplitKeyTypeBoot,Source) in SCC!" ++ eMsg+ _ -> imp $ "breakCycle.toCompare.f: impossible combination in SCC:"++ eMsg+ observe = case answer of Nothing -> "Nothing"; Just (s,_) -> "Just "++show s -- trace+ eMsg = '\n':unlines (map showE (e:es))++ ans',ans'R,ans'TB,ans'SKTB :: Maybe ((Int, Int), (Result, SCCs))+ ans' = if Set.null newIBoot then Nothing+ else go $ oldR `mappend` Result { rKind = mempty+ , rIBoot = newIBoot+ , rIKey = mempty }+ ans'R = if Set.null newIBootR then Nothing+ else go $ oldR `mappend` Result { rKind = mempty+ , rIBoot = newIBootR+ , rIKey = mempty }+ ans'RK = if Set.null newIBootRK then Nothing+ else go $ oldR `mappend` Result { rKind = mempty+ , rIBoot = newIBootRK+ , rIKey = mempty }+ ans'TB = go $ oldR `mappend` Result { rKind = Map.singleton me TypeBoot+ , rIBoot = newIBoot -- do (TypeBoot,Normal) -> ans'+ , rIKey = mempty }+ ans'SKTB = go $ oldR `mappend` Result { rKind = Map.singleton me SplitKeyTypeBoot+ , rIBoot = newIBootSKTB+ , rIKey = Set.singleton (me,me) }++ newIBoot,newIBootR,newIBootRK,newIBootSKTB :: Set (MKey,Part,MKey)+ newIBoot = Set.fromList $ do+ (va,L pa a,_) <- es+ iguard (Set.member a allV) $+ "breakCycle.toCompare.newIBoot sanity check 083425 failed:"++eMsg+ guard (((pa == Normal) &&+ (Set.member me (vTypeNeedsTypes va))) ||+ ((pa == getKey (getKind oldR a)) &&+ (Set.member me (vKeysNeedsTypes va))))+ let x=(a,pa,me)+ guard (Set.notMember x (rIBoot oldR)) -- needed when used in newIBoot2+ return x+ newIBootR = Set.fromList $ do+ b <- Set.toList (Set.union (vTypeNeedsTypes v) (vKeysNeedsTypes v))+ guard (Set.member b allV)+ guard (Source == getType (getKind oldR b))+ guard (me /= b || p == KeyFile)+ let x = (me,p,b)+ guard (Set.notMember x (rIBoot oldR))+ return x+ newIBootRK = Set.fromList $ do+ b <- Set.toList (vKeysNeedsTypes v)+ guard (Set.member b allV)+ guard (Source == getType (getKind oldR b))+ guard (me /= b || p == KeyFile)+ let x = (me,p,b)+ guard (Set.notMember x (rIBoot oldR))+ return x+ newIBootSKTB = Set.union newIBoot . Set.fromList $ + (if Set.member me (vKeysNeedsTypes v) then ((me,KeyFile,me):) else id) $ do+ b <- Set.toList (vKeysNeedsTypes v)+ guard (Set.member (me,Source,b) (rIBoot oldR)) -- copy from (me,Source,b)+ let x = (me,KeyFile,b) -- copy to (me,KeyFile,b)+ iguard (Set.notMember x (rIBoot oldR)) $+ "breakCycle.toCompare.newIBoot2 KeyTypeBoot already had entries for KeyFile!:"++eMsg+ return x++ go :: Result -> Maybe ((Int, Int), (Result, SCCs))+ go newR = let (s,sccs) = score (makeG (map fst3 (e:es)) newR)+ in Just (s,(newR,sccs))+ in ecart (">< breakCycle of "++show bits++"\n\n") $+ if null toCompare+ then imp $ "breakCycle: This SCC had no Simple or KeyTypeBoot nodes!\n"++ unlines (map show sccIn)+ else let (newR,next'sccs) = snd $ maximumBy (compare `on` fst) toCompare+ in breakGraph newR next'sccs++-- 'cull' tries to remove all the extra {-# SOURCE #-} pragmas. I am+-- not certain that repeating the 'cull' will make any difference.+cull :: [V] -> Result -> Result+cull vs rIn =+ let trial :: Result -> (MKey,Part,MKey) -> Result+ trial old x = let new = old { rIBoot = Set.delete x (rIBoot old) }+ in if null (cycles (makeG vs new)) then new else old+ rOut = foldl' trial rIn (Set.toList (rIBoot rIn))+ in if rOut == rIn then rOut else cull vs rOut+
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -13,110 +13,196 @@ -- 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,descriptorModule,enumModule,prettyPrint) where+module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,prettyPrint) where import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),DescriptorInfo(..),ProtoInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),FieldInfo(..)) +import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(Result(..),VertexKind(..),pKey,pfKey,getKind,Part(..))+ import qualified Data.ByteString.Lazy.Char8 as LC(unpack) import qualified Data.Foldable as F(foldr,toList)-import Data.List(sortBy,foldl',foldl1',sort)+import Data.List(sortBy,foldl',foldl1',group,sort,union) import Data.Function(on)-import Language.Haskell.Pretty(prettyPrint)-import Language.Haskell.Syntax+import Language.Haskell.Exts.Pretty(prettyPrint)+import Language.Haskell.Exts.Syntax hiding (Int,String)+import Language.Haskell.Exts.Syntax as Hse import qualified Data.Map as M+import Data.Maybe(mapMaybe) import qualified Data.Sequence as Seq(null,length) import qualified Data.Set as S+import System.FilePath(joinPath) --import Debug.Trace(trace) +ecart :: String -> a -> a+ecart _ x = x+ default (Int) -- -- -- -- Helper functions -noWhere :: [HsDecl]-noWhere = [] -- YYY noWhere = (HsBDecls [])+imp :: String -> a+imp s = error ("Impossible? Text.ProtocolBuffers.ProtoCompile.Gen."++s) -($$) :: HsExp -> HsExp -> HsExp-($$) = HsApp+nubSort :: Ord a => [a] -> [a]+nubSort = map head . group . sort +noWhere :: Binds+noWhere = BDecls []++($$) :: Exp -> Exp -> Exp+($$) = App+ infixl 1 $$ src :: SrcLoc src = SrcLoc "No SrcLoc" 0 0 -litStr :: String -> HsExp-litStr = HsLit . HsString+litStr :: String -> Exp+litStr = Lit . Hse.String -litIntP :: Integral x => x -> HsPat-litIntP x | x<0 = HsPParen $ HsPLit (HsInt (toInteger x))- | otherwise = HsPLit (HsInt (toInteger x))+litIntP :: Integral x => x -> Pat+litIntP x | x<0 = PParen $ PLit (Hse.Int (toInteger x))+ | otherwise = PLit (Hse.Int (toInteger x)) -litInt :: Integral x => x -> HsExp-litInt x | x<0 = HsParen $ HsLit (HsInt (toInteger x))- | otherwise = HsLit (HsInt (toInteger x))+litInt :: Integral x => x -> Exp+litInt x | x<0 = Paren $ Lit (Hse.Int (toInteger x))+ | otherwise = Lit (Hse.Int (toInteger x)) -typeApp :: String -> HsType -> HsType-typeApp s = HsTyApp (HsTyCon (private s))+typeApp :: String -> Type -> Type+typeApp s = TyApp (TyCon (private s)) -private :: String -> HsQName-private t = Qual (Module "P'") (HsIdent t)+private :: String -> QName+private t = Qual (ModuleName "P'") (Ident t) -local :: String -> HsQName-local t = UnQual (HsIdent t)+local :: String -> QName+local t = UnQual (Ident t) -pvar :: String -> HsExp-pvar t = HsVar (private t)+pvar :: String -> Exp+pvar t = Var (private t) -pcon :: String -> HsExp-pcon t = HsCon (private t)+pcon :: String -> Exp+pcon t = Con (private t) -lvar :: String -> HsExp-lvar t = HsVar (local t)+lvar :: String -> Exp+lvar t = Var (local t) -lcon :: String -> HsExp-lcon t = HsCon (local t)+lcon :: String -> Exp+lcon t = Con (local t) -var :: String -> HsPat-var t = HsPVar (HsIdent t)+patvar :: String -> Pat+patvar t = PVar (Ident t) -match :: String -> [HsPat] -> HsExp -> HsMatch-match s p r = HsMatch src (HsIdent s) p (HsUnGuardedRhs r) noWhere+match :: String -> [Pat] -> Exp -> Match+match s p r = Match src (Ident s) p Nothing (UnGuardedRhs r) noWhere -inst :: String -> [HsPat] -> HsExp -> HsDecl-inst s p r = HsFunBind [match s p r]+inst :: String -> [Pat] -> Exp -> InstDecl+inst s p r = InsDecl $ FunBind [match s p r] -mkOp :: String -> HsExp -> HsExp -> HsExp-mkOp s a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol s))) b+defun :: String -> [Pat] -> Exp -> Decl+defun s p r = FunBind [match s p r] -compose :: HsExp -> HsExp -> HsExp+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) = fmName $ foldr dotFM (promoteFM c) . map promoteFM $ a++b+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 src m1 True fromSource (Just m2)+ (Just (False,[IAbs (Ident (mName (baseName pn)))]))+ 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 (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 src m1key qualifiedFlag sourceFlag 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++-- Several items might be taken from the same module, combine these statements+mergeImports :: [ImportDecl] -> [ImportDecl]+mergeImports importsIn =+ let idKey (ImportDecl _p1 p2 p3 p4 p5 (Just (p6,_xs))) = (p2,p3,p4,p5,Just p6)+ idKey (ImportDecl _p1 p2 p3 p4 p5 Nothing) = (p2,p3,p4,p5,Nothing)+ mergeImports' (ImportDecl p1 p2 p3 p4 p5 (Just (p6,xs)))+ (ImportDecl _ _ _ _ _ (Just (_,ys))) =+ ImportDecl p1 p2 p3 p4 p5 (Just (p6,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 -> HsName-baseIdent = HsIdent . mName . baseName-baseIdent' :: ProtoFName -> HsName-baseIdent' = HsIdent . fName . baseName'+baseIdent :: ProtoName -> Name+baseIdent = Ident . mName . baseName+baseIdent' :: ProtoFName -> Name+baseIdent' = Ident . fName . baseName' -qualName :: ProtoName -> HsQName+qualName :: ProtoName -> QName qualName p@(ProtoName _ _prefix [] _base) = UnQual (baseIdent p)-qualName p@(ProtoName _ _prefix (parents) _base) = Qual (Module (joinMod parents)) (baseIdent p)+qualName p@(ProtoName _ _prefix (parents) _base) = Qual (ModuleName (joinMod parents)) (baseIdent p) -qualFName :: ProtoFName -> HsQName+qualFName :: ProtoFName -> QName qualFName p@(ProtoFName _ _prefix [] _base) = UnQual (baseIdent' p)-qualFName p@(ProtoFName _ _prefix parents _base) = Qual (Module (joinMod parents)) (baseIdent' p)+qualFName p@(ProtoFName _ _prefix parents _base) = Qual (ModuleName (joinMod parents)) (baseIdent' p) -unqualName :: ProtoName -> HsQName-unqualName p@(ProtoName _ _prefix _parent _base) = UnQual (baseIdent p)+unqualName :: ProtoName -> QName+unqualName p = UnQual (baseIdent p) -mayQualName :: ProtoName -> ProtoFName -> HsQName+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) = if joinMod (c'prefix++c'parents++[c'base]) == joinMod (prefix++parents) then UnQual (baseIdent' name) -- name is local, make UnQual@@ -125,14 +211,14 @@ -------------------------------------------- -- EnumDescriptorProto module creation ---------------------------------------------enumModule :: EnumInfo -> HsModule+enumModule :: EnumInfo -> Module enumModule ei = let protoName = enumName ei- in HsModule src (Module (fqMod protoName))- (Just [HsEThingAll (UnQual (baseIdent protoName))])+ in Module src (ModuleName (fqMod protoName)) [] Nothing+ (Just [EThingAll (unqualName protoName)]) (standardImports True False) (enumDecls ei) -enumDecls :: EnumInfo -> [HsDecl]+enumDecls :: EnumInfo -> [Decl] enumDecls ei = map ($ ei) [ enumX , instanceMergeableEnum , instanceBounded@@ -145,18 +231,19 @@ , instanceReflectEnum ] -enumX :: EnumInfo -> HsDecl-enumX ei = HsDataDecl src [] (baseIdent (enumName ei)) [] (map enumValueX (enumValues ei)) derivesEnum- where enumValueX (_,name) = HsConDecl src (HsIdent name) []+enumX :: EnumInfo -> Decl+enumX ei = DataDecl src DataType [] (baseIdent (enumName ei)) [] (map enumValueX (enumValues ei)) derivesEnum+-- where enumValueX (_,name) = ConDecl src (HsIdent name) []+ where enumValueX (_,name) = QualConDecl src [] [] (ConDecl (Ident name) []) -instanceMergeableEnum :: EnumInfo -> HsDecl+instanceMergeableEnum :: EnumInfo -> Decl instanceMergeableEnum ei - = HsInstDecl src [] (private "Mergeable") [HsTyCon (unqualName (enumName ei))] []+ = InstDecl src [] (private "Mergeable") [TyCon (unqualName (enumName ei))] [] -instanceBounded :: EnumInfo -> HsDecl+instanceBounded :: EnumInfo -> Decl instanceBounded ei- = HsInstDecl src [] (private "Bounded") [HsTyCon (unqualName (enumName ei))] - [set "minBound" (head values),set "maxBound" (last values)] -- values cannot be null in a well formed enum+ = InstDecl src [] (private "Bounded") [TyCon (unqualName (enumName ei))] + [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) @@ -168,77 +255,77 @@ // This never returns NULL. -}-instanceDefaultEnum :: EnumInfo -> HsDecl+instanceDefaultEnum :: EnumInfo -> Decl instanceDefaultEnum ei- = HsInstDecl src [] (private "Default") [HsTyCon (unqualName (enumName ei))]+ = InstDecl src [] (private "Default") [TyCon (unqualName (enumName ei))] [ inst "defaultValue" [] firstValue ]- where firstValue :: HsExp+ where firstValue :: Exp firstValue = case enumValues ei of (:) (_,n) _ -> lcon n [] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei -declToEnum :: EnumInfo -> [HsDecl]-declToEnum ei = [ HsTypeSig src [HsIdent "toMaybe'Enum"]- (HsQualType [] (HsTyFun (HsTyCon (private "Int"))- (typeApp "Maybe" (HsTyCon (unqualName (enumName ei))))))- , HsFunBind (map toEnum'one values ++ [final]) ]+declToEnum :: EnumInfo -> [Decl]+declToEnum ei = [ TypeSig src [Ident "toMaybe'Enum"]+ (TyFun (TyCon (private "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)] (pcon "Just" $$ lcon n)- final = match "toMaybe'Enum" [HsPWildCard] (pcon "Nothing")+ final = match "toMaybe'Enum" [PWildCard] (pcon "Nothing") -instanceEnum :: EnumInfo -> HsDecl+instanceEnum :: EnumInfo -> Decl instanceEnum ei- = HsInstDecl src [] (private "Enum") [HsTyCon (unqualName (enumName ei))]- (map HsFunBind [fromEnum',toEnum',succ',pred'])+ = InstDecl src [] (private "Enum") [TyCon (unqualName (enumName ei))]+ (map (InsDecl . FunBind) [fromEnum',toEnum',succ',pred']) where values = enumValues ei fromEnum' = map fromEnum'one values- fromEnum'one (v,n) = match "fromEnum" [HsPApp (local n) []] (litInt (getEnumCode v))+ fromEnum'one (v,n) = match "fromEnum" [PApp (local n) []] (litInt (getEnumCode v)) toEnum' = [ match "toEnum" [] (compose mayErr (lvar "toMaybe'Enum")) ]- mayErr = pvar "fromMaybe" $$ (HsParen (pvar "error" $$ (litStr $ + mayErr = pvar "fromMaybe" $$ (Paren (pvar "error" $$ (litStr $ "hprotoc generated code: toEnum failure for type "++ fqMod (enumName ei)))) succ' = zipWith (equate "succ") values (tail values) ++- [ match "succ" [HsPWildCard] (pvar "error" $$ (litStr $ + [ match "succ" [PWildCard] (pvar "error" $$ (litStr $ "hprotoc generated code: succ failure for type "++ fqMod (enumName ei))) ] pred' = zipWith (equate "pred") (tail values) values ++- [ match "pred" [HsPWildCard] (pvar "error" $$ (litStr $ + [ match "pred" [PWildCard] (pvar "error" $$ (litStr $ "hprotoc generated code: pred failure for type "++ fqMod (enumName ei))) ]- equate f (_,n1) (_,n2) = match f [HsPApp (local n1) []] (lcon n2)+ equate f (_,n1) (_,n2) = match f [PApp (local n1) []] (lcon n2) -- fromEnum TYPE_ENUM == 14 :: Int-instanceWireEnum :: EnumInfo -> HsDecl+instanceWireEnum :: EnumInfo -> Decl instanceWireEnum ei- = HsInstDecl src [] (private "Wire") [HsTyCon (unqualName (enumName ei))]+ = InstDecl src [] (private "Wire") [TyCon (unqualName (enumName ei))] [ withName "wireSize", withName "wirePut", withGet, withGetErr ]- where withName foo = inst foo [var "ft'",var "enum"] rhs+ where withName foo = inst foo [patvar "ft'",patvar "enum"] rhs where rhs = pvar foo $$ lvar "ft'" $$- (HsParen $ pvar "fromEnum" $$ lvar "enum")+ (Paren $ pvar "fromEnum" $$ lvar "enum") withGet = inst "wireGet" [litIntP 14] rhs where rhs = pvar "wireGetEnum" $$ lvar "toMaybe'Enum"- withGetErr = inst "wireGet" [var "ft'"] rhs+ withGetErr = inst "wireGet" [patvar "ft'"] rhs where rhs = pvar "wireGetErr" $$ lvar "ft'" -instanceGPB :: ProtoName -> HsDecl+instanceGPB :: ProtoName -> Decl instanceGPB protoName- = HsInstDecl src [] (private "GPB") [HsTyCon (unqualName protoName)] []+ = InstDecl src [] (private "GPB") [TyCon (unqualName protoName)] [] -instanceReflectEnum :: EnumInfo -> HsDecl+instanceReflectEnum :: EnumInfo -> Decl instanceReflectEnum ei- = HsInstDecl src [] (private "ReflectEnum") [HsTyCon (unqualName (enumName ei))]+ = InstDecl src [] (private "ReflectEnum") [TyCon (unqualName (enumName ei))] [ inst "reflectEnum" [] ascList- , inst "reflectEnumInfo" [ HsPWildCard ] ei' ]+ , inst "reflectEnumInfo" [ PWildCard ] ei' ] where (ProtoName xxx a b c) = enumName ei- xxx'Exp = HsParen $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx)))+ xxx'Exp = Paren $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx))) values = enumValues ei- ascList,ei',protoNameExp :: HsExp- ascList = HsList (map one values)- where one (v,ns) = HsTuple [litInt (getEnumCode v),litStr ns,lcon ns]- ei' = foldl' HsApp (pcon "EnumInfo") [protoNameExp- ,HsList $ map litStr (enumFilePath ei)- ,HsList (map two values)]- where two (v,ns) = HsTuple [litInt (getEnumCode v),litStr ns]- protoNameExp = HsParen $ foldl' HsApp (pvar "makePNF")+ ascList,ei',protoNameExp :: Exp+ ascList = List (map one values)+ where one (v,ns) = Tuple [litInt (getEnumCode v),litStr ns,lcon ns]+ ei' = foldl' App (pcon "EnumInfo") [protoNameExp+ ,List $ map litStr (enumFilePath ei)+ ,List (map two values)]+ where two (v,ns) = Tuple [litInt (getEnumCode v),litStr ns]+ protoNameExp = Paren $ foldl' App (pvar "makePNF") [ xxx'Exp, mList a, mList b, litStr (mName c) ]- where mList = HsList . map (litStr . mName)+ where mList = List . map (litStr . mName) hasExt :: DescriptorInfo -> Bool hasExt di = not (null (extRanges di))@@ -247,143 +334,196 @@ -- FileDescriptorProto module creation -------------------------------------------- -protoModule :: ProtoInfo -> ByteString -> HsModule-protoModule pri@(ProtoInfo protoName _ _ keyInfos _ _ _) fdpBS- = let exportKeys = map (HsEVar . UnQual . baseIdent' . fieldName . snd) (F.toList keyInfos)- exportNames = map (HsEVar . UnQual . HsIdent) ["protoInfo","fileDescriptorProto"]- imports = protoImports ++ map formatImport (protoImport pri)- in HsModule src (Module (fqMod protoName)) (Just (exportKeys++exportNames)) imports (keysX protoName keyInfos ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)- where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) ++- [ HsImportDecl src (Module "Text.DescriptorProtos.FileDescriptorProto") False Nothing- (Just (False,[HsIAbs (HsIdent "FileDescriptorProto")]))- , HsImportDecl src (Module "Text.ProtocolBuffers.Reflections") False Nothing- (Just (False,[HsIAbs (HsIdent "ProtoInfo")]))- , HsImportDecl src (Module "Text.ProtocolBuffers.WireMessage") True (Just (Module "P'"))- (Just (False,[HsIVar (HsIdent "wireGet,getFromBS")]))- ]- formatImport ((a,b),s) = HsImportDecl src (Module a) True asM (Just (False,map (HsIAbs . HsIdent) (S.toList s)))- where asM | a==b = Nothing- | otherwise = Just (Module b)--protoImport :: ProtoInfo -> [((String,String),S.Set String)]-protoImport protoInfo- = M.assocs . M.fromListWith S.union . filter isForeign . map withMod $ keyNames- where isForeign = let here = fqMod protoName- in (\((a,_),_) -> a/=here)- protoName = protoMod protoInfo- withMod p@(ProtoName _ _prefix modname base) = ((fqMod p,joinMod modname),S.singleton (mName base))- keyNames = F.foldr (\(e,fi) rest -> e : addName fi rest) [] (extensionKeys protoInfo)- addName fi rest = maybe rest (:rest) (typeName fi)+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 src m [] Nothing (Just (exportKeys++exportNames)) imports+ (keysXTypeVal protoName (extensionKeys pri) ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)+ where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) +++ [ ImportDecl src (ModuleName "Text.DescriptorProtos.FileDescriptorProto") False False Nothing+ (Just (False,[IAbs (Ident "FileDescriptorProto")]))+ , ImportDecl src (ModuleName "Text.ProtocolBuffers.Reflections") False False Nothing+ (Just (False,[IAbs (Ident "ProtoInfo")]))+ , ImportDecl src (ModuleName "Text.ProtocolBuffers.WireMessage") True False (Just (ModuleName "P'"))+ (Just (False,[IVar (Ident "wireGet,getFromBS")])) ] -embed'ProtoInfo :: ProtoInfo -> [HsDecl]+embed'ProtoInfo :: ProtoInfo -> [Decl] embed'ProtoInfo pri = [ myType, myValue ]- where myType = HsTypeSig src [ HsIdent "protoInfo" ] (HsQualType [] (HsTyCon (local "ProtoInfo")))- myValue = HsPatBind src (HsPApp (local "protoInfo") []) (HsUnGuardedRhs $+ where myType = TypeSig src [ Ident "protoInfo" ] (TyCon (local "ProtoInfo"))+ myValue = PatBind src (PApp (local "protoInfo") []) Nothing (UnGuardedRhs $ pvar "read" $$ litStr (show pri)) noWhere -embed'fdpBS :: ByteString -> [HsDecl]+embed'fdpBS :: ByteString -> [Decl] embed'fdpBS bs = [ myType, myValue ]- where myType = HsTypeSig src [ HsIdent "fileDescriptorProto" ] (HsQualType [] (HsTyCon (local "FileDescriptorProto")))- myValue = HsPatBind src (HsPApp (local "fileDescriptorProto") []) (HsUnGuardedRhs $+ where myType = TypeSig src [ Ident "fileDescriptorProto" ] (TyCon (local "FileDescriptorProto"))+ myValue = PatBind src (PApp (local "fileDescriptorProto") []) Nothing (UnGuardedRhs $ pvar "getFromBS" $$- HsParen (pvar "wireGet" $$ litInt 11) $$ - HsParen (pvar "pack" $$ litStr (LC.unpack bs))) noWhere+ Paren (pvar "wireGet" $$ litInt 11) $$ + Paren (pvar "pack" $$ litStr (LC.unpack bs))) noWhere -------------------------------------------- -- DescriptorProto module creation ---------------------------------------------descriptorModule :: DescriptorInfo -> HsModule-descriptorModule di- = let protoName = descName di- un = UnQual . baseIdent $ protoName- imports = standardImports False (hasExt di) ++ map formatImport (toImport di)- exportKeys = map (HsEVar . UnQual . baseIdent' . fieldName . snd) (F.toList (keys di))- formatImport ((a,b),s) = HsImportDecl src (Module a) True asM (Just (False, map (HsIAbs . HsIdent) (S.toList s)))- where asM | a==b = Nothing- | otherwise = Just (Module b)- in HsModule src (Module (fqMod protoName))- (Just (HsEThingAll un : exportKeys))- imports (descriptorX di : (keysX protoName (keys di) ++ instancesDescriptor di))+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)] -standardImports :: Bool -> Bool -> [HsImportDecl]-standardImports en ext =- [ HsImportDecl src (Module "Prelude") False Nothing (Just (False,ops))- , HsImportDecl src (Module "Prelude") True (Just (Module "P'")) Nothing- , HsImportDecl src (Module "Text.ProtocolBuffers.Header") True (Just (Module "P'")) Nothing ]- where ops | ext = map (HsIVar . HsSymbol) $ base ++ ["==","<=","&&"," || "]- | otherwise = map (HsIVar . HsSymbol) base- base | en = ["+","."]+-- 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 = ["Show","Eq","Ord","Typeable","Mergeable","Default","Wire","GPB","ReflectDescriptor"]+ ++ if hasExt di then ["ExtendMessage"] else []+ ++ if storeUnknown di then ["UnknownMessage"] else []+ instMesAPI = InstDecl src [] (private "MessageAPI")+ [TyVar (Ident "msg'"), TyFun (TyVar (Ident "msg'")) (TyCon un), (TyCon un)] []+ dataDecl = DataDecl src DataType [] (baseIdent protoName) [] [] []+ mkInst s = InstDecl src [] (private s) [TyCon un] []+ in Module src (ModuleName (fqMod protoName)) [] Nothing (Just [EAbs un]) 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 p1 m@(ModuleName _self) p3 p4 (Just exports) 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 p1 m p3 p4 (Just (exports++exportKeys)) (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 src m [] Nothing (Just exportKeys) (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 = map (EVar . unqualFName . fieldName) myKeys+ imports = (standardImports False (hasExt di) ++) . mergeImports . concat $+ [ mapMaybe (importPN result m Normal) $+ extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di)))+ , mapMaybe (importPFN result m) (map fieldName (myKeys ++ F.toList (knownKeys di))) ]+ declKeys | sepKey = []+ | otherwise = keysXTypeVal (descName di) (keys di)+ in Module src m [] Nothing (Just (EThingAll un : exportKeys)) imports+ (descriptorX di : declKeys ++ instancesDescriptor di)++minimalImports :: [ImportDecl]+minimalImports =+ [ ImportDecl src (ModuleName "Prelude") True False (Just (ModuleName "P'")) Nothing+ , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False (Just (ModuleName "P'")) Nothing ]++standardImports :: Bool -> Bool -> [ImportDecl]+standardImports isEnumMod ext =+ [ ImportDecl src (ModuleName "Prelude") False False Nothing (Just (False,ops))+ , ImportDecl src (ModuleName "Prelude") True False (Just (ModuleName "P'")) Nothing+ , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False (Just (ModuleName "P'")) Nothing ]+ where ops | ext = map (IVar . Symbol) $ base ++ ["==","<=","&&"]+ | otherwise = map (IVar . Symbol) base+ base | isEnumMod = ["+","."] | otherwise = ["+"] -toImport :: DescriptorInfo -> [((String,String),S.Set String)]-toImport di- = M.assocs . M.fromListWith S.union . filter isForeign . map withMod $ allNames- where isForeign = let here = fqMod protoName- in (\((a,_),_) -> a/=here)- protoName = descName di- withMod (Left p@(ProtoName _ _prefix modname base)) = ((fqMod p,joinMod modname),S.singleton (mName base))- withMod (Right (ProtoFName _ prefix modname base)) = ((joinMod (prefix++modname),joinMod modname),S.singleton (fName base))- allNames = F.foldr addName keyNames (fields di)- keyNames = F.foldr (\(e,fi) rest -> Left e : addName fi rest) keysKnown (keys di)- addName fi rest = maybe rest (:rest) (fmap Left (typeName fi))- keysKnown = F.foldr (\fi rest -> Right (fieldName fi) : rest) [] (knownKeys di)+keysXType :: ProtoName -> Seq KeyInfo -> [Decl]+keysXType self ks = map (makeKeyType self) . F.toList $ ks -keysX :: ProtoName -> Seq KeyInfo -> [HsDecl]-keysX self i = concatMap (makeKey self) . F.toList $ i+keysXTypeVal :: ProtoName -> Seq KeyInfo -> [Decl]+keysXTypeVal self ks = concatMap (\ ki -> [makeKeyType self ki,makeKeyVal self ki]) . F.toList $ ks -makeKey :: ProtoName -> KeyInfo -> [HsDecl]-makeKey self (extendee,f) = [ keyType, keyVal ]- where keyType = HsTypeSig src [ baseIdent' . fieldName $ f ] (HsQualType [] (foldl1 HsTyApp . map HsTyCon $+makeKeyType :: ProtoName -> KeyInfo -> Decl+makeKeyType self (extendee,f) = keyType+ where keyType = TypeSig src [ baseIdent' . fieldName $ f ] (foldl1 TyApp . map TyCon $ [ private "Key", private labeled , if extendee /= self then qualName extendee else unqualName extendee- , typeQName ]))+ , typeQName ]) labeled | canRepeat f = "Seq" | otherwise = "Maybe" typeNumber = getFieldType . typeCode $ f- typeQName :: HsQName+ 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- keyVal = HsPatBind src (HsPApp (UnQual (baseIdent' . fieldName $ f)) []) (HsUnGuardedRhs++makeKeyVal :: ProtoName -> KeyInfo -> Decl+makeKeyVal _self (_extendee,f) = keyVal+ where typeNumber = getFieldType . typeCode $ f+ keyVal = PatBind src (PApp (unqualFName . fieldName $ f) []) Nothing (UnGuardedRhs (pvar "Key" $$ litInt (getFieldId (fieldNumber f)) $$ litInt typeNumber $$ maybe (pvar "Nothing")- (HsParen . (pvar "Just" $$) . (defToSyntax (typeCode f)))+ (Paren . (pvar "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f) )) noWhere -defToSyntax :: FieldType -> HsDefault -> HsExp+defToSyntax :: FieldType -> HsDefault -> Exp defToSyntax tc x = case x of HsDef'Bool b -> pcon (show b)- HsDef'ByteString bs -> (if tc == 9 then (\xx -> HsParen (pvar "Utf8" $$ xx)) else id) $- (HsParen $ pvar "pack" $$ litStr (LC.unpack bs))- HsDef'Rational r | r < 0 -> HsParen $ HsLit (HsFrac r)- | otherwise -> HsLit (HsFrac r)+ HsDef'ByteString bs -> (if tc == 9 then (\ xx -> Paren (pvar "Utf8" $$ xx)) else id) $+ (Paren $ pvar "pack" $$ litStr (LC.unpack bs))+ HsDef'Rational r | r < 0 -> Paren $ Lit (Frac r)+ | otherwise -> Lit (Frac r) HsDef'Integer i -> litInt i - HsDef'Enum s -> HsParen $ pvar "read" $$ litStr s+ HsDef'Enum s -> Paren $ pvar "read" $$ litStr s -descriptorX :: DescriptorInfo -> HsDecl-descriptorX di = HsDataDecl src [] name [] [con] derives+descriptorX :: DescriptorInfo -> Decl+descriptorX di = DataDecl src DataType [] name [] [QualConDecl src [] [] con] derives where self = descName di- name = baseIdent $ self- con = HsRecDecl src name eFields+ name = baseIdent self+ con = RecDecl name eFields where eFields = F.foldr ((:) . fieldX) end (fields di) end = (if hasExt di then (extfield:) else id) $ (if storeUnknown di then [unknownField] else [])- extfield :: ([HsName],HsBangType)- extfield = ([HsIdent "ext'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "ExtField"))))- unknownField :: ([HsName],HsBangType)- unknownField = ([HsIdent "unknown'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "UnknownField"))))- fieldX :: FieldInfo -> ([HsName],HsBangType)- fieldX fi = ([baseIdent' . fieldName $ fi],HsUnBangedTy (labeled (HsTyCon typed)))+ extfield :: ([Name],BangType)+ extfield = ([Ident "ext'field"],UnBangedTy (TyCon (private "ExtField")))+ unknownField :: ([Name],BangType)+ unknownField = ([Ident "unknown'field"],UnBangedTy (TyCon (private "UnknownField")))+ fieldX :: FieldInfo -> ([Name],BangType)+ fieldX fi = ([baseIdent' . fieldName $ fi],UnBangedTy (labeled (TyCon typed))) where labeled | canRepeat fi = typeApp "Seq" | isRequired fi = id | otherwise = typeApp "Maybe"- typed :: HsQName+ typed :: QName typed = case useType (getFieldType (typeCode fi)) of Just s -> private s Nothing -> case typeName fi of@@ -391,7 +531,7 @@ | otherwise -> unqualName s Nothing -> error $ "No Name for Field!\n" ++ show fi -instancesDescriptor :: DescriptorInfo -> [HsDecl]+instancesDescriptor :: DescriptorInfo -> [Decl] instancesDescriptor di = map ($ di) $ (if hasExt di then (instanceExtendMessage:) else id) $ (if storeUnknown di then (instanceUnknownMessage:) else id) $@@ -403,56 +543,56 @@ , instanceReflectDescriptor ] -instanceExtendMessage :: DescriptorInfo -> HsDecl+instanceExtendMessage :: DescriptorInfo -> Decl instanceExtendMessage di- = HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (baseIdent (descName di)))]+ = InstDecl src [] (private "ExtendMessage") [TyCon (unqualName (descName di))] [ inst "getExtField" [] (lvar "ext'field")- , inst "putExtField" [var "e'f", var "msg"] putextfield- , inst "validExtRanges" [var "msg"] (pvar "extRanges" $$ (HsParen $ pvar "reflectDescriptorInfo" $$ lvar "msg"))+ , inst "putExtField" [patvar "e'f", patvar "msg"] putextfield+ , inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren $ pvar "reflectDescriptorInfo" $$ lvar "msg")) ]- where putextfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (local "ext'field") (lvar "e'f") ]+ where putextfield = RecUpdate (lvar "msg") [ FieldUpdate (local "ext'field") (lvar "e'f") ] -instanceUnknownMessage :: DescriptorInfo -> HsDecl+instanceUnknownMessage :: DescriptorInfo -> Decl instanceUnknownMessage di- = HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (baseIdent (descName di)))]+ = InstDecl src [] (private "UnknownMessage") [TyCon (unqualName (descName di))] [ inst "getUnknownField" [] (lvar "unknown'field")- , inst "putUnknownField" [var "u'f",var "msg"] putunknownfield+ , inst "putUnknownField" [patvar "u'f",patvar "msg"] putunknownfield ]- where putunknownfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (local "unknown'field") (lvar "u'f") ]+ where putunknownfield = RecUpdate (lvar "msg") [ FieldUpdate (local "unknown'field") (lvar "u'f") ] -instanceMergeable :: DescriptorInfo -> HsDecl+instanceMergeable :: DescriptorInfo -> Decl instanceMergeable di- = HsInstDecl src [] (private "Mergeable") [HsTyCon un]- [ inst "mergeEmpty" [] (foldl' HsApp (HsCon un) (replicate len (pcon "mergeEmpty")))- , inst "mergeAppend" [HsPApp un patternVars1, HsPApp un patternVars2]- (foldl' HsApp (HsCon un) (zipWith append vars1 vars2))+ = InstDecl src [] (private "Mergeable") [TyCon un]+ [ inst "mergeEmpty" [] (foldl' App (Con un) (replicate len (pcon "mergeEmpty")))+ , inst "mergeAppend" [PApp un patternVars1, PApp un patternVars2]+ (foldl' App (Con un) (zipWith append vars1 vars2)) ]- where un = UnQual (baseIdent (descName di))+ where un = unqualName (descName di) len = (if hasExt di then succ else id) $ (if storeUnknown di then succ else id) $ Seq.length (fields di)- patternVars1,patternVars2 :: [HsPat]+ patternVars1,patternVars2 :: [Pat] patternVars1 = take len inf- where inf = map (\n -> var ("x'" ++ show n)) [1..]+ where inf = map (\ n -> patvar ("x'" ++ show n)) [1..] patternVars2 = take len inf- where inf = map (\n -> var ("y'" ++ show n)) [1..]- vars1,vars2 :: [HsExp]+ where inf = map (\ n -> patvar ("y'" ++ show n)) [1..]+ vars1,vars2 :: [Exp] vars1 = take len inf- where inf = map (\n -> lvar ("x'" ++ show n)) [1..]+ where inf = map (\ n -> lvar ("x'" ++ show n)) [1..] vars2 = take len inf- where inf = map (\n -> lvar ("y'" ++ show n)) [1..]- append x y = HsParen $ pvar "mergeAppend" $$ x $$ y+ where inf = map (\ n -> lvar ("y'" ++ show n)) [1..]+ append x y = Paren $ pvar "mergeAppend" $$ x $$ y -instanceDefault :: DescriptorInfo -> HsDecl+instanceDefault :: DescriptorInfo -> Decl instanceDefault di- = HsInstDecl src [] (private "Default") [HsTyCon un]- [ inst "defaultValue" [] (foldl' HsApp (HsCon un) deflistExt) ]- where un = UnQual (baseIdent (descName di))+ = InstDecl src [] (private "Default") [TyCon un]+ [ 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 []) - defX :: FieldInfo -> HsExp+ defX :: FieldInfo -> Exp defX fi | isRequired fi = dv1 | otherwise = dv2 where dv1 = case hsDefault fi of@@ -460,16 +600,16 @@ Just hsdef -> defToSyntax (typeCode fi) hsdef dv2 = case hsDefault fi of Nothing -> pvar "defaultValue"- Just hsdef -> HsParen $ pcon "Just" $$ defToSyntax (typeCode fi) hsdef+ Just hsdef -> Paren $ pcon "Just" $$ defToSyntax (typeCode fi) hsdef -instanceMessageAPI :: ProtoName -> HsDecl+instanceMessageAPI :: ProtoName -> Decl instanceMessageAPI protoName- = HsInstDecl src [] (private "MessageAPI")- [HsTyVar (HsIdent "msg'"), HsTyFun (HsTyVar (HsIdent "msg'")) (HsTyCon un), (HsTyCon un)]- [ inst "getVal" [var "m'",var "f'"] (HsApp (lvar "f'" ) (lvar "m'")) ]- where un = UnQual (baseIdent protoName)+ = InstDecl src [] (private "MessageAPI")+ [TyVar (Ident "msg'"), TyFun (TyVar (Ident "msg'")) (TyCon un), (TyCon un)]+ [ inst "getVal" [patvar "m'",patvar "f'"] (App (lvar "f'" ) (lvar "m'")) ]+ where un = unqualName protoName -instanceWireDescriptor :: DescriptorInfo -> HsDecl+instanceWireDescriptor :: DescriptorInfo -> Decl instanceWireDescriptor di@(DescriptorInfo { descName = protoName , fields = fieldInfos , extRanges = allowedExts@@ -479,25 +619,25 @@ len = (if extensible then succ else id) $ (if storeUnknown di then succ else id) $ Seq.length fieldInfos- mine = HsPApp me . take len . map (\n -> var ("x'" ++ show n)) $ [1..]- vars = take len . map (\n -> lvar ("x'" ++ show n)) $ [1..]+ mine = PApp me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [1..]+ vars = take len . map (\ n -> lvar ("x'" ++ show n)) $ [1..] mExt | extensible = Just (vars !! Seq.length fieldInfos) | otherwise = Nothing mUnknown | storeUnknown di = Just (last vars) | otherwise = Nothing -- first case is for Group behavior, second case is for Message behavior, last is error handler- cases g m e = HsCase (lvar "ft'") [ HsAlt src (litIntP 10) (HsUnGuardedAlt g) noWhere- , HsAlt src (litIntP 11) (HsUnGuardedAlt m) noWhere- , HsAlt src HsPWildCard (HsUnGuardedAlt e) noWhere+ cases g m e = Case (lvar "ft'") [ Alt src (litIntP 10) (UnGuardedAlt g) noWhere+ , Alt src (litIntP 11) (UnGuardedAlt m) noWhere+ , Alt src PWildCard (UnGuardedAlt e) noWhere ] - sizeCases = HsUnGuardedRhs $ cases (lvar "calc'Size") + sizeCases = UnGuardedRhs $ cases (lvar "calc'Size") (pvar "prependMessageSize" $$ lvar "calc'Size") (pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")- whereCalcSize = [inst "calc'Size" [] sizes]- sizes | null sizesList = HsLit (HsInt 0)- | otherwise = HsParen (foldl1' (+!) sizesList)+ whereCalcSize = BDecls [defun "calc'Size" [] sizes]+ sizes | null sizesList = Lit (Hse.Int 0)+ | otherwise = Paren (foldl1' (+!) sizesList) where (+!) = mkOp "+" sizesList | Just v <- mUnknown = sizesListExt ++ [ pvar "wireSizeUnknownField" $$ v ] | otherwise = sizesListExt@@ -507,23 +647,23 @@ toSize var fi = let f = if isRequired fi then "wireSizeReq" else if canRepeat fi then "wireSizeRep" else "wireSizeOpt"- in foldl' HsApp (pvar f) [ litInt (wireTagLength fi)+ in foldl' App (pvar f) [ litInt (wireTagLength fi) , litInt (getFieldType (typeCode fi)) , var] - putCases = HsUnGuardedRhs $ cases+ putCases = UnGuardedRhs $ cases (lvar "put'Fields")- (HsDo [ HsQualifier $ pvar "putSize" $$- (HsParen $ foldl' HsApp (pvar "wireSize") [ litInt 10 , lvar "self'" ])- , HsQualifier $ lvar "put'Fields" ])+ (Do [ Qualifier $ pvar "putSize" $$+ (Paren $ foldl' App (pvar "wireSize") [ litInt 10 , lvar "self'" ])+ , Qualifier $ lvar "put'Fields" ]) (pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")- wherePutFields = [inst "put'Fields" [] (HsDo putStmts)]+ wherePutFields = BDecls [defun "put'Fields" [] (Do putStmts)] putStmts = putStmtsContent- where putStmtsContent | null putStmtsAll = [HsQualifier $ pvar "return" $$ HsCon (Special HsUnitCon)]+ where putStmtsContent | null putStmtsAll = [Qualifier $ pvar "return" $$ Con (Special UnitCon)] | otherwise = putStmtsAll- putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ HsQualifier $ pvar "wirePutUnknownField" $$ v ]+ putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ Qualifier $ pvar "wirePutUnknownField" $$ v ] | otherwise = putStmtsListExt- putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ HsQualifier $ pvar "wirePutExtField" $$ v ]+ putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ Qualifier $ pvar "wirePutExtField" $$ v ] | otherwise = sortedPutStmtsList sortedPutStmtsList = map snd -- remove number . sortBy (compare `on` fst) -- sort by number@@ -533,97 +673,97 @@ toPut var fi = let f = if isRequired fi then "wirePutReq" else if canRepeat fi then "wirePutRep" else "wirePutOpt"- in HsQualifier $- foldl' HsApp (pvar f) [ litInt (getWireTag (wireTag fi))+ in Qualifier $+ foldl' App (pvar f) [ litInt (getWireTag (wireTag fi)) , litInt (getFieldType (typeCode fi)) , var] - getCases = HsUnGuardedRhs $ cases+ getCases = UnGuardedRhs $ cases (pvar "getBareMessageWith" $$ lvar "check'allowed") (pvar "getMessageWith" $$ lvar "check'allowed") (pvar "wireGetErr" $$ lvar "ft'")- whereDecls = [whereUpdateSelf,whereAllowed,whereCheckAllowed]- whereAllowed = inst "allowed'wire'Tags" [] (pvar "fromDistinctAscList" $$ HsList (map litInt allowed))+ whereDecls = BDecls [whereUpdateSelf,whereAllowed,whereCheckAllowed]+ whereAllowed = defun "allowed'wire'Tags" [] (pvar "fromDistinctAscList" $$ List (map litInt allowed)) allowed = sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di)] ++ [ getWireTag (wireTag f) | f <- F.toList (knownKeys di)] locals = ["wire'Tag","field'Number","wire'Type","old'Self"]- whereCheckAllowed = inst "check'allowed" (map var locals) process+ whereCheckAllowed = defun "check'allowed" (map patvar locals) process where process = if storeUnknown di then catchUn updateBranch else updateBranch- catchUn s = pvar "catchError" $$ HsParen s- $$ HsParen (HsLambda src [HsPWildCard] (args (pvar "loadUnknown")))+ catchUn s = pvar "catchError" $$ Paren s+ $$ Paren (Lambda src [PWildCard] (args (pvar "loadUnknown"))) updateBranch | null allowed = extBranch- | otherwise = HsIf (pvar "member" $$ lvar "wire'Tag" $$ lvar "allowed'wire'Tags")+ | otherwise = If (pvar "member" $$ lvar "wire'Tag" $$ lvar "allowed'wire'Tags") (lvar "update'Self" $$ lvar "field'Number" $$ lvar "old'Self") extBranch- extBranch | extensible = HsIf (isAllowedExt (lvar "field'Number"))+ extBranch | extensible = If (isAllowedExt (lvar "field'Number")) (args (pvar "loadExtension")) unknownBranch | otherwise = unknownBranch unknownBranch =args (pvar "unknown") args x = x $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self"- isAllowedExt x = pvar "or" $$ HsList ranges where- (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp ("==")- 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+ isAllowedExt x = pvar "or" $$ List ranges where+ (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp "=="+ 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 where FieldId maxHi = maxBound- whereUpdateSelf = inst "update'Self" [var "field'Number", var "old'Self"]- (HsCase (lvar "field'Number") updateAlts)+ whereUpdateSelf = defun "update'Self" [patvar "field'Number", patvar "old'Self"]+ (Case (lvar "field'Number") updateAlts) updateAlts = map toUpdate (F.toList fieldInfos) ++ (if extensible && (not (Seq.null fieldExts)) then map toUpdateExt (F.toList fieldExts) else [])- ++ [HsAlt src HsPWildCard (HsUnGuardedAlt $+ ++ [Alt src PWildCard (UnGuardedAlt $ pvar "unknownField" $$ (lvar "old'Self") $$ (lvar "field'Number")) noWhere]- toUpdateExt fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $- pvar "wireGetKey" $$ HsVar (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere- toUpdate fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $ - pvar "fmap" $$ (HsParen $ HsLambda src [var "new'Field"] $- HsRecUpdate (lvar "old'Self")- [HsFieldUpdate (UnQual . baseIdent' . fieldName $ fi)- (labelUpdate fi)])- $$ (HsParen (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere- labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . fName . baseName' . fieldName $ fi)+ toUpdateExt fi = Alt src (litIntP . getFieldId . fieldNumber $ fi) (UnGuardedAlt $+ pvar "wireGetKey" $$ Var (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere+ toUpdate fi = Alt src (litIntP . getFieldId . fieldNumber $ fi) (UnGuardedAlt $ + pvar "fmap" $$ (Paren $ Lambda src [patvar "new'Field"] $+ RecUpdate (lvar "old'Self")+ [FieldUpdate (unqualFName . fieldName $ fi)+ (labelUpdate fi)])+ $$ (Paren (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ labelUpdate fi | canRepeat fi = pvar "append" $$ Paren ((Var . unqualFName . fieldName $ fi) $$ lvar "old'Self") $$ lvar "new'Field" | isRequired fi = qMerge (lvar "new'Field") | otherwise = qMerge (pcon "Just" $$ lvar "new'Field") where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,11] =- pvar "mergeAppend" $$ HsParen ( (lvar . fName . baseName' . fieldName $ fi)+ pvar "mergeAppend" $$ Paren ( (Var . unqualFName . fieldName $ fi) $$ lvar "old'Self" )- $$ HsParen x+ $$ Paren x | otherwise = x -- 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 "append" uses -- knowledge of how all repeated fields get merged.- in HsInstDecl src [] (private "Wire") [HsTyCon me]- [ HsFunBind [HsMatch src (HsIdent "wireSize") [var "ft'",HsPAsPat (HsIdent "self'") (HsPParen mine)] sizeCases whereCalcSize]- , HsFunBind [HsMatch src (HsIdent "wirePut") [var "ft'",HsPAsPat (HsIdent "self'") (HsPParen mine)] putCases wherePutFields]- , HsFunBind [HsMatch src (HsIdent "wireGet") [var "ft'"] getCases whereDecls]+ in InstDecl src [] (private "Wire") [TyCon me] . map InsDecl $+ [ FunBind [Match src (Ident "wireSize") [patvar "ft'",PAsPat (Ident "self'") (PParen mine)] Nothing sizeCases whereCalcSize]+ , FunBind [Match src (Ident "wirePut") [patvar "ft'",PAsPat (Ident "self'") (PParen mine)] Nothing putCases wherePutFields]+ , FunBind [Match src (Ident "wireGet") [patvar "ft'"] Nothing getCases whereDecls] ] -instanceReflectDescriptor :: DescriptorInfo -> HsDecl+instanceReflectDescriptor :: DescriptorInfo -> Decl instanceReflectDescriptor di- = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (baseIdent (descName di)))]- [ inst "getMessageInfo" [HsPWildCard] gmi- , inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ]+ = InstDecl src [] (private "ReflectDescriptor") [TyCon (unqualName (descName di))]+ [ inst "getMessageInfo" [PWildCard] gmi+ , inst "reflectDescriptorInfo" [ PWildCard ] rdi ] where -- massive shortcut through show and read- rdi :: HsExp- rdi = pvar "read" $$ litStr (show di) -- cheat using show and read- gmi,reqId,allId :: HsExp- gmi = pcon "GetMessageInfo" $$ HsParen reqId $$ HsParen allId+ rdi :: Exp+ rdi = pvar "read" $$ litStr (show di)+ gmi,reqId,allId :: Exp+ gmi = pcon "GetMessageInfo" $$ Paren reqId $$ Paren allId reqId = pvar "fromDistinctAscList" $$- HsList (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di), isRequired f])+ List (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di), isRequired f]) allId = pvar "fromDistinctAscList" $$- HsList (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di)] +++ List (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di)] ++ [ getWireTag (wireTag f) | f <- F.toList (knownKeys di)]) ------------------------------------------------------------------ -derives,derivesEnum :: [HsQName]-derives = map private ["Show","Eq","Ord","Typeable"]-derivesEnum = map private ["Read","Show","Eq","Ord","Typeable"]+derives,derivesEnum :: [Deriving]+derives = map (\ x -> (private x,[])) ["Show","Eq","Ord","Typeable"]+derivesEnum = map (\ x -> (private x,[])) ["Read","Show","Eq","Ord","Typeable"] useType :: Int -> Maybe String useType 1 = Just "Double"@@ -644,4 +784,4 @@ useType 16 = Just "Int64" useType 17 = Just "Int32" useType 18 = Just "Int64"-useType x = error $ "Text.ProtocolBuffers.Gen: Impossible? useType Unknown type code "++show x+useType x = imp $ "useType: Unknown type code (expected 1 to 18) of "++show x
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -52,7 +52,7 @@ import Text.ProtocolBuffers.ProtoCompile.Lexer(Lexed(..),alexScanTokens,getLinePos) import Text.ProtocolBuffers.ProtoCompile.Instances(parseLabel,parseType) -import Control.Monad(when,liftM2,liftM3,replicateM)+import Control.Monad(when,liftM2,liftM3) import qualified Data.ByteString.Lazy.Char8 as LC(notElem,head) import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString) import Data.Char(isUpper,toLower)
hprotoc.cabal view
@@ -1,7 +1,6 @@ name: hprotoc--- Synchronize this version number with Text.ProtocolBuffers.ProtocolCompile.version-version: 1.2.2-cabal-version: >= 1.2+version: 1.4.0+cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE@@ -24,10 +23,10 @@ Executable hprotoc Main-Is: Text/ProtocolBuffers/ProtoCompile.hs build-tools: alex- ghc-options: -Wall- build-depends: protocol-buffers == 1.2.2, protocol-buffers-descriptor == 1.2.2+ ghc-options: -O2 -Wall+ build-depends: protocol-buffers == 1.4.0, protocol-buffers-descriptor == 1.4.0 build-depends: binary, utf8-string- build-depends: parsec, haskell-src,+ build-depends: parsec < 3, haskell-src-exts == 0.4.8, containers,bytestring,array,filepath,directory,mtl,QuickCheck if flag(small_base)@@ -36,6 +35,7 @@ build-depends: base == 3.* other-modules: Paths_hprotoc+ Text.ProtocolBuffers.ProtoCompile.BreakRecursion Text.ProtocolBuffers.ProtoCompile.Gen Text.ProtocolBuffers.ProtoCompile.Instances Text.ProtocolBuffers.ProtoCompile.Lexer