add grouping

add grouping

module FrontEnd where

import Prelude

import CSS as CSS
import ChocoPie (runChocoPie)
import Data.Array as Array
import Data.Either (Either(..), hush)
import Data.Foldable (maximumBy)
import Data.Function (on)
import Data.Int as Int
import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
import Data.Newtype (class Newtype, un)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import FRP.Event (Event)
import FRP.Event as Event
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON as JSON
import Text.Parsing.StringParser (runParser)
import Type.Prelude (class IsSymbol, SProxy(..), reflectSymbol)
import Types (Path(..))
import Web.Event.Event as E
import Web.UIEvent.MouseEvent (MouseEvent)
import Web.UIEvent.MouseEvent as ME

newtype DateString = DateString String
derive instance newtypeDateString :: Newtype DateString _

type File =
  { name :: Path
  , watched :: Maybe DateString
  , series :: Maybe String
  , episode :: Maybe Int
  , latest :: Maybe Int
  }

type State =
  -- files
  { files :: Array File
  , filesLoading :: Boolean
  , iconsLoading :: Boolean
  , grouped :: Boolean
  -- counted by positions from the top
  , cursor :: Maybe Int
  }

data Query a
  = FetchData a
  | OpenFile a
  | MarkFile a
  | ToggleWatched Path a
  | SetCursor Int a
  | LinkClick Int MouseEvent a
  | WatchedClick Int MouseEvent a
  | EEQuery ExternalEvent a

initialState :: State
initialState =
  { files: []
  , filesLoading: false
  , iconsLoading: false
  , grouped: false
  , cursor: Nothing
  }

render :: State -> H.ComponentHTML Query
render state =
  HH.div []
    [ HH.h1_ [HH.text "vidtracker"]
    , header
    , HH.div_ $ Array.mapWithIndex mkFile files
    ]
  where
    files = if state.grouped
      then Array.sortBy
        (\x y -> compare x.series y.series <> compare x.episode y.episode)
        state.files
      else state.files

    header = HH.div
      [ HP.class_ $ HH.ClassName "header" ]
      [ HH.div [ HP.class_ $ HH.ClassName "info" ] $
          [ HH.h3_ [ HH.text "Info:" ] ] <> infoLines
      , HH.div [ HP.class_ $ HH.ClassName "recents" ] $
          [ HH.h3_ [ HH.text "Recently watched:" ] ] <> recents
      ]

    infoLines = HH.span_ <<< pure <<< HH.text <$>
      [ "o: open current file"
      , "k: move cursor up"
      , "j: move cursor down"
      , "W/M: mark as watched"
      , "r: refresh"
      , "I: fetch icons and reload page"
      , "files loading: " <> if state.filesLoading then "true" else "false"
      , "icons loading: " <> if state.iconsLoading then "true" else "false"
      , "grouped by series: " <> if state.grouped then "true" else "false"
      ]

    recents = mkRecent <$> Array.take (Array.length infoLines) state.files

    mkRecent file = mkDiv "recent" $ HH.text $ un Path file.name

    mkFile :: Int -> File -> _
    mkFile idx file = HH.div
      [ HP.classes
          [ HH.ClassName "file"
          , HH.ClassName case state.cursor of
              Just pos | pos == idx -> "cursor"
              _ -> ""
          , HH.ClassName case file.watched of
              Just _ -> "done"
              Nothing -> ""
          ]
      , HP.title $ "latest watched: " <> fromMaybe "unknown" (show <$> file.latest)
      , HE.onClick $ HE.input_ $ SetCursor idx
      ]
      [ HH.div
          [ HP.class_ $ HH.ClassName "icon"
          , HCSS.style do
              case file.series of
                Just series ->
                  CSS.backgroundImage (CSS.url $ un M.URL $ prefixUrl $ "/icons/" <> unsafeEncodeURIComponent series)
                Nothing ->
                  pure mempty
          ] []
      , HH.div
          [ HP.class_ $ HH.ClassName "name"
          , HE.onClick $ HE.input $ LinkClick idx
          ]
          [ HH.text $ un Path file.name ]
      , HH.div
          [ HP.classes $ HH.ClassName <$>
            [ "watched"
            , maybe "" (const "has-date") file.watched
            ]
          , HE.onClick $ HE.input $ WatchedClick idx
          ]
          [ HH.text $ case file.watched of
              Just (DateString date) -> "watched " <> date
              Nothing -> maybe "" (\x -> " last: " <> show x) file.latest
          ]
      ]

    mkDiv className e = HH.div
      [HP.class_ $ HH.ClassName className]
      [e]

eval :: Query ~> H.ComponentDSL State Query Void Aff

eval (LinkClick idx e next) = do
  H.liftEffect $ E.preventDefault $ ME.toEvent e
  _ <- eval (SetCursor idx next)
  eval (OpenFile next)

eval (WatchedClick idx e next) = do
  H.liftEffect $ E.preventDefault $ ME.toEvent e
  _ <- eval (SetCursor idx next)
  eval (MarkFile next)

eval (FetchData next) = do
  H.modify_ _ { filesLoading = true }
  attempt <- H.liftAff $ getFiles
  case attempt of
    Right files -> H.modify_ _ { files = annotateLatest files, filesLoading = false }
    Left e -> Console.error $ "Failed to fetch data: " <> show e
  pure next
  where
    getFiles = ado
      files <- get apiRoutes.files
      watched <- get apiRoutes.watched
      in (\fs w -> mkFile w <$> fs) <$> files <*> watched

    mkFile watched file@(Path name) =
      { name: Path name
      , watched: DateString <<< _.created <$> Array.find (\x -> x.path == file) watched
      , series: _.name <$> parsed
      , episode: Int.fromString <<< _.episode =<< parsed
      , latest: Nothing
      } :: File
      where
        parsed = hush $ runParser nameParser name

    annotateLatest :: Array File -> Array File
    annotateLatest xs = updateLatest <$> xs
      where
        watchedFiles :: Array File
        watchedFiles = Array.filter (\x -> isJust x.watched) xs

        grouped :: Array (Maybe File)
        grouped
            = maximumBy (compare `on` _.series)
          <$> Array.groupBy (eq `on` _.series) watchedFiles
        updateLatest x
          | match' <- \z -> z.series == x.series
          , match <- \y -> maybe false match' y
          , Just (Just y) <- Array.find match grouped
            = x { latest = y.episode }
          | otherwise = x

eval (ToggleWatched name next) = do
  Console.log $ "Updating " <> un Path name
  s <- H.get
  case Array.find (\x -> x.name == name) s.files of
    Just file -> do
      _ <- H.liftAff $ post apiRoutes.update
        { path: file.name
        , watched: maybe true (const false) file.watched
        }
      pure unit
    Nothing -> Console.error $ "Could not find file named " <> un Path name
  eval (FetchData next)

eval (SetCursor idx next) = do
  H.modify_ _ { cursor = Just idx }
  pure next

eval (EEQuery (DirectionEvent dir) next) = do
  case dir of
    Down -> H.modify_ \s -> do
      let cursor = min (Array.length s.files) (maybe 0 (_ + 1) s.cursor)
      s { cursor = Just cursor }
    Up -> H.modify_ \s -> do
      let cursor = max 0 (maybe 0 (_ - 1) s.cursor)
      s { cursor = Just cursor }
  pure next

eval (OpenFile next) = do
  s <- H.get
  case s.cursor of
    Just pos
      | Just file <- Array.index s.files pos
      -> do
      Console.log $ "Opening file: " <> un Path file.name
      _ <- H.liftAff $ post apiRoutes.open { path: file.name }
      pure next
    _ -> pure next

eval (EEQuery OpenEvent next) = eval (OpenFile next)

eval (MarkFile next) = do
  s <- H.get
  case s.cursor of
    Just pos
      | Just file <- Array.index s.files pos
      -> eval (ToggleWatched file.name next)
    _ -> pure next

eval (EEQuery MarkEvent next) = eval (MarkFile next)

eval (EEQuery RefreshEvent next) = do
  Console.log "RefreshEvent"
  eval (FetchData next)

eval (EEQuery FetchIconsEvent next) = do
  Console.log "FetchIconsEvent"
  H.modify_ _ { iconsLoading = true }
  result <- H.liftAff $ post apiRoutes.getIcons {}
  H.modify_ _ { iconsLoading = false }
  H.liftEffect $ refreshPage
  pure next

eval (EEQuery ToggleGroupedEvent next) = do
  H.modify_ \s -> s { grouped = not s.grouped }
  pure next

myButton :: H.Component HH.HTML Query Unit Void Aff
myButton =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , initializer: Just (H.action FetchData)
    , finalizer: Nothing
    , receiver: const Nothing
    }
data ExternalEvent
  -- move cursor on j/k
  = DirectionEvent Direction
  -- open file on o
  | OpenEvent
  -- mark file watched on m
  | MarkEvent
  -- call refresh files on r
  | RefreshEvent
  -- call fetch icons on I (shift + i)
  | FetchIconsEvent
  -- toggle grouping by show name
  | ToggleGroupedEvent

data Direction = Up | Down

keyboard :: Event Unit -> Effect (Event ExternalEvent)
keyboard _ = do
  {event, push} <- Event.create
  addWindowKeyListener \key ->
    case key of
      "o" -> push OpenEvent
      "k" -> push $ DirectionEvent Up
      "j" -> push $ DirectionEvent Down
      "W" -> push MarkEvent
      "M" -> push MarkEvent
      "r" -> push RefreshEvent
      "I" -> push FetchIconsEvent
      "g" -> push ToggleGroupedEvent
      _ -> pure unit
  pure event

halogen :: Event ExternalEvent -> Effect (Event Unit)
halogen externalEvents = do
  HA.runHalogenAff do
    body <- HA.awaitBody
    io <- runUI myButton unit body
    _ <- liftEffect $ Event.subscribe externalEvents \ee -> do
      launchAff_ $ io.query $ H.action $ EEQuery ee
      pure $ mempty :: Event Unit
    pure unit
  mempty

main :: Effect Unit
main = do
  liftEffect $ runChocoPie mkSink drivers
  Console.log "Started application"
  where
    mkSink sources =
      { keyboard: mempty :: Event Unit
      , halogen: sources.keyboard
      }
    drivers = {keyboard, halogen}

foreign import refreshPage :: Effect Unit

foreign import addWindowKeyListener :: (String -> Effect Unit) -> Effect Unit

prefixUrl :: String -> M.URL
prefixUrl url = M.URL $ "http://localhost:3000" <> url

get :: forall res url. JSON.ReadForeign res => IsSymbol url => GetRoute res url -> Aff (JSON.E res)
get _ = JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (prefixUrl url) M.defaultFetchOptions

post :: forall req res url. JSON.WriteForeign req => JSON.ReadForeign res => IsSymbol url =>
  PostRoute req res url -> req -> Aff (JSON.E res)
post _ body = JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: JSON.writeJSON body
      }
    action = M.json =<< fetch (prefixUrl url) options

module FrontEnd where

import Prelude

import CSS as CSS
import ChocoPie (runChocoPie)
import Data.Array as Array
import Data.Either (Either(..), hush)
import Data.Foldable (maximumBy)
import Data.Function (on)
import Data.Int as Int
import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
import Data.Newtype (class Newtype, un)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import FRP.Event (Event)
import FRP.Event as Event
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON as JSON
import Text.Parsing.StringParser (runParser)
import Type.Prelude (class IsSymbol, SProxy(..), reflectSymbol)
import Types (Path(..))
import Web.Event.Event as E
import Web.UIEvent.MouseEvent (MouseEvent)
import Web.UIEvent.MouseEvent as ME

newtype DateString = DateString String
derive instance newtypeDateString :: Newtype DateString _

type File =
  { name :: Path
  , watched :: Maybe DateString
  , series :: Maybe String
  , episode :: Maybe Int
  , latest :: Maybe Int
  }

type State =
  -- files
  { files :: Array File
  , filesLoading :: Boolean
  , iconsLoading :: Boolean
  -- counted by positions from the top
  , cursor :: Maybe Int
  }

data Query a
  = FetchData a
  | OpenFile a
  | MarkFile a
  | ToggleWatched Path a
  | SetCursor Int a
  | LinkClick Int MouseEvent a
  | WatchedClick Int MouseEvent a
  | EEQuery ExternalEvent a

initialState :: State
initialState =
  { files: []
  , filesLoading: false
  , iconsLoading: false
  , cursor: Nothing
  }

render :: State -> H.ComponentHTML Query
render state =
  HH.div []
    [ HH.h1_ [HH.text "vidtracker"]
    , header
    , HH.div_ $ Array.mapWithIndex mkFile state.files
    ]
  where
    header = HH.div
      [ HP.class_ $ HH.ClassName "header" ]
      [ HH.div [ HP.class_ $ HH.ClassName "info" ] $
          [ HH.h3_ [ HH.text "Info:" ] ] <> infoLines
      , HH.div [ HP.class_ $ HH.ClassName "recents" ] $
          [ HH.h3_ [ HH.text "Recently watched:" ] ] <> recents
      ]

    infoLines = HH.span_ <<< pure <<< HH.text <$>
      [ "o: open current file"
      , "k: move cursor up"
      , "j: move cursor down"
      , "W/M: mark as watched"
      , "r: refresh"
      , "I: fetch icons and reload page"
      , "files loading: " <> if state.filesLoading then "true" else "false"
      , "icons loading: " <> if state.iconsLoading then "true" else "false"
      ]

    recents = mkRecent <$> Array.take (Array.length infoLines) state.files

    mkRecent file = mkDiv "recent" $ HH.text $ un Path file.name

    mkFile :: Int -> File -> _
    mkFile idx file = HH.div
      [ HP.classes
          [ HH.ClassName "file"
          , HH.ClassName case state.cursor of
              Just pos | pos == idx -> "cursor"
              _ -> ""
          , HH.ClassName case file.watched of
              Just _ -> "done"
              Nothing -> ""
          ]
      , HP.title $ "latest watched: " <> fromMaybe "unknown" (show <$> file.latest)
      , HE.onClick $ HE.input_ $ SetCursor idx
      ]
      [ HH.div
          [ HP.class_ $ HH.ClassName "icon"
          , HCSS.style do
              case file.series of
                Just series ->
                  CSS.backgroundImage (CSS.url $ un M.URL $ prefixUrl $ "/icons/" <> unsafeEncodeURIComponent series)
                Nothing ->
                  pure mempty
          ] []
      , HH.div
          [ HP.class_ $ HH.ClassName "name"
          , HE.onClick $ HE.input $ LinkClick idx
          ]
          [ HH.text $ un Path file.name ]
      , HH.div
          [ HP.classes $ HH.ClassName <$>
            [ "watched"
            , maybe "" (const "has-date") file.watched
            ]
          , HE.onClick $ HE.input $ WatchedClick idx
          ]
          [ HH.text $ case file.watched of
              Just (DateString date) -> "watched " <> date
              Nothing -> maybe "" (\x -> " last: " <> show x) file.latest
          ]
      ]

    mkDiv className e = HH.div
      [HP.class_ $ HH.ClassName className]
      [e]

eval :: Query ~> H.ComponentDSL State Query Void Aff

eval (LinkClick idx e next) = do
  H.liftEffect $ E.preventDefault $ ME.toEvent e
  _ <- eval (SetCursor idx next)
  eval (OpenFile next)

eval (WatchedClick idx e next) = do
  H.liftEffect $ E.preventDefault $ ME.toEvent e
  _ <- eval (SetCursor idx next)
  eval (MarkFile next)

eval (FetchData next) = do
  H.modify_ _ { filesLoading = true }
  attempt <- H.liftAff $ getFiles
  case attempt of
    Right files -> H.modify_ _ { files = annotateLatest files, filesLoading = false }
    Left e -> Console.error $ "Failed to fetch data: " <> show e
  pure next
  where
    getFiles = ado
      files <- get apiRoutes.files
      watched <- get apiRoutes.watched
      in (\fs w -> mkFile w <$> fs) <$> files <*> watched

    mkFile watched file@(Path name) =
      { name: Path name
      , watched: DateString <<< _.created <$> Array.find (\x -> x.path == file) watched
      , series: _.name <$> parsed
      , episode: Int.fromString <<< _.episode =<< parsed
      , latest: Nothing
      } :: File
      where
        parsed = hush $ runParser nameParser name

    annotateLatest :: Array File -> Array File
    annotateLatest xs = updateLatest <$> xs
      where
        watchedFiles :: Array File
        watchedFiles = Array.filter (\x -> isJust x.watched) xs

        grouped :: Array (Maybe File)
        grouped
            = maximumBy (compare `on` _.series)
          <$> Array.groupBy (eq `on` _.series) watchedFiles
        updateLatest x
          | match' <- \z -> z.series == x.series
          , match <- \y -> maybe false match' y
          , Just (Just y) <- Array.find match grouped
            = x { latest = y.episode }
          | otherwise = x

eval (ToggleWatched name next) = do
  Console.log $ "Updating " <> un Path name
  s <- H.get
  case Array.find (\x -> x.name == name) s.files of
    Just file -> do
      _ <- H.liftAff $ post apiRoutes.update
        { path: file.name
        , watched: maybe true (const false) file.watched
        }
      pure unit
    Nothing -> Console.error $ "Could not find file named " <> un Path name
  eval (FetchData next)

eval (SetCursor idx next) = do
  H.modify_ _ { cursor = Just idx }
  pure next

eval (EEQuery (DirectionEvent dir) next) = do
  case dir of
    Down -> H.modify_ \s -> do
      let cursor = min (Array.length s.files) (maybe 0 (_ + 1) s.cursor)
      s { cursor = Just cursor }
    Up -> H.modify_ \s -> do
      let cursor = max 0 (maybe 0 (_ - 1) s.cursor)
      s { cursor = Just cursor }
  pure next

eval (OpenFile next) = do
  s <- H.get
  case s.cursor of
    Just pos
      | Just file <- Array.index s.files pos
      -> do
      Console.log $ "Opening file: " <> un Path file.name
      _ <- H.liftAff $ post apiRoutes.open { path: file.name }
      pure next
    _ -> pure next

eval (EEQuery OpenEvent next) = eval (OpenFile next)

eval (MarkFile next) = do
  s <- H.get
  case s.cursor of
    Just pos
      | Just file <- Array.index s.files pos
      -> eval (ToggleWatched file.name next)
    _ -> pure next

eval (EEQuery MarkEvent next) = eval (MarkFile next)

eval (EEQuery RefreshEvent next) = do
  Console.log "RefreshEvent"
  eval (FetchData next)

eval (EEQuery FetchIconsEvent next) = do
  Console.log "FetchIconsEvent"
  H.modify_ _ { iconsLoading = true }
  result <- H.liftAff $ post apiRoutes.getIcons {}
  H.modify_ _ { iconsLoading = false }
  H.liftEffect $ refreshPage
  pure next

myButton :: H.Component HH.HTML Query Unit Void Aff
myButton =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , initializer: Just (H.action FetchData)
    , finalizer: Nothing
    , receiver: const Nothing
    }
data ExternalEvent
  -- move cursor on j/k
  = DirectionEvent Direction
  -- open file on o
  | OpenEvent
  -- mark file watched on m
  | MarkEvent
  -- call refresh files on r
  | RefreshEvent
  -- call fetch icons on I (shift + i)
  | FetchIconsEvent

data Direction = Up | Down

keyboard :: Event Unit -> Effect (Event ExternalEvent)
keyboard _ = do
  {event, push} <- Event.create
  addWindowKeyListener \key ->
    case key of
      "o" -> push OpenEvent
      "k" -> push $ DirectionEvent Up
      "j" -> push $ DirectionEvent Down
      "W" -> push MarkEvent
      "M" -> push MarkEvent
      "r" -> push RefreshEvent
      "I" -> push FetchIconsEvent
      _ -> pure unit
  pure event

halogen :: Event ExternalEvent -> Effect (Event Unit)
halogen externalEvents = do
  HA.runHalogenAff do
    body <- HA.awaitBody
    io <- runUI myButton unit body
    _ <- liftEffect $ Event.subscribe externalEvents \ee -> do
      launchAff_ $ io.query $ H.action $ EEQuery ee
      pure $ mempty :: Event Unit
    pure unit
  mempty

main :: Effect Unit
main = do
  liftEffect $ runChocoPie mkSink drivers
  Console.log "Started application"
  where
    mkSink sources =
      { keyboard: mempty :: Event Unit
      , halogen: sources.keyboard
      }
    drivers = {keyboard, halogen}

foreign import refreshPage :: Effect Unit

foreign import addWindowKeyListener :: (String -> Effect Unit) -> Effect Unit

prefixUrl :: String -> M.URL
prefixUrl url = M.URL $ "http://localhost:3000" <> url

get :: forall res url. JSON.ReadForeign res => IsSymbol url => GetRoute res url -> Aff (JSON.E res)
get _ = JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (prefixUrl url) M.defaultFetchOptions

post :: forall req res url. JSON.WriteForeign req => JSON.ReadForeign res => IsSymbol url =>
  PostRoute req res url -> req -> Aff (JSON.E res)
post _ body = JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: JSON.writeJSON body
      }
    action = M.json =<< fetch (prefixUrl url) options


forgot about sort requirement for groupby

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Either (Either(..), either, hush)
import Data.JSDate as JSDate
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, isJust, isNothing, maybe)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect)
import Effect.Class.Console (error, errorShow, log)
import Effect.Unsafe (unsafePerformEffect)
import FrontEnd.Chart as Chart
import FrontEnd.Style (classNames)
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON as JSON
import Text.Parsing.StringParser (runParser)
import Types (Path(..), WatchedData)

get
  :: forall res url m
   . MonadAff m
  => JSON.ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (JSON.E res)
get _ =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (M.URL url) M.defaultFetchOptions

post
  :: forall req res url m
   . MonadAff m
  => JSON.WriteForeign req
  => JSON.ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (JSON.E res)
post _ body =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: JSON.writeJSON body
      }
    action = M.json =<< fetch (M.URL url) options

unE :: forall a m. MonadEffect m => (a -> m Unit) -> JSON.E a -> m Unit
unE = either errorShow

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = TitleEpisode | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

data RemoteTaskState
  = Standby
  | Working
  | Success
  | Failure

type State =
  { fileData :: Array FileData
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  , getIcons :: RemoteTaskState
  }

type FileData =
  { path :: Path
  , name :: Maybe String
  , episode :: Maybe String
  , created :: Maybe String
  }

prepareFilesData :: Array Path -> Array WatchedData -> Array FileData
prepareFilesData paths watchedData =
  go <$> paths
  where
    go path@(Path pathString) = do
      let parsed = hush $ runParser nameParser pathString
      { path
      , created: _.created <$> Array.find (\x -> x.path == path) watchedData
      , name: _.name <$> parsed
      , episode: _.episode <$> parsed
      }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter (Maybe String) a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type ChildSlots =
  ( chart :: Chart.Slot Unit
  )

ui :: H.Component HH.HTML Query Unit Void Aff
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { fileData: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      , getIcons: Standby
      }

    render :: State -> H.ComponentHTML Query ChildSlots Aff
    render state =
      HH.div
        [ HP.class_ $ classNames.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot (SProxy :: SProxy "chart") unit Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ classNames.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ classNames.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text
               $ "Run Get Icons"
              <> case state.getIcons of
                   Standby -> ": Standby"
                   Working -> ": Working..."
                   Success -> ": Success"
                   Failure -> ": Failed"
            ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ classNames.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ classNames.file]
            [ HH.h3
              [ HP.class_ $ classNames.dot
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] [ HH.text $ "Title" <> displayTicker TitleEpisode ]
            , HH.h3
              [ HP.class_ $ classNames.fileEpisode
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ classNames.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ classNames.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ classNames.deleteLink
              ] [ HH.text "" ]
            ]
        files = file <$> applyTransforms state.fileData

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms
            = applySorting
          <<< applySearchFiltering
          <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then Array.filter $ isNothing <<< _.created
          else identity
        applySearchFiltering = case state.search of
            "" -> identity
            x -> Array.filter $ \{ path: Path path } -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then identity
            else Array.reverse
          , sort' <- case col of
            TitleEpisode -> \xs -> do
              let
                preGroup = Array.sortWith _.name xs
                grouped = Array.groupBy (\{name: nameA} {name: nameB} -> nameA == nameB) preGroup
                sorted = Array.sortWith _.episode <<< Array.fromFoldable <$> grouped
              join sorted
            Status -> Array.sortWith _.created
            _ -> identity
          = rev <<< sort'
          | otherwise = identity
        parseEpisodeNumber { path: Path path } = case runParser nameParser path of
          Right {episode} -> episode
          Left _ -> "999"
        file { path, created, name, episode } =
          HH.div
            [ HP.class_ $ classNames.file ]
            [ HH.span
              [ HP.class_ $ classNames.dot
              , style do
                case name of
                  Just s ->
                    backgroundImage (url $ "icons/" <> unsafeEncodeURIComponent s)
                  Nothing -> pure mempty
              ] []
            , HH.a
              [ HP.class_ classNames.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.span
                [ HP.class_ $ classNames.fileEpisode ]
                [ HH.text $ fromMaybe "" episode ]
            , HH.button
              [ HP.classes $
                [ classNames.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watchedDate
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watchedDate))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watchedDate ]
            , HH.span
              [ HP.class_ $ classNames.fileNote ]
              [ HH.text $ maybe "" identity watchedDate ]
            , HH.button
              [ HP.classes $
                [ classNames.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter name)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ classNames.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then classNames.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watchedDate = getDate <$> created
            deleteConfirmation = member path state.deleteConfirmations
            getDate dateString =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEffect <<< JSDate.parse $ dateString

    eval :: Query ~> H.HalogenM State Query ChildSlots Void Aff
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unE
        \{filesData: fd, watched: w} -> do
          H.modify_ _ {fileData = fd, watched = w}
      pure next
      where
        getResult = do
          files <- get apiRoutes.files
          watched <- get apiRoutes.watched
          let filesData = prepareFilesData <$> files <*> watched
          pure $ { filesData: _, watched: _ } <$> filesData <*> watched

    eval (GetIcons next) = do
      H.modify_ _ {getIcons = Working}
      result <- post apiRoutes.getIcons {}
      case result of
        Right {success} | success -> H.modify_ _ {getIcons = Success}
        _ -> H.modify_ _ {getIcons = Failure}
      pure next

    eval (OpenFile path next) = do
      _ <- post apiRoutes.open {path}
      pure next

    eval (SetWatched path flag next) = do
      _ <- post apiRoutes.update {path, watched: flag}
      eval (FetchData next)

    eval (Filter name next) = do
      case name of
        Nothing -> error "Can't filter by unknown name" *> pure next
        Just s -> eval $ Search s next

    eval (Search str next) = do
      H.modify_ _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify_ _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify_ $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify_ _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify_ \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post apiRoutes.remove {path}
      eval (FetchData next)

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log $ "Running"

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Either (Either(..), either, hush)
import Data.JSDate as JSDate
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, isJust, isNothing, maybe)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect)
import Effect.Class.Console (error, errorShow, log)
import Effect.Unsafe (unsafePerformEffect)
import FrontEnd.Chart as Chart
import FrontEnd.Style (classNames)
import Global.Unsafe (unsafeEncodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Milkis as M
import Milkis.Impl.Window (windowFetch)
import NameParser (nameParser)
import Routes (GetRoute, PostRoute, apiRoutes)
import Simple.JSON as JSON
import Text.Parsing.StringParser (runParser)
import Types (Path(..), WatchedData)

get
  :: forall res url m
   . MonadAff m
  => JSON.ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (JSON.E res)
get _ =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    action = M.json =<< fetch (M.URL url) M.defaultFetchOptions

post
  :: forall req res url m
   . MonadAff m
  => JSON.WriteForeign req
  => JSON.ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (JSON.E res)
post _ body =
  H.liftAff $ JSON.read <$> action
  where
    url = reflectSymbol (SProxy :: SProxy url)
    fetch = M.fetch windowFetch
    options =
      { method: M.postMethod
      , headers: M.makeHeaders { "Content-Type": "application/json" }
      , body: JSON.writeJSON body
      }
    action = M.json =<< fetch (M.URL url) options

unE :: forall a m. MonadEffect m => (a -> m Unit) -> JSON.E a -> m Unit
unE = either errorShow

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = TitleEpisode | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

data RemoteTaskState
  = Standby
  | Working
  | Success
  | Failure

type State =
  { fileData :: Array FileData
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  , getIcons :: RemoteTaskState
  }

type FileData =
  { path :: Path
  , name :: Maybe String
  , episode :: Maybe String
  , created :: Maybe String
  }

prepareFilesData :: Array Path -> Array WatchedData -> Array FileData
prepareFilesData paths watchedData =
  go <$> paths
  where
    go path@(Path pathString) = do
      let parsed = hush $ runParser nameParser pathString
      { path
      , created: _.created <$> Array.find (\x -> x.path == path) watchedData
      , name: _.name <$> parsed
      , episode: _.episode <$> parsed
      }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter (Maybe String) a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type ChildSlots =
  ( chart :: Chart.Slot Unit
  )

ui :: H.Component HH.HTML Query Unit Void Aff
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { fileData: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      , getIcons: Standby
      }

    render :: State -> H.ComponentHTML Query ChildSlots Aff
    render state =
      HH.div
        [ HP.class_ $ classNames.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot (SProxy :: SProxy "chart") unit Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ classNames.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ classNames.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text
               $ "Run Get Icons"
              <> case state.getIcons of
                   Standby -> ": Standby"
                   Working -> ": Working..."
                   Success -> ": Success"
                   Failure -> ": Failed"
            ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ classNames.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ classNames.file]
            [ HH.h3
              [ HP.class_ $ classNames.dot
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] [ HH.text $ "Title" <> displayTicker TitleEpisode ]
            , HH.h3
              [ HP.class_ $ classNames.fileEpisode
              , HE.onClick $ HE.input_ (ChangeSorting TitleEpisode)
              ] []
            , HH.h3
              [ HP.class_ $ classNames.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ classNames.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ classNames.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ classNames.deleteLink
              ] [ HH.text "" ]
            ]
        files = file <$> applyTransforms state.fileData

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms
            = applySorting
          <<< applySearchFiltering
          <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then Array.filter $ isNothing <<< _.created
          else identity
        applySearchFiltering = case state.search of
            "" -> identity
            x -> Array.filter $ \{ path: Path path } -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then identity
            else Array.reverse
          , sort' <- case col of
            TitleEpisode -> \xs -> do
              let
                grouped = Array.groupBy (\{name: nameA} {name: nameB} -> nameA == nameB) xs
                sorted = Array.sortWith _.episode <<< Array.fromFoldable <$> grouped
              join sorted
            Status -> Array.sortWith _.created
            _ -> identity
          = rev <<< sort'
          | otherwise = identity
        parseEpisodeNumber { path: Path path } = case runParser nameParser path of
          Right {episode} -> episode
          Left _ -> "999"
        file { path, created, name, episode } =
          HH.div
            [ HP.class_ $ classNames.file ]
            [ HH.span
              [ HP.class_ $ classNames.dot
              , style do
                case name of
                  Just s ->
                    backgroundImage (url $ "icons/" <> unsafeEncodeURIComponent s)
                  Nothing -> pure mempty
              ] []
            , HH.a
              [ HP.class_ classNames.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.span
                [ HP.class_ $ classNames.fileEpisode ]
                [ HH.text $ fromMaybe "" episode ]
            , HH.button
              [ HP.classes $
                [ classNames.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watchedDate
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watchedDate))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watchedDate ]
            , HH.span
              [ HP.class_ $ classNames.fileNote ]
              [ HH.text $ maybe "" identity watchedDate ]
            , HH.button
              [ HP.classes $
                [ classNames.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter name)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ classNames.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then classNames.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watchedDate = getDate <$> created
            deleteConfirmation = member path state.deleteConfirmations
            getDate dateString =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEffect <<< JSDate.parse $ dateString

    eval :: Query ~> H.HalogenM State Query ChildSlots Void Aff
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unE
        \{filesData: fd, watched: w} -> do
          H.modify_ _ {fileData = fd, watched = w}
      pure next
      where
        getResult = do
          files <- get apiRoutes.files
          watched <- get apiRoutes.watched
          let filesData = prepareFilesData <$> files <*> watched
          pure $ { filesData: _, watched: _ } <$> filesData <*> watched

    eval (GetIcons next) = do
      H.modify_ _ {getIcons = Working}
      result <- post apiRoutes.getIcons {}
      case result of
        Right {success} | success -> H.modify_ _ {getIcons = Success}
        _ -> H.modify_ _ {getIcons = Failure}
      pure next

    eval (OpenFile path next) = do
      _ <- post apiRoutes.open {path}
      pure next

    eval (SetWatched path flag next) = do
      _ <- post apiRoutes.update {path, watched: flag}
      eval (FetchData next)

    eval (Filter name next) = do
      case name of
        Nothing -> error "Can't filter by unknown name" *> pure next
        Just s -> eval $ Search s next

    eval (Search str next) = do
      H.modify_ _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify_ _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify_ $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify_ _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify_ \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post apiRoutes.remove {path}
      eval (FetchData next)

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log $ "Running"


legacy wip

legacy wip

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Model
  ( Model
  , AnyCardModel(..)
  , encode
  , decode
  , modelToEval
  , cardModelOfType
  , modelCardType
  ) where

import SlamData.Prelude

import Data.Argonaut ((:=), (~>), (.?))
import Data.Argonaut as J
import Data.Array as A
import Data.Lens (view)
import Data.Int as Int

import SlamData.FileSystem.Resource as R

import SlamData.Workspace.Card.Eval as Eval
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (ChartType(..), printChartType)
import SlamData.Workspace.Card.Ace.Model as Ace
import SlamData.Workspace.Card.Variables.Model as Variables
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Draftboard.Model as DB
import SlamData.Workspace.Card.DownloadOptions.Component.State as DLO
import SlamData.Workspace.Card.BuildChart.Metric.Model as BuildMetric
import SlamData.Workspace.Card.BuildChart.Sankey.Model as BuildSankey
import SlamData.Workspace.Card.BuildChart.Gauge.Model as BuildGauge
import SlamData.Workspace.Card.BuildChart.Graph.Model as BuildGraph
import SlamData.Workspace.Card.BuildChart.Pie.Model as BuildPie
import SlamData.Workspace.Card.BuildChart.Bar.Model as BuildBar
import SlamData.Workspace.Card.BuildChart.Line.Model as BuildLine
import SlamData.Workspace.Card.BuildChart.Area.Model as BuildArea
import SlamData.Workspace.Card.BuildChart.Scatter.Model as BuildScatter
import SlamData.Workspace.Card.BuildChart.Funnel.Model as BuildFunnel
import SlamData.Workspace.Card.BuildChart.Radar.Model as BuildRadar
import SlamData.Workspace.Card.BuildChart.Boxplot.Model as BuildBoxplot
import SlamData.Workspace.Card.BuildChart.Heatmap.Model as BuildHeatmap

import SlamData.Form.Select as S
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data AnyCardModel
  = Ace CT.AceMode Ace.Model
  | Search String
  | Chart
  | Markdown MD.Model
  | Table JT.Model
  | Download
  | Variables Variables.Model
  | Troubleshoot
  | Cache (Maybe String)
  | Open (Maybe R.Resource)
  | DownloadOptions DLO.State
  | Draftboard DB.Model
  | BuildMetric BuildMetric.Model
  | BuildSankey BuildSankey.Model
  | BuildGauge BuildGauge.Model
  | BuildGraph BuildGraph.Model
  | BuildPie BuildPie.Model
  | BuildBar BuildBar.Model
  | BuildLine BuildLine.Model
  | BuildArea BuildArea.Model
  | BuildScatter BuildScatter.Model
  | BuildFunnel BuildFunnel.Model
  | BuildRadar BuildRadar.Model
  | BuildBoxplot BuildBoxplot.Model
  | BuildHeatmap BuildHeatmap.Model
  | ErrorCard
  | NextAction
  | PendingCard

instance arbitraryAnyCardModel ∷ SC.Arbitrary AnyCardModel where
  arbitrary =
    Gen.oneOf (pure ErrorCard)
      [ Ace <$> SC.arbitrary <*> Ace.genModel
      , Search <$> SC.arbitrary
      , pure Chart
      , Markdown <$> MD.genModel
      , Table <$> JT.genModel
      , pure Download
      , Variables <$> Variables.genModel
      , pure Troubleshoot
      , Cache <$> SC.arbitrary
      , Open <$> SC.arbitrary
      , Draftboard <$> DB.genModel
      , BuildMetric <$> BuildMetric.genModel
      , BuildSankey <$> BuildSankey.genModel
      , BuildGauge <$> BuildGauge.genModel
      , BuildGraph <$> BuildGraph.genModel
      , BuildPie <$> BuildPie.genModel
      , BuildRadar <$> BuildRadar.genModel
      , BuildBar <$> BuildBar.genModel
      , BuildLine <$> BuildLine.genModel
      , BuildArea <$> BuildArea.genModel
      , BuildScatter <$> BuildScatter.genModel
      , BuildFunnel <$> BuildFunnel.genModel
      , BuildBoxplot <$> BuildBoxplot.genModel
      , BuildHeatmap <$> BuildHeatmap.genModel
      , pure ErrorCard
      , pure NextAction
      ]

instance eqAnyCardModel ∷ Eq AnyCardModel where
  eq =
    case _, _ of
      Ace x1 y1, Ace x2 y2 → x1 ≡ x2 && Ace.eqModel y1 y2
      Search s1, Search s2 → s1 ≡ s2
      Chart, Chart → true
      Markdown x, Markdown y → MD.eqModel x y
      Table x, Table y → JT.eqModel x y
      Download, Download → true
      Variables x, Variables y → Variables.eqModel x y
      Troubleshoot, Troubleshoot → true
      Cache x, Cache y → x ≡ y
      Open x, Open y → x ≡ y
      DownloadOptions x, DownloadOptions y → DLO.eqState x y
      Draftboard x, Draftboard y → DB.eqModel x y
      BuildMetric x, BuildMetric y → BuildMetric.eqModel x y
      BuildSankey x, BuildSankey y → BuildSankey.eqModel x y
      BuildGauge x, BuildGauge y → BuildGauge.eqModel x y
      BuildGraph x, BuildGraph y → BuildGraph.eqModel x y
      BuildPie x, BuildPie y → BuildPie.eqModel x y
      BuildRadar x, BuildRadar y → BuildRadar.eqModel x y
      BuildBar x, BuildBar y → BuildBar.eqModel x y
      BuildLine x, BuildLine y → BuildLine.eqModel x y
      BuildArea x, BuildArea y → BuildArea.eqModel x y
      BuildScatter x, BuildScatter y → BuildScatter.eqModel x y
      BuildFunnel x, BuildFunnel y → BuildFunnel.eqModel x y
      BuildBoxplot x, BuildBoxplot y → BuildBoxplot.eqModel x y
      BuildHeatmap x, BuildHeatmap y → BuildHeatmap.eqModel x y
      ErrorCard, ErrorCard → true
      NextAction, NextAction → true
      _,_ → false

instance encodeJsonCardModel ∷ J.EncodeJson AnyCardModel where
  encodeJson = encodeCardModel

modelCardType
  ∷ AnyCardModel
  → CT.CardType
modelCardType =
  case _ of
    Ace mode _ → CT.Ace mode
    Search _ → CT.Search
    BuildMetric _ → CT.ChartOptions Metric
    BuildSankey _ → CT.ChartOptions Sankey
    BuildGauge _ → CT.ChartOptions Gauge
    BuildGraph _ → CT.ChartOptions Graph
    BuildPie _ → CT.ChartOptions Pie
    BuildRadar _ → CT.ChartOptions Radar
    BuildBar _ → CT.ChartOptions Bar
    BuildLine _ → CT.ChartOptions Line
    BuildArea _ → CT.ChartOptions Area
    BuildScatter _ → CT.ChartOptions Scatter
    BuildFunnel _ → CT.ChartOptions Funnel
    BuildBoxplot _ → CT.ChartOptions Boxplot
    BuildHeatmap _ → CT.ChartOptions Heatmap
    Chart → CT.Chart
    Markdown _ → CT.Markdown
    Table _ → CT.Table
    Download → CT.Download
    Variables _ → CT.Variables
    Troubleshoot → CT.Troubleshoot
    Cache _ → CT.Cache
    Open _ → CT.Open
    DownloadOptions _ → CT.DownloadOptions
    Draftboard _ → CT.Draftboard
    ErrorCard → CT.ErrorCard
    NextAction → CT.NextAction
    PendingCard → CT.PendingCard

type Model =
  { cardId ∷ CID.CardId
  , model ∷ AnyCardModel
  }

encode
  ∷ Model
  → J.Json
encode card =
  "cardId" := card.cardId
    ~> "cardType" := modelCardType card.model
    ~> "model" := encodeCardModel card.model
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode js = do
  obj ← J.decodeJson js
  cardId ← obj .? "cardId"
  cardTypeStr ← obj .? "cardType"
  model ←
    if cardTypeStr ≡ "chart-options"
      then
      decodeLegacyChartOptions js
      else do
      cardType ← obj .? "cardType"
      modelJS ← obj .? "model"
      decodeCardModel cardType modelJS
  pure { cardId, model }

type ChartConfiguration =
  { series ∷ Array (S.Select J.JCursor)
  , dimensions ∷ Array (S.Select J.JCursor)
  , measures ∷ Array (S.Select J.JCursor)
  , aggregations ∷ Array (S.Select (Maybe Ag.Aggregation))
  }

decodeCC ∷ J.Json →  Either String ChartConfiguration
decodeCC = J.decodeJson >=> \obj → do
  { series: _, dimensions: _, measures: _, aggregations: _}
    <$> obj .? "series"
    <*> obj .? "dimensions"
    <*> obj .? "measures"
    <*> ((obj .? "aggregations") <|> ((obj .? "aggregations") <#> map (map Just)))

type BuildOptions =
  { chartType ∷ ChartType
  , axisLabelAngle ∷ Int
  , axisLabelFontSize ∷ Int
  , areaStacked ∷ Boolean
  , smooth ∷ Boolean
  , bubbleMinSize ∷ Number
  , bubbleMaxSize ∷ Number
  , funnelOrder ∷ String
  , funnelAlign ∷ String
  , minColorVal ∷ Number
  , maxColorVal ∷ Number
  , colorScheme ∷ String
  , colorReversed ∷ Boolean
  }

decodeBO ∷ J.Json → Either String BuildOptions
decodeBO = J.decodeJson >=> \obj →
  { chartType: _, axisLabelAngle: _, axisLabelFontSize: _
  , areaStacked: _, smooth: _, bubbleMinSize:_, bubbleMaxSize: _
  , funnelOrder: _, funnelAlign: _, minColorVal: _, maxColorVal: _
  , colorScheme: _, colorReversed: _ }
    <$> (obj .? "chartType")
    <*> (obj .? "axisLabelAngle")
    <*> (obj .? "axisLabelFontSize")
    <*> ((obj .? "areaStacked") <|> (pure false))
    <*> ((obj .? "smooth") <|> (pure false))
    <*> ((obj .? "bubbleMinSize") <|> (pure 1.0))
    <*> ((obj .? "bubbleMaxSize") <|> (pure 50.0))
    <*> ((obj .? "funnelOrder") <|> (pure "descending"))
    <*> ((obj .? "funnelAlign") <|> (pure "center"))
    <*> ((obj .? "minColorVal") <|> (pure 0.0))
    <*> ((obj .? "maxColorVal") <|> (pure 1.0))
    <*> ((obj .? "colorScheme") <|> (pure "diverging: red-blue"))
    <*> ((obj .? "colorReversed") <|> (pure false))

decodeLegacyChartOptions
  ∷ J.Json
  → Either String AnyCardModel
decodeLegacyChartOptions js = do
  (BuildMetric.decode js <#> BuildMetric)
  <|> (BuildSankey.decode js <#> BuildSankey)
  <|> (BuildGauge.decode js <#> BuildGauge)
  <|> (BuildGraph.decode js <#> BuildGraph)
  <|> (decodeOldestCharts js)
  where
  decodeOldestCharts ∷ J.Json → String ⊹ AnyCardModel
  decodeOldestCharts js = do
    obj ← J.decodeJson js
    bo ← (obj .? "options") >>= decodeBO
    cc ← (obj .? "chartConfiguration") >>= decodeCC
    case bo.chartType of
      Pie → decodePie cc
      Line → decodeLine cc bo
      Bar → decodeBar cc bo
      Area → decodeArea cc bo
      Scatter → decodeScatter cc bo
      Radar → decodeRadar cc bo
      Funnel → decodeFunnel cc bo
      Heatmap → decodeHeatmap cc bo
      Boxplot → decodeBoxplot cc bo
      chty → throwError $ printChartType chty ⊕ " should be decoded already"

  decodePie ∷ ChartConfiguration → String ⊹ AnyCardModel
  decodePie cc = pure $ BuildPie
    let
      category =
        cc.series A.!! 0 >>= view S._value
      donut =
        cc.series A.!! 1 >>= view S._value
      parallel =
        cc.series A.!! 2 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value

      pieR =
        { category: _
        , value: _
        , valueAggregation: _
        , donut
        , parallel
        }
        <$> category
        <*> value
        <*> valueAggregation

    in
      pieR

  decodeLine ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeLine cc bo = pure $ BuildLine
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      secondValue =
        cc.measures A.!! 1 >>= view S._value
      secondValueAggregation =
        join $ cc.aggregations A.!! 1 >>= view S._value

      size = Nothing
      sizeAggregation = Nothing
      minSize = 2.0
      maxSize = 20.0
      axisLabelAngle = Int.toNumber bo.axisLabelAngle
      axisLabelFontSize = bo.axisLabelFontSize

      lineR =
        { dimension: _
        , value: _
        , valueAggregation: _
        , secondValue
        , secondValueAggregation
        , size
        , sizeAggregation
        , minSize
        , maxSize
        , axisLabelAngle
        , axisLabelFontSize
        , series
        }
        <$> dimension
        <*> value
        <*> valueAggregation
    in
      lineR

  decodeBar ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeBar _ _ = throwError "not implemented"

  decodeArea ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeArea _ _ = throwError "not implemented"

  decodeScatter ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeScatter _ _ = throwError "not implemented"

  decodeRadar ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeRadar _ _ = throwError "not implemented"

  decodeFunnel ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeFunnel _ _ = throwError "not implemented"

  decodeHeatmap ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeHeatmap _ _ = throwError "not implemented"

  decodeBoxplot ∷ ChartConfiguration → BuildOptions → String ⊹ AnyCardModel
  decodeBoxplot _ _ = throwError "not implemented"

encodeCardModel
  ∷ AnyCardModel
  → J.Json
encodeCardModel = case _ of
  Ace mode model → Ace.encode model
  Search txt → J.encodeJson txt
  Chart → J.jsonEmptyObject
  Markdown model → MD.encode model
  Table model → JT.encode model
  Download → J.jsonEmptyObject
  Variables model → Variables.encode model
  Troubleshoot → J.jsonEmptyObject
  Cache model → J.encodeJson model
  Open mres → J.encodeJson mres
  DownloadOptions model → DLO.encode model
  Draftboard model → DB.encode model
  BuildMetric model → BuildMetric.encode model
  BuildSankey model → BuildSankey.encode model
  BuildGauge model → BuildGauge.encode model
  BuildGraph model → BuildGraph.encode model
  BuildPie model → BuildPie.encode model
  BuildRadar model → BuildRadar.encode model
  BuildBar model → BuildBar.encode model
  BuildLine model → BuildLine.encode model
  BuildArea model → BuildArea.encode model
  BuildScatter model → BuildScatter.encode model
  BuildFunnel model → BuildFunnel.encode model
  BuildBoxplot model → BuildBoxplot.encode model
  BuildHeatmap model → BuildHeatmap.encode model
  ErrorCard → J.jsonEmptyObject
  NextAction → J.jsonEmptyObject
  PendingCard → J.jsonEmptyObject

decodeCardModel
  ∷ CT.CardType
  → J.Json
  → Either String AnyCardModel
decodeCardModel = case _ of
  CT.Ace mode → map (Ace mode) ∘ Ace.decode
  CT.Search → map Search ∘ J.decodeJson
  CT.ChartOptions Metric → map BuildMetric ∘ BuildMetric.decode
  CT.ChartOptions Sankey → map BuildSankey ∘ BuildSankey.decode
  CT.ChartOptions Gauge → map BuildGauge ∘ BuildGauge.decode
  CT.ChartOptions Graph → map BuildGraph ∘ BuildGraph.decode
  CT.ChartOptions Pie → map BuildPie ∘ BuildPie.decode
  CT.ChartOptions Radar → map BuildRadar ∘ BuildRadar.decode
  CT.ChartOptions Bar → map BuildBar ∘ BuildBar.decode
  CT.ChartOptions Line → map BuildLine ∘ BuildLine.decode
  CT.ChartOptions Area → map BuildArea ∘ BuildArea.decode
  CT.ChartOptions Scatter → map BuildScatter ∘ BuildScatter.decode
  CT.ChartOptions Funnel → map BuildFunnel ∘ BuildFunnel.decode
  CT.ChartOptions Boxplot → map BuildBoxplot ∘ BuildBoxplot.decode
  CT.ChartOptions Heatmap → map BuildHeatmap ∘ BuildHeatmap.decode
  CT.Chart → const $ pure Chart
  CT.Markdown → map Markdown ∘ MD.decode
  CT.Table → map Table ∘ JT.decode
  CT.Download → const $ pure Download
  CT.Variables → map Variables ∘ Variables.decode
  CT.Troubleshoot → const $ pure Troubleshoot
  CT.Cache → map Cache ∘ J.decodeJson
  CT.Open → map Open ∘ J.decodeJson
  CT.DownloadOptions → map DownloadOptions ∘ DLO.decode
  CT.Draftboard → map Draftboard ∘ DB.decode

  CT.ErrorCard → const $ pure ErrorCard
  CT.NextAction → const $ pure NextAction
  CT.PendingCard → const $ pure PendingCard

cardModelOfType
  ∷ CT.CardType
  → AnyCardModel
cardModelOfType = case _ of
  CT.Ace mode → Ace mode Ace.emptyModel
  CT.Search → Search ""
  CT.ChartOptions Metric → BuildMetric BuildMetric.initialModel
  CT.ChartOptions Sankey → BuildSankey BuildSankey.initialModel
  CT.ChartOptions Gauge → BuildGauge BuildGauge.initialModel
  CT.ChartOptions Graph → BuildGraph BuildGraph.initialModel
  CT.ChartOptions Pie → BuildPie BuildPie.initialModel
  CT.ChartOptions Radar → BuildRadar BuildRadar.initialModel
  CT.ChartOptions Bar → BuildBar BuildBar.initialModel
  CT.ChartOptions Line → BuildLine BuildLine.initialModel
  CT.ChartOptions Area → BuildArea BuildArea.initialModel
  CT.ChartOptions Scatter → BuildScatter BuildScatter.initialModel
  CT.ChartOptions Funnel → BuildFunnel BuildFunnel.initialModel
  CT.ChartOptions Boxplot → BuildBoxplot BuildBoxplot.initialModel
  CT.ChartOptions Heatmap → BuildHeatmap BuildHeatmap.initialModel
  CT.Chart → Chart
  CT.Markdown → Markdown MD.emptyModel
  CT.Table → Table JT.emptyModel
  CT.Download → Download
  CT.Variables → Variables Variables.emptyModel
  CT.Troubleshoot → Troubleshoot
  CT.Cache → Cache Nothing
  CT.Open → Open Nothing
  CT.DownloadOptions → DownloadOptions DLO.initialState
  CT.Draftboard → Draftboard DB.emptyModel
  CT.ErrorCard → ErrorCard
  CT.NextAction → NextAction
  CT.PendingCard → PendingCard

-- TODO: handle build chartype models
modelToEval
  ∷ AnyCardModel
  → String ⊹ Eval.Eval
modelToEval = case _ of
  Ace CT.SQLMode model →
    pure $ Eval.Query $ fromMaybe "" $ _.text <$> model
  Ace CT.MarkdownMode model →
    pure $ Eval.Markdown $ fromMaybe "" $ _.text <$> model
  Markdown model →
    pure $ Eval.MarkdownForm model
  Search txt →
    pure $ Eval.Search txt
  Cache fp →
    pure $ Eval.Cache fp
  Open (Just res) →
    pure $ Eval.Open res
  -- Do we need this? Eval.evalOpen is called only if Open has Just res
  Open _ →
    Left "Open model missing resource"
  Variables model →
    pure $ Eval.Variables model
  DownloadOptions model →
    pure $ Eval.DownloadOptions model
  Draftboard _ →
    pure Eval.Draftboard
  BuildMetric model  →
    pure $ Eval.BuildMetric model
  BuildSankey model →
    pure $ Eval.BuildSankey model
  BuildGauge model →
    pure $ Eval.BuildGauge model
  BuildGraph model →
    pure $ Eval.BuildGraph model
  BuildPie model →
    pure $ Eval.BuildPie model
  BuildRadar model →
    pure $ Eval.BuildRadar model
  BuildArea model →
    pure $ Eval.BuildArea model
  BuildLine model →
    pure $ Eval.BuildLine model
  BuildBar model →
    pure $ Eval.BuildBar model
  BuildScatter model →
    pure $ Eval.BuildScatter model
  BuildFunnel model →
    pure $ Eval.BuildFunnel model
  BuildHeatmap model →
    pure $ Eval.BuildHeatmap model
  BuildBoxplot model →
    pure $ Eval.BuildBoxplot model
  _ →
    pure Eval.Pass

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Model
  ( Model
  , AnyCardModel(..)
  , encode
  , decode
  , modelToEval
  , cardModelOfType
  , modelCardType
  ) where

import SlamData.Prelude

import Data.Argonaut ((:=), (~>), (.?))
import Data.Argonaut as J

import SlamData.FileSystem.Resource as R

import SlamData.Workspace.Card.Eval as Eval
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (ChartType(..))
import SlamData.Workspace.Card.Ace.Model as Ace
import SlamData.Workspace.Card.Variables.Model as Variables
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Draftboard.Model as DB
import SlamData.Workspace.Card.DownloadOptions.Component.State as DLO
import SlamData.Workspace.Card.BuildChart.Metric.Model as BuildMetric
import SlamData.Workspace.Card.BuildChart.Sankey.Model as BuildSankey
import SlamData.Workspace.Card.BuildChart.Gauge.Model as BuildGauge
import SlamData.Workspace.Card.BuildChart.Graph.Model as BuildGraph
import SlamData.Workspace.Card.BuildChart.Pie.Model as BuildPie
import SlamData.Workspace.Card.BuildChart.Bar.Model as BuildBar
import SlamData.Workspace.Card.BuildChart.Line.Model as BuildLine
import SlamData.Workspace.Card.BuildChart.Area.Model as BuildArea
import SlamData.Workspace.Card.BuildChart.Scatter.Model as BuildScatter
import SlamData.Workspace.Card.BuildChart.Funnel.Model as BuildFunnel
import SlamData.Workspace.Card.BuildChart.Radar.Model as BuildRadar
import SlamData.Workspace.Card.BuildChart.Boxplot.Model as BuildBoxplot
import SlamData.Workspace.Card.BuildChart.Heatmap.Model as BuildHeatmap

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data AnyCardModel
  = Ace CT.AceMode Ace.Model
  | Search String
  | Chart
  | Markdown MD.Model
  | Table JT.Model
  | Download
  | Variables Variables.Model
  | Troubleshoot
  | Cache (Maybe String)
  | Open (Maybe R.Resource)
  | DownloadOptions DLO.State
  | Draftboard DB.Model
  | BuildMetric BuildMetric.Model
  | BuildSankey BuildSankey.Model
  | BuildGauge BuildGauge.Model
  | BuildGraph BuildGraph.Model
  | BuildPie BuildPie.Model
  | BuildBar BuildBar.Model
  | BuildLine BuildLine.Model
  | BuildArea BuildArea.Model
  | BuildScatter BuildScatter.Model
  | BuildFunnel BuildFunnel.Model
  | BuildRadar BuildRadar.Model
  | BuildBoxplot BuildBoxplot.Model
  | BuildHeatmap BuildHeatmap.Model
  | ErrorCard
  | NextAction
  | PendingCard

instance arbitraryAnyCardModel ∷ SC.Arbitrary AnyCardModel where
  arbitrary =
    Gen.oneOf (pure ErrorCard)
      [ Ace <$> SC.arbitrary <*> Ace.genModel
      , Search <$> SC.arbitrary
      , pure Chart
      , Markdown <$> MD.genModel
      , Table <$> JT.genModel
      , pure Download
      , Variables <$> Variables.genModel
      , pure Troubleshoot
      , Cache <$> SC.arbitrary
      , Open <$> SC.arbitrary
      , Draftboard <$> DB.genModel
      , BuildMetric <$> BuildMetric.genModel
      , BuildSankey <$> BuildSankey.genModel
      , BuildGauge <$> BuildGauge.genModel
      , BuildGraph <$> BuildGraph.genModel
      , BuildPie <$> BuildPie.genModel
      , BuildRadar <$> BuildRadar.genModel
      , BuildBar <$> BuildBar.genModel
      , BuildLine <$> BuildLine.genModel
      , BuildArea <$> BuildArea.genModel
      , BuildScatter <$> BuildScatter.genModel
      , BuildFunnel <$> BuildFunnel.genModel
      , BuildBoxplot <$> BuildBoxplot.genModel
      , BuildHeatmap <$> BuildHeatmap.genModel
      , pure ErrorCard
      , pure NextAction
      ]

instance eqAnyCardModel ∷ Eq AnyCardModel where
  eq =
    case _, _ of
      Ace x1 y1, Ace x2 y2 → x1 ≡ x2 && Ace.eqModel y1 y2
      Search s1, Search s2 → s1 ≡ s2
      Chart, Chart → true
      Markdown x, Markdown y → MD.eqModel x y
      Table x, Table y → JT.eqModel x y
      Download, Download → true
      Variables x, Variables y → Variables.eqModel x y
      Troubleshoot, Troubleshoot → true
      Cache x, Cache y → x ≡ y
      Open x, Open y → x ≡ y
      DownloadOptions x, DownloadOptions y → DLO.eqState x y
      Draftboard x, Draftboard y → DB.eqModel x y
      BuildMetric x, BuildMetric y → BuildMetric.eqModel x y
      BuildSankey x, BuildSankey y → BuildSankey.eqModel x y
      BuildGauge x, BuildGauge y → BuildGauge.eqModel x y
      BuildGraph x, BuildGraph y → BuildGraph.eqModel x y
      BuildPie x, BuildPie y → BuildPie.eqModel x y
      BuildRadar x, BuildRadar y → BuildRadar.eqModel x y
      BuildBar x, BuildBar y → BuildBar.eqModel x y
      BuildLine x, BuildLine y → BuildLine.eqModel x y
      BuildArea x, BuildArea y → BuildArea.eqModel x y
      BuildScatter x, BuildScatter y → BuildScatter.eqModel x y
      BuildFunnel x, BuildFunnel y → BuildFunnel.eqModel x y
      BuildBoxplot x, BuildBoxplot y → BuildBoxplot.eqModel x y
      BuildHeatmap x, BuildHeatmap y → BuildHeatmap.eqModel x y
      ErrorCard, ErrorCard → true
      NextAction, NextAction → true
      _,_ → false

instance encodeJsonCardModel ∷ J.EncodeJson AnyCardModel where
  encodeJson = encodeCardModel

modelCardType
  ∷ AnyCardModel
  → CT.CardType
modelCardType =
  case _ of
    Ace mode _ → CT.Ace mode
    Search _ → CT.Search
    BuildMetric _ → CT.ChartOptions Metric
    BuildSankey _ → CT.ChartOptions Sankey
    BuildGauge _ → CT.ChartOptions Gauge
    BuildGraph _ → CT.ChartOptions Graph
    BuildPie _ → CT.ChartOptions Pie
    BuildRadar _ → CT.ChartOptions Radar
    BuildBar _ → CT.ChartOptions Bar
    BuildLine _ → CT.ChartOptions Line
    BuildArea _ → CT.ChartOptions Area
    BuildScatter _ → CT.ChartOptions Scatter
    BuildFunnel _ → CT.ChartOptions Funnel
    BuildBoxplot _ → CT.ChartOptions Boxplot
    BuildHeatmap _ → CT.ChartOptions Heatmap
    Chart → CT.Chart
    Markdown _ → CT.Markdown
    Table _ → CT.Table
    Download → CT.Download
    Variables _ → CT.Variables
    Troubleshoot → CT.Troubleshoot
    Cache _ → CT.Cache
    Open _ → CT.Open
    DownloadOptions _ → CT.DownloadOptions
    Draftboard _ → CT.Draftboard
    ErrorCard → CT.ErrorCard
    NextAction → CT.NextAction
    PendingCard → CT.PendingCard

type Model =
  { cardId ∷ CID.CardId
  , model ∷ AnyCardModel
  }

encode
  ∷ Model
  → J.Json
encode card =
  "cardId" := card.cardId
    ~> "cardType" := modelCardType card.model
    ~> "model" := encodeCardModel card.model
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → do
    cardId ← obj .? "cardId"
    cardType ← obj .? "cardType"
    model ← decodeCardModel cardType =<< obj .? "model"
    pure { cardId, model }

encodeCardModel
  ∷ AnyCardModel
  → J.Json
encodeCardModel = case _ of
  Ace mode model → Ace.encode model
  Search txt → J.encodeJson txt
  Chart → J.jsonEmptyObject
  Markdown model → MD.encode model
  Table model → JT.encode model
  Download → J.jsonEmptyObject
  Variables model → Variables.encode model
  Troubleshoot → J.jsonEmptyObject
  Cache model → J.encodeJson model
  Open mres → J.encodeJson mres
  DownloadOptions model → DLO.encode model
  Draftboard model → DB.encode model
  BuildMetric model → BuildMetric.encode model
  BuildSankey model → BuildSankey.encode model
  BuildGauge model → BuildGauge.encode model
  BuildGraph model → BuildGraph.encode model
  BuildPie model → BuildPie.encode model
  BuildRadar model → BuildRadar.encode model
  BuildBar model → BuildBar.encode model
  BuildLine model → BuildLine.encode model
  BuildArea model → BuildArea.encode model
  BuildScatter model → BuildScatter.encode model
  BuildFunnel model → BuildFunnel.encode model
  BuildBoxplot model → BuildBoxplot.encode model
  BuildHeatmap model → BuildHeatmap.encode model
  ErrorCard → J.jsonEmptyObject
  NextAction → J.jsonEmptyObject
  PendingCard → J.jsonEmptyObject

decodeCardModel
  ∷ CT.CardType
  → J.Json
  → Either String AnyCardModel
decodeCardModel = case _ of
  CT.Ace mode → map (Ace mode) ∘ Ace.decode
  CT.Search → map Search ∘ J.decodeJson
  -- TODO: put legacy handler here
  CT.ChartOptions Metric → map BuildMetric ∘ BuildMetric.decode
  CT.ChartOptions Sankey → map BuildSankey ∘ BuildSankey.decode
  CT.ChartOptions Gauge → map BuildGauge ∘ BuildGauge.decode
  CT.ChartOptions Graph → map BuildGraph ∘ BuildGraph.decode
  CT.ChartOptions Pie → map BuildPie ∘ BuildPie.decode
  CT.ChartOptions Radar → map BuildRadar ∘ BuildRadar.decode
  CT.ChartOptions Bar → map BuildBar ∘ BuildBar.decode
  CT.ChartOptions Line → map BuildLine ∘ BuildLine.decode
  CT.ChartOptions Area → map BuildArea ∘ BuildArea.decode
  CT.ChartOptions Scatter → map BuildScatter ∘ BuildScatter.decode
  CT.ChartOptions Funnel → map BuildFunnel ∘ BuildFunnel.decode
  CT.ChartOptions Boxplot → map BuildBoxplot ∘ BuildBoxplot.decode
  CT.ChartOptions Heatmap → map BuildHeatmap ∘ BuildHeatmap.decode
  CT.Chart → const $ pure Chart
  CT.Markdown → map Markdown ∘ MD.decode
  CT.Table → map Table ∘ JT.decode
  CT.Download → const $ pure Download
  CT.Variables → map Variables ∘ Variables.decode
  CT.Troubleshoot → const $ pure Troubleshoot
  CT.Cache → map Cache ∘ J.decodeJson
  CT.Open → map Open ∘ J.decodeJson
  CT.DownloadOptions → map DownloadOptions ∘ DLO.decode
  CT.Draftboard → map Draftboard ∘ DB.decode

  CT.ErrorCard → const $ pure ErrorCard
  CT.NextAction → const $ pure NextAction
  CT.PendingCard → const $ pure PendingCard

cardModelOfType
  ∷ CT.CardType
  → AnyCardModel
cardModelOfType = case _ of
  CT.Ace mode → Ace mode Ace.emptyModel
  CT.Search → Search ""
  CT.ChartOptions Metric → BuildMetric BuildMetric.initialModel
  CT.ChartOptions Sankey → BuildSankey BuildSankey.initialModel
  CT.ChartOptions Gauge → BuildGauge BuildGauge.initialModel
  CT.ChartOptions Graph → BuildGraph BuildGraph.initialModel
  CT.ChartOptions Pie → BuildPie BuildPie.initialModel
  CT.ChartOptions Radar → BuildRadar BuildRadar.initialModel
  CT.ChartOptions Bar → BuildBar BuildBar.initialModel
  CT.ChartOptions Line → BuildLine BuildLine.initialModel
  CT.ChartOptions Area → BuildArea BuildArea.initialModel
  CT.ChartOptions Scatter → BuildScatter BuildScatter.initialModel
  CT.ChartOptions Funnel → BuildFunnel BuildFunnel.initialModel
  CT.ChartOptions Boxplot → BuildBoxplot BuildBoxplot.initialModel
  CT.ChartOptions Heatmap → BuildHeatmap BuildHeatmap.initialModel
  CT.Chart → Chart
  CT.Markdown → Markdown MD.emptyModel
  CT.Table → Table JT.emptyModel
  CT.Download → Download
  CT.Variables → Variables Variables.emptyModel
  CT.Troubleshoot → Troubleshoot
  CT.Cache → Cache Nothing
  CT.Open → Open Nothing
  CT.DownloadOptions → DownloadOptions DLO.initialState
  CT.Draftboard → Draftboard DB.emptyModel
  CT.ErrorCard → ErrorCard
  CT.NextAction → NextAction
  CT.PendingCard → PendingCard

-- TODO: handle build chartype models
modelToEval
  ∷ AnyCardModel
  → String ⊹ Eval.Eval
modelToEval = case _ of
  Ace CT.SQLMode model →
    pure $ Eval.Query $ fromMaybe "" $ _.text <$> model
  Ace CT.MarkdownMode model →
    pure $ Eval.Markdown $ fromMaybe "" $ _.text <$> model
  Markdown model →
    pure $ Eval.MarkdownForm model
  Search txt →
    pure $ Eval.Search txt
  Cache fp →
    pure $ Eval.Cache fp
  Open (Just res) →
    pure $ Eval.Open res
  -- Do we need this? Eval.evalOpen is called only if Open has Just res
  Open _ →
    Left "Open model missing resource"
  Variables model →
    pure $ Eval.Variables model
  DownloadOptions model →
    pure $ Eval.DownloadOptions model
  Draftboard _ →
    pure Eval.Draftboard
  BuildMetric model  →
    pure $ Eval.BuildMetric model
  BuildSankey model →
    pure $ Eval.BuildSankey model
  BuildGauge model →
    pure $ Eval.BuildGauge model
  BuildGraph model →
    pure $ Eval.BuildGraph model
  BuildPie model →
    pure $ Eval.BuildPie model
  BuildRadar model →
    pure $ Eval.BuildRadar model
  BuildArea model →
    pure $ Eval.BuildArea model
  BuildLine model →
    pure $ Eval.BuildLine model
  BuildBar model →
    pure $ Eval.BuildBar model
  BuildScatter model →
    pure $ Eval.BuildScatter model
  BuildFunnel model →
    pure $ Eval.BuildFunnel model
  BuildHeatmap model →
    pure $ Eval.BuildHeatmap model
  BuildBoxplot model →
    pure $ Eval.BuildBoxplot model
  _ →
    pure Eval.Pass


Go in counter clockwise

Go in counter clockwise

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Prelude (const, ($), (+), (-), (<<<))

-- TODO: rename to Pit
type Cell = Int

type State =
  { cells :: FM.FixedMatrix72 Cell
  , storeA :: Int
  , storeB :: Int
  }

type Player = FM.Row

type PitRef = Ref
makeRef :: Player -> Int -> PitRef
makeRef = FM.makeRef

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 0 })   = Ref { row: B, idx: 0 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx - 1 }
nextRef (Ref { row: B, idx: 6 })   = Ref { row: A, idx: 6 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx + 1 }

lookup :: PitRef -> State -> Cell
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Cell -> a) -> State -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Cell -> Cell -> a) -> State -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Cell -> Cell -> Cell -> a) -> State -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

-- mapPit3 :: forall a. PitRef -> (Cell -> Cell -> Cell -> a) -> State -> a
-- mapPit3 ref f board =

playerCells :: Player -> State -> Array Cell
playerCells player = FM.getRow player <<< _.cells

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

init :: State
init =
  { cells: FM.init 6
  , storeA: 0
  , storeB: 0
  }

modify :: PitRef -> (Cell -> Cell) -> State -> State
modify ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clear :: PitRef -> State -> State
clear pitRef = modify pitRef (const 0)

store :: Player -> Cell -> State -> State
store A seeds state = state { storeA = state.storeA + seeds }
store B seeds state = state { storeA = state.storeB + seeds }

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Prelude (const, ($), (+), (-), (<<<))

-- TODO: rename to Pit
type Cell = Int

type State =
  { cells :: FM.FixedMatrix72 Cell
  , storeA :: Int
  , storeB :: Int
  }

type Player = FM.Row

type PitRef = Ref
makeRef :: Player -> Int -> PitRef
makeRef = FM.makeRef

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 6 })   = Ref { row: B, idx: 6 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx + 1 }
nextRef (Ref { row: B, idx: 0 })   = Ref { row: A, idx: 0 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx - 1 }

lookup :: PitRef -> State -> Cell
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Cell -> a) -> State -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Cell -> Cell -> a) -> State -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Cell -> Cell -> Cell -> a) -> State -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

-- mapPit3 :: forall a. PitRef -> (Cell -> Cell -> Cell -> a) -> State -> a
-- mapPit3 ref f board =

playerCells :: Player -> State -> Array Cell
playerCells player = FM.getRow player <<< _.cells

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

init :: State
init =
  { cells: FM.init 6
  , storeA: 0
  , storeB: 0
  }

modify :: PitRef -> (Cell -> Cell) -> State -> State
modify ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clear :: PitRef -> State -> State
clear pitRef = modify pitRef (const 0)

store :: Player -> Cell -> State -> State
store A seeds state = state { storeA = state.storeA + seeds }
store B seeds state = state { storeA = state.storeB + seeds }


tiny bit of documentation, might help people get over their initial confusion when not finding a  function

-- | Functions that expose the KeyboardEvent API.
-- |
-- | https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent
-- |
-- | Note: The deprecated attributes `.keyCode`, `.charCode`, and
-- | `.which` are deliberately omitted. It is currently recommended to use
-- | `KeyboardEvent.key` instead.
-- |
-- | If browser support for `KeyboardEvent.key` is not yet widespread
-- | enough for your use case, consider using a polyfill
-- | (e.g. https://github.com/inexorabletash/polyfill#keyboard-events)
-- | or use the purescript FFI to access the deprecated attributes you
-- | want to work with.
-- |
module DOM.Event.KeyboardEvent
  ( module T
  , eventToKeyboardEvent
  , key
  , code
  , locationIndex
  , location
  , KeyLocation(..)
  , toEnumKeyLocation
  , fromEnumKeyLocation
  , ctrlKey
  , shiftKey
  , altKey
  , metaKey
  , repeat
  , isComposing
  , getModifierState
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, toEnum)
import Data.Foreign (F, toForeign)
import Data.Maybe (Maybe(..), fromJust)
import DOM (DOM)
import DOM.Event.Types (Event, KeyboardEvent, readKeyboardEvent)
import DOM.Event.Types (KeyboardEvent, keyboardEventToEvent, readKeyboardEvent) as T

eventToKeyboardEvent :: Event -> F KeyboardEvent
eventToKeyboardEvent = readKeyboardEvent <<< toForeign

-- | A non-empty Unicode character string containing the printable representation
-- | of the key, if available.
foreign import key :: KeyboardEvent -> String

-- | Returns a string representing a physical key on the keyboard. Not
-- | affected by keyboard layout or state of the modifier keys.
foreign import code :: KeyboardEvent -> String

foreign import locationIndex :: KeyboardEvent -> Int

location :: Partial => KeyboardEvent -> KeyLocation
location = fromJust <<< toEnum <<< locationIndex

data KeyLocation
  = Standard
  | Left
  | Right
  | Numpad

derive instance eqKeyLocation :: Eq KeyLocation
derive instance ordKeyLocation :: Ord KeyLocation

instance boundedKeyLocation :: Bounded KeyLocation where
  bottom = Standard
  top = Numpad

instance enumKeyLocation :: Enum KeyLocation where
  succ = defaultSucc toEnumKeyLocation fromEnumKeyLocation
  pred = defaultPred toEnumKeyLocation fromEnumKeyLocation

instance boundedEnumKeyLocation :: BoundedEnum KeyLocation where
  cardinality = Cardinality 4
  toEnum = toEnumKeyLocation
  fromEnum = fromEnumKeyLocation

toEnumKeyLocation :: Int -> Maybe KeyLocation
toEnumKeyLocation =
  case _ of
    0 -> Just Standard
    1 -> Just Left
    2 -> Just Right
    3 -> Just Numpad
    _ -> Nothing

fromEnumKeyLocation :: KeyLocation -> Int
fromEnumKeyLocation =
  case _ of
    Standard -> 0
    Left -> 1
    Right -> 2
    Numpad -> 3

foreign import ctrlKey :: KeyboardEvent -> Boolean

foreign import shiftKey :: KeyboardEvent -> Boolean

foreign import altKey :: KeyboardEvent -> Boolean

foreign import metaKey :: KeyboardEvent -> Boolean

foreign import repeat :: KeyboardEvent -> Boolean

foreign import isComposing :: KeyboardEvent -> Boolean

foreign import getModifierState
  :: forall eff
   . String
  -> KeyboardEvent
  -> Eff (dom :: DOM | eff) Boolean

module DOM.Event.KeyboardEvent
  ( module T
  , eventToKeyboardEvent
  , key
  , code
  , locationIndex
  , location
  , KeyLocation(..)
  , toEnumKeyLocation
  , fromEnumKeyLocation
  , ctrlKey
  , shiftKey
  , altKey
  , metaKey
  , repeat
  , isComposing
  , getModifierState
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, toEnum)
import Data.Foreign (F, toForeign)
import Data.Maybe (Maybe(..), fromJust)
import DOM (DOM)
import DOM.Event.Types (Event, KeyboardEvent, readKeyboardEvent)
import DOM.Event.Types (KeyboardEvent, keyboardEventToEvent, readKeyboardEvent) as T

eventToKeyboardEvent :: Event -> F KeyboardEvent
eventToKeyboardEvent = readKeyboardEvent <<< toForeign

foreign import key :: KeyboardEvent -> String

foreign import code :: KeyboardEvent -> String

foreign import locationIndex :: KeyboardEvent -> Int

location :: Partial => KeyboardEvent -> KeyLocation
location = fromJust <<< toEnum <<< locationIndex

data KeyLocation
  = Standard
  | Left
  | Right
  | Numpad

derive instance eqKeyLocation :: Eq KeyLocation
derive instance ordKeyLocation :: Ord KeyLocation

instance boundedKeyLocation :: Bounded KeyLocation where
  bottom = Standard
  top = Numpad

instance enumKeyLocation :: Enum KeyLocation where
  succ = defaultSucc toEnumKeyLocation fromEnumKeyLocation
  pred = defaultPred toEnumKeyLocation fromEnumKeyLocation

instance boundedEnumKeyLocation :: BoundedEnum KeyLocation where
  cardinality = Cardinality 4
  toEnum = toEnumKeyLocation
  fromEnum = fromEnumKeyLocation

toEnumKeyLocation :: Int -> Maybe KeyLocation
toEnumKeyLocation =
  case _ of
    0 -> Just Standard
    1 -> Just Left
    2 -> Just Right
    3 -> Just Numpad
    _ -> Nothing

fromEnumKeyLocation :: KeyLocation -> Int
fromEnumKeyLocation =
  case _ of
    Standard -> 0
    Left -> 1
    Right -> 2
    Numpad -> 3

foreign import ctrlKey :: KeyboardEvent -> Boolean

foreign import shiftKey :: KeyboardEvent -> Boolean

foreign import altKey :: KeyboardEvent -> Boolean

foreign import metaKey :: KeyboardEvent -> Boolean

foreign import repeat :: KeyboardEvent -> Boolean

foreign import isComposing :: KeyboardEvent -> Boolean

foreign import getModifierState
  :: forall eff
   . String
  -> KeyboardEvent
  -> Eff (dom :: DOM | eff) Boolean