{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}

-- | The basic types and combinators of Sunroof.
module Language.Sunroof.Types
  ( T(..)
  , ThreadProxy(..)
  , SunroofThread(..)
  , JS(..), JSA, JSB
  , unJS
  , single
  , JSI(..)
  , callcc
  , done, liftJS, kast
  , JSFunction, JSContinuation
  , function , continuation, goto
  , apply, ($$)
  , cast
  , (#)
  , attr
  , fun, invoke, new
  , evaluate, value
  , switch
  , nullJS
  , delete
  , JSTuple(..)  -- TODO: Call this SunroofTuple?
  , SunroofKey(..)
  ) where

import Control.Monad.Operational

import Data.Monoid ( Monoid(..) )
--import Data.Semigroup ( Semigroup(..) )
import Data.Boolean ( BooleanOf, IfB(..), EqB(..) )
import Data.Proxy ( Proxy(Proxy) )
import Data.Semigroup ( Semigroup(..) )

import Language.Sunroof.JavaScript
  ( Expr, Type(Fun), Id
  , showExpr, literal )
import Language.Sunroof.Classes
  ( Sunroof(..), SunroofValue(..), SunroofArgument(..) )
import Language.Sunroof.Selector ( JSSelector, label, (!) )
import Language.Sunroof.JS.Bool ( JSBool, jsIfB )
import Language.Sunroof.JS.Object ( JSObject, object )
import Language.Sunroof.JS.Number ( JSNumber )
import Language.Sunroof.JS.String ( string, JSString )

-- -------------------------------------------------------------
-- Thread Model
-- -------------------------------------------------------------

-- | The possible threading models for Javascript computations.
data T = A -- ^ Atomic - The computation will not be interrupted.
       | B -- ^ Blocking - The computation may block and wait to enable
           --   interleaving with other computations.
       deriving (Eq, Ord, Show)

-- | A proxy to capture the type of threading model used.
--   See 'SunroofThread'.
data ThreadProxy (t :: T) = ThreadProxy

-- | When implemented the type supports determining the threading model
--   during runtime.
class SunroofThread (t :: T) where
  -- | Determine the used threading model captured the given 'ThreadProxy'
  --   object.
  evalStyle    :: ThreadProxy t -> T
  -- | Create a possibly blocking computation from the given one.
  blockableJS :: (Sunroof a) => JS t a -> JS B a

instance SunroofThread A where
  evalStyle _ = A
  blockableJS = liftJS

instance SunroofThread B where
  evalStyle _ = B
  blockableJS = id

-- -------------------------------------------------------------
-- JS Monad - The Javascript Monad
-- -------------------------------------------------------------

infix  5 :=

-- | The monadic type of Javascript computations.
--
--   @JS t a@ is a computation using the thread model @t@ (see 'T').
--   It returns a result of type @a@.
data JS :: T -> * -> * where
  JS   :: ((a -> Program (JSI t) ()) -> Program (JSI t) ()) -> JS t a
  (:=) :: (Sunroof a, Sunroof o) => JSSelector a -> a -> o -> JS t ()

-- | Short-hand type for atmoic Javascript computations.
type JSA a = JS A a

-- | Short-hand type for possibly blocking Javascript computations.
type JSB a = JS B a

-- | Lifts a single primitive Javascript instruction ('JSI') into the
--   'JS' monad.
single :: JSI t a -> JS t a
single i = JS $ \ k -> singleton i >>= k

-- | Unwraps the 'JS' monad into a continuation
--   on 'Control.Monad.Operational.Program'.
unJS :: JS t a -> (a -> Program (JSI t) ()) -> Program (JSI t) ()
unJS (JS m) k = m k
unJS ((:=) sel a obj) k = singleton (JS_Assign sel a (cast obj)) >>= k

instance Monad (JS t) where
  return a = JS $ \ k -> return a >>= k
  m >>= k = JS $ \ k0 -> unJS m (\ r -> unJS (k r) k0)

instance Functor (JS t) where
  fmap f jsm = jsm >>= (return . f)

type instance BooleanOf (JS t a) = JSBool

instance (SunroofThread t, Sunroof a, SunroofArgument a) => IfB (JS t a) where
    ifB i h e = single $ JS_Branch i h e

-- | We define the Semigroup instance for JS, where
--   the first result (but not the first effect) is discarded.
--   Thus, '<>' is the analog of the monadic '>>'.
instance Semigroup (JS t a) where
  js1 <> js2 = js1 >> js2

instance Monoid (JS t ()) where
  mempty = return ()
  mappend = (<>)

-- | 'JSI' represents the primitive effects or instructions for
--   the JS monad.
--
--     [@JS_Assign s v o@] assigns a value @v@ to the selected field @s@
--       in the object @o@.
--
--     [@JS_Select s o@] returns the value of the selected field @s@
--       in the object @o@.
--
--     [@JS_Delete s o@] delete the selected field @s@ in the object @o@.
--
--     [@JS_Invoke a f@] calls the function @f@ with the arguments @a@.
--
--     [@JS_Eval v@] evaluates the value @v@. Subsequent instructions
--       use the value instead of reevaluating the expression.
--
--     [@JS_Function f@] creates a Javascript function
--       from the Haskell function @f@.
--
--     [@JS_Continuation f@] creates a Javascript continuation (function that never returns a value)
--       from the Haskell function @f@.
--
--     [@JS_Branch b t f@] creates a @if-then-else@ statement in Javascript.
--       In that statement @b@ is the condition, @t@ is the true branch and
--       @f@ is the false branch.
--
--     [@JS_Return v@] translates into an actual @return@ statement that
--       returns the value @v@ in Javascript.
--
--     [@JS_Assign_ v x@] assigns the value @x@ to the variable with name @v@.
--
--     [@JS_Fix v x@] models a fixpoint computation in 'JS'. See 'jsfix'.
--
data JSI :: T -> * -> * where
  JS_Assign  :: (Sunroof a) => JSSelector a -> a -> JSObject -> JSI t ()
  JS_Select  :: (Sunroof a) => JSSelector a -> JSObject -> JSI t a
  JS_Delete  :: (Sunroof a) => JSSelector a -> JSObject -> JSI t ()
  -- Perhaps take the overloaded vs [Expr] and use jsArgs in the compiler?
  JS_Invoke :: (SunroofArgument a, Sunroof r) => a -> JSFunction a r -> JSI t r
  JS_Eval   :: (Sunroof a) => a -> JSI t a
  JS_Function :: (SunroofArgument a, Sunroof b) => (a -> JS A b) -> JSI t (JSFunction a b)
  JS_Continuation :: (SunroofArgument a) => (a -> JS B ()) -> JSI t (JSContinuation a)
  -- Needs? Boolean bool, bool ~ BooleanOf (JS a)
  JS_Branch :: (SunroofThread t, Sunroof a, SunroofArgument a, Sunroof bool) => bool -> JS t a -> JS t a  -> JSI t a
  JS_Return  :: (Sunroof a) => a -> JSI t ()
  JS_Assign_ :: (Sunroof a) => Id -> a -> JSI t ()
  JS_Comment :: String -> JSI t ()
  JS_Fix     :: (SunroofArgument a) => (a -> JS A a) -> JSI t a
  -- TODO: generalize Assign[_] to have a RHS

-- -------------------------------------------------------------
-- Cross the Threading Model Combinators
-- -------------------------------------------------------------

-- | Lift the atomic computation into another computation.
liftJS :: (Sunroof a) => JS A a -> JS t a
liftJS m = do
        o <- function (\ () -> m)
        apply o ()

-- -------------------------------------------------------------
-- JSFunction Type
-- -------------------------------------------------------------

-- | Type of Javascript functions.
--   The first type argument is the type of function argument.
--   This needs to be a instance of 'SunroofArgument'.
--   The second type argument of 'JSFunction' is the function return type.
--   It needs to be a instance of 'Sunroof'.
data JSFunction args ret = JSFunction Expr

instance Show (JSFunction a r) where
  show (JSFunction v) = showExpr False v

-- | Functions are first-class citizens of Javascript. Therefore they
--   are 'Sunroof' values.
instance forall a r . (SunroofArgument a, Sunroof r) => Sunroof (JSFunction a r) where
  box = JSFunction
  unbox (JSFunction e) = e
  typeOf _ = Fun (typesOf (Proxy :: Proxy a)) (typeOf (Proxy :: Proxy r))

type instance BooleanOf (JSFunction a r) = JSBool

-- | Functions may be the result of a branch.
instance (SunroofArgument a, Sunroof r) => IfB (JSFunction a r) where
  ifB = jsIfB

-- | 'JSFunction's may be created from Haskell functions if they have
--   the right form.
instance (SunroofArgument a, Sunroof b) => SunroofValue (a -> JS A b) where
  type ValueOf (a -> JS A b) = JS A (JSFunction a b)    -- TO revisit
  js = function

-- -------------------------------------------------------------
-- JSFunction Combinators
-- -------------------------------------------------------------

-- | Create a binding to a Javascript top-level function with
--   the given name. It is advised to create these bindings with an
--   associated type signature to ensure type safty while using
--   this function. Example:
--
-- > alert :: JSFunction JSString ()
-- > alert = fun "alert"
fun :: (SunroofArgument a, Sunroof r) => String -> JSFunction a r
fun = JSFunction . literal

-- | Create an 'A'tomic Javascript function from a Haskell function.
function :: (SunroofArgument a, Sunroof b) => (a -> JS A b) -> JS t (JSFunction a b)
function = single . JS_Function

infixl 1 `apply`

-- | @apply f a@ applies the function @f@ to the given arguments @a@.
--   A typical use case looks like this:
--
-- > foo `apply` (x,y)
--
--   See '$$' for a convenient infix operator to do this.
apply :: (SunroofArgument args, Sunroof ret) => JSFunction args ret -> args -> JS t ret
apply f args = f # with args
  where
    with :: (SunroofArgument a, Sunroof r) => a -> JSFunction a r -> JS t r
    with a fn = single $ JS_Invoke a fn

-- | @f $$ a@ applies the function 'f' to the given arguments @a@.
--   See 'apply'.
($$) :: (SunroofArgument args, Sunroof ret) => JSFunction args ret -> args -> JS t ret
($$) = apply

-- -------------------------------------------------------------
-- JSContinuation Type
-- -------------------------------------------------------------

-- | Type of Javascript functions.
--   The first type argument is the type of function argument.
--   This needs to be a instance of 'SunroofArgument'.
--   The second type argument of 'JSFunction' is the function return type.
--   It needs to be a instance of 'Sunroof'.
data JSContinuation args = JSContinuation Expr

instance Show (JSContinuation a) where
  show (JSContinuation v) = showExpr False v

-- | Functions are first-class citizens of Javascript. Therefore they
--   are 'Sunroof' values.
instance forall a . (SunroofArgument a) => Sunroof (JSContinuation a) where
  box = JSContinuation
  unbox (JSContinuation e) = e
  typeOf _ = Fun (typesOf (Proxy :: Proxy a)) (typeOf (Proxy :: Proxy ()))

type instance BooleanOf (JSContinuation a) = JSBool

-- | Functions may be the result of a branch.
instance (SunroofArgument a, Sunroof r) => IfB (JSContinuation a) where
  ifB = jsIfB

-- | 'JSFunction's may be created from Haskell functions if they have
--   the right form.
instance (SunroofArgument a) => SunroofValue (a -> JS B ()) where
  type ValueOf (a -> JS B ()) = JS B (JSContinuation a)    -- TO revisit
  js = continuation

-- -------------------------------------------------------------
-- JSFunction Combinators
-- -------------------------------------------------------------

-- | We can compile 'B'lockable functions that return @()@.
--   Note that, with the 'B'-style threads, we return from a
--   call when we first block, not at completion of the call.
continuation :: (SunroofArgument a) => (a -> JS B ()) -> JS t (JSContinuation a)
continuation = single . JS_Continuation

-- | @kast@ is cast to continuation. @k@ is the letter often used to signify a continuation.
kast :: (SunroofArgument a) => JSFunction a () -> JSContinuation a
kast = cast

-- Implementation of goto and callCC from
--   http://stackoverflow.com/questions/9050725/call-cc-implementation
--
-- | Reify the current contination as a Javascript continuation
callcc :: SunroofArgument a => (JSContinuation a -> JS B a) -> JS B a
callcc f = JS $ \ cc -> unJS (do o <- continuation (goto' cc)
                                 f o
                              ) cc
   where goto' :: (x ~ ()) => (a -> Program (JSI B) ()) -> a -> JS B x
         goto' cont argument = JS $ \ _ -> cont argument


-- | Abort the current computation at this point.
done :: JS t a
done = JS $ \ _ -> return ()

-- | @goto@ calls the given continuation with the given argument,
--   and never returns.
goto :: forall args a t . (SunroofArgument args) => JSContinuation args -> args -> JS t a
goto k args = JS $ \ _ -> singleton $ JS_Invoke args (cast k  :: JSFunction args ())

-- -------------------------------------------------------------
-- Basic Combinators
-- -------------------------------------------------------------

-- | Cast one Sunroof value into another.
--
--   This is sometimes needed due to Javascripts flexible type system.
cast :: (Sunroof a, Sunroof b) => a -> b
cast = box . unbox

infixr 0 #

-- | The @#@-operator is the Haskell analog to the @.@-operator
--   in Javascript. Example:
--
-- > document # getElementById "bla"
--
--   This can be seen as equivalent of @document.getElementById(\"bla\")@.
(#) :: a -> (a -> JS t b) -> JS t b
(#) obj act = act obj
-- We should use this operator for the obj.label concept.
-- It has been used in other places (but I can not seems
-- to find a library for it)

-- | Creates a selector for attributes of Javascript objects.
--   It is advised to use this together with an associated type
--   signature to avoid ambiguity. Example:
--
-- > length :: JSSelector JSNumber
-- > length = attr "length"
--
--   Selectors can be used with '!'.
attr :: String -> JSSelector a
attr a = label $ string a

-- | @invoke s a o@ calls the method with name @s@ using the arguments @a@
--   on the object @o@. A typical use would look like this:
--
-- > o # invoke "foo" (x, y)
--
--   Another use case is writing Javascript API bindings for common methods:
--
-- > getElementById :: JSString -> JSObject -> JS t JSObject
-- > getElementById s = invoke "getElementById" s
--
--   Like this the flexible type signature gets fixed. See 'Language.Sunroof.Types.#'
--   for how to use these bindings.
invoke :: (SunroofArgument a, Sunroof r, Sunroof o) => String -> a -> o -> JS t r
invoke str args obj = (obj ! attr str) `apply` args

-- | @new n a@ calls the new operator on the constructor @n@
--   supplying the argument @a@. A typical use would look like this:
--
-- > new "Object" ()
--
new :: (SunroofArgument a) => String -> a -> JS t JSObject
new cons args = fun ("new " ++ cons) `apply` args

-- | Evaluate a 'Sunroof' value. This forces evaluation
--   of the given expression to a value and enables binding it to a
--   variable. Example:
--
-- > x <- evaluate $ "A" <> "B"
-- > alert x
-- > alert x
--
--   This would result in: @var v0 = \"A\"+\"B\"; alert(v0); alert(v0);@. But:
--
-- > x <- return $ "A" <> "B"
-- > alert x
-- > alert x
--
--   This will result in: @alert(\"A\"+\"B\"); alert(\"A\"+\"B\");@.
evaluate :: (Sunroof a) => a -> JS t a
evaluate a  = single (JS_Eval a)

-- | Synonym for 'evaluate'.
value :: (Sunroof a) => a -> JS t a
value = evaluate

-- | Combinator for @switch@-like statements in Javascript.
--
--   /Note/: This will not be translated into
--   actual switch statment, because you are aloud arbitrary
--   expressions in the cases.
switch :: ( EqB a, BooleanOf a ~ JSBool
          , Sunroof a, Sunroof b
          , SunroofArgument b
          , SunroofThread t
          ) => a -> [(a,JS t b)] -> JS t b
switch _a [] = return (cast (object "undefined"))
switch a ((c,t):e) = ifB (a ==* c) t (switch a e)

-- | The @null@ reference in Javascript.
nullJS :: JSObject
nullJS = box $ literal "null"

-- -------------------------------------------------------------
-- delete
-- -------------------------------------------------------------

-- | @o # delete lab@ removes the label @lab@ from the object @o@.
delete :: (Sunroof a) => JSSelector a -> JSObject -> JS t ()
delete sel o = single (JS_Delete sel o)

-- -------------------------------------------------------------
-- JSTuple Type Class
-- -------------------------------------------------------------

-- | If something is a 'JSTuple', it can easily be decomposed and
--   recomposed from different components. This is meant as a convenient
--   access to attributes of an object.
-- TODO: revisit this
class Sunroof o => JSTuple o where
        type Internals o
        match :: (Sunroof o) => o -> Internals o
        tuple :: Internals o -> JS t o

instance JSTuple JSObject where
  type Internals JSObject = ()
  match _ = ()
  tuple () = new "Object" ()


-- -------------------------------------------------------------
-- SunroofKey Type Class
-- -------------------------------------------------------------

-- | Everything that can be used as an key in a dictionary lookup.
class Sunroof key => SunroofKey key where
   jsKey :: key -> JSSelector a

-- To break the module loop
instance SunroofKey JSString where
   jsKey = label

instance SunroofKey JSNumber where
   jsKey k = label ("" <> cast k)

instance SunroofKey JSBool where
   jsKey k = label ("" <> cast k)