module LOAG.Common where

import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.Maybe (isNothing)
import Data.STRef
import Data.Array.ST
import Data.List (intercalate, foldl', nub)
import CommonTypes
import Control.Arrow
import Control.Monad.ST
import Control.Monad (forM, when, forM_, forM_, foldM)

import LOAG.Graphs

data Ag = Ag    (Int,Int)   -- attribute  range
                (Int,Int)   -- occurrence range
                [Edge]      -- direct dependencies
                [Nt]        -- non-terminals
data Nt = Nt String 
                [Edge] -- direct dps from inh -> syn
                [Edge] -- direct dps from syn -> inh 
                -- inh attributes with direction and instances
                [(Vertex,[Vertex],Direction)]
                -- syn attributes with direction and instances
                [(Vertex,[Vertex],Direction)]
                [Pr]            -- productions of this Nt
    deriving (Int -> Nt -> ShowS
[Nt] -> ShowS
Nt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nt] -> ShowS
$cshowList :: [Nt] -> ShowS
show :: Nt -> String
$cshow :: Nt -> String
showsPrec :: Int -> Nt -> ShowS
$cshowsPrec :: Int -> Nt -> ShowS
Show)
data Pr = Pr    PLabel
                [Edge]          -- direct dependencies between fields
                [(Edge,Edge,Bool)] -- all siblings pairs, with generalised version, and boolean that denotes whether if it is an edge of LHS
                [Fd]            -- the fields of this production, including lhs
    deriving (Int -> Pr -> ShowS
[Pr] -> ShowS
Pr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pr] -> ShowS
$cshowList :: [Pr] -> ShowS
show :: Pr -> String
$cshow :: Pr -> String
showsPrec :: Int -> Pr -> ShowS
$cshowsPrec :: Int -> Pr -> ShowS
Show)
data Fd = Fd    String          -- field name
                String          -- type of the field
                [(Vertex,Vertex)]        -- inherited atts (gen, inst)
                [(Vertex,Vertex)]        -- synthesized atts (gen, inst)
    deriving (Int -> Fd -> ShowS
[Fd] -> ShowS
Fd -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fd] -> ShowS
$cshowList :: [Fd] -> ShowS
show :: Fd -> String
$cshow :: Fd -> String
showsPrec :: Int -> Fd -> ShowS
$cshowsPrec :: Int -> Fd -> ShowS
Show)

type Attrs = [Attr]
data Attr  = Attr String Direction MyType
    deriving (Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attr] -> ShowS
$cshowList :: [Attr] -> ShowS
show :: Attr -> String
$cshow :: Attr -> String
showsPrec :: Int -> Attr -> ShowS
$cshowsPrec :: Int -> Attr -> ShowS
Show, Attr -> Attr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c== :: Attr -> Attr -> Bool
Eq, Eq Attr
Attr -> Attr -> Bool
Attr -> Attr -> Ordering
Attr -> Attr -> Attr
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 :: Attr -> Attr -> Attr
$cmin :: Attr -> Attr -> Attr
max :: Attr -> Attr -> Attr
$cmax :: Attr -> Attr -> Attr
>= :: Attr -> Attr -> Bool
$c>= :: Attr -> Attr -> Bool
> :: Attr -> Attr -> Bool
$c> :: Attr -> Attr -> Bool
<= :: Attr -> Attr -> Bool
$c<= :: Attr -> Attr -> Bool
< :: Attr -> Attr -> Bool
$c< :: Attr -> Attr -> Bool
compare :: Attr -> Attr -> Ordering
$ccompare :: Attr -> Attr -> Ordering
Ord)
data Direction = Inh | AnyDir | Syn
    deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, Eq Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
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 :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
Ord, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
$cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
enumFromTo :: Direction -> Direction -> [Direction]
$cenumFromTo :: Direction -> Direction -> [Direction]
enumFromThen :: Direction -> Direction -> [Direction]
$cenumFromThen :: Direction -> Direction -> [Direction]
enumFrom :: Direction -> [Direction]
$cenumFrom :: Direction -> [Direction]
fromEnum :: Direction -> Int
$cfromEnum :: Direction -> Int
toEnum :: Int -> Direction
$ctoEnum :: Int -> Direction
pred :: Direction -> Direction
$cpred :: Direction -> Direction
succ :: Direction -> Direction
$csucc :: Direction -> Direction
Enum)


foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' :: forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
_ a
a [] = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
foldM' a -> b -> m a
f a
a (b
x:[b]
xs) = a -> b -> m a
f a
a b
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
fax -> a
fax seq :: forall a b. a -> b -> b
`seq` forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> b -> m a
f a
fax [b]
xs

modifyArray :: a i t -> i -> (t -> t) -> m ()
modifyArray a i t
r i
k t -> t
f = do
    t
v <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a i t
r i
k
    forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a i t
r i
k (t -> t
f t
v)

setConcatMap :: (a -> Set a) -> Set a -> Set a
setConcatMap a -> Set a
f = forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr (forall a. Ord a => Set a -> Set a -> Set a
S.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a
f) forall a. Set a
S.empty
isLoc :: MyOccurrence -> Bool
isLoc (MyOccurrence (PLabel
_,String
f) ALabel
_) = String
f forall a. Eq a => a -> a -> Bool
== String
"loc" Bool -> Bool -> Bool
|| String
f forall a. Eq a => a -> a -> Bool
== String
"inst" -- transparent occr ? 

instance Eq Direction where
    Direction
Inh == :: Direction -> Direction -> Bool
== Direction
Syn = Bool
False
    Direction
Syn == Direction
Inh = Bool
False
    Direction
_ == Direction
_     = Bool
True

data MyType = TyInt
            | TyBool
            | TyString
            | TyData String
            | TyLit String
            | TyArr MyType MyType
            | NoType  -- the empty set of values (no members)
            | AnyType -- the set of all values (union of all types)

type SchedRef s = (STArray s Vertex (Maybe Int),ThreadRef s)
type AttrAssRef s = STArray s Vertex (Maybe Int)
type ThreadRef s = STRef s InterfaceRes
-- production is identified by its name and its parent non-terminal
type PLabel = (MyType,String) 
type FLabel = String -- field label
-- attribute is identified by its name and its direction
type ALabel = (String, Direction)
type AI_N   = M.Map MyType MyAttributes
type AS_N   = M.Map MyType MyAttributes
type A_N    = M.Map MyType MyAttributes
type A_P    = M.Map PLabel MyOccurrences
-- Get the (data)type of a certain child at a certain production
type FTY    = M.Map (PLabel, FLabel) MyType
-- Get the fields corresponding to a certain type
type TYFS   = M.Map MyType [(PLabel, FLabel)]
-- the definition of given occ uses these occs
type SF_P   = M.Map MyOccurrence (S.Set MyOccurrence) 
type PMP    = M.Map Int MyOccurrence
type PMP_R  = M.Map MyOccurrence Int
type NMP    = M.Map Int MyAttribute
type NMP_R  = M.Map MyAttribute Int
type FMap   = M.Map (PLabel,FLabel) (S.Set MyOccurrence, S.Set MyOccurrence)
type FsInP  = M.Map PLabel [(PLabel, FLabel)]
type LOAGRes =  ( Maybe TDPRes 
                , InterfaceRes
                , ADSRes)
type VisCount= (Int, Int, Float)
type ADSRes  = [Edge]
type TDPRes  = A.Array Vertex Vertices --M.Map PLabel TDPGraph
type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) 
type InterfaceRes = M.Map String (IM.IntMap [Vertex])
type HOMap   = M.Map PLabel (S.Set FLabel) 
data CType = T1 | T2 
           | T3 [Edge] -- completing edges from which to select candidates
    deriving (Int -> CType -> ShowS
[CType] -> ShowS
CType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CType] -> ShowS
$cshowList :: [CType] -> ShowS
show :: CType -> String
$cshow :: CType -> String
showsPrec :: Int -> CType -> ShowS
$cshowsPrec :: Int -> CType -> ShowS
Show)

findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a
findWithErr :: forall k a. (Ord k, Show k, Show a) => Map k a -> String -> k -> a
findWithErr Map k a
m String
err k
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
err) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k a
m
findWithErr' :: IntMap b -> String -> Int -> b
findWithErr' IntMap b
m String
err Int
k= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
err) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap b
m

-- Defining the MyAttribute (attribute at non-terimal
-- and the MyOccurrences (attribute at a production)
type MyAttributes = [MyAttribute]
data MyAttribute  = MyAttribute {MyAttribute -> MyType
typeOf :: MyType, MyAttribute -> ALabel
alab :: ALabel}
    deriving (Eq MyAttribute
MyAttribute -> MyAttribute -> Bool
MyAttribute -> MyAttribute -> Ordering
MyAttribute -> MyAttribute -> MyAttribute
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 :: MyAttribute -> MyAttribute -> MyAttribute
$cmin :: MyAttribute -> MyAttribute -> MyAttribute
max :: MyAttribute -> MyAttribute -> MyAttribute
$cmax :: MyAttribute -> MyAttribute -> MyAttribute
>= :: MyAttribute -> MyAttribute -> Bool
$c>= :: MyAttribute -> MyAttribute -> Bool
> :: MyAttribute -> MyAttribute -> Bool
$c> :: MyAttribute -> MyAttribute -> Bool
<= :: MyAttribute -> MyAttribute -> Bool
$c<= :: MyAttribute -> MyAttribute -> Bool
< :: MyAttribute -> MyAttribute -> Bool
$c< :: MyAttribute -> MyAttribute -> Bool
compare :: MyAttribute -> MyAttribute -> Ordering
$ccompare :: MyAttribute -> MyAttribute -> Ordering
Ord, MyAttribute -> MyAttribute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MyAttribute -> MyAttribute -> Bool
$c/= :: MyAttribute -> MyAttribute -> Bool
== :: MyAttribute -> MyAttribute -> Bool
$c== :: MyAttribute -> MyAttribute -> Bool
Eq)
<.> :: MyType -> ALabel -> MyAttribute
(<.>)         = MyType -> ALabel -> MyAttribute
MyAttribute
infixl 7 <.>
instance Show MyAttribute where
    show :: MyAttribute -> String
show (MyAttribute MyType
t ALabel
a) = forall a. Show a => a -> String
show MyType
t forall a. [a] -> [a] -> [a]
++ String
"<.>" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ALabel
a

type MyOccurrences = [MyOccurrence]
data MyOccurrence = MyOccurrence {MyOccurrence -> (PLabel, String)
argsOf :: (PLabel, FLabel), MyOccurrence -> ALabel
attr :: ALabel}
    deriving (Eq MyOccurrence
MyOccurrence -> MyOccurrence -> Bool
MyOccurrence -> MyOccurrence -> Ordering
MyOccurrence -> MyOccurrence -> MyOccurrence
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 :: MyOccurrence -> MyOccurrence -> MyOccurrence
$cmin :: MyOccurrence -> MyOccurrence -> MyOccurrence
max :: MyOccurrence -> MyOccurrence -> MyOccurrence
$cmax :: MyOccurrence -> MyOccurrence -> MyOccurrence
>= :: MyOccurrence -> MyOccurrence -> Bool
$c>= :: MyOccurrence -> MyOccurrence -> Bool
> :: MyOccurrence -> MyOccurrence -> Bool
$c> :: MyOccurrence -> MyOccurrence -> Bool
<= :: MyOccurrence -> MyOccurrence -> Bool
$c<= :: MyOccurrence -> MyOccurrence -> Bool
< :: MyOccurrence -> MyOccurrence -> Bool
$c< :: MyOccurrence -> MyOccurrence -> Bool
compare :: MyOccurrence -> MyOccurrence -> Ordering
$ccompare :: MyOccurrence -> MyOccurrence -> Ordering
Ord, MyOccurrence -> MyOccurrence -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MyOccurrence -> MyOccurrence -> Bool
$c/= :: MyOccurrence -> MyOccurrence -> Bool
== :: MyOccurrence -> MyOccurrence -> Bool
$c== :: MyOccurrence -> MyOccurrence -> Bool
Eq)
>.< :: (PLabel, String) -> ALabel -> MyOccurrence
(>.<)         = (PLabel, String) -> ALabel -> MyOccurrence
MyOccurrence
infixl 8 >.<
instance Show MyOccurrence where
    show :: MyOccurrence -> String
show (MyOccurrence ((MyType
t,String
p),String
f) ALabel
a) = 
        forall a. [a] -> [[a]] -> [a]
intercalate String
"." [forall a. Show a => a -> String
show MyType
t,String
p,String
f] forall a. [a] -> [a] -> [a]
++ String
"."forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ALabel
a

dirOfOcc :: MyOccurrence -> Direction
dirOfOcc :: MyOccurrence -> Direction
dirOfOcc = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. MyOccurrence -> ALabel
attr

handOut :: (PLabel, FLabel) -> MyAttribute -> MyOccurrence
handOut :: (PLabel, String) -> MyAttribute -> MyOccurrence
handOut (PLabel, String)
p = ((PLabel, String)
p (PLabel, String) -> ALabel -> MyOccurrence
>.<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. MyAttribute -> ALabel
alab

handAllOut :: (PLabel, FLabel) -> MyAttributes -> MyOccurrences
handAllOut :: (PLabel, String) -> [MyAttribute] -> [MyOccurrence]
handAllOut (PLabel, String)
p [MyAttribute]
os = forall a b. (a -> b) -> [a] -> [b]
map ((PLabel, String) -> MyAttribute -> MyOccurrence
handOut (PLabel, String)
p) [MyAttribute]
os

map2F  :: (Ord a)        => M.Map a [b] -> a -> [b]
map2F :: forall a b. Ord a => Map a [b] -> a -> [b]
map2F Map a [b]
m a
a = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
a Map a [b]
m of
              Maybe [b]
Nothing -> []
              Just [b]
bs -> [b]
bs

map2F'  :: (Ord a)        => M.Map a (S.Set b) -> a -> (S.Set b)
map2F' :: forall a b. Ord a => Map a (Set b) -> a -> Set b
map2F' Map a (Set b)
m a
a = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
a Map a (Set b)
m of
               Maybe (Set b)
Nothing -> forall a. Set a
S.empty
               Just Set b
bs -> Set b
bs

flipDir :: Direction -> Direction
flipDir :: Direction -> Direction
flipDir Direction
Syn = Direction
Inh
flipDir Direction
Inh = Direction
Syn

-- creates all pairs of elements such that no equal elements end up in a pair
-- and considering only one direction
pairs :: [a] -> [(a,a)]
pairs :: forall a. [a] -> [(a, a)]
pairs [] = []
pairs (a
x:[a]
xs) = forall a b. (a -> b) -> [a] -> [b]
map ((,) a
x) [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [(a, a)]
pairs [a]
xs

toMyTy :: Type -> MyType
toMyTy :: Type -> MyType
toMyTy (Haskell String
str) = String -> MyType
TyLit String
str
toMyTy (NT Identifier
id [String]
_ Bool
_ )  = String -> MyType
TyData forall a b. (a -> b) -> a -> b
$ Identifier -> String
getName Identifier
id
toMyTy Type
Self          = forall a. HasCallStack => String -> a
error String
"Type Self in phase 3"

fromMyTy :: MyType -> Type
fromMyTy :: MyType -> Type
fromMyTy (TyLit String
str) = (String -> Type
Haskell String
str)
fromMyTy (TyData String
id) = Identifier -> [String] -> Bool -> Type
NT (String -> Identifier
identifier String
id) [] Bool
False

toMyAttr :: Direction -> MyType -> Attributes -> MyAttributes
toMyAttr :: Direction -> MyType -> Attributes -> [MyAttribute]
toMyAttr Direction
d MyType
dty = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey 
                    (\Identifier
ident Type
ty [MyAttribute]
as -> MyType
dty MyType -> ALabel -> MyAttribute
<.> (Identifier -> String
getName Identifier
ident,Direction
d)forall a. a -> [a] -> [a]
:[MyAttribute]
as) []

completing :: FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes
completing :: forall s. FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes
completing FrGraph
ids SchedRef s
sched [Nt]
nts = do   
    [(String, IntMap [Int])]
ims <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Nt]
nts forall a b. (a -> b) -> a -> b
$ forall s.
FrGraph -> AttrAssRef s -> Nt -> ST s (String, IntMap [Int])
completingN FrGraph
ids (forall a b. (a, b) -> a
fst SchedRef s
sched)
    let threads :: InterfaceRes
threads = (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, IntMap [Int])]
ims)
    forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall a b. (a, b) -> b
snd SchedRef s
sched) InterfaceRes
threads
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InterfaceRes
threads 

completingN :: FrGraph -> AttrAssRef s -> Nt -> 
                    ST s ((String, IM.IntMap [Vertex]))
completingN :: forall s.
FrGraph -> AttrAssRef s -> Nt -> ST s (String, IntMap [Int])
completingN ids :: FrGraph
ids@(DirGraph
idsf, DirGraph
idst) AttrAssRef s
schedA
                (Nt String
nt_id [Edge]
_ [Edge]
_ [(Int, [Int], Direction)]
inhs [(Int, [Int], Direction)]
syns [Pr]
_) = do
    STRef s (IntMap [Int])
schedS <- forall a s. a -> ST s (STRef s a)
newSTRef forall a. IntMap a
IM.empty
    let attrs :: [(Int, [Int], Direction)]
attrs = [(Int, [Int], Direction)]
inhs forall a. [a] -> [a] -> [a]
++ [(Int, [Int], Direction)]
syns
        dty :: MyType
dty = String -> MyType
TyData String
nt_id
        assign :: (Int, [Int], Direction) -> ST s ()
assign (Int
attr,[Int]
_,Direction
dAttr) = do
         let succs :: Vertices
succs = DirGraph
idsf forall i e. Ix i => Array i e -> i -> e
A.! Int
attr
         Array Int (Maybe Int)
assigned <- forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
freeze AttrAssRef s
schedA
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Array Int (Maybe Int)
assigned forall i e. Ix i => Array i e -> i -> e
A.! Int
attr) forall a b. (a -> b) -> a -> b
$ do
           case Vertices -> [Int]
IS.toList Vertices
succs of 
             [] ->Int -> Int -> ST s ()
wrap_up Int
attr(if Direction
Synforall a. Eq a => a -> a -> Bool
==Direction
dAttr then Int
1 else Int
2)
             [Int]
ss ->case [(Int, Maybe Int)] -> Maybe Edge
selMax forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
idforall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&(Array Int (Maybe Int)
assigned forall i e. Ix i => Array i e -> i -> e
A.!)) [Int]
ss of
                      Maybe Edge
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      Just (Int
a,Int
mx) -> do
                          let dA :: Direction
dA | forall a. Integral a => a -> Bool
even Int
mx   = Direction
Inh
                                 | Bool
otherwise = Direction
Syn
                          Int -> Int -> ST s ()
wrap_up Int
attr (if Direction
dA forall a. Eq a => a -> a -> Bool
== Direction
dAttr 
                                          then Int
mx else Int
mxforall a. Num a => a -> a -> a
+Int
1)
        wrap_up :: Int -> Int -> ST s ()
wrap_up Int
attr Int
k = do
         forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (IntMap [Int])
schedS (forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. [a] -> [a] -> [a]
(++) Int
k [Int
attr])
         forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray AttrAssRef s
schedA Int
attr (forall a. a -> Maybe a
Just Int
k)
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, [Int], Direction)]
attrs (Int, [Int], Direction) -> ST s ()
assign
        selMax :: [(Vertex, Maybe Int)] -> Maybe (Vertex, Int)
        selMax :: [(Int, Maybe Int)] -> Maybe Edge
selMax [(Int
v,Maybe Int
mi)] = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Int
v) Maybe Int
mi
        selMax ((Int, Maybe Int)
x:[(Int, Maybe Int)]
xs)  = case (Int, Maybe Int)
x of 
                          (Int
a', Maybe Int
Nothing) -> forall a. Maybe a
Nothing
                          (Int
a', Just Int
i') -> 
                            case [(Int, Maybe Int)] -> Maybe Edge
selMax [(Int, Maybe Int)]
xs of 
                             Maybe Edge
Nothing -> forall a. Maybe a
Nothing
                             Just (Int
a,Int
i)  -> 
                                case forall a. Ord a => a -> a -> Ordering
compare Int
i Int
i' of
                                 Ordering
LT -> forall a. a -> Maybe a
Just (Int
a',Int
i')
                                 Ordering
_  -> forall a. a -> Maybe a
Just (Int
a,Int
i)
    --make sure all are assigned
    case [(Int, [Int], Direction)]
attrs of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
nt_id, forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
1,[]),(Int
2,[])])
      [(Int, [Int], Direction)]
as -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, [Int], Direction)]
as (Int, [Int], Direction) -> ST s ()
assign forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap [Int])
schedS forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) String
nt_id)

fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge],[Edge])
fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge], [Edge])
fetchEdges FrGraph
ids InterfaceRes
threads [Nt]
nts =
    let ivdNs :: [([Edge], [Edge])]
ivdNs = forall a b. (a -> b) -> [a] -> [b]
map (FrGraph -> InterfaceRes -> Nt -> ([Edge], [Edge])
fetchEdgesN FrGraph
ids InterfaceRes
threads) [Nt]
nts
    in (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [([Edge], [Edge])]
ivdNs

fetchEdgesN :: FrGraph -> InterfaceRes -> Nt
                    -> ([Edge],[Edge])
fetchEdgesN :: FrGraph -> InterfaceRes -> Nt -> ([Edge], [Edge])
fetchEdgesN (DirGraph
idsf, DirGraph
idst) InterfaceRes
threads 
        (Nt String
nt_id [Edge]
_ [Edge]
_ [(Int, [Int], Direction)]
_ [(Int, [Int], Direction)]
_ [Pr]
_) =
    let sched :: IntMap [Int]
sched = forall k a. (Ord k, Show k, Show a) => Map k a -> String -> k -> a
findWithErr InterfaceRes
threads String
"schedule err" String
nt_id
        mx :: Int
mx    = if forall a. IntMap a -> Bool
IM.null IntMap [Int]
sched then Int
0 else forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> (Int, a)
IM.findMax IntMap [Int]
sched
        findK :: Int -> [Int]
findK Int
0 = []
        findK Int
k = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap [Int]
sched) forall a. [a] -> [a] -> [a]
++ Int -> [Int]
findK (Int
kforall a. Num a => a -> a -> a
-Int
1)
        ivd :: [Edge]
ivd =  [ (Int
f,Int
t) | Int
k <- [Int
2..Int
mx]
                   , Int
f <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap [Int]
sched
                   , Int
t <- Int -> [Int]
findK (Int
kforall a. Num a => a -> a -> a
-Int
1)]
     in ([Edge]
ivd, [ (Int
f, Int
t) | (Int
f, Int
t) <- [Edge]
ivd
                          , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Int -> Vertices -> Bool
IS.member Int
t (DirGraph
idsf forall i e. Ix i => Array i e -> i -> e
A.! Int
f) ])

instance Show MyType where
    show :: MyType -> String
show MyType
TyInt        = String
"Int"
    show MyType
TyBool       = String
"Bool"
    show MyType
TyString     = String
"String"
    show (TyData String
t)   = String
t
    show (TyLit String
t)    = forall a. Show a => a -> String
show String
t
    show (TyArr MyType
a MyType
b)  = forall a. Show a => a -> String
show MyType
a forall a. [a] -> [a] -> [a]
++ String
" -> (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MyType
b forall a. [a] -> [a] -> [a]
++ String
")" 
    show MyType
NoType       = forall a. HasCallStack => String -> a
error String
"Trying to show NoType"
    show MyType
AnyType      = String
"AnyType"

-- | Instance for Eq and Ord are required to make sure that AnyType
-- | Equals every other type in every other situation
instance Eq MyType where
    MyType
TyInt       == :: MyType -> MyType -> Bool
== MyType
TyInt        = Bool
True
    MyType
TyBool      == MyType
TyBool       = Bool
True
    MyType
TyString    == MyType
TyString     = Bool
True
    TyData String
n    == TyData String
n'    = String
n forall a. Eq a => a -> a -> Bool
== String
n'
    TyLit String
ty    == TyLit String
ty'    = String
ty forall a. Eq a => a -> a -> Bool
== String
ty'
    TyArr MyType
l MyType
r   == TyArr MyType
l' MyType
r'  = MyType
l forall a. Eq a => a -> a -> Bool
== MyType
l' Bool -> Bool -> Bool
&& MyType
r forall a. Eq a => a -> a -> Bool
== MyType
r'
    MyType
NoType      == MyType
_            = Bool
False
    MyType
_           == MyType
NoType       = Bool
False
    MyType
AnyType     == MyType
_            = Bool
True
    MyType
_           == MyType
AnyType      = Bool
True
    MyType
_           == MyType
_            = Bool
False

instance Ord MyType where
    MyType
NoType compare :: MyType -> MyType -> Ordering
`compare` MyType
_          = Ordering
LT
    MyType
_   `compare` MyType
NoType        = Ordering
GT
    MyType
AnyType `compare` MyType
_         = Ordering
EQ
    MyType
_   `compare` MyType
AnyType       = Ordering
EQ
    MyType
TyInt `compare` MyType
TyInt       = Ordering
EQ
    MyType
TyInt `compare` MyType
_           = Ordering
LT
    MyType
TyBool `compare` MyType
TyInt      = Ordering
GT
    MyType
TyBool `compare` MyType
TyBool     = Ordering
EQ
    MyType
TyBool `compare` MyType
_          = Ordering
LT
    MyType
TyString `compare` MyType
TyInt    = Ordering
GT
    MyType
TyString `compare` MyType
TyBool   = Ordering
GT
    MyType
TyString `compare` MyType
TyString = Ordering
EQ
    MyType
TyString `compare` MyType
_        = Ordering
LT
    TyData String
_ `compare` MyType
TyInt    = Ordering
GT
    TyData String
_ `compare` MyType
TyBool   = Ordering
GT
    TyData String
_ `compare` MyType
TyString = Ordering
GT
    TyData String
a `compare` TyData String
b = forall a. Ord a => a -> a -> Ordering
compare String
a String
b
    TyData String
_ `compare` MyType
_        = Ordering
LT
    TyLit  String
a `compare` TyLit String
b  = forall a. Ord a => a -> a -> Ordering
compare String
a String
b
    TyLit  String
_ `compare` TyArr MyType
_ MyType
_= Ordering
LT    
    TyLit  String
_ `compare` MyType
_        = Ordering
GT
    TyArr MyType
a MyType
a' `compare` TyArr MyType
b MyType
b' = 
        case forall a. Ord a => a -> a -> Ordering
compare MyType
a MyType
b of
            Ordering
LT -> Ordering
LT
            Ordering
GT -> Ordering
GT
            Ordering
EQ -> forall a. Ord a => a -> a -> Ordering
compare MyType
a' MyType
b'
    TyArr MyType
_ MyType
_ `compare` MyType
_       = Ordering
GT