{-|
Module      : WebFudgets
Description : Fudgets for Web Programming
Maintainer  : Thomas Hallgren

Web Fudgets is a prototype library for writing web application in a
functional style in Haskell.

Web Fudgets is based on <http://www.altocumulus.org/Fudgets Fudgets>
(a Graphical User Interface Libary for Haskell developed in the early 1990s)
but has a completely separate implementation
on top of <http://haste-lang.org/ Haste>.
-}
{-# LANGUAGE StandaloneDeriving #-}
module WebFudgets(-- * The Fudget type
                  F,
                  -- ** Running a fudget
                  runF,
                  -- * User interface elements
                  buttonF,ButtonClick(..),buttonGroupF,
                  toggleButtonF,checkboxF,selectF,
                  stringDisplayF,showF,
                  readShowF,numberF,stringF,passwordF,canvasF,
                  imgF,imgF',
                  -- * Static content
                  textF,htmlF,ahrefF,
                  -- * Layout
                  h1F,h2F,h3F,pF,tableF,divF,boxF,ulF,liF,preF,
                  withF,
                  -- * Fudget combinators
                  -- | <<P/fudget_plumbing2.jpg>>

                  -- ** Parallel composition
                  (>+<),(>+),(+<),listF,
                  -- ** Serial composition
                  (=<=),(=>=),
                  -- ** Loops
                  loopLeftF,loopThroughRightF,
                  -- * Adding application specific functionality
                  -- ** Stateless
                  mapF,filterF,mapMaybeF,concatMapF,
                  -- ** Stateful
                  stateF,
                  -- ** Stream processors
                  idF,putF,nullF,concatF,
                  -- * Timing
                  timerF,Tick(..),
                  -- * Haste extras
                  addStyleLink,documentHead,devicePixelRatio,
                  -- ** Re-exported from Haste
                  URL,Attribute,(=:),attr,style,prop,AttrValue,
                  MouseEvent(..),MouseData(..),MouseButton(..),Interval(..)
                  ) where

import Haste
import Haste.DOM
import Haste.Events
import Haste.Concurrent
import Haste.Graphics.Canvas
import Haste.Foreign(constant)
import Haste.Prim(toJSStr)
import Data.List(findIndex)
import Control.Monad(when,zipWithM)

-- | The type of an event handler
type H a = a -> CIO ()

-- | @F hi ho@ is the type of a fudget that
-- consumes an high-level input stream of values of type @hi@ and
-- produces an high-level output stream of values of type @ho@.
-- It can also generate a number of user interface elements,
-- and can read input from and send output to those user interface elements.
-- <<P/the_fudget2.jpg>>
newtype F hi ho = F (H ho->CIO (H hi,[Elem]))

-- | 'runF' is typically used only once in the @main@ function of a program.
-- It runs the fudget and adds any user interface elements it generates
-- to the 'documentBody' of the web page.
runF (F fud) = concurrent $
               do (_,es) <- fud ignore
                  viewport <- newElem "meta" `with`
                               [attr "name" =: "viewport",
                                attr "content" =: "width = device-width"]
                  appendChild documentHead viewport
                --setStyle documentBody "background" "#eee"
                  liftIO $ mapM_ (appendChild documentBody) es

instance Monoid (F hi ho) where
  mempty = nullF
  mappend (F f1) (F f2) = F $ \ oh -> do (_,es1) <- f1 oh
                                         (_,es2) <- f2 oh
                                         return (ignore,es1++es2)

instance Functor (F hi) where
  fmap f (F fud) = F $ \ oh -> fud (oh . f)


absF f = F $ \ oh -> return (f oh,[])

-- | @putF x fud@ outputs @x@, then behaves like fud
putF x (F fud) = F $ \ oh -> do oh x; fud oh

nullF = absF (const ignore)
-- ^ Ignores all input. Doesn't produce any output.

idF   = absF id
-- ^ @mapF id@, propagates all input directly to the output

mapF f = absF (. f)
-- ^ Like 'map' for lists. @mapF f@ outputs @f x@ for every @x@ in the input stream

mapMaybeF f = absF (\oh->maybe (return ()) oh . f)
-- ^ Like 'mapMaybe' for lists. A combination of 'mapF' and 'filterF'.

filterF p = mapMaybeF (\x->if p x then Just x else Nothing)
-- ^ Like 'filter' for lists. Propagates values from the input stream to
-- the output stream if they pass a test.

stateF f init = F $ \ oh -> do state <- newMVar init
                               let ih i = do old <- takeMVar state
                                             let (new,out) = f old i
                                             putMVar state new
                                             oh out
                               return (ih,[])
-- ^ @stateF@ is used to maintain an internal state.
-- Given a state transition function @f@ and an initial state @s@,
-- @stateF f s@ responds to input by applying @f@ to it to update the
-- internal state and generate an output.

-- | Like 'concat' for lists, flattens a stream of lists.
concatF :: F [i] i 
concatF = absF mapM_

-- | Like 'concatMap' for lists. A combination of 'concatF' and 'mapF'.
concatMapF :: (i->[o]) -> F i o
concatMapF f = absF (\oh -> mapM_ oh  . f)

infixr 3 =<=,=>=

-- | Right-to-left serial composition. The output stream of the right fudget
-- is connected to the input stream of the left fudget. This was
-- originally called '>==<' in Fudgets.
F f1 =<= F f2 = F $ \ oh -> do (ih1,es1) <- f1 oh
                               (ih2,es2) <- f2 ih1
                               return (ih2,es1++es2)

-- | Left-to-right serial composition. The output stream of the left fudget
-- is connected to the input stream of the right fudget. (This was not
-- included in the original implementation of Fudgets. Using both '=>='
-- and '=<=' in the same expression might lead to confusion...)
F f1 =>= F f2 = F $ \ oh -> do (ih2,es2) <- f2 oh
                               (ih1,es1) <- f1 ih2
                               return (ih1,es1++es2)

infixl 5 >+<,+<,>+
-- | Tagged parallel composition. Messages to/from the left fudget are
-- tagged 'Left'. Messages to/from the right fudget are tagged 'Right'.
F f1 >+< F f2 = F $ \ oh -> do  (ih1,es1) <- f1 (oh . Left)
                                (ih2,es2) <- f2 (oh . Right)
                                return (either ih1 ih2,es1++es2)

-- | Parallel composition where only the right fudget is connected.
-- The left fudget is typically static content.
F f1 +< F f2 = F $ \ oh -> do  (ih1,es1) <- f1 ignore
                               (ih2,es2) <- f2 oh
                               return (ih2,es1++es2)

-- | Parallel composition where only the left fudget is connected.
-- The right fudget is typically static content.
F f1 >+ F f2 = F $ \ oh -> do  (ih1,es1) <- f1 oh
                               (ih2,es2) <- f2 ignore
                               return (ih1,es1++es2)


-- | Tagged parallel composition of a list of fudgets
listF tfs = F $ \ oh ->
            do (ihs,ess) <- unzip <$> sequence [f (oh . (,) t) | (t,F f)<-tfs]
               let tihs = zip (map fst tfs) ihs
                   ih (t,i) = maybe (return ()) ($ i) (lookup t tihs)
               return (ih,concat ess)

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

-- | Creates a feedback loop. @loopLeftF fud@ behaves as follows:
-- output from @fud@ tagged @Left@ will be sent back to
-- the input of @fud@. Output from @fud@ tagged @Right@ will be sent to the
-- output of @loopLeftF fud@. Input to @loopLeftF fud@ will be tagged
-- @Right@ and delivered to @fud@.
loopLeftF (F fud) =
  F $ \ oh -> do loop <- newEmptyMVar
                 (ih,es) <- fud (either (forkIO . putMVar loop . Left) oh)
                 forkIO $ let feed = do ih =<< takeMVar loop
                                        feed
                          in feed
                 return (putMVar loop . Right,es)

-- | @loopThroughRightF master slave@ is similar to loopLeftF master, but
-- the loop goes through the @slave@ fudget. (A better name might be
-- @encapsulateF@ since all communication with the @slave@ has to go via
-- the @master@, so the @slave@ is encapsulated in this sense.)
loopThroughRightF lfud rfud = loopCompThroughRightF (lfud>+<rfud)


loopCompThroughRightF :: (F (Either (Either a b) c) (Either (Either c d) a)) -> F b d
loopCompThroughRightF w =
    let post (Left (Left x)) = Left (Right x)
        post (Left (Right x)) = Right x
        post (Right x) = Left (Left (Left x))
        pre (Left x) = x
        pre (Right x) = Left (Right x)
    in  loopLeftF (prepostMapHigh pre post w)

prepostMapHigh pre post fud = post <$> fud =<= mapF pre

--------------------------------------------------------------------------------
divF = wrapF "div"
-- ^ A div element @\<div>...\</div>@
pF = wrapF "p"
-- ^ Paragraph @\<p>...\</p>@
h1F = wrapF "h1"
-- ^ Level 1 header @\<h1>...\</h1>@
h2F = wrapF "h2"
-- ^ Level 2 header @\<h2>...\</h2>@
h3F = wrapF "h3"
-- ^ Level 3 header @\<h3>...\</h3>@

ulF = wrapF "ul"
-- ^ Unordered list @\<ul>...\</ul>@

liF = wrapF "li"
-- ^ List item @\<li>...\</li>@

-- | A div element with a black border and some padding
boxF = wrapF' "div" [style "border" =: "1px solid black",
                     style "padding" =: "1ex",
                     style "margin" =: "1ex"]

preF = wrapF "pre"
-- ^ A pre element @\<pre>...\</pre>@

wrapF = layoutF . wrap

wrapF' tagname as = layoutF (wrap' tagname as)

layoutF layout = modifyF (fmap (:[]) . layout)

modifyF modify (F fud) = F $ \ oh ->
                         do (ih,es) <- fud oh
                            es' <- modify es
                            return (ih,es')

-- | Apply attributes to the elements generated by a fudget
withF fud as = modifyF (\es->mapM_ (`set` as) es>>return es) fud

-- | A table with @n@ columns
tableF = layoutF . tableL

tableL n es = do tds <- mapM (wrap1 "td") es
                 rows <- mapM (wrap "tr") (chop n tds)
                 wrap "table" rows

-- | Plain text
textF = staticF . newTextElem

-- | Text with HTML markup
htmlF s = staticF (newElem "span" `with` [prop "innerHTML"=:(s::String)])

staticF haste = F $ const ((,) ignore . (:[]) <$> haste)

-- | A hyperlink @\<a href="url">...\</a>@
ahrefF :: URL -> F i o -> F i o
ahrefF url = layoutF (wrap' "a" [attr "href" =: url])

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

-- | An image, @\<img src="/url/" alt="">@
-- You can change the image dynamically by sending in the URL of another
-- image.
imgF :: URL -> F URL o
imgF = imgF' [attr "alt" =: ""]

-- | An image with extra attributes, @\<img src="/url/" ...>@.
-- You can change the image dynamically by sending in the URL of another
-- image.
imgF' :: [Attribute] -> URL -> F URL o
imgF' as url = F $ \ oh ->
               do el <- newElem "img" `with` (attr "src" =: url:as)
                  let ih url = setAttr el "src" url
                  return (ih,[el])

-- | 'stringDisplayF' combined with 'show'
showF :: Show i => F i o
showF = nullF =<= stringF `withF` as =<= mapF show
  where
    as = [attr "readonly" =: "readonly"]

-- | An output-only element displaying text, @\<span>...\</span>@
stringDisplayF =
    F $ \ oh ->
    do el <- newElem "span"
       let ih s = do clearChildren el
                     appendChild el =<< newTextElem s
       return (ih,[el])

-- | 'stringF' combined with 'show' and 'read'
readShowF :: (Show a,Read a) => F a a
readShowF = mapMaybeF readM =<= stringF =<= mapF show

-- | 'readShowF' restricted to numbers, @\<input type="number">@
numberF :: (Show a,Read a,Num a) => F a a
numberF =  mapMaybeF readM =<= inputF "number" =<= mapF show

-- | A string input/output field, @\<input type="text">@
stringF = inputF "text"

-- | A string input/output field that shows @****@ instead of the actual
-- input, @\<input type="password">@
passwordF = inputF "password"

inputF ty = inputF'  [prop "type"=:ty]

inputF' ps =
  F $ \ oh ->
  do inp <- newElem "input" `with` ps
     onEvent inp Change $ \_ -> do oh =<< getProp inp "value"
     let ih s = do old <- getProp inp "value"
                   when (s/=old) $ do setProp inp "value" s
                                      oh s
     return (ih,[inp])


data ButtonClick = BtnClick deriving (Eq,Show,Read)

-- | Creates a button, like @\<input type="button" value="/label/">@.
-- It outputs 'BtnClick' when pressed. ('BtnClick' received on the input
-- is propagated directly to the output, allowing button clicks to
-- be simulated programmatically.)
buttonF lbl =
  F $ \ oh ->
  do btn <- newElem "input" `with` [prop "type"=:"button"]
     setProp btn "value" lbl
     onEvent btn Click $ \_ -> oh BtnClick
     return (oh,[btn])

-- | Creates a button with another fudget inside (which
-- should be something simple, e.g. an 'imgF' or a 'stringDisplayF'...),
-- @\<button>...\<\/button>@.
buttonGroupF (F fud) =
  F $ \ oh ->
  do (ih,els) <- fud (oh . Right)
     btn <- wrap "button" els
     onEvent btn Click $ \_ -> oh (Left BtnClick)
     return (either (oh . Left) ih,[btn])
  
-- | A 'checkboxF' with a label
toggleButtonF lbl = wrapF "label" (checkboxF >+ textF lbl)

-- | A checkbox, @\<input type=checkbox>@.
-- (Slightly buggy at the moment: sending in 'False' does
-- not unckeck the checkbox.)
checkboxF =
  F $ \ oh ->
  do inp <- newElem "input" `with` [attr "type" =: "checkbox"]
     let checked = (=="true") <$> getProp inp "checked"
     onEvent inp Change $ \_ -> do oh =<< checked
     let ih b = do {-old <- checked
                 when (b/=old) $-} do writeLog =<< getProp inp "checked"
                                      writeLog ("checked "++show b)
                                      setProp inp "checked"
                                        (if b then "true" else "false")
                                      oh b
     return (ih,[inp])

-- | A menu of options, @\<select>\<option>...\<\/option>...\<\/select>@
selectF :: Eq alt => [(alt,String)] -> alt -> F alt alt
selectF alts start_alt =
    F $ \ oh -> 
    do el <- wrap "select" =<< zipWithM option [0..] alts
       let change = setProp el "value" .show
           ih alt = maybeM (\ix->do change ix;oh alt) (alt_ix alt)
       ih start_alt
       onEvent el Change $ \_ -> do Just ix <- getValue el
                                    oh (vs!!ix)
       return (ih,[el])
  where
    vs = map fst alts
    start_ix =  alt_ix start_alt
    alt_ix alt = findIndex (==alt) vs

    option n (_,lbl) =
      (wrap1 "option" =<< newTextElem lbl) `with` [attr "value"=:show n]
    
-- | Creates a canvas of given width and height. Use the 'Picture' type
-- from "Haste.Graphics.Canvas" to draw things. The canvas outputs
-- 'MouseUp' events (becase 'MouseUp' seems to work for both the left and
-- the right mouse button, while 'Click' only works for the left mouse
-- button).
canvasF :: (Int,Int) -> F (Picture ()) (MouseEvent,MouseData)
canvasF (width,height) =
  F $ \ oh ->
  do el <- newElem "canvas" `with` ([style "width" =: (show width++"px"),
                                    style "height" =: (show height++"px"),
                                    prop "width" =: show (k*width),
                                    prop "height" =: show (k*height)])
    --http://stackoverflow.com/questions/10864249/disabling-right-click-context-menu-on-a-html-canvas
     setAttr el "oncontextmenu" "return false"
     Just canvas <- getCanvas el
     onEvent el MouseUp $ \ed -> oh (MouseUp,ed)
     return (render canvas . scale (k,k),[el])
  where
    k :: Num a => a
    k = fromIntegral devicePixelRatio

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

data Tick = Tick deriving (Eq,Show)

-- | 'timerF' outputs 'Tick' after a specified delay or at regular intervals.
-- The timer starts when it receives 'Just' /interval/ on its input.
-- The timer stops when it receives 'Nothing' in its input.
timerF = F $ \ oh ->
         do tvar <- newMVar Nothing
            let stop = do t <- takeMVar tvar
                          maybe (return ()) stopTimer t
                          putMVar tvar Nothing
                start d = do takeMVar tvar
                             putMVar tvar . Just =<< setTimer d (oh Tick)
                ih Nothing = stop
                ih (Just d) = do stop; start d
            return (ih,[])

deriving instance Show Interval

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


ignore _ = return ()

chop n [] = []
chop n xs = xs1:chop n xs2
     where (xs1,xs2) = splitAt n xs

maybeM m = maybe (return ()) m

readM x = case reads x of
            [(x,s)] | lex s == [("","")] -> Just x
            _ -> Nothing

wrap1 tagname = wrap tagname . (:[])

wrap tagname = wrap' tagname []

wrap' tagname as es = do e <- newElem tagname `with` as
                         mapM_ (appendChild e) es
                         return e


devicePixelRatio = constant (toJSStr "window.devicePixelRatio") :: Int

documentHead = constant (toJSStr "document.head") :: Elem

-- | Add a link to a style sheet to the document head,
-- @\<link rel="stylesheet" type="text\/css" href="/url/">@
addStyleLink url =
  do link <- newElem "link" `with` [attr "rel" =: "stylesheet",
                                    attr "type" =: "text/css",
                                    attr "href" =: (url::URL)]
     appendChild documentHead link