help understand strange behavior in a lazy code

I write a program which generate orthogonal representation of a planar graph. For this job I use GHC 6.10.1. My code bases on FGL library. It uses to keep a graph structure.

Recently I have found an error which I can't explain. If drop the context job of my program then:

main = let g = insEdge (0,1,()) $ buildGr [ ([], 0, (), []), ([], 1, (), []) ]
           g' = delEdge (0,1) g
        in if 1 `elem` suc g 0
              then putStrLn "OK"
              else putStrLn "ERROR "

This program must print "OK" but the result is "ERROR"

Here is more detailed. Function prepareData is got a graph with help edges. Data BlockScheme also keeps theirs in the list cyclesInfoBS. Theses edges are required an algorithm of the function dualGraph.

Function prepareG builds new graph from one deleting these edges. And a value of the embeddedBSG variable must be same everywhere.

But an error occurs when dualGraph works. Tracing inside says that the graph hasn't got help edge (2,1) but before call of dualGraph its graph argument has got help edges. dualGraph's module hasn't got neither delEdge nor delEdge nor delNodes nor delNode and doesn't call a function which were to do this. dualGraph's module only reads the graph variable.

If comment code deleting help edges then they stay.

the state of the graph before dualGraph:

__+embeddedBSG = 
0:NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((1,3),3)]
1:NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[]
2:NodeLabel {typeLabel = HelpNode, sizeLabel = (0.0,0.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((2,0),1)]
3:NodeLabel {typeLabel = IfWhBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((1,0),2),((2,2),1),((0,1),4)]
4:NodeLabel {typeLabel = OpBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((0,1),2)]

the state of the graph into DualGraph module:

0:(0.0,NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((1,3),3)]
1:(30.0,NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[]
2:(45.0,NodeLabel {typeLabel = HelpNode, sizeLabel = (0.0,0.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[]
3:(15.0,NodeLabel {typeLabel = IfWhBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((2,2),1),((1,0),2),((0,1),4)]
4:(35.0,NodeLabel {typeLabel = OpBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((0,1),2)]
allEdges: = [(OutEdge,(2,(0,1))),(InEdge,(3,(0,1)))]

Node 2 of second state hasn't got any outgoing edges.

There is a place where the error is detected function lSortSuc in DualGraph.

lSortSuc vertexId graph =.... It requires vertex with vertexId has got at least 1 incoming edge and 1 outgoing one or it is sink node. The sink node is 1 in this case.

Then It can suppose lSortSuc is called somewhere yet for graph without help edges for node 2. But it isn't true.

Does anybody have any ideas? What can I do?

type BlockSchemeGraph = Gr NodeLabel ()

data CycleInfo =
    CycleInfo {
        reversedEdge ::  Edge ,
        helpEdge ::  Edge
    }    deriving (Show, Eq)

data BlockScheme = BlockScheme { graphBS :: BlockSchemeGraph,
                                 cyclesInfoBS :: [ CycleInfo ],
                                 generalSchemeOptionsBS :: (),
                                 backBonesBS :: [ [ Node ] ]
                                } deriving (Show, Eq)


prepareData bs =
 let bsg = graphBS bs
     [ sink, source ]  = map head $ pam bsg [  getSinks, getSources ]
     [ helpNode ] = newNodes 1 bsg
     helpEdges = [ (source,helpNode), (helpNode, sink) ]
     bsg' = insEdges [ (a,b, ()) | (a,b)  (l, 0.0) )
                           -- here help edges are deleted
              $ foldr (\cinf g -> delEdge  (helpEdge cinf)  g)
                      (trace ("\n\nembG = " ++ show embG) embG)
                      cyclesInfo
     f (v, height) g =
       let fsuc (w, (order, weight)) g =
              setELabel' (v,w) (order, weight + height/2) g
           fpre (w, (order, weight)) g =
              setELabel' (w,v) (order, weight + height/2) g
           g' = foldr fsuc g $ lsuc g v
        in foldr fpre g' $ lpre g' v
  in emap (\(order, weight) -> (order, {-round-} weight))
          . foldr f embG'
          . map (\n -> (n, snd . sizeLabel $ getVLabel n embG))
          $ nodes embG

-----------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module GraphVisualiser  
#if defined(MYDEBUG)
#else
 (visualiseScheme, BlockSchemeImage )
#endif
    where

import SimpleUtil (map2,swap,pam, vopt, compareDouble)
import Data.Maybe (fromJust,isJust)
import Data.List (foldl',find, nubBy, deleteFirstsBy, maximumBy)
import qualified Data.Map as Map
import SchemeCompiler
import InductivePlus
import GraphEmbedder
import DualGraph
import TopologicalNumbering
import Text.Printf (printf)
import Debug.Trace 

type NodePosition = (Double,Double)
type EdgePosition = [ NodePosition ]

type BSIG = Gr (NodePosition, NodeLabel) EdgePosition
newtype BlockSchemeImage = BlkScmImg BSIG deriving  Eq

getWeight = fst
visualiseScheme :: BlockScheme -> BlockSchemeImage
visualiseScheme bs =
 let (numEmbBsg, numDualBsg, emf, nmf, source, sink) = prepareData bs

     xCoords = map (calcXForBackBone (numEmbBsg, numDualBsg, emf, nmf)) $ backBonesBS bs
     calcedNodes = calcNodePositions numEmbBsg numDualBsg nmf emf source sink xCoords
     calcedEdges = calcEdgePositions numEmbBsg numDualBsg nmf emf source sink calcedNodes xCoords
     scaledG = scaleGraph calcedEdges
     -- 
     g'  = reverseFeedBacks scaledG $ cyclesInfoBS bs
  in BlkScmImg g' --  -- calcedEdges

calcXForBackBone (numEmbBsg, numDualBsg, emf, nmf) idsOfNodes =
 --
 let (_, (xleft, xright) )  =
         maximumBy (\ (v1, (xleft1, xright1) ) (v2, (xleft2, xright2) ) ->
                         compare (xright1 - xleft1) (xright2 - xleft2) )
                   $ map (\ v -> (v, fidsToWeights numDualBsg $ Map.lookup v nmf ))
                         idsOfNodes
  in ( (xright + xleft) / 2.0 , idsOfNodes )
-- g :: Gr (NodePosition, NodeLabel) [ NodePositions ]  
reverseFeedBacks g cyclesInfo = foldr fEdge g cyclesInfo
 where fEdge cinfo g =
        let elbl = getELabel e g
            e = reversedEdge cinfo
            (v,w) = e
            g' = delEdge e g
         in insEdge (w,v, reverse elbl) g'
calcEdgePositions numEmbBsg numDualBsg nmf emf source sink calcedNodes backBones =  
 let fEdge e@(v,w) g =
      let xOfe =  case find (\ (x, lst) ->
                                if v `elem` lst && w `elem` lst
                                   then True
                                   else False
                            ) backBones of
                    Nothing -> halfSumEdge numDualBsg emf e
                    Just (x,_) -> x
          [startY, endY] = map (\n -> getWeight $ getVLabel n numEmbBsg) [ v, w ]
          coords = [ (xOfe, startY), (xOfe, endY) ]
          g' = setELabel' (v,w) coords g
       in trace ( "\n\ncoords = " ++ show coords ++ "\ncalc edge " ++ show (v,w) ++ "\nemf = "
                                          ++ show emf ++ "\nnmf = " ++ show nmf
                                          ++ "\nnumDualBsg = " ++ show numDualBsg
                                          ++ "\nnumEmbBsg = " ++ show numEmbBsg)
                g'
     outEdgesOfSource = map fst $ lSortSuc numEmbBsg source
     inEdgesOfSink    = map fst $ lSortPre numEmbBsg sink
     fixFouthEdgeLbl v lst yModifier g =
         case lst of
              [ _ ] -> g
              [ _, _ ] -> (trace "\nFixFouth\n" g)
              [ _, _, _ ] -> g
              [ _, _, _, w ] ->
                let [ (x1,y1), p2 ] = getELabel (v,w) g
                    (xv, yv) = fst $ getVLabel v g
                 in setELabel' (v,w)
                               [ (xv, yModifier y1 ), (x1, yModifier y1 ), p2 ]
                               g
              _ -> error $ "visualiseScheme.fixFouthEdgeLbl: lst has more than 4 edges!!!\n"
                           ++ show lst
     calcedUsualEdges = foldr fEdge
                              calcedNodes
                              $ edges calcedNodes
     calcedAll  = fixFouthEdgeLbl sink inEdgesOfSink (+1)
                   $ fixFouthEdgeLbl source outEdgesOfSource (\a -> a - 1) calcedUsualEdges

  in trace ("\ncalcedAll = " ++ show calcedAll) calcedAll

scaleGraph g =
 let 
     factor = 3.0
     marginLT = 10
     modifyCoord = (marginLT + ) .  (*factor)  -- marginLeft и marginTop
     modifyCoords a = map2 modifyCoord . vopt (-) a $ minCoordinates g
  in    emap (map modifyCoords)
                $ nmap (\(coords, lbl) -> (modifyCoords coords, lbl) )
                       g
prepareData bs =
 let bsg = graphBS bs
     [ sink, source ]  = map head $ pam bsg [  getSinks, getSources ]
     [ helpNode ] = newNodes 1 bsg
     helpEdges = [ (source,helpNode), (helpNode, sink) ]
     bsg' = insEdges [ (a,b, ()) | (a,b)  (l, 0.0) )
              $ foldr (\cinf g -> {- g ) --- -} delEdge (helpEdge cinf) g)
                      (trace ("\n\nembG = " ++ show embG) embG)
                      cyclesInfo
     f (v, height) g =
       let fsuc (w, (order, weight)) g =
              setELabel' (v,w) (order, weight + height/2) g
           fpre (w, (order, weight)) g =
              setELabel' (w,v) (order, weight + height/2) g
           g' = foldr fsuc g $ lsuc g v
        in foldr fpre g' $ lpre g' v
  in emap (\(order, weight) -> (order, {-round-} weight))
          . foldr f embG'
          . map (\n -> (n, snd . sizeLabel $ getVLabel n embG))
          $ nodes embG

prepareDualG dg   g  =
 let dg' = emap (\lbl -> (lbl, 0.0)) dg
     widthElement v sucOrPre =
       let width = fst . sizeLabel $ getVLabel v g
        in width / (fromIntegral . length $ sucOrPre g v)
     -- node is face        
     fNodes v (dg  :: Gr Face (Edge, Double) )=
      let fEdge (w, (orig@(origV, origW), weight)) dg =
            let wV = widthElement origV lsuc
                wW = widthElement origW lpre
             in setELabel' (v,w)   (orig, weight + wV + wW) dg
          outgoing :: [ (Node, (Edge, Double)) ]
          outgoing = lsuc dg v
       in foldr fEdge dg outgoing
   in emap (\(e, weight) -> (e, {-round-} weight))
           . foldr fNodes dg'
           $ nodes dg

calcNodePositions numEmbBsg numDualBsg nmf emf source sink  backBones {- :: [ (Double, [ Node ] ) -} = 
 let fNode v (g :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) = 
      if v == source -- s
         then calcSorT v id g lSortSuc numEmbBsg numDualBsg emf backBones
         else if v == sink -- t
                 then calcSorT v swap g lSortPre numEmbBsg numDualBsg emf backBones
                 else let vlbl = getVLabel v numEmbBsg
                          xCoord = case find (\ (x, lst) ->
                                                 if v `elem` lst
                                                    then True
                                                    else False
                                             ) backBones of
                                     Nothing -> halfSumNode numDualBsg nmf v
                                     Just (x,_) -> x
                       in setVLabel' v ((xCoord, getWeight vlbl ), snd vlbl) g
     g' :: Gr (NodePosition, NodeLabel) [ NodePosition ]
     g' =  emap (\_ -> [] ) $ nmap (\(weight, lbl) -> ((0.0,0.0), lbl))
                                   numEmbBsg 
     result :: Gr (NodePosition, NodeLabel) [ NodePosition ]                       
     result = foldr fNode
                    g'
           开发者_运维百科         $ nodes numEmbBsg
  in result 

calcSorT v selector (g  :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) edgeSelector numEmbBsg numDualBsg emf backBones =
  let calcSTDegree4 w =
       let (weight , vlbl) = getVLabel v numEmbBsg
        in setVLabel' v ((halfSumEdge numDualBsg emf $ selector (v,w) ,
                          weight ),
                        vlbl )
                        g
   in case map fst $ edgeSelector numEmbBsg v of
          [ ] -> error $ "calcSorT: node " ++ show v
                         ++ " hasn't got any suc edges!\nGraph:\n"  ++ show g
                         ++ "\nnumEmbBsg = \n" ++ show numEmbBsg

          [ w ] -> let (weight, vlbl) = getVLabel v numEmbBsg
                       xCoord = case find (\ (x, lst) ->
                                              if v `elem` lst
                                                 then True
                                                 else False
                                          ) backBones of
                                  Nothing -> halfSumEdge numDualBsg emf $ selector (v,w)
                                           -----halfSumNode numDualBsg nmf v
                                  Just (x,_) -> x
                    in setVLabel' v ((xCoord , weight), vlbl) 
                                g
          [ w1, _ ] -> let (weight , vlbl) = getVLabel v numEmbBsg
                        in setVLabel' v (( snd . fidsToWeights numDualBsg
                                               $ Map.lookup (selector (v, w1)) emf,
                                          weight),
                                          vlbl
                                        )
                                      g
          [ _, w, _ ] -> calcSTDegree4 w 
          [ _, w, _, _ ] -> calcSTDegree4 w
          moreEdges  -> error $ "calcSorT: node " ++ show v ++ "has got too may edges!:\n"
                                ++ show moreEdges ++ "\nGraph:" ++ show g
                                ++ "\nnumEmbBsg = " ++ show numEmbBsg

--- fidsToWeights :: Maybe EdgeFaces -> NodePosition
fidsToWeights numDualBsg = map2 (\fid -> getWeight $ getVLabel fid numDualBsg) . fromJust

halfSum numDualBsg fids  = ( uncurry (+) (fidsToWeights numDualBsg fids) / 2.0 ) :: Double
halfSumNode numDualBsg nmf v = (halfSum numDualBsg) $ Map.lookup v nmf                       
halfSumEdge numDualBsg emf e = (halfSum numDualBsg) $ Map.lookup e emf


-----------------------------------------------------------------------

module DualGraph
#if defined(MYDEBUG)
#else
(dualGraph, Face(..), leftFace, rightFace, FaceId, EdgeFaces, EdgeMapFaces,NodeMapFaces, DualGraph, lSortSuc, lSortPre)
#endif
      where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe (fromJust,isJust)
import SimpleUtil (apa,swap,map2)
import Data.List (foldl', sortBy, find)
import InductivePlus
import GraphEmbedder
import Debug.Trace

type FaceId = Int
type EdgeFaces = (FaceId, FaceId)
type EdgeMapFaces = Map.Map Edge EdgeFaces

type NodeMapFaces = Map.Map Node EdgeFaces

leftFace :: EdgeFaces -> FaceId
leftFace = fst
rightFace :: EdgeFaces -> FaceId
rightFace = snd

data Face = Face { sourceNode, sinkNode :: Node,
                   leftContour, rightContour :: Set.Set Edge --- [ Node ],
                 } |
            OuterFace {
                         leftContour, rightContour :: Set.Set Edge --- [ Node ],
                      } deriving (Show, Eq)

nodePathToEdgePath :: Ord a => [ a ] -> Set.Set (a,a)
nodePathToEdgePath (h:rest) = Set.fromList . snd
                              $ foldl' (\ (current,result) next ->
                                         (next, (current, next) : result))
                                       (h, [])
                                       rest

newFace src leftC rightC =
  Face { sourceNode = src,
         sinkNode = last leftC,
         leftContour = nodePathToEdgePath $ src : leftC,
         rightContour = nodePathToEdgePath $ src : rightC -- ,
       }

newOuterFace embG edgeSelector slotModifier =
 case filter (\v -> null $ lpre embG v) $ nodes embG of
  [] -> error $ "newOuterFace: the graph hasn't got any source vertex\n"
                ++ show embG
  [ v ] -> slotModifier emptyOuterFace
                        . nodePathToEdgePath
                        $ findContour v
  sourceVertexes ->
     error $ "newOuterFace: the graph has got more than one source vertex:"
             ++ show sourceVertexes
             ++ "\nThe Graph:\n" ++ show embG
 where
  emptyOuterFace = OuterFace { leftContour = Set.empty,
                               rightContour = Set.empty
                             }
  findContour v =
   case lSortSuc embG v of
     [] -> [ v ]
     someEdges -> v : (findContour . fst $ edgeSelector someEdges )

setRightContour face con = face { rightContour = con }
setLeftContour face con = face { leftContour = con }


type DualGraph = Gr Face Edge

dualGraph :: BlockSchemeEmbeddedGraph -> (DualGraph, EdgeMapFaces, NodeMapFaces)

checkm msg g = if 1 `notElem` suc g 2
                  then error $ "\ncheckm: " ++ msg ++ "\nthe G = " ++ show g
                  else trace ( "\n\nsuc g 2 = " ++ show (suc g 2) ) g

dualGraph embGr =
 let embG = checkm "dualGraph: "  embGr
     usualFaces = snd . foldr (findFaces embG)
                              (2, buildGr [] ) --- Map.empty)
                              $ nodes embG

     sFace = newOuterFace embG head setRightContour
     tFace = newOuterFace embG last setLeftContour
     allFaces = insNodes [ (0,sFace), (1,tFace) ] usualFaces
     allNodes = map (\n -> (n, getVLabel n allFaces))
                    $ nodes allFaces
     linkedFaces = foldr linkage
                         allFaces
                         [ (f1, f2) | f1@(fid1,_)  fid1
                         ]
     emf = foldr (\(fid,f) m -> let comb fun conSel m = Set.fold (\e m -> Map.insertWith fun

              e

              (fid,fid)

              m)
                                                                 m
                                                                 $ conSel f
                                 in comb (\ (_,r) (l,_) -> (l,r) )
                                         leftContour
                                         $ comb (\ (l,_) (_,r) -> (l,r) )
                                                rightContour
                                                m
                 )
                 Map.empty
                 allNodes

     fNMF n m = let (lFace,rFace) = case lSortSuc embG n of
                           [] -> let ls = lSortPre embG n
                                     lFace = leftFace
                                              . fromJust
                                              $ Map.lookup (fst $ head ls, n) -- last ls, n)
                                                           emf
                                     rFace = rightFace
                                              . fromJust
                                              $ Map.lookup (fst $ last ls, n) -- head ls, n)
                                                           emf
                                  in (lFace, rFace)
                           ls  -> let lFace = leftFace
                                              . fromJust
                                              $ Map.lookup (n, fst $ head ls)
                                                           emf
                                      rFace = rightFace
                                              . fromJust
                                              $ Map.lookup (n, fst $ last ls)
                                                           emf
                                   in (lFace, rFace)
                 in Map.insert n (lFace, rFace) m
     nmf = foldr fNMF Map.empty $ nodes embG
  in trace ("\nDualGrapn: (linkedFaces, emf, nmf) \n"   ++ show (linkedFaces, emf, nmf) ) (linkedFaces, emf, nmf)


findFaces embG v st =
  case map fst $ lSortSuc (checkm "findFaces: " embG) v of
   [] ->  st -- вершина не может образовать грань
   [_] -> st
   (firstOut:outgoing) -> snd $ foldl' (findFace embG v)
                                       (firstOut,st)
                                       outgoing

data EdgeType = InEdge  | OutEdge deriving (Show,Eq)

lSortEdges gren v =
 let g = trace ("\nlSortEdges: g = " ++ show gren) (checkm ("lSortEdges: v = " ++ show v )gren)
     getEdgeNumber (OutEdge, (_, (n,_))) = n
     getEdgeNumber (InEdge, (_, (_,n))) = n

     oute = lsuc g v
     ine  = lpre g v
     allEdges =  sortBy (apa compare getEdgeNumber)
                 $ concat [ map (\lbl -> (OutEdge, lbl) ) oute,
                            map (\lbl -> (InEdge, lbl) )  ine ]

     cAllEdges = cycle allEdges

     zeroEdge = head (trace ("allEdges: = " ++ show allEdges) allEdges)
     spanE e = span ((e ==) . fst)
     outEdges = case fst zeroEdge of

                  OutEdge ->  fst . spanE OutEdge
                              . snd . spanE InEdge
                              . snd $ spanE OutEdge cAllEdges
                  _       ->  fst . spanE OutEdge . snd $ spanE InEdge cAllEdges
     inEdges = case fst zeroEdge of
                  InEdge ->  fst . spanE InEdge
                              . snd . spanE OutEdge
                              . snd $ spanE InEdge cAllEdges
                  _      ->  fst . spanE InEdge . snd $ spanE OutEdge cAllEdges

  in if null ine || null oute
        then let [ sv ] = getSources g
                 findContour prew w =
                   if w /= v
                      then findContour (Just w) . fst . head $ (trace ("\n\nlSortSuc g w = " ++ show w

  ++ " lsortSuc = " ++ show (lSortSuc g w))
                                                                      ( lSortSuc g w ))
                      else prew
                 wOfFirstEdge = fromJust $ findContour Nothing sv
                 sine = sortBy (apa notCompare (snd . snd)) ine
                 (beforeW, withW) = span ((wOfFirstEdge /=) . fst) sine
              in ( sortBy (apa compare (fst . snd)) oute,
                   withW ++ sortBy (apa compare (snd . snd)) beforeW
                 )
        else map2 (map snd)
                  (outEdges, inEdges)
 where notCompare a b = case compare a b of
                          EQ -> EQ
                          LT -> GT
                          GT -> LT

lSortPre g v = let res = snd $ lSortEdges g v in
                   trace ("\n\nlSortPre(" ++ show v ++ ") = " ++ show res) res
lSortSuc g v = let res = fst $ lSortEdges g v in
                   trace ("\n\nlSortSuc(" ++ show v ++ ", g=  " ++ show g ++ ") = " ++ show res) res

findFace embG v (wi, st@ (freeFID, mf)) wj  =
  let findContour v w pStop selectEdge =
         let preEdges = lSortPre (checkm ("findFace: v = " ++ show v ++ " wi = "
                                             ++ show wi ++ " v = " ++ show v
                                             ++ " w = " ++ show w ++ " wj = "
                                             ++ show wj) embG) w
             sucEdges = lSortSuc embG w
             nextW = selectEdge sucEdges
             res = if null sucEdges || (not (null preEdges) && pStop v preEdges) -- w is t-node
                      then [ w ]
                      else w : findContour w nextW pStop selectEdge
          in trace ("findContour: v = " ++ show v ++ " w = " ++ show w ++ " suc = " ++ show sucEdges ++ " pre = " ++ show preEdges )
                   res

      leftCon = findContour v wi
                            (\v -> (v /= ) . fst . head ) -- last )
                            (fst . last)
      rightCon = findContour v wj
                             (\v -> (v /=) . fst . last ) -- head )
                             (fst . head )
      tr = trace ("\nfindFace v = " ++ show v ++ " wi = " ++ show wi ++ " wj = " ++ show wj  ++ " freeFID = " ++ show freeFID )
                 leftCon
      res = (wj, (freeFID + 1,
                  insNode (freeFID, newFace v tr rightCon) mf
                 )
            )
   in trace ("\nfindFace: " ++ show res ) res

linkage ((fid1, f1), (fid2, f2)) g =
 let getC f = (leftContour f, rightContour f)
     [ (lc1, rc1), (lc2, rc2) ] = map getC [f1,f2]
     foldIntersection res selector =
       let (ff1, ff2) = selector (fid1, fid2) in
           foldr (\e@(v,w) g -> insEdge (ff1,ff2,e) g )
                 g
                 res
  in case Set.toList $ lc1 `Set.intersection` rc2 of
       [] ->
         case Set.toList $ rc1 `Set.intersection` lc2 of
          [] -> g
          -- из f2  в f1
          res       -> foldIntersection res id
       res       -> foldIntersection res swap 

---

In your example:

main = let g = insEdge (0,1,()) $ buildGr [ ([], 0, (), []), ([], 1, (), []) ]
           g' = delEdge (0,1) g
        in if 1 `elem` suc g 0
              then putStrLn "OK"
              else putStrLn "ERROR "

the variable g' is never used. Should the expression suc g 0 be suc g' 0? It seems to me that this should make it print OK...