{- |
Module: Operators
Description: Operators used in creating Ion specifications
Copyright: (c) 2015 Chris Hodapp

-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Ivory.Language.Ion.Operators where

import           Control.Applicative ( (<$>) )
import           Control.Exception
import           Control.Monad
import           Control.Monad.State hiding ( forever )

import qualified Ivory.Language as IL
import qualified Ivory.Language.Monad as ILM
import           Ivory.Language.Proc ( Def(..), Proc(..), IvoryCall_,
                                       IvoryProcDef )

import           Ivory.Language.Ion.Base
import           Ivory.Language.Ion.Schedule
import           Ivory.Language.Ion.Util

-- | Transform a sub-node according to a function which transforms
-- 'Schedule' items, and then collect the state from it.
addAction :: (Schedule -> Schedule) -> Ion a -> Ion a
addAction fn sub = do
  start <- get
  -- 'Run' the sub-node, passing in a minimal starting state (except
  -- for the unique ID & name):
  let temp = IonDef
             { ionId = ionId start
             , ionNum = ionNum start
             , ionCtxt = fn $ ionCtxt start
                         -- FIXME: How much is ionCtxt needed, considering
                         -- that we copy it?
             , ionDefs = return ()
             , ionSched = [fn $ ionCtxt start]
             }
      (a, def) = runState sub temp
  -- Collect some of the state that the sub-node produced:
  put $ start { ionNum = ionNum def
              , ionDefs = ionDefs start >> ionDefs def
              -- , ionTree = ionTree start ++ [Tree.Node act $ ionTree def]
              , ionSched = ionSched start ++ ionSched def
              }
  return a

getSched :: Ion Schedule
getSched = ionCtxt <$> get

getPhase :: Ion Integer
getPhase = schedPhase <$> ionCtxt <$> get

-- | Specify a name of a sub-node, returning the parent.  This node
-- name is used in the paths to the node and in some C identifiers in
-- the generated C code; its purpose is mainly diagnostic and to help
-- the C code be more comprehensible.
ion :: String -- ^ Name
       -> Ion a -- ^ Sub-node
       -> Ion a
ion name = addAction setName
  where setName sch = case checkCName name of
          Just i -> throw $ InvalidCName (schedPath sch) name i
          Nothing -> sch { schedName = name
                         , schedPath = schedPath sch ++ [name]
                         }

phaseSet :: Integral i => i -> Schedule -> Schedule
phaseSet ph sch = if (ph' >= schedPeriod sch)
                  then throw $
                       PhaseExceedsPeriod (schedPath sch) ph' (schedPeriod sch)
                  else sch { schedPhase = ph' }
  where ph' = fromIntegral ph

-- | Specify a relative, minimum delay for a sub-node - i.e. a minimum
-- offset past the phase that is inherited.  For instance, in the
-- example,
--
-- @
--     'phase' 20 $ do
--        'phase' 40 $ foo
--        'delay' 2 $ bar
--        'delay' 2 $ baz
-- @
-- 
-- @foo@ and @bar@ both run at a (minimum) phase of 22, because the
-- entire @do@ block inherits that minimum phase.
delay :: Integral i =>
         i -- ^ Relative phase
         -> Ion a -- ^ Sub-node
         -> Ion a
delay ph = addAction setDelay
  where setDelay sch = phaseSet (schedPhase sch + fromIntegral ph) sch

-- | Specify a minimum phase for a sub-node - that is, the earliest
-- tick within a period that the sub-node should be scheduled at.
-- Phase must be non-negative, and lower than the period.
phase :: Integral i =>
         i -- ^ Phase
         -> Ion a -- ^ Sub-node
         -> Ion a
phase ph = addAction (phaseSet ph)

-- | Specify a period for a sub-node - that is, the interval, in
-- ticks, at which the sub-node is scheduled to repeat.  Period must
-- be positive; a period of 1 indicates that the sub-node executes at
-- every single clock tick.
period :: Integral i =>
          i -- ^ Period
          -> Ion a -- ^ Sub-node
          -> Ion a
period p = addAction setPeriod
  where p' = fromIntegral p
        setPeriod sch = if (p' <= 0)
                        then throw $ PeriodMustBePositive (schedPath sch) p'
                        else sch { schedPeriod = p' }

-- | Specify a sub-period for a sub-node - that is, the factor by
-- which to multiply the inherited period.  A factor of 2, for
-- instance, would execute the sub-node half as often as its parent.
subPeriod :: Integral i =>
             i -- ^ Factor by which to multiply period (must be positive)
             -> Ion a -- ^ Sub-node
             -> Ion a
subPeriod f = addAction divPeriod
  where divPeriod sch = let p = schedPeriod sch * fromIntegral f
                        in if (p <= 0)
                           then throw $ PeriodMustBePositive (schedPath sch) p
                           else sch { schedPeriod = p }

-- | Ignore a sub-node completely. This is intended to mask off some
-- part of a spec while still leaving it present for compilation.
-- Note that this disables only the scheduled effects of a node, and
-- so it has no effect on things like 'newProc'.
disable :: Ion a -> Ion ()
disable _ = return ()
-- FIXME: Explain this better.  'disable' and 'cond' only apply to certain
-- things.

-- | Make a sub-node's execution conditional; if the given Ivory effect
-- returns 'true' (as evaluated at the inherited phase and period),
-- then this sub-node is active, and otherwise is not.  Multiple
-- conditions may accumulate, in which case they combine with a
-- logical @and@ (i.e. all of them must be true for the node to be active).
cond :: IvoryAction IL.IBool -> Ion a -> Ion a
cond pred = addAction setCond
  where setCond sch = sch { schedCond = pred : schedCond sch }

-- | Attach an Ivory effect to an 'Ion'.  This effect will execute at
-- the inherited phase and period of the node.
ivoryEff :: IvoryAction () -> Ion ()
ivoryEff iv = addAction addEff $ return ()
  where addEff sch = sch { schedAction = schedAction sch ++ [iv] }

-- | Return a unique name.
newName :: Ion String
newName = do state <- get
             let num' = ionNum state
             put $ state { ionNum = num' + 1 }
             return $ ionId state ++ "_" ++ show num'

-- | Allocate a 'IL.MemArea' for this 'Ion', returning a reference to it.
-- If the initial value fails to specify the type of this, then an
-- external signature may be needed (or instead 'areaP'').  If access
-- to this variable is needed outside of the 'Ion' monad, retrieve the
-- reference from an 'Ion' with the 'ionRef' function.
-- The 'ModuleDef' for this will be generated automatically.
area' :: (IL.IvoryArea area, IL.IvoryZero area) =>
         String -- ^ Name of variable
         -> Maybe (IL.Init area) -- ^ Initial value (or 'Nothing')
         -> Ion (IL.Ref IL.Global area)
area' name init = do
  let mem = IL.area name init
  state <- get
  put $ state { ionDefs = ionDefs state >> IL.defMemArea mem }
  return $ IL.addrOf mem

-- | Same as 'area'', but with an initial 'IL.Proxy' to disambiguate
-- the area type.
areaP' :: (IL.IvoryArea area, IL.IvoryZero area) =>
         IL.Proxy area -- ^ Proxy (to disambiguate type)
         -> String -- ^ Name of variable
         -> Maybe (IL.Init area) -- ^ Initial value (or 'Nothing')
         -> Ion (IL.Ref IL.Global area)
areaP' _ = area'

-- | This is 'area'', but using 'Ion' to create a unique name.
-- (The purpose for this is to help with composing an 'Ion' or
-- instantiating one multiple times.)
newArea :: (IL.IvoryArea area, IL.IvoryZero area) =>
           Maybe (IL.Init area) -> Ion (IL.Ref IL.Global area)
newArea init = mkArea =<< newName
  where mkArea name = area' name init

-- | This is 'areaP'', but using 'Ion' to create a unique name.
newAreaP :: (IL.IvoryArea area, IL.IvoryZero area) =>
            IL.Proxy area -> Maybe (IL.Init area) ->
            Ion (IL.Ref IL.Global area)
newAreaP _ = newArea

-- | This is like Ivory 'proc', but using 'Ion' to give the
-- procedure a unique name.
newProc :: (IvoryProcDef proc impl) => impl -> Ion (Def proc)
newProc impl = do
  name <- newName
  state <- get
  let fn sym = IL.proc sym impl
  put $ state { ionDefs = ionDefs state >> (IL.incl $ fn name) }
  return $ fn name

-- | 'newProc' with an initial 'Proxy' to disambiguate the procedure type
newProcP :: (IvoryProcDef proc impl) =>
            IL.Proxy (Def proc) -> impl -> Ion (Def proc)
newProcP _ = newProc

-- | All the @adapt_X_Y@ functions adapt an Ivory procedure which
-- takes @X@ arguments and returns nothing, into an Ivory procedure
-- which takes @Y@ arguments.  If @X@ > @Y@ then zero is passed for
-- the argument(s); if @Y@ < @X@ then the additional arguments are
-- ignored.  The generated procedure is automatically included as part
-- of the 'Ion' spec.  The main point of this is to simplify the
-- chaining together of Ivory procedures.
adapt_0_1 :: (IL.IvoryType a, IL.IvoryVar a) =>
             Def ('[] ':-> ()) -> Ion (Def ('[a] ':-> ()))
adapt_0_1 fn0 = newProc $ \_ -> IL.body $ IL.call_ fn0

adapt_1_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a) =>
             Def ('[a] ':-> ()) -> Ion (Def ('[] ':-> ()))
adapt_1_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0

adapt_0_2 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b) =>
             Def ('[] ':-> ()) -> Ion (Def ('[a,b] ':-> ()))
adapt_0_2 fn0 = newProc $ \_ _ -> IL.body $ IL.call_ fn0

adapt_2_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b,
              IL.IvoryVar b) =>
             Def ('[a, b] ':-> ()) -> Ion (Def ('[] ':-> ()))
adapt_2_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0

adapt_0_3 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b,
              IL.IvoryType c, IL.IvoryVar c) =>
             Def ('[] ':-> ()) -> Ion (Def ('[a,b,c] ':-> ()))
adapt_0_3 fn0 = newProc $ \_ _ _ -> IL.body $ IL.call_ fn0

adapt_3_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b,
              IL.IvoryVar b, Num c, IL.IvoryType c, IL.IvoryVar c) =>
             Def ('[a, b, c] ':-> ()) -> Ion (Def ('[] ':-> ()))
adapt_3_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0 0

adapt_0_4 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b,
              IL.IvoryType c, IL.IvoryVar c, IL.IvoryType d, IL.IvoryVar d) =>
             Def ('[] ':-> ()) -> Ion (Def ('[a,b,c,d] ':-> ()))
adapt_0_4 fn0 = newProc $ \_ _ _ _ -> IL.body $ IL.call_ fn0

adapt_4_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b,
              IL.IvoryVar b, Num c, IL.IvoryType c, IL.IvoryVar c, Num d,
              IL.IvoryType d, IL.IvoryVar d) =>
             Def ('[a, b, c, d] ':-> ()) -> Ion (Def ('[] ':-> ()))
adapt_4_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0 0 0

adapt_0_5 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b,
              IL.IvoryType c, IL.IvoryVar c, IL.IvoryType d, IL.IvoryVar d,
              IL.IvoryType e, IL.IvoryVar e) =>
             Def ('[] ':-> ()) -> Ion (Def ('[a,b,c,d,e] ':-> ()))
adapt_0_5 fn0 = newProc $ \_ _ _ _ _ -> IL.body $ IL.call_ fn0

-- FIXME: I am almost certain that a better way exists than what I did
-- above - perhaps using typeclasses and mimicking what Ivory did to
-- define the functions.

-- | Create a timer resource.  The returned 'Ion' still must be called
-- at regular intervals (e.g. by including it in a larger Ion spec
-- that is already active).  See 'startTimer' and 'stopTimer' to
-- actually activate this timer.
timer :: (a ~ 'IL.Stored t, Num t, IL.IvoryStore t, IL.IvoryInit t,
          IL.IvoryEq t, IL.IvoryOrd t, IL.IvoryArea a, IL.IvoryZero a) =>
         IL.Proxy t -- ^ Proxy to resolve timer type
         -> Def ('[] ':-> ()) -- ^ Timer expiration procedure
         -> Ion (IL.Ref IL.Global (IL.Stored t))
timer _ expFn = do
  name <- newName

  ion name $ do
    var <- area' name $ Just $ IL.ival 0
    
    ion "decr" $ ivoryEff $ do
      val <- IL.deref var
      IL.ifte_ (val IL.==? 0) (return ()) -- Do nothing if already 0
      -- Otherwise, decrement
        $ do let val' = val - 1
             IL.store var (val')
             -- If it transitions to 0, then call the expiration proc
             IL.ifte_ (val' IL.>? 0) (return ()) $ IL.call_ expFn

    return var
-- FIXME: If the timer expiration procedure is to be fixed at
-- compile-time, maybe I should also just allow Ivory effects.  This
-- might make for lighter code and drop the need to make a new
-- function as a handler.

-- | Begin counting a timer down by the given number of ticks.
startTimer :: (Num t, IL.IvoryStore t, IL.IvoryZeroVal t) =>
              IL.Ref IL.Global (IL.Stored t) -- ^ Timer from 'timer'
              -> Integer -- ^ Countdown time
              -> ILM.Ivory eff ()
startTimer ref n = IL.store ref $ fromInteger n
-- FIXME: Will this even work right in usage?  Think of whether or not
-- the variable will be in scope.  Must these be in the same module?

-- | Stop a timer from running.
stopTimer ref = startTimer ref 0