{-# LANGUAGE  DeriveDataTypeable #-}
module Main where
import Haste
import Haste.Foreign
import Haste.Graphics.Canvas
import Haste.HPlay.View
import Haste.HPlay.Cell as Cell
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Monoid
import Data.Typeable
import Prelude hiding (div,all,id,print,getChar, putStr, putStrLn,getLine)
import qualified Data.Map as V
import Data.Maybe
import Data.List(isInfixOf)


main= runBody $ do  -- PerchM monad
      h1 ! style "text-align:center" $ "hplayground examples"
      h3 $ center $ do
         a ! href "https://github.com/agocorona/hplayground" $ "Git repository"
         toElem "   "
         a ! href "https://github.com/agocorona/hplayground/blob/master/src/Main.hs" $ "Examples code"
         toElem "   "
         a ! href "haskell-web.blogspot.com.es/2014/07/hplayground-translate-your-console.html" $ "Article"
    ++> do   -- Widget monad
        (table ! style "border-collapse:collapse"
                <<<(tr ! style "vertical-align:top"
                     <<< ( tds <<< sumTwo
                     <|>   tds <<< sumfold 3
                     <|>   tds <<< sumRecursive)
                <|> tr ! style "vertical-align:top"
                     <<<  (tds <<< (counter 3 <|> buttons <|> linksample)
                     <|>   tds <<< sumCell
                     <|>   tds <<< showpascal 4)
                <|> tr ! style "vertical-align:top"
                     <<<  (tds <<< formWidget
                     <|>   tds <<< palindrome
                     <|>   tds <<< naiveTodo)
                <|> tr ! style "vertical-align:top"
                     <<<  (tds <<< drawcanvas
                     <|>   tds <<< gallery
                     <|>   tds <<< mouse )

                   ))

        <++  b << "bottom of the page"
   where
   tds= td ! style "padding:15px;border-style:dotted"

-- Don't be scared by the operators:
-- <|> is the Alternantive combinator, to combine Widget() entries
-- and the <<< combinator simply encloses a widget within a HTML tag.
-- ++> prepend HTML to a widget
-- <++ postpend it



sumTwo :: Widget ()
sumTwo = p  "This widget sum two numbers and append the result. Using applicative and monadic expressions" ++>
  (p <<< do
     r <- (+) <$> fromStr "first number"  ++> br
                   ++> inputInt Nothing `fire` OnKeyUp  <++ br
              <*> fromStr "second number " ++> br
                   ++> inputInt Nothing `fire` OnKeyUp  <++ br
     p <<< fromStr "result: " ++>  b (show r) ++> return())

  where
  less3 x= if x < 3 then return Nothing else  return . Just $ b " no more than 2 please"

sumRecursive :: Widget ()
sumRecursive = p  "This widget sum recursively n numbers. When enters 0, present the result" ++> sumr 0
  where
  sumr r=do
    r' <- inputInt Nothing `fire` OnKeyUp
    if r'== 0
      then  br ++> fromStr "result: " ++>  b (show r) ++> noWidget
      else do
        b (show $ r+r') ++> br ++> return ()
        sumr (r+r')

sumfold :: Int -> Widget ()
sumfold n =  p  ("This widget sum "++ show n ++" numbers and append the result using a fold") ++>
       (p <<< do
         r <- foldl (<>)  (return 0) . take n $ repeat $ inputInt Nothing `fire` OnKeyUp <++  br
         br ++> fromStr "result: " ++>  b (show r) ++> return ())

instance Monoid Int where
  mappend= (+)
  mempty= 0



newtype Counter= Counter Int deriving Typeable

counter n = p "Two counters. One is pure and recursive, the other is stateful"
            ++> br ++> (center <<< (counter1 n <|> counter2 n))

 where
    -- a "pure" counter
    counter1 :: Int -> Widget ()
    counter1 n= (b (show n) ++> onemore)  `wcallback` (const $ counter1 $ n +1)

    onemore=  submitButton "+" `fire` OnClick


    -- a stateful counter
    counter2 n = do
      onemore -- isEmpty (getSData :: Widget Counter ) <|> (onemore >> return True)
      Counter n <- getSData <|> return (Counter n)
      wraw $ b (show n)
      setSessionData . Counter $ n +1



sumCell :: Widget ()

sumCell = p  "This widget sum recursively n numbers, but remember the\
          \ previos entries when one entry is edited" ++> sumr 0 0

 where
 sumr i r=do
     r' <- cell i
     b (show $ r+r') ++> br ++> return ()
     sumr (i +1) (r+r')

 cell i=  do
     stored <- Just <$> getNumber i <|> return Nothing
     r' <- inputInt stored `fire` OnKeyUp <|> fromM stored
     addNumber i r'
     return r'
   where
   addNumber i x= do
        xs <- getSData <|> return  V.empty
        setSData $ V.insert i x xs

   getNumber :: Int -> Widget Int
   getNumber i= do
        xs <- getSData
        case  V.lookup i xs of
          Nothing -> empty
          Just x  -> return x

   fromM Nothing = empty
   fromM (Just x) = return x



-- pascal triangle http://www.haskell.org/haskellwiki/Blow_your_mind

pascal = iterate (\row -> zipWith (+) ([0] ++ row) (row ++ [0])) [1] :: [[Int]]

showpascal n= p << ("Show " ++ show n ++ " rows of the Pascal triangle ")
   ++> mconcat[p ! style "text-align:center" $ row | row <- take n pascal]
   ++> empty   -- the applicative empty === noWidget




drawcanvas :: Widget ()
drawcanvas=
 p << "This example draw a function of x between 10 and -10. You can define the function\
      \ using javascript expressions"  ++>

 (center <<< do
      let initial= "x*x+x+10;"
          sanitize str= if isInfixOf "alert" str then initial else str
      expr <- inputString (Just initial) `fire` OnKeyUp <++ br <|> return initial
      wraw $ canvas ! id "canvas"  $ noHtml
      wraw $ draw $sanitize expr)


  where

  evalFormula :: String  -> IO Double
  evalFormula= ffi $ toJSString "(function(exp){ return eval(exp);})"

  draw expr= liftIO $ do
    Just can <- getCanvasById "canvas"
    let range= [-10..10]
        exprs = Prelude.map (\v -> subst 'x' (show v) expr) range
    ps <- mapM evalFormula  exprs
    render can $ scale (3,1) $ translate (50,130) $ rotate pi $ stroke $do
        line (-10,0) (10,0)
        line (0,30) (0,-30)
        path $ zip range ps

  subst _ _ []= []
  subst c v (c':cs)
    | c==c' =  v++ subst c v cs
    | otherwise= c':subst c v cs



newtype GalleryIndex= G Int deriving Typeable

gallery :: Widget ()
gallery = p "this example show a image gallery. It advances each 20 seconds and by\
               \ pressing the button" ++>
 (wtimeout 20000 $ do
  G i <- getSData <|> return (G 0)
  let i' = if i == length gall-1  then 0 else  i+1
  setSData $ G i'
  wraw $ do
      img ! src (gall !! i) ! width "100%" ! height "100%"    -- raw Perch code
      br
  submitButton ">" `fire` OnClick
 `wcallback` \_ -> gallery)

  where
  gall=["http://almaer.com/blog/uploads/interview-haskell.png"
       ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQmmC4kV3NPFIpGL_x4H_iHG_p-c93DGjWfkxVtjxEFVng7A8o-nw"
       ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcQ_ywj-zxDq3h_B4l48XHsjTywrdbK5egxvhxkYJ1HOkDFXd_-H"
       ,"https://encrypted-tbn3.gstatic.com/images?q=tbn:ANd9GcS53axpzkDyzEUAdaIP3YsaHuR-_YqN9qFK3W4bp_D2OBZfW5BU_Q"
       ,"https://encrypted-tbn1.gstatic.com/images?q=tbn:ANd9GcSfP70npv4FOrkBjScP0tVu2t3veSNoFQ6MMxX6LDO8kldNeu-DxQ"
       ,"https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcRAgKkpDyzk8kdIqk5ECsZ14XgbpBzyWFvrCrHombkSBAUn6jFo"
       ]


mouse :: Widget ()
mouse= do
    wraw (div  ! style "height:100px;background-color:lightgreen;position:relative"
               $ h1 "Mouse events here")
                            `fire` OnMouseOut
                            `fire` OnMouseOver
                            `fire` OnMouseDown
                            `fire` OnMouseMove
                            `fire` OnMouseUp
                            `fire` OnClick
                            `fire` OnDblClick
                            `fire` OnKeyPress
                            `fire` OnKeyDown
                            `fire` OnKeyUp
    evdata  <- getEventData
    wraw $ p << ( (evName evdata) ++" "++ show (evData evdata))

linksample= br ++> wlink "Hi!" (toElem "This link say Hi!")`fire` OnClick >>= \r -> wraw( b (" returns "++ r))

buttons= p "Different input elements:" ++> checkButton
                                       **> br ++> br
                                       ++> radio
                                       **> br ++> br
                                       ++> select
                                       <++ br
    where
    checkButton=do
       rs <- getCheckBoxes(
                       ((setCheckBox False "Red"    <++ b "red")   `fire` OnClick)
                    <> ((setCheckBox False "Green"  <++ b "green") `fire` OnClick)
                    <> ((setCheckBox False "blue"   <++ b "blue")  `fire` OnClick))
       wraw $ fromStr " returns: " <> b (show rs)

    radio= do
       r <- getRadio [\n -> fromStr v ++> setRadioActive v n | v <- ["red","green","blue"]]

       wraw $ fromStr " returns: " <> b ( show r )

    select= do
       r <- getSelect (   setOption "red"   (fromStr "red")  
                      <|> setOption "green" (fromStr "green")
                      <|> setOption "blue"  (fromStr "blue"))
              `fire` OnClick

       wraw $ fromStr " returns: " <> b ( show r )

formWidget=  center <<< do -- PerchM monad
      p "Fields of a form appear in sequence. \
        \Some of the fields trigger events instantly. Some others use a button to trigger them. \
        \It also contains option buttons, radio buttons etc"
      p $ do
        toElem "This formulary is the same than the one "
        a ! href "http://mflowdemo.herokuapp.com/noscript/monadicwidgets/combination"
          $ "run in the server by MFlow"
  ++>
   do
      (n,s) <- (,) <$> p << "Who are you? "
                   ++> getString Nothing <! hint "name"     <++ br
                   <*> getString Nothing <! hint "surname"  <++ br
                   <** submitButton "ok" `fire` OnClick <++ br

      flag <- b << "Do you " ++> getRadio[radiob "work?",radiob "study?"] <++ br

      r<- case flag of
         "work?" -> Left  <$> b << "do you enjoy your work? "
                              ++> getBool True "yes" "no"
                              <** submitButton "ok" `fire` OnClick <++ br

         "study?"-> Right <$> b << "do you study in "
                              ++> getRadio[radiob "University"
                                          ,radiob "High School"]

      p << ("You are "++n++" "++s)

        ++> case r of
             Left fl ->   p << ("You work and it is " ++ show fl ++ " that you enjoy your work")
                            ++> noWidget

             Right stu -> p << ("You study at the " ++ stu)
                            ++> noWidget

  where
  hint s= [("placeholder",s)]
  radiob s n=  wlabel  (fromStr s) $ setRadioActive s n


palindrome= p << "To search palindromes: one box present the other's reversed. It is also\
                 \ an example of cell usage" ++> do
 let entry= boxCell "entry" :: Cell String
     revEntry= boxCell "revEntry"

 r <- center <<< ((mk entry    Nothing `fire` OnKeyUp >>= return . Left) <++ br <|>
                  (mk revEntry Nothing `fire` OnKeyUp >>= return . Right))

 case r of
  Left s  -> do
   r  <- Cell.get entry >>= return . reverse
   revEntry .= r
  Right s -> do
   r' <- Cell.get revEntry >>= return . reverse
   entry .= r'


newtype Tasks = Tasks [String] deriving Typeable

data TaskAction =  Done | Destroy

naiveTodo= do
 p $ do   -- PerchM monad
     toElem "Work in progress for a todo application to be added to "
     a ! href "http://todomvc.com" $ "todomvc.com"
 ++> todos

 where

 todos= center <<< h1 "todos" ++>
     do
      let entry = boxCell "todo"
      task <- mk entry Nothing `fire` OnKeyUp
      EventData _ (Key k) <- getEventData
      when( k == 13)  $ do
         entry .= ""
         Tasks tasks <- getSData <|> return (Tasks [])
         setSData . Tasks $ task:tasks

         at "list" Insert $ foldl (<|>) mempty [ display t | t <- (task:tasks)]
         return ()
     <|>
      wraw (div ! id "list" $ noHtml)



 display task=  li <<< (do
  ch <- getCheckBoxes $ setCheckBox False "check" `fire` OnClick
  case ch of
        ["check"] -> wraw  $ b ! style "text-decoration:line-through;" $ task
        _         -> wraw  $ b task

                                  )