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
(Int -> Nt -> ShowS)
-> (Nt -> String) -> ([Nt] -> ShowS) -> Show Nt
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
(Int -> Pr -> ShowS)
-> (Pr -> String) -> ([Pr] -> ShowS) -> Show Pr
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
(Int -> Fd -> ShowS)
-> (Fd -> String) -> ([Fd] -> ShowS) -> Show Fd
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
(Int -> Attr -> ShowS)
-> (Attr -> String) -> ([Attr] -> ShowS) -> Show Attr
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
(Attr -> Attr -> Bool) -> (Attr -> Attr -> Bool) -> Eq Attr
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
Eq Attr
-> (Attr -> Attr -> Ordering)
-> (Attr -> Attr -> Bool)
-> (Attr -> Attr -> Bool)
-> (Attr -> Attr -> Bool)
-> (Attr -> Attr -> Bool)
-> (Attr -> Attr -> Attr)
-> (Attr -> Attr -> Attr)
-> Ord 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
$cp1Ord :: Eq Attr
Ord)
data Direction = Inh | AnyDir | Syn
    deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
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
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord 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
$cp1Ord :: Eq Direction
Ord, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
(Direction -> Direction)
-> (Direction -> Direction)
-> (Int -> Direction)
-> (Direction -> Int)
-> (Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> Direction -> [Direction])
-> Enum 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' :: (a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
_ a
a [] = a -> m 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 m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
fax -> a
fax a -> m a -> m a
`seq` (a -> b -> m a) -> a -> [b] -> m a
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 <- a i t -> i -> m t
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a i t
r i
k
    a i t -> i -> t -> m ()
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 = (a -> Set a -> Set a) -> Set a -> Set a -> Set a
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set a -> Set a -> Set a) -> (a -> Set a) -> a -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a
f) Set a
forall a. Set a
S.empty
isLoc :: MyOccurrence -> Bool
isLoc (MyOccurrence (PLabel
_,String
f) ALabel
_) = String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"loc" Bool -> Bool -> Bool
|| String
f String -> String -> Bool
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
(Int -> CType -> ShowS)
-> (CType -> String) -> ([CType] -> ShowS) -> Show CType
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 :: Map k a -> String -> k -> a
findWithErr Map k a
m String
err k
k = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> a
forall a. HasCallStack => String -> a
error String
err) a -> a
forall a. a -> a
id (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Maybe a
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= b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> b
forall a. HasCallStack => String -> a
error String
err) b -> b
forall a. a -> a
id (Maybe b -> b) -> Maybe b -> b
forall a b. (a -> b) -> a -> b
$ Int -> IntMap b -> Maybe 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
Eq MyAttribute
-> (MyAttribute -> MyAttribute -> Ordering)
-> (MyAttribute -> MyAttribute -> Bool)
-> (MyAttribute -> MyAttribute -> Bool)
-> (MyAttribute -> MyAttribute -> Bool)
-> (MyAttribute -> MyAttribute -> Bool)
-> (MyAttribute -> MyAttribute -> MyAttribute)
-> (MyAttribute -> MyAttribute -> MyAttribute)
-> Ord 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
$cp1Ord :: Eq MyAttribute
Ord, MyAttribute -> MyAttribute -> Bool
(MyAttribute -> MyAttribute -> Bool)
-> (MyAttribute -> MyAttribute -> Bool) -> Eq MyAttribute
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) = MyType -> String
forall a. Show a => a -> String
show MyType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"<.>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ALabel -> String
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
Eq MyOccurrence
-> (MyOccurrence -> MyOccurrence -> Ordering)
-> (MyOccurrence -> MyOccurrence -> Bool)
-> (MyOccurrence -> MyOccurrence -> Bool)
-> (MyOccurrence -> MyOccurrence -> Bool)
-> (MyOccurrence -> MyOccurrence -> Bool)
-> (MyOccurrence -> MyOccurrence -> MyOccurrence)
-> (MyOccurrence -> MyOccurrence -> MyOccurrence)
-> Ord 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
$cp1Ord :: Eq MyOccurrence
Ord, MyOccurrence -> MyOccurrence -> Bool
(MyOccurrence -> MyOccurrence -> Bool)
-> (MyOccurrence -> MyOccurrence -> Bool) -> Eq MyOccurrence
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) = 
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [MyType -> String
forall a. Show a => a -> String
show MyType
t,String
p,String
f] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."String -> ShowS
forall a. [a] -> [a] -> [a]
++ ALabel -> String
forall a. Show a => a -> String
show ALabel
a

dirOfOcc :: MyOccurrence -> Direction
dirOfOcc :: MyOccurrence -> Direction
dirOfOcc = ALabel -> Direction
forall a b. (a, b) -> b
snd (ALabel -> Direction)
-> (MyOccurrence -> ALabel) -> MyOccurrence -> Direction
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
>.<) (ALabel -> MyOccurrence)
-> (MyAttribute -> ALabel) -> MyAttribute -> 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 = (MyAttribute -> MyOccurrence) -> [MyAttribute] -> [MyOccurrence]
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 :: Map a [b] -> a -> [b]
map2F Map a [b]
m a
a = case a -> Map a [b] -> Maybe [b]
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' :: Map a (Set b) -> a -> Set b
map2F' Map a (Set b)
m a
a = case a -> Map a (Set b) -> Maybe (Set b)
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 -> Set b
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 :: [a] -> [(a, a)]
pairs [] = []
pairs (a
x:[a]
xs) = (a -> (a, a)) -> [a] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) a
x) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [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 (String -> MyType) -> String -> MyType
forall a b. (a -> b) -> a -> b
$ Identifier -> String
getName Identifier
id
toMyTy Type
Self          = String -> MyType
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 = (Identifier -> Type -> [MyAttribute] -> [MyAttribute])
-> [MyAttribute] -> Attributes -> [MyAttribute]
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)MyAttribute -> [MyAttribute] -> [MyAttribute]
forall a. a -> [a] -> [a]
:[MyAttribute]
as) []

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

completingN :: FrGraph -> AttrAssRef s -> Nt -> 
                    ST s ((String, IM.IntMap [Vertex]))
completingN :: 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 <- IntMap [Int] -> ST s (STRef s (IntMap [Int]))
forall a s. a -> ST s (STRef s a)
newSTRef IntMap [Int]
forall a. IntMap a
IM.empty
    let attrs :: [(Int, [Int], Direction)]
attrs = [(Int, [Int], Direction)]
inhs [(Int, [Int], Direction)]
-> [(Int, [Int], Direction)] -> [(Int, [Int], Direction)]
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 DirGraph -> Int -> Vertices
forall i e. Ix i => Array i e -> i -> e
A.! Int
attr
         Array Int (Maybe Int)
assigned <- AttrAssRef s -> ST s (Array Int (Maybe Int))
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
         Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Array Int (Maybe Int)
assigned Array Int (Maybe Int) -> Int -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
A.! Int
attr) (ST s () -> ST s ()) -> ST s () -> ST s ()
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
SynDirection -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
==Direction
dAttr then Int
1 else Int
2)
             [Int]
ss ->case [(Int, Maybe Int)] -> Maybe Edge
selMax ([(Int, Maybe Int)] -> Maybe Edge)
-> [(Int, Maybe Int)] -> Maybe Edge
forall a b. (a -> b) -> a -> b
$ (Int -> (Int, Maybe Int)) -> [Int] -> [(Int, Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. a -> a
id(Int -> Int) -> (Int -> Maybe Int) -> Int -> (Int, Maybe Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&(Array Int (Maybe Int)
assigned Array Int (Maybe Int) -> Int -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
A.!)) [Int]
ss of
                      Maybe Edge
Nothing -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      Just (Int
a,Int
mx) -> do
                          let dA :: Direction
dA | Int -> Bool
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 Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
dAttr 
                                          then Int
mx else Int
mxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        wrap_up :: Int -> Int -> ST s ()
wrap_up Int
attr Int
k = do
         STRef s (IntMap [Int]) -> (IntMap [Int] -> IntMap [Int]) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (IntMap [Int])
schedS (([Int] -> [Int] -> [Int])
-> Int -> [Int] -> IntMap [Int] -> IntMap [Int]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) Int
k [Int
attr])
         AttrAssRef s -> Int -> Maybe Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray AttrAssRef s
schedA Int
attr (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k)
         [(Int, [Int], Direction)]
-> ((Int, [Int], Direction) -> ST s ()) -> ST s ()
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)] = (Int -> Edge) -> Maybe Int -> Maybe Edge
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) -> Maybe Edge
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 -> Maybe Edge
forall a. Maybe a
Nothing
                             Just (Int
a,Int
i)  -> 
                                case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
i' of
                                 Ordering
LT -> Edge -> Maybe Edge
forall a. a -> Maybe a
Just (Int
a',Int
i')
                                 Ordering
_  -> Edge -> Maybe Edge
forall a. a -> Maybe a
Just (Int
a,Int
i)
    --make sure all are assigned

    case [(Int, [Int], Direction)]
attrs of
      [] -> (String, IntMap [Int]) -> ST s (String, IntMap [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
nt_id, [(Int, [Int])] -> IntMap [Int]
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
1,[]),(Int
2,[])])
      [(Int, [Int], Direction)]
as -> [(Int, [Int], Direction)]
-> ((Int, [Int], Direction) -> ST s ()) -> ST s ()
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 ST s () -> ST s (IntMap [Int]) -> ST s (IntMap [Int])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STRef s (IntMap [Int]) -> ST s (IntMap [Int])
forall s a. STRef s a -> ST s a
readSTRef STRef s (IntMap [Int])
schedS ST s (IntMap [Int])
-> (IntMap [Int] -> ST s (String, IntMap [Int]))
-> ST s (String, IntMap [Int])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String, IntMap [Int]) -> ST s (String, IntMap [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, IntMap [Int]) -> ST s (String, IntMap [Int]))
-> (IntMap [Int] -> (String, IntMap [Int]))
-> IntMap [Int]
-> ST s (String, IntMap [Int])
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 = (Nt -> ([Edge], [Edge])) -> [Nt] -> [([Edge], [Edge])]
forall a b. (a -> b) -> [a] -> [b]
map (FrGraph -> InterfaceRes -> Nt -> ([Edge], [Edge])
fetchEdgesN FrGraph
ids InterfaceRes
threads) [Nt]
nts
    in ([[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Edge]] -> [Edge])
-> ([[Edge]] -> [Edge]) -> ([[Edge]], [[Edge]]) -> ([Edge], [Edge])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (([[Edge]], [[Edge]]) -> ([Edge], [Edge]))
-> ([[Edge]], [[Edge]]) -> ([Edge], [Edge])
forall a b. (a -> b) -> a -> b
$ [([Edge], [Edge])] -> ([[Edge]], [[Edge]])
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 = InterfaceRes -> String -> String -> IntMap [Int]
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 IntMap [Int] -> Bool
forall a. IntMap a -> Bool
IM.null IntMap [Int]
sched then Int
0 else (Int, [Int]) -> Int
forall a b. (a, b) -> a
fst ((Int, [Int]) -> Int) -> (Int, [Int]) -> Int
forall a b. (a -> b) -> a -> b
$ IntMap [Int] -> (Int, [Int])
forall a. IntMap a -> (Int, a)
IM.findMax IntMap [Int]
sched
        findK :: Int -> [Int]
findK Int
0 = []
        findK Int
k = ([Int] -> ([Int] -> [Int]) -> Maybe [Int] -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Int] -> [Int]
forall a. a -> a
id (Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [Int] -> Maybe [Int]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap [Int]
sched) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
findK (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        ivd :: [Edge]
ivd =  [ (Int
f,Int
t) | Int
k <- [Int
2..Int
mx]
                   , Int
f <- [Int] -> ([Int] -> [Int]) -> Maybe [Int] -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Int] -> [Int]
forall a. a -> a
id (Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [Int] -> Maybe [Int]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap [Int]
sched
                   , Int
t <- Int -> [Int]
findK (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]
     in ([Edge]
ivd, [ (Int
f, Int
t) | (Int
f, Int
t) <- [Edge]
ivd
                          , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Vertices -> Bool
IS.member Int
t (DirGraph
idsf DirGraph -> Int -> Vertices
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)    = ShowS
forall a. Show a => a -> String
show String
t
    show (TyArr MyType
a MyType
b)  = MyType -> String
forall a. Show a => a -> String
show MyType
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ MyType -> String
forall a. Show a => a -> String
show MyType
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" 
    show MyType
NoType       = ShowS
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n'
    TyLit String
ty    == TyLit String
ty'    = String
ty String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ty'
    TyArr MyType
l MyType
r   == TyArr MyType
l' MyType
r'  = MyType
l MyType -> MyType -> Bool
forall a. Eq a => a -> a -> Bool
== MyType
l' Bool -> Bool -> Bool
&& MyType
r MyType -> MyType -> Bool
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 = String -> String -> Ordering
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  = String -> String -> Ordering
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 MyType -> MyType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare MyType
a MyType
b of
            Ordering
LT -> Ordering
LT
            Ordering
GT -> Ordering
GT
            Ordering
EQ -> MyType -> MyType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare MyType
a' MyType
b'
    TyArr MyType
_ MyType
_ `compare` MyType
_       = Ordering
GT