{-# LANGUAGE OverloadedStrings,KindSignatures, GADTs, ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}

module Network.JavaScript.Internal
  ( -- * JavaScript
    JavaScript(..)
    -- * Commands
  , Command()
  , internalCommand
  , internalConstructor
    -- * Procedures
  , Procedure()
  , internalProcedure
    -- * Primitives and (Remote) Values
  , Primitive(..)
  , RemoteValue(..)
  , var
    -- * (Applicative) Packets
  , Packet(..)
  , AF(..)
  , RemoteMonad(..)
  , evalAF
  , concatAF
    -- * Monads
  , M(..)
  , evalM
  ) where

import           Data.Aeson (ToJSON(..), FromJSON(..))
import qualified Data.Aeson.Encoding.Internal as AI
import qualified Data.Binary.Builder as B
import           Data.Text.Lazy(Text, pack)
import           Data.Text.Lazy.Encoding(encodeUtf8)
import           Data.String

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

newtype JavaScript = JavaScript Text
  deriving Show

instance IsString JavaScript where
  fromString = JavaScript . fromString
  
instance Semigroup JavaScript where
  JavaScript x <> JavaScript y = JavaScript $ x <> y
  
instance Monoid JavaScript where
  mempty = JavaScript mempty
  mappend = (<>)

class Command f where
  internalCommand :: JavaScript -> f ()
  internalConstructor :: JavaScript -> f (RemoteValue a)

class Procedure f where
  internalProcedure :: FromJSON a => JavaScript -> f a
  
-- | The Remote Applicative Packet
newtype Packet a = Packet (AF Primitive a)
  deriving (Functor, Applicative)

-- | The Remote Monad
newtype RemoteMonad a = RemoteMonad (M Primitive a)
  deriving (Functor, Applicative, Monad)

data Primitive :: * -> * where
  Command   :: JavaScript -> Primitive ()
  Procedure :: FromJSON a => JavaScript -> Primitive a
  Constructor :: JavaScript -> Primitive (RemoteValue a)

instance Command Packet where
  internalCommand = Packet . PrimAF . Command  
  internalConstructor = Packet . PrimAF . Constructor

instance Procedure Packet where
  internalProcedure = Packet . PrimAF . Procedure

instance Command RemoteMonad where
  internalCommand = RemoteMonad . PrimM . Command  
  internalConstructor = RemoteMonad . PrimM . Constructor

instance Procedure RemoteMonad where
  internalProcedure = RemoteMonad . PrimM . Procedure

-- A Local handle into a remote value.
newtype RemoteValue a = RemoteValue Int
  deriving (Eq, Ord, Show)

-- Remote values can not be encoded in JSON, but are JavaScript variables.
instance ToJSON (RemoteValue a) where
  toJSON = error "toJSON not supported for RemoteValue"
  toEncoding rv = AI.unsafeToEncoding $ B.fromLazyByteString $ encodeUtf8 txt
    where
      JavaScript txt = var rv
      
-- | generate the text for a RemoteValue. They can be used as assignment
--   targets as well, but exposes the JavaScript scoping semantics.
var :: RemoteValue a -> JavaScript
var (RemoteValue n) = JavaScript $ "jsb.rs[" <> pack (show n) <> "]"

------------------------------------------------------------------------------
-- Framework types for Applicative and Monad

data AF :: (* -> *) -> * -> * where
 PureAF :: a -> AF m a
 PrimAF :: m a -> AF m a
 ApAF :: AF m (a -> b) -> AF m a -> AF m b

instance Functor (AF m) where
  fmap f g = pure f <*> g
  
instance Applicative (AF m) where
  pure = PureAF
  (<*>) = ApAF

concatAF :: (forall x . m x -> Maybe b) -> AF m a -> [b]
concatAF _ (PureAF _) = []
concatAF f (PrimAF p) = case f p of
  Nothing -> []
  Just r -> [r]
concatAF f (ApAF m1 m2) = concatAF f m1 ++ concatAF f m2

evalAF :: Applicative f => (forall x . m x -> f x) -> AF m a -> f a
evalAF _ (PureAF a) = pure a
evalAF f (PrimAF p) = f p
evalAF f (ApAF g h) = evalAF f g <*> evalAF f h

data M :: (* -> *) -> * -> * where
 PureM :: a -> M m a
 PrimM :: m a -> M m a
 ApM :: M m (a -> b) -> M m a -> M m b
 BindM :: M m a -> (a -> M m b) -> M m b

instance Functor (M m) where
  fmap f g = pure f <*> g
  
instance Applicative (M m) where
  pure = PureM
  (<*>) = ApM

instance Monad (M m) where
  return = PureM
  (>>=) = BindM
  (>>) = (*>)

evalM :: Monad f => (forall x . m x -> f x) -> M m a -> f a
evalM _ (PureM a) = pure a
evalM f (PrimM p) = f p
evalM f (ApM g h) = evalM f g <*> evalM f h
evalM f (BindM m k) = evalM f m >>=  evalM f . k