{-# LANGUAGE CPP #-}

{-| 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 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 :: String -> a -> a
ecart String
_ a
a = a
a

fst3 :: (a,b,c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
x,b
_,c
_) = a
x

snd3 :: (a,b,c) -> b
snd3 :: (a, b, c) -> b
snd3 (a
_,b
x,c
_) = b
x

imp :: String -> a
imp :: String -> a
imp String
s = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Inconceivable! Text.ProtocolBuffers.ProtoCompile.BreakRecursion."String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s

iguard :: Monad m => Bool -> String -> m ()
iguard :: Bool -> String -> m ()
iguard Bool
True String
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
iguard Bool
False String
s = String -> m ()
forall a. String -> a
imp String
s

-- The Gen.hs module will be working with these String types
type MKey = FMName String

pKey :: ProtoName -> MKey
pKey :: ProtoName -> MKey
pKey (ProtoName {haskellPrefix :: ProtoName -> [MName String]
haskellPrefix=[MName String]
a,parentModule :: ProtoName -> [MName String]
parentModule=[MName String]
b,baseName :: ProtoName -> MName String
baseName=MName String
c}) = (MKey -> MKey -> MKey) -> [MKey] -> MKey
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MKey -> MKey -> MKey
forall a. Dotted a => FMName a -> FMName a -> FMName a
dotFM ([MKey] -> MKey)
-> ([MName String] -> [MKey]) -> [MName String] -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MName String -> MKey) -> [MName String] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map MName String -> MKey
forall a. Dotted a => MName a -> FMName a
promoteFM ([MName String] -> MKey) -> [MName String] -> MKey
forall a b. (a -> b) -> a -> b
$ [MName String]
a[MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++[MName String]
b[MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++[MName String
c]

pfKey :: ProtoFName -> MKey
pfKey :: ProtoFName -> MKey
pfKey (ProtoFName {haskellPrefix' :: ProtoFName -> [MName String]
haskellPrefix'=[MName String]
a,parentModule' :: ProtoFName -> [MName String]
parentModule'=[MName String]
b}) = (MKey -> MKey -> MKey) -> [MKey] -> MKey
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MKey -> MKey -> MKey
forall a. Dotted a => FMName a -> FMName a -> FMName a
dotFM ([MKey] -> MKey)
-> ([MName String] -> [MKey]) -> [MName String] -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MName String -> MKey) -> [MName String] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map MName String -> MKey
forall a. Dotted a => MName a -> FMName a
promoteFM ([MName String] -> MKey) -> [MName String] -> MKey
forall a b. (a -> b) -> a -> b
$ [MName String]
a[MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++[MName String]
b

-- Which reprensentation a message currently has
data VertexKind = TopProtoInfo
                | Simple
                | TypeBoot
                | KeyTypeBoot
                | SplitKeyTypeBoot
  deriving (Int -> VertexKind -> String -> String
[VertexKind] -> String -> String
VertexKind -> String
(Int -> VertexKind -> String -> String)
-> (VertexKind -> String)
-> ([VertexKind] -> String -> String)
-> Show VertexKind
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [VertexKind] -> String -> String
$cshowList :: [VertexKind] -> String -> String
show :: VertexKind -> String
$cshow :: VertexKind -> String
showsPrec :: Int -> VertexKind -> String -> String
$cshowsPrec :: Int -> VertexKind -> String -> String
Show,VertexKind -> VertexKind -> Bool
(VertexKind -> VertexKind -> Bool)
-> (VertexKind -> VertexKind -> Bool) -> Eq VertexKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VertexKind -> VertexKind -> Bool
$c/= :: VertexKind -> VertexKind -> Bool
== :: VertexKind -> VertexKind -> Bool
$c== :: VertexKind -> VertexKind -> Bool
Eq,Eq VertexKind
Eq VertexKind
-> (VertexKind -> VertexKind -> Ordering)
-> (VertexKind -> VertexKind -> Bool)
-> (VertexKind -> VertexKind -> Bool)
-> (VertexKind -> VertexKind -> Bool)
-> (VertexKind -> VertexKind -> Bool)
-> (VertexKind -> VertexKind -> VertexKind)
-> (VertexKind -> VertexKind -> VertexKind)
-> Ord VertexKind
VertexKind -> VertexKind -> Bool
VertexKind -> VertexKind -> Ordering
VertexKind -> VertexKind -> VertexKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VertexKind -> VertexKind -> VertexKind
$cmin :: VertexKind -> VertexKind -> VertexKind
max :: VertexKind -> VertexKind -> VertexKind
$cmax :: VertexKind -> VertexKind -> VertexKind
>= :: VertexKind -> VertexKind -> Bool
$c>= :: VertexKind -> VertexKind -> Bool
> :: VertexKind -> VertexKind -> Bool
$c> :: VertexKind -> VertexKind -> Bool
<= :: VertexKind -> VertexKind -> Bool
$c<= :: VertexKind -> VertexKind -> Bool
< :: VertexKind -> VertexKind -> Bool
$c< :: VertexKind -> VertexKind -> Bool
compare :: VertexKind -> VertexKind -> Ordering
$ccompare :: VertexKind -> VertexKind -> Ordering
$cp1Ord :: Eq VertexKind
Ord)

-- Which of the 3 sorts of files (maked with * in analysis) a vertex represents
data Part = Normal | Source | KeyFile deriving (Int -> Part -> String -> String
[Part] -> String -> String
Part -> String
(Int -> Part -> String -> String)
-> (Part -> String) -> ([Part] -> String -> String) -> Show Part
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Part] -> String -> String
$cshowList :: [Part] -> String -> String
show :: Part -> String
$cshow :: Part -> String
showsPrec :: Int -> Part -> String -> String
$cshowsPrec :: Int -> Part -> String -> String
Show,Part -> Part -> Bool
(Part -> Part -> Bool) -> (Part -> Part -> Bool) -> Eq Part
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Part -> Part -> Bool
$c/= :: Part -> Part -> Bool
== :: Part -> Part -> Bool
$c== :: Part -> Part -> Bool
Eq,Eq Part
Eq Part
-> (Part -> Part -> Ordering)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Part)
-> (Part -> Part -> Part)
-> Ord Part
Part -> Part -> Bool
Part -> Part -> Ordering
Part -> Part -> Part
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Part -> Part -> Part
$cmin :: Part -> Part -> Part
max :: Part -> Part -> Part
$cmax :: Part -> Part -> Part
>= :: Part -> Part -> Bool
$c>= :: Part -> Part -> Bool
> :: Part -> Part -> Bool
$c> :: Part -> Part -> Bool
<= :: Part -> Part -> Bool
$c<= :: Part -> Part -> Bool
< :: Part -> Part -> Bool
$c< :: Part -> Part -> Bool
compare :: Part -> Part -> Ordering
$ccompare :: Part -> Part -> Ordering
$cp1Ord :: Eq Part
Ord)

-- Vertex data.  A graph may have several nodes with the same value of
-- V and different values of Part.
data V = V { V -> MKey
vMKey :: !MKey
           , V -> Set MKey
vNeedsKeys :: !(Set MKey)
           , V -> Set MKey
vKeysNeedsTypes :: !(Set MKey)
           , V -> Set MKey
vTypeNeedsTypes :: !(Set MKey) }
  deriving Int -> V -> String -> String
[V] -> String -> String
V -> String
(Int -> V -> String -> String)
-> (V -> String) -> ([V] -> String -> String) -> Show V
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [V] -> String -> String
$cshowList :: [V] -> String -> String
show :: V -> String
$cshow :: V -> String
showsPrec :: Int -> V -> String -> String
$cshowsPrec :: Int -> V -> String -> String
Show

-- A link to a module's file
data Label = L !Part !MKey deriving (Int -> Label -> String -> String
[Label] -> String -> String
Label -> String
(Int -> Label -> String -> String)
-> (Label -> String) -> ([Label] -> String -> String) -> Show Label
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Label] -> String -> String
$cshowList :: [Label] -> String -> String
show :: Label -> String
$cshow :: Label -> String
showsPrec :: Int -> Label -> String -> String
$cshowsPrec :: Int -> Label -> String -> String
Show,Label -> Label -> Bool
(Label -> Label -> Bool) -> (Label -> Label -> Bool) -> Eq Label
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Label -> Label -> Bool
$c/= :: Label -> Label -> Bool
== :: Label -> Label -> Bool
$c== :: Label -> Label -> Bool
Eq,Eq Label
Eq Label
-> (Label -> Label -> Ordering)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Label)
-> (Label -> Label -> Label)
-> Ord Label
Label -> Label -> Bool
Label -> Label -> Ordering
Label -> Label -> Label
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Label -> Label -> Label
$cmin :: Label -> Label -> Label
max :: Label -> Label -> Label
$cmax :: Label -> Label -> Label
>= :: Label -> Label -> Bool
$c>= :: Label -> Label -> Bool
> :: Label -> Label -> Bool
$c> :: Label -> Label -> Bool
<= :: Label -> Label -> Bool
$c<= :: Label -> Label -> Bool
< :: Label -> Label -> Bool
$c< :: Label -> Label -> Bool
compare :: Label -> Label -> Ordering
$ccompare :: Label -> Label -> Ordering
$cp1Ord :: Eq Label
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 { Result -> Map MKey VertexKind
rKind :: Map MKey VertexKind
                     , Result -> Set (MKey, Part, MKey)
rIBoot :: Set (MKey,Part,MKey)
                     , Result -> Set (MKey, MKey)
rIKey :: Set (MKey,MKey) }
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq,Int -> Result -> String -> String
[Result] -> String -> String
Result -> String
(Int -> Result -> String -> String)
-> (Result -> String)
-> ([Result] -> String -> String)
-> Show Result
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result] -> String -> String
$cshowList :: [Result] -> String -> String
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> String -> String
$cshowsPrec :: Int -> Result -> String -> String
Show)

displayResult :: Result -> String
displayResult :: Result -> String
displayResult (Result {rKind :: Result -> Map MKey VertexKind
rKind = Map MKey VertexKind
kv, rIBoot :: Result -> Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
ab, rIKey :: Result -> Set (MKey, MKey)
rIKey=Set (MKey, MKey)
ab'keys }) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [ String
"--- displayResult ----"
  , String
"Modules which are not Simple"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((MKey, VertexKind) -> String) -> [(MKey, VertexKind)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(MKey
k,VertexKind
v) -> String -> String
indent (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Show a => a -> String -> String
shows (MKey -> String
forall a. FMName a -> a
fmName MKey
k) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"  has kind  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ VertexKind -> String
forall a. Show a => a -> String
show VertexKind
v) (Map MKey VertexKind -> [(MKey, VertexKind)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map MKey VertexKind
kv) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
"Module imports marked with SOURCE for Types"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((MKey, Part, MKey) -> String) -> [(MKey, Part, MKey)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
indent (String -> String)
-> ((MKey, Part, MKey) -> String) -> (MKey, Part, MKey) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MKey, Part, MKey) -> String
forall a. Show a => (MKey, a, MKey) -> String
untriple) (Set (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall a. Set a -> [a]
Set.toAscList Set (MKey, Part, MKey)
ab) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
"Module imports marked with SOURCE or 'Key for keys"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((MKey, MKey) -> String) -> [(MKey, MKey)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
indent (String -> String)
-> ((MKey, MKey) -> String) -> (MKey, MKey) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MKey, MKey) -> String
unpair) (Set (MKey, MKey) -> [(MKey, MKey)]
forall a. Set a -> [a]
Set.toAscList Set (MKey, MKey)
ab'keys)
 where indent :: String -> String
indent = (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:)(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:)
       untriple :: (MKey, a, MKey) -> String
untriple (MKey
a,a
p,MKey
b) = MKey -> String
forall a. FMName a -> a
fmName MKey
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : import {-# SOURCE #-} " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MKey -> String
forall a. FMName a -> a
fmName MKey
b
       unpair :: (MKey, MKey) -> String
unpair (MKey
a,MKey
b) = MKey -> String
forall a. FMName a -> a
fmName MKey
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : import {-# SOURCE or 'Key #-} " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MKey -> String
forall a. FMName a -> a
fmName MKey
b

showSCCs :: SCCs -> String
showSCCs :: SCCs -> String
showSCCs SCCs
gs = ([E] -> String) -> SCCs -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ [E]
g -> String
"\n>< SCC Graph ><\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++(E -> String) -> [E] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap E -> String
showE [E]
g) SCCs
gs
showG :: G -> String
showG :: [E] -> String
showG [E]
g = Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:(E -> String) -> [E] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap E -> String
showE [E]
g
showE :: E -> String
showE :: E -> String
showE (V
v,Label
n,[Label]
ls) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
"( "String -> String -> String
forall a. [a] -> [a] -> [a]
++Label -> String
forall a. Show a => a -> String
show Label
n, String
"  , "String -> String -> String
forall a. [a] -> [a] -> [a]
++V -> String
forall a. Show a => a -> String
show V
v, String
"  , "String -> String -> String
forall a. [a] -> [a] -> [a]
++[Label] -> String
forall a. Show a => a -> String
show [Label]
ls, String
")" ]

instance Monoid Result where
  mempty :: Result
mempty = Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result Map MKey VertexKind
forall a. Monoid a => a
mempty Set (MKey, Part, MKey)
forall a. Monoid a => a
mempty Set (MKey, MKey)
forall a. Monoid a => a
mempty
#if __GLASGOW_HASKELL__ >= 804
instance Semigroup Result where
  Result
r1 <> :: Result -> Result -> Result
<> Result
r2 =
#else
  mappend r1 r2 =
#endif
    Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = (VertexKind -> VertexKind -> VertexKind)
-> Map MKey VertexKind
-> Map MKey VertexKind
-> Map MKey VertexKind
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith VertexKind -> VertexKind -> VertexKind
forall a. Ord a => a -> a -> a
max (Result -> Map MKey VertexKind
rKind Result
r1) (Result -> Map MKey VertexKind
rKind Result
r2)
           , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
-> Set (MKey, Part, MKey) -> Set (MKey, Part, MKey)
forall a. Monoid a => a -> a -> a
mappend (Result -> Set (MKey, Part, MKey)
rIBoot Result
r1) (Result -> Set (MKey, Part, MKey)
rIBoot Result
r2)
           , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey) -> Set (MKey, MKey) -> Set (MKey, MKey)
forall a. Monoid a => a -> a -> a
mappend (Result -> Set (MKey, MKey)
rIKey Result
r1) (Result -> Set (MKey, MKey)
rIKey Result
r2) }

getKind :: Result -> MKey -> VertexKind
getKind :: Result -> MKey -> VertexKind
getKind Result
r = let m :: Map MKey VertexKind
m = Result -> Map MKey VertexKind
rKind Result
r in \MKey
n -> VertexKind -> MKey -> Map MKey VertexKind -> VertexKind
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault VertexKind
Simple MKey
n Map MKey VertexKind
m

getType :: VertexKind -> Part
getType :: VertexKind -> Part
getType VertexKind
TopProtoInfo = String -> Part
forall a. String -> a
imp String
"getType: TopProtoInfo"
getType VertexKind
Simple = Part
Normal
getType VertexKind
TypeBoot = Part
Source
getType VertexKind
KeyTypeBoot = Part
Source
getType VertexKind
SplitKeyTypeBoot = Part
Source

getKey :: VertexKind -> Part
getKey :: VertexKind -> Part
getKey VertexKind
TopProtoInfo = Part
Normal
getKey VertexKind
Simple = Part
Normal
getKey VertexKind
TypeBoot = Part
Normal
getKey VertexKind
KeyTypeBoot = Part
Source
getKey VertexKind
SplitKeyTypeBoot = Part
KeyFile

-- 'makeResult' is the main function for this module
makeResult :: ProtoInfo -> Result
makeResult :: ProtoInfo -> Result
makeResult ProtoInfo
protoInfo =
  let pvs :: (V, [V])
pvs@(V
p,[V]
vs) = ProtoInfo -> (V, [V])
makeVertices ProtoInfo
protoInfo
      initResult :: Result
initResult = (V, [V]) -> Result
breakKeys (V, [V])
pvs
      sccs :: SCCs
sccs = [E] -> SCCs
cycles ([V] -> Result -> [E]
makeG (V
pV -> [V] -> [V]
forall a. a -> [a] -> [a]
:[V]
vs) Result
initResult)
      answer :: Result
answer = [V] -> Result -> Result
cull (V
pV -> [V] -> [V]
forall a. a -> [a] -> [a]
:[V]
vs) (Result -> Result) -> Result -> Result
forall a b. (a -> b) -> a -> b
$ Result -> SCCs -> Result
breakGraph Result
initResult SCCs
sccs
      finalGraph :: [E]
finalGraph = [V] -> Result -> [E]
makeG (V
pV -> [V] -> [V]
forall a. a -> [a] -> [a]
:[V]
vs) Result
answer
      remainingProblems :: SCCs
remainingProblems = [E] -> SCCs
cycles [E]
finalGraph
      msg :: String
msg = [String] -> String
unlines [ String
"<!!!!!!!!!!!> KLAXON, RED SPINNING LIGHT, ETC."
                    , String
"! WARNING: hprotoc unexpectedly failed to disentangle all the mutually-recursive message definitions."
                    , String
"! PLEASE REPORT THIS FAILURE ALONG WITH THE PROTO FILE."
                    , String
"! The failed subset is:"
                    ] String -> String -> String
forall a. [a] -> [a] -> [a]
++ SCCs -> String
showSCCs SCCs
remainingProblems String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n</!!!!!!!!!!!>"
  in if SCCs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null SCCs
remainingProblems then String -> Result -> Result
forall a. String -> a -> a
ecart ([E] -> String
showG [E]
finalGraph) Result
answer
     else String -> Result -> Result
forall a. String -> a -> a
trace String
msg Result
answer

-- Build the graph using the vertices and the Result so far.
makeG :: [V] -> Result -> G
makeG :: [V] -> Result -> [E]
makeG [V]
vs Result
r = (V -> [E]) -> [V] -> [E]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Result -> V -> [E]
makeEdgesForV Result
r) [V]
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 :: ProtoInfo -> (V, [V])
makeVertices ProtoInfo
pi = (V, [V])
answer where
  answer :: (V, [V])
answer =  ( V
protoInfoV , (DescriptorInfo -> V) -> [DescriptorInfo] -> [V]
forall a b. (a -> b) -> [a] -> [b]
map DescriptorInfo -> V
makeV (ProtoInfo -> [DescriptorInfo]
messages ProtoInfo
pi) [V] -> [V] -> [V]
forall a. [a] -> [a] -> [a]
++ (OneofInfo -> V) -> [OneofInfo] -> [V]
forall a b. (a -> b) -> [a] -> [b]
map OneofInfo -> V
makeVoneof (ProtoInfo -> [OneofInfo]
oneofs ProtoInfo
pi) )

  protoInfoV :: V
protoInfoV = V :: MKey -> Set MKey -> Set MKey -> Set MKey -> V
V { vMKey :: MKey
vMKey = ProtoName -> MKey
pKey (ProtoInfo -> ProtoName
protoMod ProtoInfo
pi)
                 , vNeedsKeys :: Set MKey
vNeedsKeys = Set MKey
forall a. Monoid a => a
mempty
                 , vKeysNeedsTypes :: Set MKey
vKeysNeedsTypes = Seq KeyInfo -> Set MKey
knt (ProtoInfo -> Seq KeyInfo
extensionKeys ProtoInfo
pi)
                 , vTypeNeedsTypes :: Set MKey
vTypeNeedsTypes = Set MKey
forall a. Monoid a => a
mempty }

  makeV :: DescriptorInfo -> V
makeV DescriptorInfo
di = V :: MKey -> Set MKey -> Set MKey -> Set MKey -> V
V { vMKey :: MKey
vMKey = ProtoName -> MKey
pKey (DescriptorInfo -> ProtoName
descName DescriptorInfo
di)
               , vNeedsKeys :: Set MKey
vNeedsKeys = Seq FieldInfo -> Set MKey
nk (DescriptorInfo -> Seq FieldInfo
knownKeys DescriptorInfo
di)
               , vKeysNeedsTypes :: Set MKey
vKeysNeedsTypes = Seq KeyInfo -> Set MKey
knt (DescriptorInfo -> Seq KeyInfo
keys DescriptorInfo
di)
               , vTypeNeedsTypes :: Set MKey
vTypeNeedsTypes = Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Seq FieldInfo -> Set MKey
tnt (DescriptorInfo -> Seq FieldInfo
fields DescriptorInfo
di)) (Seq OneofInfo -> Set MKey
ont (DescriptorInfo -> Seq OneofInfo
descOneofs DescriptorInfo
di)) }

  makeVoneof :: OneofInfo -> V
makeVoneof OneofInfo
oi = V :: MKey -> Set MKey -> Set MKey -> Set MKey -> V
V { vMKey :: MKey
vMKey = ProtoName -> MKey
pKey (OneofInfo -> ProtoName
oneofName OneofInfo
oi)
                    , vNeedsKeys :: Set MKey
vNeedsKeys = Set MKey
forall a. Monoid a => a
mempty
                    , vKeysNeedsTypes :: Set MKey
vKeysNeedsTypes = Set MKey
forall a. Monoid a => a
mempty
                    , vTypeNeedsTypes :: Set MKey
vTypeNeedsTypes = (Seq FieldInfo -> Set MKey
tnt (Seq FieldInfo -> Set MKey)
-> (OneofInfo -> Seq FieldInfo) -> OneofInfo -> Set MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyInfo -> FieldInfo) -> Seq KeyInfo -> Seq FieldInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyInfo -> FieldInfo
forall a b. (a, b) -> b
snd (Seq KeyInfo -> Seq FieldInfo)
-> (OneofInfo -> Seq KeyInfo) -> OneofInfo -> Seq FieldInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofInfo -> Seq KeyInfo
oneofFields) OneofInfo
oi
                    }                    

  allK :: Set MKey
allK = [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList (ProtoName -> MKey
pKey (ProtoInfo -> ProtoName
protoMod ProtoInfo
pi) MKey -> [MKey] -> [MKey]
forall a. a -> [a] -> [a]
: (DescriptorInfo -> MKey) -> [DescriptorInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoName -> MKey
pKey (ProtoName -> MKey)
-> (DescriptorInfo -> ProtoName) -> DescriptorInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorInfo -> ProtoName
descName) (ProtoInfo -> [DescriptorInfo]
messages ProtoInfo
pi))
  allT :: Set MKey
allT = [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> [MKey] -> Set MKey
forall a b. (a -> b) -> a -> b
$ ((DescriptorInfo -> MKey) -> [DescriptorInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoName -> MKey
pKey (ProtoName -> MKey)
-> (DescriptorInfo -> ProtoName) -> DescriptorInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorInfo -> ProtoName
descName) (ProtoInfo -> [DescriptorInfo]
messages ProtoInfo
pi)) [MKey] -> [MKey] -> [MKey]
forall a. [a] -> [a] -> [a]
++ ((OneofInfo -> MKey) -> [OneofInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoName -> MKey
pKey (ProtoName -> MKey)
-> (OneofInfo -> ProtoName) -> OneofInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofInfo -> ProtoName
oneofName) (ProtoInfo -> [OneofInfo]
oneofs ProtoInfo
pi))

  tnt :: Seq FieldInfo -> Set MKey
  tnt :: Seq FieldInfo -> Set MKey
tnt Seq FieldInfo
fs = Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set MKey
allT (Set MKey -> Set MKey) -> Set MKey -> Set MKey
forall a b. (a -> b) -> a -> b
$ [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> [MKey] -> Set MKey
forall a b. (a -> b) -> a -> b
$ (ProtoName -> MKey) -> [ProtoName] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map ProtoName -> MKey
pKey ([ProtoName] -> [MKey])
-> (Seq FieldInfo -> [ProtoName]) -> Seq FieldInfo -> [MKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldInfo -> Maybe ProtoName) -> [FieldInfo] -> [ProtoName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldInfo -> Maybe ProtoName
typeName ([FieldInfo] -> [ProtoName])
-> (Seq FieldInfo -> [FieldInfo]) -> Seq FieldInfo -> [ProtoName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq FieldInfo -> [FieldInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldInfo -> [MKey]) -> Seq FieldInfo -> [MKey]
forall a b. (a -> b) -> a -> b
$ Seq FieldInfo
fs

  ont :: Seq OneofInfo -> Set MKey
  ont :: Seq OneofInfo -> Set MKey
ont Seq OneofInfo
os = Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set MKey
allT (Set MKey -> Set MKey) -> Set MKey -> Set MKey
forall a b. (a -> b) -> a -> b
$ [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> [MKey] -> Set MKey
forall a b. (a -> b) -> a -> b
$ (OneofInfo -> MKey) -> [OneofInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoName -> MKey
pKey (ProtoName -> MKey)
-> (OneofInfo -> ProtoName) -> OneofInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofInfo -> ProtoName
oneofName) ([OneofInfo] -> [MKey])
-> (Seq OneofInfo -> [OneofInfo]) -> Seq OneofInfo -> [MKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq OneofInfo -> [OneofInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq OneofInfo -> [MKey]) -> Seq OneofInfo -> [MKey]
forall a b. (a -> b) -> a -> b
$ Seq OneofInfo
os

  knt :: Seq KeyInfo -> Set MKey
  knt :: Seq KeyInfo -> Set MKey
knt Seq KeyInfo
ks =
    let ([ProtoName]
pns, [FieldInfo]
fsL) = [KeyInfo] -> ([ProtoName], [FieldInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip (Seq KeyInfo -> [KeyInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq KeyInfo
ks)
        fnt :: [FieldInfo] -> Set MKey
        fnt :: [FieldInfo] -> Set MKey
fnt [FieldInfo]
fs = [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> [MKey] -> Set MKey
forall a b. (a -> b) -> a -> b
$ ((ProtoName -> MKey) -> [ProtoName] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map ProtoName -> MKey
pKey ([ProtoName] -> [MKey])
-> ([FieldInfo] -> [ProtoName]) -> [FieldInfo] -> [MKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldInfo -> Maybe ProtoName) -> [FieldInfo] -> [ProtoName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldInfo -> Maybe ProtoName
typeName ([FieldInfo] -> [MKey]) -> [FieldInfo] -> [MKey]
forall a b. (a -> b) -> a -> b
$ [FieldInfo]
fs) [MKey] -> [MKey] -> [MKey]
forall a. [a] -> [a] -> [a]
++ ((FieldInfo -> MKey) -> [FieldInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoFName -> MKey
pfKey (ProtoFName -> MKey)
-> (FieldInfo -> ProtoFName) -> FieldInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> ProtoFName
fieldName) [FieldInfo]
fs)
    in Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set MKey
allT (Set MKey -> Set MKey) -> Set MKey -> Set MKey
forall a b. (a -> b) -> a -> b
$ Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ((ProtoName -> MKey) -> [ProtoName] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map ProtoName -> MKey
pKey [ProtoName]
pns)) ([FieldInfo] -> Set MKey
fnt [FieldInfo]
fsL)

  nk :: Seq FieldInfo -> Set MKey
  nk :: Seq FieldInfo -> Set MKey
nk Seq FieldInfo
fs = Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set MKey
allK (Set MKey -> Set MKey) -> Set MKey -> Set MKey
forall a b. (a -> b) -> a -> b
$ [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> [MKey] -> Set MKey
forall a b. (a -> b) -> a -> b
$ (FieldInfo -> MKey) -> [FieldInfo] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (ProtoFName -> MKey
pfKey (ProtoFName -> MKey)
-> (FieldInfo -> ProtoFName) -> FieldInfo -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> ProtoFName
fieldName) ([FieldInfo] -> [MKey])
-> (Seq FieldInfo -> [FieldInfo]) -> Seq FieldInfo -> [MKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq FieldInfo -> [FieldInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldInfo -> [MKey]) -> Seq FieldInfo -> [MKey]
forall a b. (a -> b) -> a -> b
$ Seq FieldInfo
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 :: (V, [V]) -> Result
breakKeys (V
pv,[V]
vsOther) =
  let vs :: [V]
vs = V
pv V -> [V] -> [V]
forall a. a -> [a] -> [a]
: [V]
vsOther
      es :: [E]
es = (V -> E) -> [V] -> [E]
forall a b. (a -> b) -> [a] -> [b]
map V -> E
makeInitialEdges [V]
vs where
        makeInitialEdges :: V -> E
makeInitialEdges V
v = (V
v,Part -> MKey -> Label
L Part
Normal MKey
self,[ Part -> MKey -> Label
L Part
Normal MKey
b | MKey
b <- Set MKey -> [MKey]
forall a. Set a -> [a]
Set.toList (V -> Set MKey
vNeedsKeys V
v), MKey
bMKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/=MKey
self ])
          where self :: MKey
self = V -> MKey
vMKey V
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
startingResult = Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = Map MKey VertexKind
needTypeBoot, rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
forall a. Monoid a => a
mempty, rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
forall a. Monoid a => a
mempty }
      needTypeBoot :: Map MKey VertexKind
needTypeBoot = MKey -> VertexKind -> Map MKey VertexKind
forall k a. k -> a -> Map k a
Map.singleton (V -> MKey
vMKey V
pv) VertexKind
TopProtoInfo Map MKey VertexKind -> Map MKey VertexKind -> Map MKey VertexKind
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                     ( [(MKey, VertexKind)] -> Map MKey VertexKind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(MKey, VertexKind)] -> Map MKey VertexKind)
-> ([E] -> [(MKey, VertexKind)]) -> [E] -> Map MKey VertexKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E -> (MKey, VertexKind)) -> [E] -> [(MKey, VertexKind)]
forall a b. (a -> b) -> [a] -> [b]
map (\(V
_,L Part
_ MKey
a,[Label]
_) -> (MKey
a,VertexKind
TypeBoot))
                                    ([E] -> [(MKey, VertexKind)])
-> ([E] -> [E]) -> [E] -> [(MKey, VertexKind)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E -> Bool) -> [E] -> [E]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(V
_,Label
_,[Label]
bLs) -> Bool -> Bool
not ([Label] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Label]
bLs)) ([E] -> Map MKey VertexKind) -> [E] -> Map MKey VertexKind
forall a b. (a -> b) -> a -> b
$ [E]
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 :: Result -> SCCs -> Result
breakSCCs Result
r SCCs
sccs = Result
r Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` [Result] -> Result
forall a. Monoid a => [a] -> a
mconcat (([E] -> Result) -> SCCs -> [Result]
forall a b. (a -> b) -> [a] -> [b]
map [E] -> Result
breakSCC SCCs
sccs)
      breakSCC :: G -> Result
      breakSCC :: [E] -> Result
breakSCC [] = String -> Result
forall a. String -> a
imp (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"breakKeys.breakSCC: The SCC cannot be empty!"
      breakSCC [E]
es' = let (V
toBust,SCCs
next'sccs) = ((Int, Int), (V, SCCs)) -> (V, SCCs)
forall a b. (a, b) -> b
snd (((Int, Int), (V, SCCs)) -> (V, SCCs))
-> ((Int, Int), (V, SCCs)) -> (V, SCCs)
forall a b. (a -> b) -> a -> b
$ (((Int, Int), (V, SCCs)) -> ((Int, Int), (V, SCCs)) -> Ordering)
-> [((Int, Int), (V, SCCs))] -> ((Int, Int), (V, SCCs))
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> (((Int, Int), (V, SCCs)) -> (Int, Int))
-> ((Int, Int), (V, SCCs))
-> ((Int, Int), (V, SCCs))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Int, Int), (V, SCCs)) -> (Int, Int)
forall a b. (a, b) -> a
fst) (((E, [E]) -> ((Int, Int), (V, SCCs)))
-> [(E, [E])] -> [((Int, Int), (V, SCCs))]
forall a b. (a -> b) -> [a] -> [b]
map (E, [E]) -> ((Int, Int), (V, SCCs))
forall a b c. ((a, b, c), [E]) -> ((Int, Int), (a, SCCs))
f ([E] -> [(E, [E])]
forall a. [a] -> [(a, [a])]
pullEach [E]
es'))
                           where f :: ((a, b, c), [E]) -> ((Int, Int), (a, SCCs))
f ((a
v,b
_,c
_),[E]
es'') = let ((Int, Int)
s,SCCs
sccs) = [E] -> ((Int, Int), SCCs)
score [E]
es'' in ((Int, Int)
s,(a
v,SCCs
sccs))
                         bk :: MKey
bk = V -> MKey
vMKey V
toBust -- ZZZ 
                         ik :: Set (MKey, MKey)
ik = [(MKey, MKey)] -> Set (MKey, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList [ (MKey
ek,MKey
bk) | MKey
ek <- (E -> MKey) -> [E] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (V -> MKey
vMKey (V -> MKey) -> (E -> V) -> E -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> V
forall a b c. (a, b, c) -> a
fst3) [E]
es', MKey
ekMKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/=MKey
bk ] -- ZZZ
                         newResult :: Result
newResult = Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = MKey -> VertexKind -> Map MKey VertexKind
forall k a. k -> a -> Map k a
Map.singleton MKey
bk VertexKind
KeyTypeBoot
                                            , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
forall a. Monoid a => a
mempty
                                            , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
ik } -- ZZZ
                     in Result -> SCCs -> Result
breakSCCs Result
newResult SCCs
next'sccs
      -- Init boot marks some incoming links to use SOURCE
      initBoot :: Result -> Result
initBoot Result
r = Result
r { rIBoot :: Set (MKey, Part, MKey)
rIBoot = [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> ([E] -> [(MKey, Part, MKey)]) -> [E] -> Set (MKey, Part, MKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E -> [(MKey, Part, MKey)]) -> [E] -> [(MKey, Part, MKey)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap E -> [(MKey, Part, MKey)]
withParts ([E] -> Set (MKey, Part, MKey)) -> [E] -> Set (MKey, Part, MKey)
forall a b. (a -> b) -> a -> b
$ [E]
es }
        where withParts :: E -> [(MKey, Part, MKey)]
withParts (V
_,L Part
_ MKey
a,[Label]
bLs) = [ MKey -> MKey -> (MKey, Part, MKey)
withPart MKey
a MKey
b | L Part
_ MKey
b <- [Label]
bLs ]
              withPart :: MKey -> MKey -> (MKey, Part, MKey)
withPart MKey
a MKey
b = let p :: Part
p = VertexKind -> Part
getKey (Result -> MKey -> VertexKind
getKind Result
r MKey
b) in (MKey
b,Part
p,MKey
a)
  in Result -> Result
initBoot (Result -> Result) -> Result -> Result
forall a b. (a -> b) -> a -> b
$ Result -> SCCs -> Result
breakSCCs Result
startingResult ([E] -> SCCs
cycles [E]
es)

score :: G -> ( (Int,Int), SCCs )
score :: [E] -> ((Int, Int), SCCs)
score [E]
es = ((Int
value,Int
parts),SCCs
sccs) where
  sccs :: SCCs
sccs = [E] -> SCCs
cycles [E]
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 :: Int
value = (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> ([E] -> Int) -> [E] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [E] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [E]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([E] -> Int) -> SCCs -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> ([E] -> Int) -> [E] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [E] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) SCCs
sccs))
  -- The number of parts is used as a potential tie breaker, prefering more parts
  parts :: Int
parts = SCCs -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length SCCs
sccs -- # of pieces

-- select the non-trivial sccs from edges
cycles :: G -> SCCs
cycles :: [E] -> SCCs
cycles = ([E] -> Bool) -> SCCs -> SCCs
forall a. (a -> Bool) -> [a] -> [a]
filter [E] -> Bool
forall a. [a] -> Bool
atLeastTwo (SCCs -> SCCs) -> ([E] -> SCCs) -> [E] -> SCCs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SCC E -> [E]) -> [SCC E] -> SCCs
forall a b. (a -> b) -> [a] -> [b]
map SCC E -> [E]
forall vertex. SCC vertex -> [vertex]
flattenSCC ([SCC E] -> SCCs) -> ([E] -> [SCC E]) -> [E] -> SCCs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [E] -> [SCC E]
forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR
  where atLeastTwo :: [a] -> Bool
        atLeastTwo :: [a] -> Bool
atLeastTwo (a
_:a
_:[a]
_) = Bool
True
        atLeastTwo [a]
_ = Bool
False

-- pull out each element as candidate and list without the element
pullEach :: [a] -> [(a,[a])]
pullEach :: [a] -> [(a, [a])]
pullEach = ([a] -> [a]) -> [a] -> [(a, [a])]
forall a c. ([a] -> c) -> [a] -> [(a, c)]
go [a] -> [a]
forall a. a -> a
id where go :: ([a] -> c) -> [a] -> [(a, c)]
go [a] -> c
_ [] = []
                       go [a] -> c
f (a
x:[a]
xs) = (a
x,[a] -> c
f [a]
xs) (a, c) -> [(a, c)] -> [(a, c)]
forall a. a -> [a] -> [a]
: ([a] -> c) -> [a] -> [(a, c)]
go ([a] -> c
f ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [a]
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 :: Result -> V -> [E]
makeEdgesForV Result
r V
v =
  let me :: MKey
me = V -> MKey
vMKey V
v;  myKind :: VertexKind
myKind = MKey -> VertexKind
getK MKey
me
      getK :: MKey -> VertexKind
getK = Result -> MKey -> VertexKind
getKind Result
r;  self :: Part -> Label
self Part
p = Part -> MKey -> Label
L Part
p MKey
me;
      typeL :: Part -> MKey -> Label
typeL Part
p MKey
n = if (MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey
me,Part
p,MKey
n) (Result -> Set (MKey, Part, MKey)
rIBoot Result
r) then Part -> MKey -> Label
L Part
Normal MKey
n
                    else let checkSource :: Part
checkSource = VertexKind -> Part
getType (MKey -> VertexKind
getK MKey
n)
                         in if Part
checkSource Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== Part
Source then Part -> MKey -> Label
L Part
Source MKey
n  -- sanity check
                              else String -> Label
forall a. HasCallStack => String -> a
error String
"makeEdgesForV.typeL.getType.getK of n did not return Source!"
      keyL :: MKey -> Label
keyL MKey
n = if (MKey, MKey) -> Set (MKey, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey
me,MKey
n) (Result -> Set (MKey, MKey)
rIKey Result
r) then Part -> MKey -> Label
L Part
Normal MKey
n
                 else Part -> MKey -> Label
L (VertexKind -> Part
getKey (MKey -> VertexKind
getK MKey
n)) MKey
n
      sKNT :: Label -> Set Label
sKNT (L Part
p MKey
_) = (MKey -> Label) -> Set MKey -> Set Label
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Part -> MKey -> Label
typeL Part
p) (V -> Set MKey
vKeysNeedsTypes V
v)
      sTNT :: Label -> Set Label
sTNT (L Part
p MKey
_) = (MKey -> Label) -> Set MKey -> Set Label
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Part -> MKey -> Label
typeL Part
p) (V -> Set MKey
vTypeNeedsTypes V
v)
      sNK :: Label -> Set Label
sNK Label
_ = (MKey -> Label) -> Set MKey -> Set Label
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map MKey -> Label
keyL (V -> Set MKey
vNeedsKeys V
v)

      notMe :: Set Label -> [Label]
notMe Set Label
set = [ Label
e | e :: Label
e@(L Part
_p MKey
o) <- Set Label -> [Label]
forall a. Set a -> [a]
Set.toList Set Label
set, MKey
oMKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/=MKey
me ]
      standard :: E
standard = let s :: Label
s = Part -> Label
self Part
Normal in (V
v,Label
s,Set Label -> [Label]
notMe (Set Label -> [Label]) -> Set Label -> [Label]
forall a b. (a -> b) -> a -> b
$ [Set Label] -> Set Label
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Label -> Set Label
sKNT Label
s, Label -> Set Label
sTNT Label
s, Label -> Set Label
sNK Label
s])
      source :: E
source = let s :: Label
s = Part -> Label
self Part
Source in (V
v,Label
s,[])
      sourceKTB :: E
sourceKTB = let s :: Label
s = Part -> Label
self Part
Source in (V
v,Label
s,Set Label -> [Label]
notMe (Set Label -> [Label]) -> Set Label -> [Label]
forall a b. (a -> b) -> a -> b
$ Label -> Set Label
sKNT Label
s)
      standardSKTB :: E
standardSKTB = let s :: Label
s = Part -> Label
self Part
Normal in (V
v,Label
s,Set Label -> [Label]
notMe' (Set Label -> [Label]) -> Set Label -> [Label]
forall a b. (a -> b) -> a -> b
$ Set Label -> Set Label -> Set Label
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Label -> Set Label
sNK Label
s) (Label -> Set Label
sTNT Label
s))
        where notMe' :: Set Label -> [Label]
notMe' Set Label
set = [ Label
e | e :: Label
e@(L Part
p MKey
o) <- Set Label -> [Label]
forall a. Set a -> [a]
Set.toList Set Label
set, MKey
oMKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/=MKey
me Bool -> Bool -> Bool
|| Part
pPart -> Part -> Bool
forall a. Eq a => a -> a -> Bool
==Part
KeyFile ]
      keyfileSKTB :: E
keyfileSKTB = let s :: Label
s = Part -> Label
self Part
KeyFile in (V
v,Label
s,Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (Set Label -> [Label]) -> Set Label -> [Label]
forall a b. (a -> b) -> a -> b
$ Label -> Set Label
sKNT Label
s)

  in case VertexKind
myKind of -- commented out the purely SOURCE and SINK nodes:
       VertexKind
TopProtoInfo     -> [E
standard]
       VertexKind
Simple           -> [E
standard]
       VertexKind
TypeBoot         -> [E
standard,E
source]
       VertexKind
KeyTypeBoot      -> [E
standard,E
sourceKTB]
       VertexKind
SplitKeyTypeBoot -> [E
standardSKTB,E
keyfileSKTB,E
source]

breakGraph ::  Result -> SCCs -> Result
breakGraph :: Result -> SCCs -> Result
breakGraph Result
r [] = String -> Result -> Result
forall a. String -> a -> a
ecart (String
"\nbreakGraph leaf answer\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++Result -> String
displayResult Result
r) (Result -> Result) -> Result -> Result
forall a b. (a -> b) -> a -> b
$ Result
r
breakGraph Result
r SCCs
sccs = String -> Result -> Result
forall a. String -> a -> a
ecart (String
"\nbreakGraph\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++Result -> String
displayResult Result
r) (Result -> Result) -> Result -> Result
forall a b. (a -> b) -> a -> b
$
                    Result
r Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` [Result] -> Result
forall a. Monoid a => [a] -> a
mconcat (([E] -> Result) -> SCCs -> [Result]
forall a b. (a -> b) -> [a] -> [b]
map (Result -> [E] -> Result
breakCycle Result
r) (SCCs -> SCCs
rejoinVertices SCCs
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 :: SCCs -> SCCs
rejoinVertices [] = []
rejoinVertices g :: SCCs
g@([[E]
_]) = SCCs
g
rejoinVertices SCCs
gs = 
  let vgs :: [(Set MKey,G)]
      vgs :: [(Set MKey, [E])]
vgs = ([E] -> (Set MKey, [E])) -> SCCs -> [(Set MKey, [E])]
forall a b. (a -> b) -> [a] -> [b]
map (\ [E]
g -> ([MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MKey] -> Set MKey) -> ([E] -> [MKey]) -> [E] -> Set MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E -> MKey) -> [E] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (V -> MKey
vMKey (V -> MKey) -> (E -> V) -> E -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> V
forall a b c. (a, b, c) -> a
fst3) ([E] -> Set MKey) -> [E] -> Set MKey
forall a b. (a -> b) -> a -> b
$ [E]
g,[E]
g)) SCCs
gs
      process :: [(Set a, [a])] -> [[a]]
process [] = []
      process ((Set a
_,[a]
g):[]) = [[a]
g]
      process ((Set a
v,[a]
g):[(Set a, [a])]
rest) = ([(Set a, [a])] -> [(Set a, [a])]) -> [(Set a, [a])] -> [[a]]
walk [(Set a, [a])] -> [(Set a, [a])]
forall a. a -> a
id [(Set a, [a])]
rest where
        walk :: ([(Set a, [a])] -> [(Set a, [a])]) -> [(Set a, [a])] -> [[a]]
walk [(Set a, [a])] -> [(Set a, [a])]
p [] = [a]
g [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [(Set a, [a])] -> [[a]]
process ([(Set a, [a])] -> [(Set a, [a])]
p [])
        walk [(Set a, [a])] -> [(Set a, [a])]
p (x :: (Set a, [a])
x@(Set a
v',[a]
g'):[(Set a, [a])]
rest') | Set a -> Bool
forall a. Set a -> Bool
Set.null (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
v Set a
v') = ([(Set a, [a])] -> [(Set a, [a])]) -> [(Set a, [a])] -> [[a]]
walk ([(Set a, [a])] -> [(Set a, [a])]
p ([(Set a, [a])] -> [(Set a, [a])])
-> ([(Set a, [a])] -> [(Set a, [a])])
-> [(Set a, [a])]
-> [(Set a, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set a, [a])
x(Set a, [a]) -> [(Set a, [a])] -> [(Set a, [a])]
forall a. a -> [a] -> [a]
:)) [(Set a, [a])]
rest'
                                 | Bool
otherwise = [(Set a, [a])] -> [[a]]
process ((Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
v Set a
v',[a]
g[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
g') (Set a, [a]) -> [(Set a, [a])] -> [(Set a, [a])]
forall a. a -> [a] -> [a]
: [(Set a, [a])] -> [(Set a, [a])]
p [])
  in [(Set MKey, [E])] -> SCCs
forall a a. Ord a => [(Set a, [a])] -> [[a]]
process [(Set MKey, [E])]
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 :: Result -> [E] -> Result
breakCycle Result
oldR [E]
sccIn = 
  let bits :: [Label]
bits = (E -> Label) -> [E] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map E -> Label
forall a b c. (a, b, c) -> b
snd3 [E]
sccIn -- trace
      -- toCompare should never be null.
      toCompare :: [((Int, Int), (Result, SCCs))]
toCompare = ((E, [E]) -> Maybe ((Int, Int), (Result, SCCs)))
-> [(E, [E])] -> [((Int, Int), (Result, SCCs))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (E, [E]) -> Maybe ((Int, Int), (Result, SCCs))
f ([E] -> [(E, [E])]
forall a. [a] -> [(a, [a])]
pullEach [E]
sccIn) where
        allV :: Set MKey
allV = [MKey] -> Set MKey
forall a. Ord a => [a] -> Set a
Set.fromList ((E -> MKey) -> [E] -> [MKey]
forall a b. (a -> b) -> [a] -> [b]
map (V -> MKey
vMKey (V -> MKey) -> (E -> V) -> E -> MKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> V
forall a b c. (a, b, c) -> a
fst3) [E]
sccIn)
        f :: (E,[E]) -> Maybe ((Int, Int), (Result, SCCs))
        f :: (E, [E]) -> Maybe ((Int, Int), (Result, SCCs))
f (e :: E
e@(V
v,L Part
p MKey
me,[Label]
_bLs), [E]
es) = String
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall a. String -> a -> a
ecart (String
">< picking:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++E -> String
showE E
eString -> String -> String
forall a. [a] -> [a] -> [a]
++
                                           String
"\nfrom:"String -> String -> String
forall a. [a] -> [a] -> [a]
++[Label] -> String
forall a. Show a => a -> String
show [Label]
bitsString -> String -> String
forall a. [a] -> [a] -> [a]
++
                                           String
"\nscore: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
observeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") (Maybe ((Int, Int), (Result, SCCs))
 -> Maybe ((Int, Int), (Result, SCCs)))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$
                                    Maybe ((Int, Int), (Result, SCCs))
answer where
          answer :: Maybe ((Int, Int), (Result, SCCs))
answer = case (Result -> MKey -> VertexKind
getKind Result
oldR MKey
me,Part
p) of
                     (VertexKind
TopProtoInfo,Part
Normal)      -> Maybe ((Int, Int), (Result, SCCs))
ans'R
                     (VertexKind
Simple,Part
Normal)            -> Maybe ((Int, Int), (Result, SCCs))
ans'R  Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ((Int, Int), (Result, SCCs))
ans'TB -- ans' is part of ans'TB
                     (VertexKind
TypeBoot,Part
Normal)          -> Maybe ((Int, Int), (Result, SCCs))
ans'   Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ((Int, Int), (Result, SCCs))
ans'R
                     (VertexKind
KeyTypeBoot,Part
Normal)       -> Maybe ((Int, Int), (Result, SCCs))
ans'   Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ((Int, Int), (Result, SCCs))
ans'R
                     (VertexKind
KeyTypeBoot,Part
Source)       -> Maybe ((Int, Int), (Result, SCCs))
ans'RK Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ((Int, Int), (Result, SCCs))
ans'SKTB -- ans' may be redundant
                     (VertexKind
SplitKeyTypeBoot,Part
Normal)  -> Maybe ((Int, Int), (Result, SCCs))
ans'   Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
-> Maybe ((Int, Int), (Result, SCCs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ((Int, Int), (Result, SCCs))
ans'R
                     (VertexKind
SplitKeyTypeBoot,Part
KeyFile) -> Maybe ((Int, Int), (Result, SCCs))
ans'RK -- ans' may be redundant
                     (VertexKind
TypeBoot,Part
Source) -> String -> Maybe ((Int, Int), (Result, SCCs))
forall a. String -> a
imp (String -> Maybe ((Int, Int), (Result, SCCs)))
-> String -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$
                       String
"breakCycle.toCompare.f cannot have (TypeBoot,Source) in SCC!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eMsg
                     (VertexKind
SplitKeyTypeBoot,Part
Source) -> String -> Maybe ((Int, Int), (Result, SCCs))
forall a. String -> a
imp (String -> Maybe ((Int, Int), (Result, SCCs)))
-> String -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$
                       String
"breakCycle.toCompare.f cannot have (SplitKeyTypeBoot,Source) in SCC!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eMsg
                     (VertexKind, Part)
_ -> String -> Maybe ((Int, Int), (Result, SCCs))
forall a. String -> a
imp (String -> Maybe ((Int, Int), (Result, SCCs)))
-> String -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ String
"breakCycle.toCompare.f: impossible combination in SCC:"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eMsg
          observe :: String
observe = case Maybe ((Int, Int), (Result, SCCs))
answer of Maybe ((Int, Int), (Result, SCCs))
Nothing -> String
"Nothing"; Just ((Int, Int)
s,(Result, SCCs)
_) -> String
"Just "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int)
s  -- trace
          eMsg :: String
eMsg = Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:[String] -> String
unlines ((E -> String) -> [E] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map E -> String
showE (E
eE -> [E] -> [E]
forall a. a -> [a] -> [a]
:[E]
es))

          ans',ans'R,ans'TB,ans'SKTB :: Maybe ((Int, Int), (Result, SCCs))
          ans' :: Maybe ((Int, Int), (Result, SCCs))
ans' = if Set (MKey, Part, MKey) -> Bool
forall a. Set a -> Bool
Set.null Set (MKey, Part, MKey)
newIBoot then Maybe ((Int, Int), (Result, SCCs))
forall a. Maybe a
Nothing
                   else Result -> Maybe ((Int, Int), (Result, SCCs))
go (Result -> Maybe ((Int, Int), (Result, SCCs)))
-> Result -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ Result
oldR Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = Map MKey VertexKind
forall a. Monoid a => a
mempty
                                                   , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
newIBoot
                                                   , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
forall a. Monoid a => a
mempty }
          ans'R :: Maybe ((Int, Int), (Result, SCCs))
ans'R = if Set (MKey, Part, MKey) -> Bool
forall a. Set a -> Bool
Set.null Set (MKey, Part, MKey)
newIBootR then Maybe ((Int, Int), (Result, SCCs))
forall a. Maybe a
Nothing
                    else Result -> Maybe ((Int, Int), (Result, SCCs))
go (Result -> Maybe ((Int, Int), (Result, SCCs)))
-> Result -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ Result
oldR Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = Map MKey VertexKind
forall a. Monoid a => a
mempty
                                                    , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
newIBootR
                                                    , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
forall a. Monoid a => a
mempty }
          ans'RK :: Maybe ((Int, Int), (Result, SCCs))
ans'RK = if Set (MKey, Part, MKey) -> Bool
forall a. Set a -> Bool
Set.null Set (MKey, Part, MKey)
newIBootRK then Maybe ((Int, Int), (Result, SCCs))
forall a. Maybe a
Nothing
                     else Result -> Maybe ((Int, Int), (Result, SCCs))
go (Result -> Maybe ((Int, Int), (Result, SCCs)))
-> Result -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ Result
oldR Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = Map MKey VertexKind
forall a. Monoid a => a
mempty
                                                     , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
newIBootRK
                                                     , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
forall a. Monoid a => a
mempty }
          ans'TB :: Maybe ((Int, Int), (Result, SCCs))
ans'TB = Result -> Maybe ((Int, Int), (Result, SCCs))
go (Result -> Maybe ((Int, Int), (Result, SCCs)))
-> Result -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ Result
oldR Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = MKey -> VertexKind -> Map MKey VertexKind
forall k a. k -> a -> Map k a
Map.singleton MKey
me VertexKind
TypeBoot
                                              , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
newIBoot -- do (TypeBoot,Normal) -> ans'
                                              , rIKey :: Set (MKey, MKey)
rIKey = Set (MKey, MKey)
forall a. Monoid a => a
mempty }
          ans'SKTB :: Maybe ((Int, Int), (Result, SCCs))
ans'SKTB = Result -> Maybe ((Int, Int), (Result, SCCs))
go (Result -> Maybe ((Int, Int), (Result, SCCs)))
-> Result -> Maybe ((Int, Int), (Result, SCCs))
forall a b. (a -> b) -> a -> b
$ Result
oldR Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result :: Map MKey VertexKind
-> Set (MKey, Part, MKey) -> Set (MKey, MKey) -> Result
Result { rKind :: Map MKey VertexKind
rKind = MKey -> VertexKind -> Map MKey VertexKind
forall k a. k -> a -> Map k a
Map.singleton MKey
me VertexKind
SplitKeyTypeBoot
                                                , rIBoot :: Set (MKey, Part, MKey)
rIBoot = Set (MKey, Part, MKey)
newIBootSKTB
                                                , rIKey :: Set (MKey, MKey)
rIKey = (MKey, MKey) -> Set (MKey, MKey)
forall a. a -> Set a
Set.singleton (MKey
me,MKey
me) }

          newIBoot,newIBootR,newIBootRK,newIBootSKTB :: Set (MKey,Part,MKey)
          newIBoot :: Set (MKey, Part, MKey)
newIBoot = [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a b. (a -> b) -> a -> b
$ do
            (V
va,L Part
pa MKey
a,[Label]
_) <- [E]
es
            Bool -> String -> [()]
forall (m :: * -> *). Monad m => Bool -> String -> m ()
iguard (MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
a Set MKey
allV) (String -> [()]) -> String -> [()]
forall a b. (a -> b) -> a -> b
$
              String
"breakCycle.toCompare.newIBoot sanity check 083425 failed:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
eMsg
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (((Part
pa Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== Part
Normal) Bool -> Bool -> Bool
&&
                    (MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
me (V -> Set MKey
vTypeNeedsTypes V
va))) Bool -> Bool -> Bool
||
                   ((Part
pa Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== VertexKind -> Part
getKey (Result -> MKey -> VertexKind
getKind Result
oldR MKey
a)) Bool -> Bool -> Bool
&&
                    (MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
me (V -> Set MKey
vKeysNeedsTypes V
va))))
            let x :: (MKey, Part, MKey)
x=(MKey
a,Part
pa,MKey
me)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey, Part, MKey)
x (Result -> Set (MKey, Part, MKey)
rIBoot Result
oldR))  -- needed when used in newIBoot2
            (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall (m :: * -> *) a. Monad m => a -> m a
return (MKey, Part, MKey)
x
          newIBootR :: Set (MKey, Part, MKey)
newIBootR = [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a b. (a -> b) -> a -> b
$ do
            MKey
b <- Set MKey -> [MKey]
forall a. Set a -> [a]
Set.toList (Set MKey -> Set MKey -> Set MKey
forall a. Ord a => Set a -> Set a -> Set a
Set.union (V -> Set MKey
vTypeNeedsTypes V
v) (V -> Set MKey
vKeysNeedsTypes V
v))
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
b Set MKey
allV)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Part
Source Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== VertexKind -> Part
getType (Result -> MKey -> VertexKind
getKind Result
oldR MKey
b))
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (MKey
me MKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/= MKey
b Bool -> Bool -> Bool
|| Part
p Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== Part
KeyFile)
            let x :: (MKey, Part, MKey)
x = (MKey
me,Part
p,MKey
b)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey, Part, MKey)
x (Result -> Set (MKey, Part, MKey)
rIBoot Result
oldR))
            (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall (m :: * -> *) a. Monad m => a -> m a
return (MKey, Part, MKey)
x
          newIBootRK :: Set (MKey, Part, MKey)
newIBootRK = [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a b. (a -> b) -> a -> b
$ do
            MKey
b <- Set MKey -> [MKey]
forall a. Set a -> [a]
Set.toList (V -> Set MKey
vKeysNeedsTypes V
v)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
b Set MKey
allV)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Part
Source Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== VertexKind -> Part
getType (Result -> MKey -> VertexKind
getKind Result
oldR MKey
b))
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (MKey
me MKey -> MKey -> Bool
forall a. Eq a => a -> a -> Bool
/= MKey
b Bool -> Bool -> Bool
|| Part
p Part -> Part -> Bool
forall a. Eq a => a -> a -> Bool
== Part
KeyFile)
            let x :: (MKey, Part, MKey)
x = (MKey
me,Part
p,MKey
b)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey, Part, MKey)
x (Result -> Set (MKey, Part, MKey)
rIBoot Result
oldR))
            (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall (m :: * -> *) a. Monad m => a -> m a
return (MKey, Part, MKey)
x
          newIBootSKTB :: Set (MKey, Part, MKey)
newIBootSKTB = Set (MKey, Part, MKey)
-> Set (MKey, Part, MKey) -> Set (MKey, Part, MKey)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (MKey, Part, MKey)
newIBoot (Set (MKey, Part, MKey) -> Set (MKey, Part, MKey))
-> ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> [(MKey, Part, MKey)]
-> Set (MKey, Part, MKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a. Ord a => [a] -> Set a
Set.fromList ([(MKey, Part, MKey)] -> Set (MKey, Part, MKey))
-> [(MKey, Part, MKey)] -> Set (MKey, Part, MKey)
forall a b. (a -> b) -> a -> b
$ 
            (if MKey -> Set MKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MKey
me (V -> Set MKey
vKeysNeedsTypes V
v) then ((MKey
me,Part
KeyFile,MKey
me)(MKey, Part, MKey) -> [(MKey, Part, MKey)] -> [(MKey, Part, MKey)]
forall a. a -> [a] -> [a]
:) else [(MKey, Part, MKey)] -> [(MKey, Part, MKey)]
forall a. a -> a
id) ([(MKey, Part, MKey)] -> [(MKey, Part, MKey)])
-> [(MKey, Part, MKey)] -> [(MKey, Part, MKey)]
forall a b. (a -> b) -> a -> b
$ do
              MKey
b <- Set MKey -> [MKey]
forall a. Set a -> [a]
Set.toList (V -> Set MKey
vKeysNeedsTypes V
v)
              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (MKey
me,Part
Source,MKey
b) (Result -> Set (MKey, Part, MKey)
rIBoot Result
oldR)) -- copy from (me,Source,b)
              let x :: (MKey, Part, MKey)
x = (MKey
me,Part
KeyFile,MKey
b)                         -- copy to (me,KeyFile,b)
              Bool -> String -> [()]
forall (m :: * -> *). Monad m => Bool -> String -> m ()
iguard ((MKey, Part, MKey) -> Set (MKey, Part, MKey) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (MKey, Part, MKey)
x (Result -> Set (MKey, Part, MKey)
rIBoot Result
oldR)) (String -> [()]) -> String -> [()]
forall a b. (a -> b) -> a -> b
$
                String
"breakCycle.toCompare.newIBoot2 KeyTypeBoot already had entries for KeyFile!:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
eMsg
              (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall (m :: * -> *) a. Monad m => a -> m a
return (MKey, Part, MKey)
x

          go :: Result -> Maybe ((Int, Int), (Result, SCCs))
          go :: Result -> Maybe ((Int, Int), (Result, SCCs))
go Result
newR = let ((Int, Int)
s,SCCs
sccs) = [E] -> ((Int, Int), SCCs)
score ([V] -> Result -> [E]
makeG ((E -> V) -> [E] -> [V]
forall a b. (a -> b) -> [a] -> [b]
map E -> V
forall a b c. (a, b, c) -> a
fst3 (E
eE -> [E] -> [E]
forall a. a -> [a] -> [a]
:[E]
es)) Result
newR)
                    in ((Int, Int), (Result, SCCs)) -> Maybe ((Int, Int), (Result, SCCs))
forall a. a -> Maybe a
Just ((Int, Int)
s,(Result
newR,SCCs
sccs))
  in String -> Result -> Result
forall a. String -> a -> a
ecart (String
">< breakCycle of "String -> String -> String
forall a. [a] -> [a] -> [a]
++[Label] -> String
forall a. Show a => a -> String
show [Label]
bitsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n\n") (Result -> Result) -> Result -> Result
forall a b. (a -> b) -> a -> b
$
     if [((Int, Int), (Result, SCCs))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Int, Int), (Result, SCCs))]
toCompare
       then String -> Result
forall a. String -> a
imp (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"breakCycle: This SCC had no Simple or KeyTypeBoot nodes!\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((E -> String) -> [E] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map E -> String
forall a. Show a => a -> String
show [E]
sccIn)
       else let (Result
newR,SCCs
next'sccs) = ((Int, Int), (Result, SCCs)) -> (Result, SCCs)
forall a b. (a, b) -> b
snd (((Int, Int), (Result, SCCs)) -> (Result, SCCs))
-> ((Int, Int), (Result, SCCs)) -> (Result, SCCs)
forall a b. (a -> b) -> a -> b
$ (((Int, Int), (Result, SCCs))
 -> ((Int, Int), (Result, SCCs)) -> Ordering)
-> [((Int, Int), (Result, SCCs))] -> ((Int, Int), (Result, SCCs))
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> (((Int, Int), (Result, SCCs)) -> (Int, Int))
-> ((Int, Int), (Result, SCCs))
-> ((Int, Int), (Result, SCCs))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Int, Int), (Result, SCCs)) -> (Int, Int)
forall a b. (a, b) -> a
fst) [((Int, Int), (Result, SCCs))]
toCompare
            in Result -> SCCs -> Result
breakGraph Result
newR SCCs
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 :: [V] -> Result -> Result
cull [V]
vs Result
rIn =
  let trial :: Result -> (MKey,Part,MKey) -> Result
      trial :: Result -> (MKey, Part, MKey) -> Result
trial Result
old (MKey, Part, MKey)
x = let new :: Result
new = Result
old { rIBoot :: Set (MKey, Part, MKey)
rIBoot = (MKey, Part, MKey)
-> Set (MKey, Part, MKey) -> Set (MKey, Part, MKey)
forall a. Ord a => a -> Set a -> Set a
Set.delete (MKey, Part, MKey)
x (Result -> Set (MKey, Part, MKey)
rIBoot Result
old) }
                    in if SCCs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([E] -> SCCs
cycles ([V] -> Result -> [E]
makeG [V]
vs Result
new)) then Result
new else Result
old
      rOut :: Result
rOut = (Result -> (MKey, Part, MKey) -> Result)
-> Result -> [(MKey, Part, MKey)] -> Result
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Result -> (MKey, Part, MKey) -> Result
trial Result
rIn (Set (MKey, Part, MKey) -> [(MKey, Part, MKey)]
forall a. Set a -> [a]
Set.toList (Result -> Set (MKey, Part, MKey)
rIBoot Result
rIn))
  in if Result
rOut Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
rIn then Result
rOut else [V] -> Result -> Result
cull [V]
vs Result
rOut