------------------------------------------------------------------
-- |
-- Module      :  Language.JSMW.Iterator
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Implementation of iterable data structures.
------------------------------------------------------------------

module Language.JSMW.Iterator (
  Sequence (..)
 ,StringMap (..)
 ,Iterator
 ,ContBrk
 ,ITERF
 ,continue
 ,stop
 ,iterseq
 ,itermut
 ,append
 ,emptymap
 ,store
 ,getval
 ,strseq
) where

import Control.Monad
import Control.Monad.RWS
import Language.JSMW.Monad
import Language.JSMW.Type
import Language.JSMW.Cond
import Language.JSMW.Arith
import BrownPLT.JavaScript.Syntax

-- | A datatype to represent sequences (in other words, Javascript arrays that
-- represent WebIDL sequences).

data Sequence a = Sequence a

-- | A datatype to represent Javascript objects as maps looked up by string key.

data StringMap a = StringMap a

-- | An opaque data type to represent an iterator container. Iteration finction is executed
-- within a container which does not allow access even to the object iterated over.

data Iterator = Iterator

instance JContainer Iterator

-- | An opaque data type to represent a result of an iterating function.

data ContBrk = CB

-- | A type for an iterating function. Such function takes two arguments:
-- a current element of a sequence, and a value from the previous iteration.
-- It should return a value of type 'ContBrk', that is the one produced by
-- either 'continue' or 'stop'.

type ITERF a b = Expression a -> Expression b -> JSMW Iterator ContBrk (Expression ContBrk)

-- | If an iterating function wishes to continue the iterations, it calls 'continue'
-- in order to pass the value to the next iteration. Internally, it wraps the value
-- supplied into a Javascript object, and returns it from the iterating function.

continue :: Expression a -> JSMW Iterator ContBrk (Expression ContBrk)

continue a = contbrk a True

-- | If an iterating function wishes to end iterations, it calls 'stop'
-- in order to have the value supplied to be returned from the iteration.
-- Due to their type signature, 'continue' and 'stop' can only be called from an
-- iterating function.

stop :: Expression a -> JSMW Iterator ContBrk (Expression ContBrk)

stop a = contbrk a False

-- Common part for continue and stop.

contbrk a tf = do
  let cbo = ObjectLit CB [
              (PropString CB "flag", BoolLit CB tf)
             ,(PropString CB "next", a /\ CB)]
  return cbo

-- | Iterate over a sequence. This is a hybrid of mapM and foldl. The iterating function
-- is called on every element starting with index 0 until the maximum index is reached,
-- or 'stop' is called from the iterating function.

iterseq :: (JContainer e)
        => Expression b             -- ^Starting value
        -> Expression (Sequence a)  -- ^The sequence to iterate over
        -> ITERF a b                -- ^The iterating function
        -> JSMW e s (Expression b)  -- ^Returned value of the same type as the starting value.

iterseq sv sq itf = do
  acc <- mkNewVar
  elt <- mkNewVar
  let telt = undefined :: a
      tacc = undefined :: b
      tdbl = undefined :: Double
  blk <- nestBlock (NullLit Iterator) (itf (VarRef telt (Id telt elt))
                                           (VarRef tacc (Id tacc acc)))
  funv <- once =<< return (FuncExpr tacc [Id tacc elt, Id tacc acc] (blk /\ tacc))
  ctr <- ask
  blk' <- nestBlock ctr $ do
    switch (isNull sq) $ do
      True --> return sv
      False --> do
        vq <- once sq
        vs <- once sv
        vl <- once =<< dotRef "length" vq
        vi <- once =<< numberM 0
        vv <- copy =<< return vs
        iblk <- nestBlock ctr $ do
          ve <- getjsIndex vi vq 
          vr <- once =<< return (CallExpr tacc funv [ve, vv])
          vf <- dotRef "flag" vr
          vx <- dotRef "next" vr
          writeStmt $ vv `assign` vx
          writeStmt $ IfStmt tacc vf (ContinueStmt tacc Nothing) (BreakStmt tacc Nothing)
        writeStmt $ ForStmt tacc NoInit 
                                 (Just $ (vi `lt` vl) /\ tacc)
                                 (Just $ incr vi /\ tacc)
                                 iblk
        return vv
  let iterdcl = FuncExpr tacc [] blk'
  once =<< return (CallExpr tacc iterdcl [])

-- | Iterate over a mutable object. The iterating function is passed an accumulated value,
-- and the mutable object reference. Depending on what the iterating function returns
-- (after possibly having mutated the object), the iteration continues, or it stops.
-- This type of iteration has potential to loop.

itermut :: (JContainer e)
        => Expression b               -- ^Starting value
        -> Expression a               -- ^The mutable object
        -> ITERF a b                  -- ^The iterating function
        -> JSMW e s (Expression b)    -- ^Returned value of the same type as the starting value.


itermut sv mo itf = do
  acc <- mkNewVar
  orf <- mkNewVar
  let torf = undefined :: a
      tacc = undefined :: b
  blk <- nestBlock (NullLit Iterator) (itf (VarRef torf (Id torf orf))
                                           (VarRef tacc (Id tacc acc)))
  funv <- once =<< return (FuncExpr tacc [Id tacc orf, Id tacc acc] (blk /\ tacc))
  ctr <- ask
  blk' <- nestBlock ctr $ do
    switch (isNull mo) $ do
      True --> return sv
      False --> do
        vo <- once mo
        vs <- once sv
        vv <- copy =<< return vs
        iblk <- nestBlock ctr $ do
          vr <- once =<< return (CallExpr tacc funv [vo, vv /\ torf])
          vf <- dotRef "flag" vr
          vx <- dotRef "next" vr
          writeStmt $ vv `assign` vx
          writeStmt $ IfStmt tacc vf (ContinueStmt tacc Nothing) (BreakStmt tacc Nothing)
        writeStmt $ ForStmt tacc NoInit Nothing Nothing iblk
        return vv
  let iterdcl = FuncExpr tacc [] blk'
  once =<< return (CallExpr tacc iterdcl [])

-- | Create an empty map of the given type.

emptymap :: JSMW e s (Expression (StringMap a))

emptymap = do
  let tm = StringMap (undefined :: a)
  return (ObjectLit tm []) >>= once

-- | Store a value in a string map at the given index. If anything is already stored,
-- it is overwritten. No value is returned.

store :: Expression String
      -> Expression a
      -> Expression (StringMap a)
      -> JSMW e s (Expression ())

store i v m = do
  let st = undefined :: s
  writeStmt (BracketRef st (m /\ st) (i /\ st) `assign` (v /\ st))
  return unit

-- | Get a value from a string map by the given index. Null may be returned.

getval :: Expression String
       -> Expression (StringMap a)
       -> JSMW e s (Expression a)

getval k m = getjsProperty k m >>= once

-- | Represent a string as a sequence, so it may be iterated over. Since characters do not
-- exist in Javascript, the iterating function will receive one-character strings
-- as sequence elements.

strseq :: Expression String -> Expression (Sequence String)

strseq = castExpr (undefined :: Sequence String)

-- |Append a value to a sequence. If a sequence object is undefined then a singleton list
-- is formed.

append :: (JContainer e)
       => Expression a
       -> Expression (Sequence a)
       -> JSMW e s (Expression (Sequence a))

append a s = do
  let ts = Sequence (undefined :: a)
      sngl = ArrayLit ts [a /\ ts]
  switch (isNull s) $ do
    True --> do return sngl >>= once
    False --> do
      return (CallExpr ts (DotRef ts (s /\ ts) (Id ts "concat")) [sngl]) >>= once