{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE RankNTypes                 #-}

-- | The following program:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Control.Applicative
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = textUI "Example program" logic
-- >   where
-- >     logic = combine <$> checkBox   "a"
-- >                     <*> spinButton "b" 1
-- >                     <*> spinButton "c" 0.1
-- >                     <*> entry      "d"
-- > 
-- >     combine a b c d = display (a, b + c, d)
--
-- ... creates a user interface that looks like this:
--
-- <<http://i.imgur.com/xPifEtA.png User interface on startup>>
--
-- Every time you update a control on the left panel, the right panel updates
-- in response:
--
-- <<http://i.imgur.com/TTxgSwN.png User interface after user input>>
--
-- Once @ghc-8.0@ is out then you can simplify the above program even further
-- using the `ApplicativeDo` extension:
--
-- > {-# LANGUAGE ApplicativeDo     #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = textUI "Example program" (do
-- >     a <- checkBox   "a"
-- >     b <- spinButton "b" 1
-- >     c <- spinButton "c" 0.1
-- >     d <- entry      "d"
-- >     return (display (a, b + c, d)) )
--
-- This library also supports graphical output, like in the following program:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Backend.Cairo (Cairo)
-- > import Diagrams.Prelude
-- > import Typed.Spreadsheet
-- > 
-- > data AColor = Red | Orange | Yellow | Green | Blue | Purple
-- >     deriving (Enum, Bounded, Show)
-- > 
-- > toColor :: AColor -> Colour Double
-- > toColor Red    = red
-- > toColor Orange = orange
-- > toColor Yellow = yellow
-- > toColor Green  = green
-- > toColor Blue   = blue
-- > toColor Purple = purple
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Example program" logic
-- >   where
-- >     logic = combine <$> radioButton       "Color"    Red [Orange .. Purple]
-- >                     <*> spinButtonAt 100  "Radius"       1
-- >                     <*> spinButton        "X Coordinate" 1
-- >                     <*> spinButton        "Y Coordinate" 1
-- > 
-- >     combine :: AColor -> Double -> Double -> Double -> Diagram Cairo
-- >     combine color r x y =
-- >         circle r # fc (toColor color) # translate (r2 (x, y))
--
-- This produces a canvas that colors, resizes, and moves a circle in response
-- to user input:
--
-- <<http://i.imgur.com/ddYoG46.png Graphical user interface>>
--
-- The general workflow for this library is:
--
-- * You build primitive `Updatable` values using `checkBox`, `spinButton`,
--   `entry`, or `radioButton`, each of which corresponds to a control on the
--   left panel of the user interface
-- * You transform or combine `Updatable` values using `Functor` and
--   `Applicative` operations.  Composite values update whenever one of their
--   substituent values update
-- * You consume an @(`Updatable` `Text`)@ value using `textUI`, which displays
--   the continuously updating value in the right panel of the user interface
--
-- You can get started quickly by cloning and building this project:
--
-- > $ git clone https://github.com/Gabriel439/Haskell-Typed-Spreadsheet-Library.git
-- > $ stack build --install-ghc             # Builds the executable
-- > $ stack exec typed-spreadsheet-example  # Runs the executable
--
-- That project includes the code for the above example in @exec/Main.hs@.  Just
-- modify that file and rebuild to play with the example.
--
-- NOTE: You must compile your program with the @-threaded@ flag.  The example
-- project takes care of this.
--
-- See the \"Examples\" section at the bottom of this module for more examples.

module Typed.Spreadsheet (
    -- * Types
      Updatable
    , textUI
    , graphicalUI

    -- * Controls
    , checkBox
    , spinButton
    , entry
    , radioButton

    -- * Controls with Defaults
    , checkBoxAt
    , spinButtonAt
    , entryAt

    -- * Utilities
    , display

    -- * Examples
    -- $examples
    ) where

import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (STM)
import Control.Foldl (Fold(..))
import Control.Monad.IO.Class (liftIO)
import Data.Monoid
import Data.String (IsString(..))
import Data.Text (Text)
import Diagrams.Backend.Cairo (Cairo)
import Diagrams.Backend.Gtk (renderToGtk)
import Diagrams.Prelude (Diagram, r2, reflectY, translate, (#))
import Lens.Micro (_Left, _Right)
import Graphics.UI.Gtk (AttrOp((:=)))

import qualified Control.Concurrent.STM   as STM
import qualified Control.Concurrent.Async as Async
import qualified Control.Foldl            as Fold
import qualified Data.Text                as Text
import qualified Graphics.UI.Gtk          as Gtk

data Cell a = forall e . Cell (IO (STM e, Fold e a))

instance Functor Cell where
    fmap f (Cell m) = Cell (fmap (fmap (fmap f)) m)

instance Applicative Cell where
    pure a = Cell (pure (empty, pure a))

    Cell mF <*> Cell mX = Cell (liftA2 helper mF mX)
      where
        helper (inputF, foldF) (inputX, foldX) = (input, fold )
          where
            input = fmap Left inputF <|> fmap Right inputX

            fold = Fold.handles _Left foldF <*> Fold.handles _Right foldX

-- | An updatable input value
data Updatable a = Updatable (Control -> Cell a)

instance Functor Updatable where
    fmap f (Updatable m) = Updatable (fmap (fmap f) m)

instance Applicative Updatable where
    pure a = Updatable (pure (pure a))

    Updatable mf <*> Updatable mx = Updatable (liftA2 (<*>) mf mx)

instance Monoid a => Monoid (Updatable a) where
    mempty = pure mempty

    mappend = liftA2 mappend

instance IsString a => IsString (Updatable a) where
    fromString str = pure (fromString str)

instance Num a => Num (Updatable a) where
    fromInteger = pure . fromInteger

    negate = fmap negate
    abs    = fmap abs
    signum = fmap signum

    (+) = liftA2 (+)
    (*) = liftA2 (*)
    (-) = liftA2 (-)

instance Fractional a => Fractional (Updatable a) where
    fromRational = pure . fromRational

    recip = fmap recip

    (/) = liftA2 (/)

instance Floating a => Floating (Updatable a) where
    pi = pure pi

    exp   = fmap exp
    sqrt  = fmap sqrt
    log   = fmap log
    sin   = fmap sin
    tan   = fmap tan
    cos   = fmap cos
    asin  = fmap sin
    atan  = fmap atan
    acos  = fmap acos
    sinh  = fmap sinh
    tanh  = fmap tanh
    cosh  = fmap cosh
    asinh = fmap asinh
    atanh = fmap atanh
    acosh = fmap acosh

    (**)    = liftA2 (**)
    logBase = liftA2 logBase

-- | Use a `Control` to obtain updatable input `Updatable`s
data Control = Control
    { _checkBoxAt   :: Bool -> Text -> Cell Bool
    , _spinButtonAt :: Double -> Text -> Double -> Cell Double
    , _entryAt      :: Text -> Text -> Cell Text
    , _radioButton  :: forall a . Show a => Text -> a -> [a] -> Cell a
    }

-- | Build a `Text`-based user interface
textUI
    :: Text
    -- ^ Window title
    -> Updatable Text
    -- ^ Program logic
    -> IO ()
textUI = ui textSetup processTextEvent
  where
    textSetup :: Gtk.HBox -> IO Gtk.TextBuffer
    textSetup hBox = do
        textView   <- Gtk.textViewNew
        textBuffer <- Gtk.get textView Gtk.textViewBuffer
        Gtk.set textView
            [ Gtk.textViewEditable      := False
            , Gtk.textViewCursorVisible := False
            ]

        hAdjust <- Gtk.textViewGetHadjustment textView
        vAdjust <- Gtk.textViewGetVadjustment textView
        scrolledWindow <- Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust)
        Gtk.set scrolledWindow
            [ Gtk.containerChild           := textView
            , Gtk.scrolledWindowShadowType := Gtk.ShadowIn
            ]
        Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow 0
        return textBuffer

    processTextEvent :: Gtk.TextBuffer -> Text -> IO ()
    processTextEvent textBuffer txt =
        Gtk.set textBuffer [ Gtk.textBufferText := txt ]

-- | Build a `Diagram`-based user interface
graphicalUI
    :: Text
    -- ^ Window title
    -> Updatable (Diagram Cairo)
    -- ^ Program logic
    -> IO ()
graphicalUI = ui setupGraphical processGraphicalEvent
  where
    setupGraphical :: Gtk.HBox -> IO Gtk.DrawingArea
    setupGraphical hBox = do
        drawingArea <- Gtk.drawingAreaNew
        Gtk.boxPackStart hBox drawingArea Gtk.PackGrow 0
        return drawingArea

    processGraphicalEvent :: Gtk.DrawingArea -> Diagram Cairo -> IO ()
    processGraphicalEvent drawingArea diagram = do
        drawWindow <- Gtk.widgetGetDrawWindow drawingArea
        (w, h) <- Gtk.widgetGetSize drawingArea
        let w' = fromIntegral w / 2
        let h' = fromIntegral h / 2
        renderToGtk drawWindow (diagram # reflectY # translate (r2 (w', h')))

-- | Shared logic for `textUI` and `graphicalUI`
ui  :: (Gtk.HBox -> IO a)
    -> (a -> b -> IO ())
    -> Text
    -> Updatable b
    -> IO ()
ui setup process title (Updatable k) = do
    _ <- Gtk.initGUI

    window <- Gtk.windowNew
    Gtk.set window
        [ Gtk.containerBorderWidth := 5
        ]

    vBox <- Gtk.vBoxNew False 5

    hBox <- Gtk.hBoxNew False 5
    Gtk.boxPackStart hBox vBox Gtk.PackNatural 0
    a    <- setup hBox

    Gtk.set window
        [ Gtk.windowTitle         := title
        , Gtk.containerChild      := hBox
        , Gtk.windowDefaultWidth  := 600
        , Gtk.windowDefaultHeight := 400
        ]

    let __spinButtonAt :: Double -> Text -> Double -> Cell Double
        __spinButtonAt s0 label stepX = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            let minX = fromIntegral (minBound :: Int)
            let maxX = fromIntegral (maxBound :: Int)
            spinButton_ <- Gtk.spinButtonNewWithRange minX maxX stepX
            Gtk.set spinButton_
                [ Gtk.spinButtonValue    := s0
                ]
            _  <- Gtk.onValueSpinned spinButton_ (do
                n <- Gtk.get spinButton_ Gtk.spinButtonValue
                STM.atomically (STM.putTMVar tmvar n) )

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := spinButton_
                , Gtk.frameLabel     := label
                ]

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Fold.lastDef s0) )

    let __checkBoxAt :: Bool -> Text -> Cell Bool
        __checkBoxAt s0 label = Cell (do
            checkButton <- Gtk.checkButtonNewWithLabel label

            Gtk.set checkButton [ Gtk.toggleButtonActive := s0 ]
            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on checkButton Gtk.toggled (do
                pressed <- Gtk.get checkButton Gtk.toggleButtonActive
                STM.atomically (STM.putTMVar tmvar pressed) )

            Gtk.boxPackStart vBox checkButton Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Fold.lastDef s0) )

    let __entryAt :: Text -> Text -> Cell Text
        __entryAt s0 label = Cell (do
            entry_ <- Gtk.entryNew

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := entry_
                , Gtk.frameLabel     := label
                ]
            Gtk.set entry_ [ Gtk.entryText := s0 ]

            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on entry_ Gtk.editableChanged (do
                txt <- Gtk.get entry_ Gtk.entryText
                STM.atomically (STM.putTMVar tmvar txt) )

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Fold.lastDef s0) )

    let __radioButton :: Show a => Text -> a -> [a] -> Cell a
        __radioButton label x xs = Cell (do
            tmvar <- STM.newEmptyTMVarIO

            vBoxRadio <- Gtk.vBoxNew False 5

            let makeButton f a = do
                    button <- f (show a)
                    Gtk.boxPackStart vBoxRadio button Gtk.PackNatural 0
                    _ <- Gtk.on button Gtk.toggled (do
                        active <- Gtk.get button Gtk.toggleButtonActive
                        if active
                            then STM.atomically (STM.putTMVar tmvar a)
                            else return () )
                    return button

            button <- makeButton Gtk.radioButtonNewWithLabel x
            mapM_ (makeButton (Gtk.radioButtonNewWithLabelFromWidget button)) xs

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := vBoxRadio
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Fold.lastDef x) )

    let control = Control
            { _checkBoxAt   = __checkBoxAt
            , _spinButtonAt = __spinButtonAt
            , _entryAt      = __entryAt
            , _radioButton  = __radioButton
            }

    doneTMVar <- STM.newEmptyTMVarIO

    let run (Cell m) = do
            (stm, Fold step begin done) <- Gtk.postGUISync m
            -- I don't know why this delay is necessary for diagrams output
            threadDelay 200000
            let loop x = do
                    let b = done x
                    Gtk.postGUISync (process a b)
                    let doneTransaction = do
                            STM.takeTMVar doneTMVar
                            return Nothing
                    me <- STM.atomically (doneTransaction <|> fmap pure stm)
                    case me of
                        Nothing -> return ()
                        Just e  -> loop (step x e)
            loop begin

    _ <- Gtk.on window Gtk.deleteEvent (liftIO (do
        STM.atomically (STM.putTMVar doneTMVar ())
        Gtk.mainQuit
        return False ))
    Gtk.widgetShowAll window
    Async.withAsync (run (k control)) (\a -> do
        Gtk.mainGUI
        Async.wait a )

-- | A check box that returns `True` if selected and `False` if unselected
checkBox
    :: Text
    -- ^ Label
    -> Updatable Bool
checkBox = checkBoxAt False

-- | A `Double` spin button
spinButton
    :: Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
spinButton = spinButtonAt 0

-- | A `Text` entry
entry
    :: Text
    -- ^ Label
    -> Updatable Text
entry = entryAt Text.empty

-- | A control that selects from one or more mutually exclusive choices
radioButton
    :: Show a
    => Text
    -- ^ Label
    -> a
    -- ^ 1st choice (Default selection)
    -> [a]
    -- ^ Remaining choices
    -> Updatable a
radioButton label a0 as =
    Updatable (\control -> _radioButton control label a0 as)

-- | Same as `checkBox` except that you can specify the initial state
checkBoxAt
    :: Bool
    -- ^ Initial state 
    -> Text
    -- ^ Label
    -> Updatable Bool
checkBoxAt s0 label =
    Updatable (\control -> _checkBoxAt control s0 label)

-- | Same as `spinButton` except that you can specify the initial state
spinButtonAt
    :: Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
spinButtonAt s0 label x =
    Updatable (\control -> _spinButtonAt control s0 label x)

-- | Same as `entry` except that you can specify the initial state
entryAt
    :: Text
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Updatable Text
entryAt s0 label = Updatable (\control -> _entryAt control s0 label)

-- | Convert a `Show`able value to `Text`
display :: Show a => a -> Text
display = Text.pack . show

-- $examples
--
-- Mortgage calculator:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Control.Applicative
-- > import Data.Monoid
-- > import Data.Text (Text)
-- > import Typed.Spreadsheet
-- > 
-- > payment :: Double -> Double -> Double -> Text
-- > payment mortgageAmount numberOfYears yearlyInterestRate
-- >     =  "Monthly payment: $"
-- >     <> display (mortgageAmount * (i * (1 + i) ^ n) / ((1 + i) ^ n - 1))
-- >   where
-- >     n = truncate (numberOfYears * 12)
-- >     i = yearlyInterestRate / 12 / 100
-- > 
-- > logic :: Updatable Text
-- > logic = payment <$> spinButton "Mortgage Amount"          1000
-- >                 <*> spinButton "Number of years"             1
-- >                 <*> spinButton "Yearly interest rate (%)"    0.01
-- > 
-- > main :: IO ()
-- > main = textUI "Mortgage payment" logic
--
-- Example input and output:
--
-- <<http://i.imgur.com/nvRZ9HC.png Mortgage calculator program>>
--
-- Mad libs:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Data.Monoid
-- > import Typed.Spreadsheet
-- > 
-- > noun = entry "Noun"
-- > 
-- > verb = entry "Verb"
-- > 
-- > adjective = entry "Adjective"
-- > 
-- > example =
-- >     "I want to " <> verb <> " every " <> noun <> " because they are so " <> adjective
-- > 
-- > main :: IO ()
-- > main = textUI "Mad libs" example
--
-- The above program works because the `Updatable` type implements `IsString`
-- and `Monoid`, so no `Applicative` operations are necessary
--
-- Example input and output:
--
-- <<http://i.imgur.com/k22An4Y.png Mad libs program>>
--
-- Sinusoid plot:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Backend.Cairo (Cairo)
-- > import Diagrams.Prelude
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Example program" logic
-- >   where
-- >     logic = combine <$> spinButtonAt 50  "Amplitude (Pixels)"   0.1
-- >                     <*> spinButtonAt 0.1 "Frequency (Pixels⁻¹)" 0.001
-- >                     <*> spinButtonAt 90  "Phase (Degrees)"      1
-- > 
-- >     combine :: Double -> Double -> Double -> Diagram Cairo
-- >     combine amplitude frequency phase = strokeP (fromVertices points) <> axes
-- >       where
-- >         axes = arrowBetween (p2 (0, 0)) (p2 ( 100,    0))
-- >             <> arrowBetween (p2 (0, 0)) (p2 (-100,    0))
-- >             <> arrowBetween (p2 (0, 0)) (p2 (   0,  100))
-- >             <> arrowBetween (p2 (0, 0)) (p2 (   0, -100))
-- > 
-- >         f x = amplitude * cos (frequency * x + phase * pi / 180)
-- > 
-- >         points = map (\x -> p2 (x, f x)) [-100, -99 .. 100]
--
-- Example input and output:
--
-- <<http://i.imgur.com/ueF0w7U.png Sinusoid plot>>
--
-- Factor diagram:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Backend.Cairo (Cairo)
-- > import Diagrams.Prelude
-- > import Diagrams.TwoD.Factorization (factorDiagram')
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Factor diagram" logic
-- >   where
-- >     logic = combine <$> spinButtonAt 3 "Factor #1" 1
-- >                     <*> spinButtonAt 3 "Factor #2" 1
-- >                     <*> spinButtonAt 3 "Factor #3" 1
-- > 
-- >     combine :: Double -> Double -> Double -> Diagram Cairo
-- >     combine x y z =
-- >         factorDiagram' [truncate x, truncate y, truncate z] # scale 10
--
-- Example input and output:
--
-- <<http://i.imgur.com/eMvMtKk.png Factor diagram>>