{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module SchedInfo (
                  SchedInfo(..),

                  MethodConflictOp(..),
                  MethodConflictInfo(..),

                  makeMethodConflictDocs,

                  -- this is needed by BinData, for storing the contents
                  extractFromMethodConflictInfo,
                  -- these are needed only to support the scheduling pragma
                  mapMethodConflictInfo,
                  concatMapMethodConflictInfo,
                  filterMethodConflictInfo
                  ) where

#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
import Prelude hiding ((<>))
#endif

import Data.List(foldl',sortBy)
import PFPrint
import Eval
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Generics as Generic

-- ========================================================================
-- SchedInfo

data SchedInfo idtype = SchedInfo {
        methodConflictInfo :: MethodConflictInfo idtype,
        -- methods which have a rule that must execute between them
        -- (in the given order) and the list of rules
        -- XXX should we include the rule names?  they don't exist
        -- XXX on the boundary, but could be useful for debugging
        rulesBetweenMethods :: [((idtype, idtype), [idtype])],
        -- methods which have a rule that must execute before it
        -- along with the list of rules involved.
        -- Left  = rule directly before this method
        -- Right = method called by this method which requires a rule before it
        rulesBeforeMethods :: [(idtype,[Either idtype idtype])],
        -- methods which allow an unsynchronized clock domain crossing
        clockCrossingMethods :: [idtype]
        }
        deriving (Show, Ord, Eq, Generic.Data, Generic.Typeable)

instance (PPrint idtype, Ord idtype) => PPrint (SchedInfo idtype) where
    pPrint d p si =
        sep [text "SchedInfo",
             pPrint d 0 (methodConflictInfo si),
             pPrint d 0 (rulesBetweenMethods si),
             pPrint d 0 (rulesBeforeMethods si),
             pPrint d 0 (clockCrossingMethods si)]

instance (PVPrint idtype, Ord idtype) => PVPrint (SchedInfo idtype) where
    pvPrint d p si =
        sep [text "SchedInfo",
             pvPrint d 0 (methodConflictInfo si),
             pvPrint d 0 (rulesBetweenMethods si),
             pvPrint d 0 (rulesBeforeMethods si),
             pvPrint d 0 (clockCrossingMethods si)]

instance (Hyper idtype) => Hyper (SchedInfo idtype) where
    hyper si y = hyper4 (methodConflictInfo si)
                        (rulesBetweenMethods si)
                        (rulesBeforeMethods si)
                        (clockCrossingMethods si)
                        y

-- ========================================================================
-- MethodConflictOp
--

data MethodConflictOp = CF | SB | ME | P | SBR | C | EXT
       deriving (Eq, Ord)

instance Show MethodConflictOp where
   show CF = "CF"
   show SB = "SB"
   show ME = "ME"
   show P  = "P"
   show SBR = "SBR"
   show C = "C"
   show EXT = "EXT"

-- ========================================================================
-- MethodConflictInfo
--

{- a CF b     => a & b have the same effect when executed in parallel
                 in the same rule, or when executed in either order
                 in different rules in the same cycle.
   a SB b     => a & b have the same effect when executed in parallel
                 in the same rule, or when a is executed before b in
                 different rules in the same cycle.  Executing b before
                 a within one cycle is illegal.
   ME [a,b,c] => only one of a,b or c can execute in any cycle.
   a P b      => a & b may be executed in parallel within a single
                 rule.  It is illegal to execute a & b in the same
                 cycle in two different rules, in any order.
   a SBR b    => a may be executed before b in different rules in
                 the same cycle.  It is illegal to execute a & b in
                 parallel in a single rule, or to execute b before a
                 in two different rules in the same cycle.
   a C b      => a & b may not execute in the same cycle, whether in
                 one rule or two, in any order.
   EXT a      => two executions of a cannot occur in one rule.
                 a & b can execute in two different rules in the same
                 cycle but the effect will be different.  The
                 difference must be resolved external to the module.
-}

data MethodConflictInfo idtype =
    MethodConflictInfo {
        sCF  :: [(idtype, idtype)],
        sSB  :: [(idtype, idtype)],
        sME  :: [[idtype]],
        sP   :: [(idtype, idtype)],
        sSBR :: [(idtype, idtype)],
        sC   :: [(idtype, idtype)],
        sEXT :: [idtype]
    }
    deriving (Show, Ord, Eq, Generic.Data, Generic.Typeable)

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

instance (PPrint idtype, Ord idtype) => PPrint (MethodConflictInfo idtype) where
    pPrint d p mci =
        let ds = makeMethodConflictDocs (pPrint d p) ppReadable "[" "]" mci
        in  text "[" <> sepList ds (text ",") <> text "]"

instance (PVPrint idtype, Ord idtype) => PVPrint (MethodConflictInfo idtype) where
    pvPrint d p mci  =
        let ds = makeMethodConflictDocs (pvPrint d p) pvpReadable "[" "]" mci
        in  text "[" <> sepList ds (text ",") <> text "]"


-- Given:
--   * a printing function for ids (pPrint or pvPrint)
--   * a function for turning the ids into strings for sorting order
--   * start and stop enclosure for a list (we assume comma-separated)
--   * a MethodConflictInfo structure
-- Produce:
--   a list of Doc for the MethodConflictInfo info
--   (un-factored from pairs to groups)
--
makeMethodConflictDocs :: (Ord idtype) =>
                          (idtype -> Doc) ->
                          (idtype -> String) ->
                          String -> String ->
                          MethodConflictInfo idtype -> [Doc]
makeMethodConflictDocs pId sId listStart listEnd
        (MethodConflictInfo { sCF=sCF0, sSB=sSB0, sME=sME0, sP=sP0,
                              sSBR=sSBR0, sC=sC0, sEXT=sEXT0 }) =
    [pp m <+> text "CF"  <+> pp m' | (m,m') <- toPairsOfLists sCF0  ] ++
    [pp m <+> text "SB"  <+> pp m' | (m,m') <- toPairsOfLists sSB0  ] ++
    [         text "ME"  <+> pp m  |  m     <- sME_ordered          ] ++
    [pp m <+> text "P"   <+> pp m' | (m,m') <- toPairsOfLists sP0   ] ++
    [pp m <+> text "SBR" <+> pp m' | (m,m') <- toPairsOfLists sSBR0 ] ++
    [pp m <+> text "C"   <+> pp m' | (m,m') <- toPairsOfLists sC0   ] ++
    (if null sEXT0 then [] else [text "EXT" <+> pp sEXT_ordered])
  where
      pp [m] = pId m
      pp ms  =
          text listStart <> (sepList (map pId ms) (text ",")) <> text listEnd

      collect ps = M.fromListWith (S.union) [(a,S.singleton b) | (a,b) <- ps]
      toPairsOfLists ps = let m1 = collect ps
                              m2 = collect [(s,a) | (a,s) <- M.toList m1]
                          in sortLP [ (sortI (S.toList s2), sortI (S.toList s1))
                                    | (s1,s2) <- M.toList m2
                                    ]

      sortI  = sortBy (\ i1 i2 -> (sId i1) `compare` (sId i2))
      sortL  = sortBy (\ is1 is2 -> (map sId is1) `compare` (map sId is2))
      sortLP = sortBy (\(is1,_) (is2,_) -> (map sId is1) `compare` (map sId is2))
      sME_ordered  = sortL (map sortI sME0)
      sEXT_ordered = sortI sEXT0

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

mapMethodConflictInfo :: (a -> b) ->
                         MethodConflictInfo a -> MethodConflictInfo b
mapMethodConflictInfo f x =
    let
        f2 (x1,x2) = (f x1, f x2)
        nsCF = (map f2 (sCF x))
        nsSB = (map f2 (sSB x))
        nsME = (map (map f) (sME x))
        nsP  = (map f2 (sP x))
        nsSBR= (map f2 (sSBR x))
        nsC  = (map f2 (sC x))
        nsEXT= (map f (sEXT x))
    in
        MethodConflictInfo {
            sCF  = nsCF,
            sSB  = nsSB,
            sME  = nsME,
            sP   = nsP,
            sSBR = nsSBR,
            sC   = nsC,
            sEXT = nsEXT
        }

concatMapMethodConflictInfo ::  (a -> [b]) ->
                                MethodConflictInfo a -> MethodConflictInfo b
concatMapMethodConflictInfo f x =
    let
        f2 z = [(tx,ty) | (x,y) <- z,
                          tx <- f x,
                          ty <- f y]

        nsCF = f2 (sCF x)
        nsSB = f2 (sSB x)
        nsME = (map (concatMap f) (sME x))
        nsP  = f2 (sP x)
        nsSBR= f2 (sSBR x)
        nsC  = f2 (sC x)
        nsEXT= (concatMap f (sEXT x))
    in
        MethodConflictInfo {
            sCF  = nsCF,
            sSB  = nsSB,
            sME  = nsME,
            sP   = nsP,
            sSBR = nsSBR,
            sC   = nsC,
            sEXT = nsEXT
        }

filterMethodConflictInfo :: Eq a => (a -> Bool) ->
                            MethodConflictInfo a -> MethodConflictInfo a
filterMethodConflictInfo f x =
    let
        f2 (x,y) = (f x) || (f y)

        nsCF = filter f2 (sCF x)
        nsSB = filter f2 (sSB x)
        nsME = filter ( /= []) (map (filter f) (sME x))
        nsP  = filter f2 (sP x)
        nsSBR= filter f2 (sSBR x)
        nsC  = filter f2 (sC x)
        nsEXT= (filter f (sEXT x))
    in
        MethodConflictInfo {
            sCF  = nsCF,
            sSB  = nsSB,
            sME  = nsME,
            sP   = nsP,
            sSBR = nsSBR,
            sC   = nsC,
            sEXT = nsEXT
        }

extractFromMethodConflictInfo :: Ord a => MethodConflictInfo a -> [a]
extractFromMethodConflictInfo x =
    let
        f s (x,y) = S.insert x (S.insert y s)
        setCF = foldl' f S.empty (sCF x)
        setSB = foldl' f S.empty (sSB x)
        setME = S.fromList (concat (sME x))
        setP  = foldl' f S.empty (sP x)
        setSBR= foldl' f S.empty (sSBR x)
        setC  = foldl' f S.empty (sC x)
        setEXT= S.fromList (sEXT x)
    in S.toList (S.unions [setCF, setSB, setME, setP, setSBR, setC, setEXT])

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

instance (Hyper idtype) => Hyper (MethodConflictInfo idtype) where
    hyper (MethodConflictInfo { sCF=cf, sSB=sb, sME=me, sP=p,
                                sSBR=sbr, sC=c, sEXT=ext }) y =
        hyper7 cf sb me p sbr c ext y

-- ========================================================================