diff --git a/Text/ProtocolBuffers/ProtoCompile.hs b/Text/ProtocolBuffers/ProtoCompile.hs --- a/Text/ProtocolBuffers/ProtoCompile.hs +++ b/Text/ProtocolBuffers/ProtoCompile.hs @@ -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))) diff --git a/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs @@ -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 + diff --git a/Text/ProtocolBuffers/ProtoCompile/Gen.hs b/Text/ProtocolBuffers/ProtoCompile/Gen.hs --- a/Text/ProtocolBuffers/ProtoCompile/Gen.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Gen.hs @@ -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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Parser.hs b/Text/ProtocolBuffers/ProtoCompile/Parser.hs --- a/Text/ProtocolBuffers/ProtoCompile/Parser.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Parser.hs @@ -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) diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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