{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

{-
--------------------------------------------------------------------------------
--
-- Copyright (C) 2008 Martin Sulzmann, Edmund Lam. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}


module Actor.ActorCompiler where

{- version using memoization, the programmer must explicitly provide the "line number" -}

import Actor.ActorBase
import Actor.ActorSyntax


-- the bare actor class, minimal functionality required to
-- implement the multi-set message matching algorithm           


-- TODO: we need rm -> a (which seems too strong), otherwise some constraints cant be deduced

class EMatch m => Actor a m rm idx st | a -> m rm idx st, rm -> a  where -- we could use type functions here
  -- a is the actor type
  -- m is the (plain) message
  -- rm is the (rich) message with more (internal) information, eg the message's location
  -- idx is the search index where to start
  -- st is the current state of our search

  getMessage :: a -> Maybe Int -> IO (Maybe rm)
  deleteMsg :: a -> rm -> IO ()
  getIndex :: a -> m -> IO idx    -- m is a pattern message
  initSearch :: a -> idx -> IO st
  nextMsg :: a -> st -> IO (Maybe rm)
  resetMB :: a -> IO ()

  extractMsg :: rm -> IO (InternalMsg m)              

  -- memoization

  codeLookup :: a -> Int -> IO (Maybe [CompClause a rm ()])
  memoCode :: a -> (Int,[CompClause a rm ()]) -> IO ()
{-
getMessage gets the most recent active message which is then put
into the store (pool of inactive messages)
a time-out (microseconds, action) is an additional parameter
if getMessage returns Nothing the time for waiting for an 
incoming message has exceeded the time-out limit,
if Just x then x is the next incoming message

deleteMsg deletes message in the store 

getIndex computes the index for each message

initSearch sets up the search based on a given index idx

nextMsg gets the next message matching a given index idx

resetMB restores the mailbox by putting store contraints back into the queue/mailbox
-}


-- behavior of receive clauses can be specified via the following data type

data MemoFlag = NoMemo | Memo Int

data ReceiveParameters = 
         RecParm { memo :: MemoFlag 
                     -- we'll use the provided Int to store the 'compiled' clauses
                 , resetAction :: IO ()
                     -- the action to be executed before executing the body (rhs)
                     -- typically, resetMB 
                 , timeOut :: Maybe (Int, IO ())
                     -- waits number of microseconds for incoming message, then executes action
                     -- and 'aborts' receive clause
                 }



-- (compiled) receive clauses representation
-----------------------------------------------

type Code_RHS a = IO a

-- external receive clauses are pairs of ([MatchTask msg], Code_RHS a)
-- we compile them to a function

type CompClause act rmsg code = rmsg -> act -> IO (Maybe (Code_RHS code))
                    -- rmsg is the currently active message (in rich format)
                    -- search for matching lhs performed in IO
                    -- if match found commit and return code for rhs
                    -- otherwise return Nothing


-- receive clauses execution scheme
------------------------------------------



-- NOTE: We can only support memo for receive bodies returning () "unit",
--      For any other return type, some types would be too polymorphic.


-- standard reveive, no memoization, always reset MB, no timeout
receive :: (Actor act msg rmsg idx st, Show msg) => act -> [([MatchTask msg], Code_RHS a)] -> IO a
receive  act prog =  receiveInternal act (build prog)
  where
    build [] = []
    build ((tasks,body):rest) = (compile (do {resetMB act; body}) tasks) ++ (build rest)
       -- maintain order of clauses!

-- generalized, parameterized receive 
receiveParm :: (Actor act msg rmsg idx st, Show msg) => 
           act -> ReceiveParameters -> [([MatchTask msg], Code_RHS ())] -> IO ()
receiveParm act parm prog =
 let -- 'compilation' of match clauses
     build [] = []  
     build ((tasks,body):rest) = (compile (do {resetAction parm; body}) tasks) ++ (build rest)
       -- we plug in the resetAction before we execute the body
       -- maintain order of clauses (important in case of sequential execution)

 in case (memo parm) of
      NoMemo -> receiveInternal2 act parm (build prog)  -- no memoization
      Memo idx -> do res <- codeLookup act idx     -- memoization
                     case res of                   -- check if already stored
                       Just code -> receiveInternal2 act parm code  
                       Nothing -> do let code = build prog
                                     memoCode act (idx,code)
                                     receiveInternal2 act parm code

receiveInternal :: (Actor a m rm idx st, Show m) => a -> [CompClause a rm c] -> IO c
receiveInternal act comp =
  do { Just active_msg <- getMessage act Nothing -- no timeout
     --; putStr "** StartSearch with getMessage **\n"
     ; res <- select active_msg act comp
     ; case res of
         Just action -> action
         Nothing     -> receiveInternal act comp
     }
-- get active message (which we then put into the store, pool of inactive messages)
-- check if the active messages fires any of the receive clauses (tried from top to bottom)
-- if yes, simply execute rhs/body, otherwise repeat, get a next/new active message ...


receiveInternal2 :: (Actor a m rm idx st, Show m) => a -> ReceiveParameters -> [CompClause a rm ()] -> IO ()
receiveInternal2 act parm compiled_clauses =
  let setupTimeOut = case (timeOut parm) of
                        Nothing -> Nothing 
                        Just (t,_) -> Just t
      timeOutAction = let Just (_,action) = timeOut parm
                      in action
      choose Nothing a1 a2 = a1
      choose (Just x) a1 a2 = a2 x
      seqMsgSeqCls =  
          -- sequential processing of incoming messages, and
          -- sequential, top to bottom, application of clauses
          do active_msg_res <- getMessage act setupTimeOut 
             case active_msg_res of
                Just active_msg ->
                  do --putStrLn $ "Msg arrived" 
                     res <- select active_msg act compiled_clauses
                     case res of
                        Just action -> do --putStrLn "fire" 
                                          action
                        Nothing     -> do --putStrLn "failed, try again"
                                          seqMsgSeqCls
                Nothing -> timeOutAction
  in seqMsgSeqCls



select :: Actor a m rm idx st => rm -> a -> [CompClause a rm c] -> IO (Maybe (Code_RHS c))
select _ _ [] = return Nothing
select msg act (comp:comps) = 
  do { res <- comp msg act
     ; case res of
        Just action -> return (Just action)
        Nothing -> select msg act comps
     }
-- based on the given message, check if any of the (compiled) clauses can be executed



-- compilation scheme for receive clauses
------------------------------------------------------

-- compilation of a single receive clause 
-- yields several compiled clauses, any of the messages
-- in the pattern could be matched first

compile :: (Actor act msg rmsg idx st, Show msg)  => 
            Code_RHS a -> [MatchTask msg] -> [CompClause act rmsg a]
compile body tasks =
   map compileClause (optimize (generateTasks tasks))
 where

-- compileClause tries to match the first message pattern
-- the search for the remaining message patterns are done by compileSingle

   --compileClause :: [MatchTask msg] -> rmsg -> act -> IO (Maybe (IO a))
   compileClause tasks msg act =   -- msg is a message in rich format
       -- \msg -> \act -> 
         case (head tasks) of -- get the first task
           Simp active_msg ->  
            do { -- putStr "Matchsearch start:\n"
                 -- ; putStr ("active_msg = " ++ show active_msg ++ "\n")
                 -- ; putStr ("msg = " ++ show msg ++ "\n")
                 plain_msg <- extractMsg msg
               ;(b,var_env) <- internal_match [] plain_msg active_msg
                  -- multi-set matching, see definition of internal_match
                  -- where we use tags to remember already matched messages
               ; if b 
                  then compileSingle act
                      (do {deleteMsg act msg; body}) var_env (tail tasks)
                       -- compileSingle accumulates all deletes by putting them
                       -- in front of body
                  else return Nothing }
           Prop active_msg ->
             do { plain_msg <- extractMsg msg
                ; (b,var_env) <- internal_match [] plain_msg active_msg
                  -- multi-set matching, see definition of internal_match
                ; if b 
                  then compileSingle act (do {body}) var_env (tail tasks)
                       -- no delete for props
                  else return Nothing }
           Guard _ -> error "A guard can't be the first match task"

-- nothing at the moment
-- early guard scheduling, alternative semantics (best match), ...
optimize :: [[MatchTask msg]] -> [[MatchTask msg]]
optimize = id

-- we only need to guarantee that each element appears once in front
generateTasks [] = error "simps/props can't be empty"
generateTasks xs = 
 let go 1 xs = [xs]
     go n xs = [xs] ++ go (n-1) (shuffle xs) 
 in go (length xs) xs

shuffle [] = []
shuffle (x:xs) = xs ++ [x]

-- we permute tasks, 
-- the first tasks must be either Simp or Prop
-- all guards are at the tail to ensure that there're no unbound variables
-- NOTE: But we don't catch cases like [ x > y ] !
permuteTasks :: [MatchTask msg] -> [[MatchTask msg]]
permuteTasks tasks = [ ys ++ guards | ys <- permute simps_props ]
   where
    test (Prop _) = True
    test (Simp _) = True
    test (Guard _) = False
    simps_props = filter (\t -> test t) tasks
    guards = filter (\t -> not (test t)) tasks

-- brute-force permutation, unnecessary
permute [] = []
permute [x] = [[x]]
permute (x:xs) = 
       [ zs | ys <- permute xs, zs <- patch x ys ]

patch x zs = [x:zs] ++ [(take n zs) ++ [x] ++ (drop n zs) | n <- [1..length zs]]


-- compilation for a fixed sequence of match tasks
-- we thread through a list of tags, var_env, to check for already bound pattern variables
-- and already matched messages
compileSingle :: (Actor act msg rmsg idx st, Show msg) => 
            act -> Code_RHS a -> [Tag] -> [MatchTask msg] -> IO (Maybe (Code_RHS a))
compileSingle act body _ [] = return (Just body) 
compileSingle act body var_env ((Guard guard):tasks) = 
   do { b <- guard
      ; if b 
         then compileSingle act body var_env tasks
         else return Nothing
      }
compileSingle act body var_env (task:tasks) =
 let  getMsg (Simp x) = x
      getMsg (Prop x) = x
      getMsg _ = error "the impossible has happened, always check for guards first"
 in case getMsg task of
   active_msg ->

-- we perform a linear search of the store to find a match for active_msg
-- st is a store pointer, points to the current "inactive" message in the store
-- nextMsg will update st to the next "inactive" message

     do { idx <- getIndex act active_msg
        ; st <- initSearch act idx
        ; search st }
      where
       search st = 
        do { result <- nextMsg act st
           ; case result of
               Nothing -> return Nothing -- back-track
               Just msg -> 
                 do { -- putStr "Matchsearch2 \n"
                     -- ; putStr ("active_msg = " ++ show active_msg ++ "\n")
                     -- ; putStr ("msg = " ++ show msg ++ "\n")
                      plain_msg <- extractMsg msg
                    ; (b,var_env2) <- internal_match var_env plain_msg active_msg 
                       -- side-effect of binding pattern variables
                       -- multi-set matching, see definition of internal_match
                    ; if b then 
                       do { rest <- compileSingle act body var_env2 tasks
                            -- choice point
                          ; case rest of
                              Nothing -> search st
                              Just code_rest -> 
                                case task of
                                  Simp _ ->
                                    return (Just (do {deleteMsg act msg; code_rest}))
                                    -- we must delete msg, not active_msg
                                    -- we use syntactic equality testing for delete
                                  Prop _ -> return (Just code_rest)
                                            -- nothing to delete
                          }
                       else search st --return Nothing is wrong 
                                      -- we must continue the search !!!!!
                    }
            }