clarify import

clarify import

module Example.RemGeneric where

import Prelude
import Control.Plus (Plus)
import Data.Functor.Coproduct (Coproduct(..))

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

data QueryP a = Remove a

type ChildSlot = Unit

type StateP = Unit

withRemove :: forall g p s' f'. (Functor g)
           => ParentComponent StateP s' QueryP f' g ChildSlot p
withRemove = component render eval
    where
        render :: Render StateP QueryP ChildSlot
        render _ =
            H.div_ [ H.slot unit
                   , H.button [ E.onClick $ E.input_ Remove ]
                              [ H.text "Remove" ]
                   ]
        eval :: EvalP QueryP StateP s' QueryP f' g ChildSlot p
        eval (Remove a) = pure a

type State s f g p =
    InstalledState StateP s QueryP f g ChildSlot p

type Query f =
    Coproduct QueryP (ChildF ChildSlot f)

addRemove :: forall s f g p. (Plus g)
          => Component s f g p
          -> s
          -> Component (State s f g p) (Query f) g p
addRemove comp state = install withRemove mkChild
    where
        mkChild _ = createChild comp state

module Example.RemGeneric where

import Prelude
import Control.Plus (Plus)
import Data.Functor.Coproduct

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

data QueryP a = Remove a

type ChildSlot = Unit

type StateP = Unit

withRemove :: forall g p s' f'. (Functor g)
           => ParentComponent StateP s' QueryP f' g ChildSlot p
withRemove = component render eval
    where
        render :: Render StateP QueryP ChildSlot
        render _ =
            H.div_ [ H.slot unit
                   , H.button [ E.onClick $ E.input_ Remove ]
                              [ H.text "Remove" ]
                   ]
        eval :: EvalP QueryP StateP s' QueryP f' g ChildSlot p
        eval (Remove a) = pure a

type State s f g p =
    InstalledState StateP s QueryP f g ChildSlot p

type Query f =
    Coproduct QueryP (ChildF ChildSlot f)

addRemove :: forall s f g p. (Plus g)
          => Component s f g p
          -> s
          -> Component (State s f g p) (Query f) g p
addRemove comp state = install withRemove mkChild
    where
        mkChild _ = createChild comp state


Use new run function in tests

Use new run function in tests

module Test.Data.Array.ST (testArrayST) where

import Prelude

import Control.Monad.ST as ST
import Data.Array.ST (withArray)
import Data.Array.ST as STA
import Data.Foldable (all)
import Data.Maybe (Maybe(..), isNothing)
import Effect (Effect)
import Effect.Console (log)
import Test.Assert (assert)

testArrayST :: Effect Unit
testArrayST = do

  log "run should produce an immutable array by running a constructor operation"

  assert $ STA.run (do
    arr <- STA.empty
    void $ STA.push 1 arr
    void $ STA.push 2 arr
    pure arr) == [1, 2]

  log "withArray should run an operation on a copy of an array"

  let original = [1, 2, 3]
  assert $ ST.run (withArray (STA.push 42) original) == [1, 2, 3, 42]
  assert $ original == [1, 2, 3]

  log "empty should produce an empty array"

  assert $ STA.run STA.empty == nil

  log "thaw should produce an STArray from a standard array"

  assert $ STA.run (STA.thaw [1, 2, 3]) == [1, 2, 3]

  log "freeze should produce a standard array from an STArray"

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.freeze arr) == [1, 2, 3]

  log "unsafeThaw should produce an STArray from a standard array"

  assert $ STA.run (STA.unsafeThaw [1, 2, 3]) == [1, 2, 3]

  log "push should append a value to the end of the array"

  assert $ STA.run (do
    arr <- STA.empty
    void $ STA.push 1 arr
    void $ STA.push 2 arr
    pure arr) == [1, 2]

  assert $ STA.run (do
    arr <- STA.thaw [1, 2, 3]
    void $ STA.push 4 arr
    pure arr) == [1, 2, 3, 4]

  log "push should return the new length of the array"

  assert $ ST.run (do
    arr <- STA.thaw [unit, unit, unit]
    STA.push unit arr) == 4

  log "pushAll should append multiple values to the end of the array"

  assert $ STA.run (do
    arr <- STA.empty
    void $ STA.pushAll [1, 2] arr
    pure arr) == [1, 2]

  assert $ STA.run (do
    arr <- STA.thaw [1, 2, 3]
    void $ STA.pushAll [4, 5, 6] arr
    pure arr) == [1, 2, 3, 4, 5, 6]

  log "pushAll should return the new length of the array"

  assert $ ST.run (do
    arr <- STA.thaw [unit, unit, unit]
    STA.pushAll [unit, unit] arr) == 5

  log "peek should return Nothing when peeking a value outside the array bounds"

  assert $ isNothing $ ST.run (do
    arr <- STA.empty
    STA.peek 0 arr)

  assert $ isNothing $ ST.run (do
    arr <- STA.thaw [1]
    STA.peek 1 arr)

  assert $ isNothing $ ST.run (do
    arr <- STA.empty
    STA.peek (-1) arr)

  log "peek should return the value at the specified index"

  assert $ ST.run (do
    arr <- STA.thaw [1]
    STA.peek 0 arr) == Just 1

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.peek 2 arr) == Just 3

  log "poke should return true when a value has been updated succesfully"

  assert $ ST.run (do
    arr <- STA.thaw [1]
    STA.poke 0 10 arr)

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke 2 30 arr)

  log "poke should return false when attempting to modify a value outside the array bounds"

  assert $ not $ ST.run (do
    arr <- STA.empty
    STA.poke 0 10 arr)

  assert $ not $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke 3 100 arr)

  assert $ not $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke (-1) 100 arr)

  log "poke should replace the value at the specified index"

  assert $ STA.run (do
    arr <- STA.thaw [1]
    void $ STA.poke 0 10 arr
    pure arr) == [10]

  log "poke should do nothing when attempting to modify a value outside the array bounds"

  assert $ STA.run (do
    arr <- STA.thaw [1]
    void $ STA.poke 1 2 arr
    pure arr) == [1]

  log "sort should reorder a list into ascending order based on the result of compare"
  assert $ STA.run (
    STA.sort =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [1, 2, 3, 4, 5, 6]

  log "sortBy should reorder a list into ascending order based on the result of a comparison function"
  assert $ STA.run (
    STA.sortBy (flip compare) =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [6, 5, 4, 3, 2, 1]

  log "sortWith should reorder a list into ascending order based on the result of compare over a projection"
  assert $ STA.run (
    STA.sortWith identity =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [1, 2, 3, 4, 5, 6]

  log "splice should be able to delete multiple items at a specified index"

  assert $ STA.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 3 [] arr
    pure arr) == [1, 5]

  log "splice should return the items removed"

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    STA.splice 1 3 [] arr) == [2, 3, 4]

  log "splice should be able to insert multiple items at a specified index"

  assert $ STA.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 0 [0, 100] arr
    pure arr) == [1, 0, 100, 2, 3, 4, 5]

  log "splice should be able to delete and insert at the same time"

  assert $ STA.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 2 [0, 100] arr
    pure arr) == [1, 0, 100, 4, 5]

  log "toAssocArray should return all items in the array with the correct indices and values"

  assert $ all (\{ value: v, index: i } -> v == i + 1) $ ST.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    STA.toAssocArray arr)

  assert $ all (\{ value: v, index: i } -> v == (i + 1) * 10) $ ST.run (do
    arr <- STA.thaw [10, 20, 30, 40, 50]
    STA.toAssocArray arr)

nil :: Array Int
nil = []

module Test.Data.Array.ST (testArrayST) where

import Prelude

import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Data.Array.ST (STArray, withArray)
import Data.Array.ST as STA
import Data.Foldable (all)
import Data.Maybe (Maybe(..), isNothing)
import Effect (Effect)
import Effect.Console (log)
import Test.Assert (assert)

run :: forall a. (forall r. ST r (STArray r a)) -> Array a
run act = ST.run (act >>= STA.unsafeFreeze)

testArrayST :: Effect Unit
testArrayST = do

  log "run should produce an immutable array by running a constructor operation"

  assert $ STA.run (do
    arr <- STA.empty
    void $ STA.push 1 arr
    void $ STA.push 2 arr
    pure arr) == [1, 2]

  log "withArray should run an operation on a copy of an array"

  let original = [1, 2, 3]
  assert $ ST.run (withArray (STA.push 42) original) == [1, 2, 3, 42]
  assert $ original == [1, 2, 3]

  log "empty should produce an empty array"

  assert $ run STA.empty == nil

  log "thaw should produce an STArray from a standard array"

  assert $ run (STA.thaw [1, 2, 3]) == [1, 2, 3]

  log "freeze should produce a standard array from an STArray"

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.freeze arr) == [1, 2, 3]

  log "unsafeThaw should produce an STArray from a standard array"

  assert $ run (STA.unsafeThaw [1, 2, 3]) == [1, 2, 3]

  log "push should append a value to the end of the array"

  assert $ run (do
    arr <- STA.empty
    void $ STA.push 1 arr
    void $ STA.push 2 arr
    pure arr) == [1, 2]

  assert $ run (do
    arr <- STA.thaw [1, 2, 3]
    void $ STA.push 4 arr
    pure arr) == [1, 2, 3, 4]

  log "push should return the new length of the array"

  assert $ ST.run (do
    arr <- STA.thaw [unit, unit, unit]
    STA.push unit arr) == 4

  log "pushAll should append multiple values to the end of the array"

  assert $ run (do
    arr <- STA.empty
    void $ STA.pushAll [1, 2] arr
    pure arr) == [1, 2]

  assert $ run (do
    arr <- STA.thaw [1, 2, 3]
    void $ STA.pushAll [4, 5, 6] arr
    pure arr) == [1, 2, 3, 4, 5, 6]

  log "pushAll should return the new length of the array"

  assert $ ST.run (do
    arr <- STA.thaw [unit, unit, unit]
    STA.pushAll [unit, unit] arr) == 5

  log "peek should return Nothing when peeking a value outside the array bounds"

  assert $ isNothing $ ST.run (do
    arr <- STA.empty
    STA.peek 0 arr)

  assert $ isNothing $ ST.run (do
    arr <- STA.thaw [1]
    STA.peek 1 arr)

  assert $ isNothing $ ST.run (do
    arr <- STA.empty
    STA.peek (-1) arr)

  log "peek should return the value at the specified index"

  assert $ ST.run (do
    arr <- STA.thaw [1]
    STA.peek 0 arr) == Just 1

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.peek 2 arr) == Just 3

  log "poke should return true when a value has been updated succesfully"

  assert $ ST.run (do
    arr <- STA.thaw [1]
    STA.poke 0 10 arr)

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke 2 30 arr)

  log "poke should return false when attempting to modify a value outside the array bounds"

  assert $ not $ ST.run (do
    arr <- STA.empty
    STA.poke 0 10 arr)

  assert $ not $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke 3 100 arr)

  assert $ not $ ST.run (do
    arr <- STA.thaw [1, 2, 3]
    STA.poke (-1) 100 arr)

  log "poke should replace the value at the specified index"

  assert $ run (do
    arr <- STA.thaw [1]
    void $ STA.poke 0 10 arr
    pure arr) == [10]

  log "poke should do nothing when attempting to modify a value outside the array bounds"

  assert $ run (do
    arr <- STA.thaw [1]
    void $ STA.poke 1 2 arr
    pure arr) == [1]

  log "sort should reorder a list into ascending order based on the result of compare"
  assert $ run (
    STA.sort =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [1, 2, 3, 4, 5, 6]

  log "sortBy should reorder a list into ascending order based on the result of a comparison function"
  assert $ run (
    STA.sortBy (flip compare) =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [6, 5, 4, 3, 2, 1]

  log "sortWith should reorder a list into ascending order based on the result of compare over a projection"
  assert $ run (
    STA.sortWith identity =<< STA.unsafeThaw [1, 3, 2, 5, 6, 4]
  ) == [1, 2, 3, 4, 5, 6]

  log "splice should be able to delete multiple items at a specified index"

  assert $ run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 3 [] arr
    pure arr) == [1, 5]

  log "splice should return the items removed"

  assert $ ST.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    STA.splice 1 3 [] arr) == [2, 3, 4]

  log "splice should be able to insert multiple items at a specified index"

  assert $ run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 0 [0, 100] arr
    pure arr) == [1, 0, 100, 2, 3, 4, 5]

  log "splice should be able to delete and insert at the same time"

  assert $ run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    void $ STA.splice 1 2 [0, 100] arr
    pure arr) == [1, 0, 100, 4, 5]

  log "toAssocArray should return all items in the array with the correct indices and values"

  assert $ all (\{ value: v, index: i } -> v == i + 1) $ ST.run (do
    arr <- STA.thaw [1, 2, 3, 4, 5]
    STA.toAssocArray arr)

  assert $ all (\{ value: v, index: i } -> v == (i + 1) * 10) $ ST.run (do
    arr <- STA.thaw [10, 20, 30, 40, 50]
    STA.toAssocArray arr)

nil :: Array Int
nil = []


removed evaluator tests for now

removed evaluator tests for now

module Test.Main where

import Prelude
import Data.List (length)
import Data.Traversable (for)

import Test.Parser as Parser
-- import Test.Evaluator as Evaluator
import Test.AST as AST
import Test.TypeChecker as TypeChecker

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Writer (execWriter)

import Node.Process (PROCESS, exit)

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  log $ "Running AST tests..."
  let astLog = execWriter AST.runTests
  log $ "  ...found " <> show (length astLog) <> " errors"
  for astLog log

  log $ "Running parser tests..."
  let parserLog = execWriter Parser.runTests
  log $ "  ...found " <> show (length parserLog) <> " errors"
  for parserLog log
{-
  log $ "Running evaluator tests..."
  let evaluatorLog = execWriter Evaluator.runTests
  log $ "  ...found " <> show (length evaluatorLog) <> " errors"
  for evaluatorLog log
  -}
  log $ "Running type checker tests..."
  let typeCheckerLog = execWriter TypeChecker.runTests
  log $ "  ...found " <> show (length typeCheckerLog) <> " errors"
  for typeCheckerLog log
  let errorCount = length parserLog + {- length evaluatorLog + -} length astLog + length typeCheckerLog
  if errorCount == 0
    then do
      log $ "All tests succesfull"
      exit 0
    else do
      log $ "Found " <> show errorCount <> " errors!"
      exit 1

module Test.Main where

import Prelude
import Data.List (length)
import Data.Traversable (for)

import Test.Parser as Parser
import Test.Evaluator as Evaluator
import Test.AST as AST
import Test.TypeChecker as TypeChecker

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Writer (execWriter)

import Node.Process (PROCESS, exit)

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  log $ "Running AST tests..."
  let astLog = execWriter AST.runTests
  log $ "  ...found " <> show (length astLog) <> " errors"
  for astLog log

  log $ "Running parser tests..."
  let parserLog = execWriter Parser.runTests
  log $ "  ...found " <> show (length parserLog) <> " errors"
  for parserLog log

  log $ "Running evaluator tests..."
  let evaluatorLog = execWriter Evaluator.runTests
  log $ "  ...found " <> show (length evaluatorLog) <> " errors"
  for evaluatorLog log

  log $ "Running type checker tests..."
  let typeCheckerLog = execWriter TypeChecker.runTests
  log $ "  ...found " <> show (length typeCheckerLog) <> " errors"
  for typeCheckerLog log
  let errorCount = length parserLog + length evaluatorLog + length astLog + length typeCheckerLog
  if errorCount == 0
    then do
      log $ "All tests succesfull"
      exit 0
    else do
      log $ "Found " <> show errorCount <> " errors!"
      exit 1


need to sort first to get max

need to sort first to get max

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
  , filesData :: Array File
  , filesLoading :: Boolean
  , iconsLoading :: Boolean
  , grouped :: Boolean
  -- counted by positions from the top
  , cursor :: Maybe Int
  }

data Query a
  = FetchData a
  | UpdateFiles 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: []
  , filesData: []
  , 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
          , HP.title (un Path file.name)
          ]
          [ 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 filesData -> H.modify_ _ { filesData = filesData, filesLoading = false }
    Left e -> Console.error $ "Failed to fetch data: " <> show e
  eval (UpdateFiles 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

eval (UpdateFiles next) = do
  H.modify_ \s -> do
    let annotated = annotateLatest s.filesData
    if s.grouped
      then s { files = groupFiles annotated }
      else s { files = annotated }
  pure next
  where
    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` _.episode)
          <$> Array.groupBy (eq `on` _.series)
              (Array.sortWith _.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

    groupFiles = Array.sortBy
      (\x y
        -> compare x.series y.series
        <> compare x.episode y.episode
      )

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 }
  state <- H.get

  case state.cursor of
    Just cursor | cursor == 0 -> liftEffect $ scrollToTop
    Just cursor | Just file <- Array.index state.files =<< state.cursor -> do
      liftEffect $ scrollIntoView file.name
    _ -> pure unit

  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 }
  eval (UpdateFiles 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

foreign import scrollIntoView :: Path -> Effect Unit

foreign import scrollToTop :: 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
  , filesData :: Array File
  , filesLoading :: Boolean
  , iconsLoading :: Boolean
  , grouped :: Boolean
  -- counted by positions from the top
  , cursor :: Maybe Int
  }

data Query a
  = FetchData a
  | UpdateFiles 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: []
  , filesData: []
  , 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
          , HP.title (un Path file.name)
          ]
          [ 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 filesData -> H.modify_ _ { filesData = filesData, filesLoading = false }
    Left e -> Console.error $ "Failed to fetch data: " <> show e
  eval (UpdateFiles 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

eval (UpdateFiles next) = do
  H.modify_ \s -> do
    let annotated = annotateLatest s.filesData
    if s.grouped
      then s { files = groupFiles annotated }
      else s { files = annotated }
  pure next
  where
    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

    groupFiles = Array.sortBy
      (\x y
        -> compare x.series y.series
        <> compare x.episode y.episode
      )

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 }
  state <- H.get

  case state.cursor of
    Just cursor | cursor == 0 -> liftEffect $ scrollToTop
    Just cursor | Just file <- Array.index state.files =<< state.cursor -> do
      liftEffect $ scrollIntoView file.name
    _ -> pure unit

  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 }
  eval (UpdateFiles 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

foreign import scrollIntoView :: Path -> Effect Unit

foreign import scrollToTop :: 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


9.4.1 Experiment with the strokePath and setStrokeStyle functions in each of the examples so far.

module Example.Shapes where
import Prelude

import Data.Maybe

import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

translate :: forall r. Number -> Number ->
              { x :: Number, y :: Number | r } ->
              { x :: Number, y :: Number | r }
translate dx dy shape = shape
  { x = shape.x + dx
  , y = shape.y + dy
  }

main = do
  Just canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  setFillStyle "#0000FF" ctx

  fillPath ctx $ rect ctx $ translate (-200.0) (-200.0)
    { x: 250.0
    , y: 250.0
    , w: 100.0
    , h: 100.0
    }

  setFillStyle "#00FF00" ctx

  fillPath ctx $ arc ctx $ translate 200.0 200.0
    { x: 300.0
    , y: 300.0
    , r: 50.0
    , start: Math.pi * 5.0 / 8.0
    , end: Math.pi * 2.0
    }

  setStrokeStyle "#FFAA00" ctx
  setLineWidth 5.0 ctx

  strokePath ctx $ do
    moveTo ctx 300.0 260.0
    lineTo ctx 260.0 340.0
    lineTo ctx 340.0 340.0
    closePath ctx

module Example.Shapes where

import Prelude

import Data.Maybe

import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

translate :: forall r. Number -> Number ->
              { x :: Number, y :: Number | r } ->
              { x :: Number, y :: Number | r }
translate dx dy shape = shape
  { x = shape.x + dx
  , y = shape.y + dy
  }

main = do
  Just canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  setFillStyle "#0000FF" ctx

  fillPath ctx $ rect ctx $ translate (-200.0) (-200.0)
    { x: 250.0
    , y: 250.0
    , w: 100.0
    , h: 100.0
    }

  setFillStyle "#00FF00" ctx

  fillPath ctx $ arc ctx $ translate 200.0 200.0
    { x: 300.0
    , y: 300.0
    , r: 50.0
    , start: Math.pi * 5.0 / 8.0
    , end: Math.pi * 2.0
    }

  setFillStyle "#FF0000" ctx

  fillPath ctx $ do
    moveTo ctx 300.0 260.0
    lineTo ctx 260.0 340.0
    lineTo ctx 340.0 340.0
    closePath ctx


Fixed bugs regarding getting tokens. Refactored and cleaned.

module Main where

import Control.Apply (lift3)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, liftEff', parallel, sequential)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Now (now)
import Coroutines (consumerToQuery, routeProducer)
import DOM.Websocket.WebSocket as WS
import Data.Bifunctor (rmap)
import Data.DateTime.Instant (instant)
import Data.Either (Either(Right, Left), either)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Int (toNumber)
import Data.Maybe (maybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Tuple.Nested (Tuple3, get1, get2, get3, tuple3)
import Data.Validation.Semigroup (V, invalid, unV)
import Effects (LemmingPantsEffects)
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI)
import Lemmingpants as LP
import Network.HTTP.Affjax as AX
import Postgrest as PG
import Prelude (type (~>), Unit, bind, discard, pure, void, ($), (*), (*>), (<#>), (<$>), (<*>), (<<<), (<>), (>), (>>=))
import Simple.JSON (read)
import Types.Agenda (Agenda)
import Types.Agenda as AG
import Types.Attendee (Attendee, newAttendeeDB)
import Types.Token (Payload(..), Token(..), loadToken, removeToken, saveToken)
import Websockets (wsProducer)

parseAgenda :: Foreign -> Either MultipleErrors Agenda
parseAgenda = read

parseAttendees :: Foreign -> Either MultipleErrors (Array Attendee)
parseAttendees = read

combineFailures
  :: forall a b c
   . Either MultipleErrors a
  -> Either MultipleErrors b
  -> Either MultipleErrors c
  -> Either MultipleErrors (Tuple3 a b c)
combineFailures e1 e2 e3 =
  let
    toV :: Either MultipleErrors ~> V MultipleErrors
    toV = either invalid pure
    fromV = unV Left Right
  in fromV (lift3 tuple3 (toV e1) (toV e2) (toV e3))

loadInitialState :: forall e. Aff (LemmingPantsEffects e) (Either MultipleErrors LP.Input)
loadInitialState = do
  sequential
    (combineFailures <$>                                        parallel loadOrGetNewToken
                     <*> ((\r -> parseAgenda    r.response) <$> parallel (AX.get initialAgendaUrl))
                     <*> ((\r -> parseAttendees r.response) <$> parallel (AX.get initialAttendeesUrl)))
    <#> rmap (\tpl ->
      { token:                           get1 tpl
      , agenda:    AG.jumpToFirstActive (get2 tpl)
      , attendees: newAttendeeDB        (get3 tpl)
      })
  where
    initialAgendaUrl = PG.createURL "/agenda_item?select=*,speakerQueues:speaker_queue(id,state,speakers:active_speakers(id,attendeeId:attendee_id,state,timesSpoken:times_spoken))&speaker_queue.state=in.(init,active)&order=order_.asc&order=speaker_queue.id.asc&speaker_queue.active_speakers.state=in.(init,active)"
    initialAttendeesUrl = PG.createURL "/attendee?select=id,cid,name,nick,numbers:attendee_number(id)"

    -- | Get a new token if the current token is too old.
    -- | Otherwise, make do with the one saved in local storage.
    loadOrGetNewToken :: Aff (LemmingPantsEffects e) (Either MultipleErrors Token)
    loadOrGetNewToken = do
      et <- loadToken
      case et of
        Left  _ -> do
          et' <- PG.requestAnonymousToken
          case et' of
            Left  l -> (pure <<< Left) l
            Right r -> do
              _ <- saveToken r
              (pure <<< pure) r
        Right t@(Token t') ->
          (liftEff' now) >>= \n ->
            let (Payload p) = t'.payload
                mexp        = instant (Milliseconds ((toNumber p.exp) * 1000.0))
             in if maybe false (_ > n) mexp
                  then (pure <<< pure) t
                  else removeToken *> loadOrGetNewToken -- The recursion hack!

pfest
  :: forall a e
   . CR.Producer a (Aff (LemmingPantsEffects e)) Unit
  -> CR.Consumer a (Aff (LemmingPantsEffects e)) Unit
  -> Aff           (LemmingPantsEffects e) Unit
pfest a = void <<< forkAff <<< CR.runProcess <<< CR.connect a

main :: forall e. Eff (LemmingPantsEffects (console :: CONSOLE | e)) Unit
main = do
  log "Hello lemming!"
  HA.runHalogenAff do
    body <- HA.awaitBody
    est  <- loadInitialState
    case est of
      Left  es -> liftEff $ log $ "ERROR: " <> foldMap renderForeignError es
      Right st -> do
        connection <-
          let (Token t') = st.token
           in liftEff $ WS.create (WS.URL $ PG.createWSURL $ "/state_updates/" <> t'.raw) []
        driver     <- runUI LP.component st body
        pfest (wsProducer connection)      (consumerToQuery driver.query LP.WSMsg)
        pfest (routeProducer LP.locations) (consumerToQuery driver.query LP.ChangePage)

module Main where

import Data.Tuple.Nested

import Control.Apply (lift3)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, liftEff', parallel, sequential)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (throw)
import Control.Monad.Eff.Now (now)
import Coroutines (consumerToQuery, routeProducer)
import DOM.Websocket.WebSocket as WS
import Data.Bifunctor (rmap)
import Data.DateTime.Instant (instant)
import Data.Either (Either(Right, Left), either)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Int (toNumber)
import Data.Maybe (maybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Validation.Semigroup (V, invalid, unV)
import Debug.Trace (traceA)
import Effects (LemmingPantsEffects)
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI)
import Lemmingpants as LP
import Network.HTTP.Affjax as AX
import Postgrest as PG
import Prelude (type (~>), Unit, bind, discard, pure, void, ($), (*), (*>), (<#>), (<$>), (<*>), (<<<), (<>), (>), (>>=))
import Simple.JSON (read)
import Types.Agenda (Agenda)
import Types.Agenda as AG
import Types.Attendee (Attendee, newAttendeeDB)
import Types.Token (Payload(..), Token(..), loadToken, removeToken, saveToken)
import Websockets (wsProducer)

parseAgenda :: Foreign -> Either MultipleErrors Agenda
parseAgenda = read

parseAttendees :: Foreign -> Either MultipleErrors (Array Attendee)
parseAttendees = read

combineFailures
  :: forall a b c
   . Either MultipleErrors a
  -> Either MultipleErrors b
  -> Either MultipleErrors c
  -> Either MultipleErrors (Tuple3 a b c)
combineFailures e1 e2 e3 =
  let
    toV :: Either MultipleErrors ~> V MultipleErrors
    toV = either invalid pure
    fromV = unV Left Right
  in fromV (lift3 tuple3 (toV e1) (toV e2) (toV e3))

loadInitialState :: forall e. Aff (LemmingPantsEffects e) LP.Input
loadInitialState = do
  rs <- sequential
    (combineFailures <$>                                        parallel loadOrGetNewToken
                     <*> ((\r -> parseAgenda    r.response) <$> parallel (AX.get initialAgendaUrl))
                     <*> ((\r -> parseAttendees r.response) <$> parallel (AX.get initialAttendeesUrl)))
  case rs of
    Left  es  ->
      traceA (foldMap renderForeignError es) *> liftEff' (throw "FETCH DATA ERROR!")
    Right tpl ->
      pure { token:                           get1 tpl
           , agenda:    AG.jumpToFirstActive (get2 tpl)
           , attendees: newAttendeeDB        (get3 tpl)
           }
  where
    initialAgendaUrl = PG.createURL "/agenda_item?select=*,speakerQueues:speaker_queue(id,state,speakers:active_speakers(id,attendeeId:attendee_id,state,timesSpoken:times_spoken))&speaker_queue.state=in.(init,active)&order=order_.asc&order=speaker_queue.id.asc&speaker_queue.active_speakers.state=in.(init,active)"
    initialAttendeesUrl = PG.createURL "/attendee?select=id,cid,name,nick,numbers:attendee_number(id)"

    -- | Get a new token if the current token is too old.
    -- | Otherwise, make do with the one saved in local storage.
    loadOrGetNewToken :: Aff (LemmingPantsEffects e) (Either MultipleErrors Token)
    loadOrGetNewToken = do
      et <- loadToken
      case et of
        Left  _ ->
          PG.requestAnonymousToken
            <#> \t -> rmap (saveToken) t *> t
        Right t@(Token t') ->
          (liftEff' now) >>= \n ->
            let (Payload p) = t'.payload
                mexp        = instant (Milliseconds (toNumber (p.exp * 1000)))
             in if maybe false (_ > n) mexp
                  then (pure <<< pure) t
                  else removeToken *> loadOrGetNewToken -- The recursion hack!

main :: forall e. Eff (LemmingPantsEffects (console :: CONSOLE | e)) Unit
main = do
  log "Hello lemming!"
  HA.runHalogenAff do
    body       <- HA.awaitBody
    st         <- loadInitialState
    connection <-
      let (Token t') = st.token
       in liftEff $ WS.create (WS.URL $ PG.createWSURL $ "/state_updates/" <> t'.raw) []
    driver     <- runUI LP.component st body
    pfest (wsProducer connection)      (consumerToQuery driver.query LP.WSMsg)
    pfest (routeProducer LP.locations) (consumerToQuery driver.query LP.ChangePage)

pfest
  :: forall a e
   . CR.Producer a (Aff (LemmingPantsEffects e)) Unit
  -> CR.Consumer a (Aff (LemmingPantsEffects e)) Unit
  -> Aff           (LemmingPantsEffects e) Unit
pfest a = void <<< forkAff <<< CR.runProcess <<< CR.connect a


radar build wip

radar build wip

module SlamData.Workspace.Card.BuildChart.Radar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Radar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, JCursor, Json, cursorGet, toNumber, toString)
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?))
import Data.Lens as Lens
import Data.Map as M
import Data.Set as Set
import Data.Int as Int

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.BuildChart.Radar.Model (Model, RadarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Radar))
import SlamData.Workspace.Card.Chart.Aggregation as Ag
import SlamData.Workspace.Card.Chart.Axis (Axis, Axes, analyzeJArray)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.BuildOptions.ColorScheme (colors)
import SlamData.Workspace.Card.Chart.Semantics as Sem
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.BuildChart.Radar.Model (RadarR)

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  numRecords ←
    CET.liftQ $ QQ.count resource

  when (numRecords > 10000)
    $ QE.throw
    $ "The 10000 record limit for visualizations has been exceeded - the current dataset contains "
    ⊕ show numRecords
    ⊕ " records. "
    ⊕ "Please consider using a 'limit' or 'group by' clause in the query to reduce the result size."

  records ←
    CET.liftQ $ QQ.all resource

  pure $ Port.ChartInstructions (buildRadar conf records) Radar

infixr 3 type M.Map as >>

-- | One radar serie. Actually just data for echarts radar series
type RadarSerie =
  { name ∷ Maybe String
  , items ∷ String >> Number
  }

-- | All series that are drawn on one radar
type SeriesOnRadar =
  { name ∷ Maybe String
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , radius ∷ Maybe Number
  , series ∷ Array RadarSerie
  }

buildRadarData ∷ RadarR → JArray → Array SeriesOnRadar
buildRadarData r records = series
  where
  -- | maybe parallel >> maybe multiple series >> category name >> values
  dataMap ∷ Maybe String >> Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> String >> Array Number
    → Json
    → Maybe String >> Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    case toString =<< cursorGet r.category js of
      Nothing → acc
      Just categoryKey →
        let
          mbParallel = toString =<< flip cursorGet js =<< r.parallel
          mbMultiple = toString =<< flip cursorGet js =<< r.multiple
          values = foldMap A.singleton $ toNumber =<< cursorGet r.value js

          alterParallelFn
            ∷ Maybe (Maybe String >> String >> Array Number)
            → Maybe (Maybe String >> String >> Array Number)
          alterParallelFn Nothing =
            Just $ M.singleton mbMultiple $ M.singleton categoryKey values
          alterParallelFn (Just multiple) =
            Just $ M.alter alterMultipleFn mbMultiple multiple

          alterMultipleFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterMultipleFn Nothing =
            Just $ M.singleton categoryKey values
          alterMultipleFn (Just category) =
            Just $ M.alter alterCategoryFn categoryKey category

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
         M.alter alterParallelFn mbParallel acc

  unpositionedSeries ∷ Array SeriesOnRadar
  unpositionedSeries =
    foldMap mkSeriesOnRadar $ M.toList dataMap

  mkSeriesOnRadar
    ∷ Maybe String × (Maybe String >> String >> Array Number)
    → Array SeriesOnRadar
  mkSeriesOnRadar (name × seriesData) =
    [{ name
     , x: Nothing
     , y: Nothing
     , radius: Nothing
     , series: foldMap mkMultipleSeries $ M.toList seriesData
     }]

  mkMultipleSeries
    ∷ Maybe String × (String >> Array Number)
    → Array RadarSerie
  mkMultipleSeries (name × itemsData) =
    [{ name
     , items: map (Ag.runAggregation r.valueAggregation) itemsData
     }]

  series ∷ Array SeriesOnRadar
  series =
    let
      len = A.length unpositionedSeries

      itemsInRow
        | len < 2 = 1
        | len < 5 = 2
        | len < 10 = 3
        | otherwise = 4

      numRows =
        Int.ceil $ Int.toNumber len / Int.toNumber itemsInRow

      topStep =
        90.0 / Int.toNumber numRows

      setPositions
        ∷ Array SeriesOnRadar
        → Int
        → Int
        → Int
        → Array SeriesOnRadar
        → Array SeriesOnRadar
      setPositions acc colIx rowIx inThisRow arr = case A.uncons arr of
        Nothing → acc
        Just {head, tail} →
          let
            top = topStep * ((Int.toNumber rowIx) + 0.5) + 5.0

            leftStep = 90.0 / Int.toNumber inThisRow

            left = leftStep * ((Int.toNumber colIx) + 0.5) + 5.0

            toPush =
              head { x = Just left
                   , y = Just top
                   , radius = Just $ 90.0 / Int.toNumber itemsInRow
                   }

            newAcc = A.snoc acc toPush

            newColIx
              | one + colIx < inThisRow = colIx + one
              | otherwise = zero

            newRowIx
              | newColIx ≡ zero = rowIx + one
              | otherwise = rowIx

            inNewRow
              | A.length tail > itemsInRow = itemsInRow
              | newColIx ≠ zero = itemsInRow
              | otherwise = A.length tail
          in
            setPositions newAcc newColIx newRowIx inNewRow tail
    in
      setPositions [ ] 0 0 itemsInRow unpositionedSeries

buildRadar ∷ RadarR → JArray → DSL OptionI
buildRadar r records = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem serieNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu, sans"

  E.colors colors

  E.titles
    $ traverse_ E.title titles

  E.radars
    $ traverse_ E.radar radars

  E.series
    $ traverse_ E.radarSeries series

  where
  radarData ∷ Array SeriesOnRadar
  radarData = buildRadarData r records

  serieNames ∷ Array String
  serieNames =
    A.fromFoldable
      $ foldMap (_.series
                 ⋙ foldMap (_.name
                            ⋙ (foldMap Set.singleton)))
        radarData

  titles ∷ Array (DSL ETP.TitleI)
  titles = [ ]

  series ∷ Array (DSL ETP.RadarSeriesI)
  series = [ ]

  radars ∷ Array (DSL ETP.RadarI)
  radars = [ ]

module SlamData.Workspace.Card.BuildChart.Radar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Radar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, JCursor, Json, cursorGet, toNumber, toString)
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?))
import Data.Lens as Lens
import Data.Map as M
import Data.Int as Int

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.BuildChart.Radar.Model (Model, RadarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Radar))
import SlamData.Workspace.Card.Chart.Aggregation as Ag
import SlamData.Workspace.Card.Chart.Axis (Axis, Axes, analyzeJArray)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.BuildOptions.ColorScheme (colors)
import SlamData.Workspace.Card.Chart.Semantics as Sem
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  numRecords ←
    CET.liftQ $ QQ.count resource

  when (numRecords > 10000)
    $ QE.throw
    $ "The 10000 record limit for visualizations has been exceeded - the current dataset contains "
    ⊕ show numRecords
    ⊕ " records. "
    ⊕ "Please consider using a 'limit' or 'group by' clause in the query to reduce the result size."

  records ←
    CET.liftQ $ QQ.all resource

  pure $ Port.ChartInstructions (buildRadar conf records) Radar

buildRadar ∷ RadarR → JArray → DSL OptionI
buildRadar r records = do
  pure unit


Remove unused Prelude import

Remove unused Prelude import

module Control.Monad.ST where

import Control.Monad.Eff (Eff(), runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not
-- | "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef s a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef
  :: forall a h r
   . a
  -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef
  :: forall a h r
   . STRef h a
  -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the
-- | current value.
foreign import modifySTRef
  :: forall a h r
   . STRef h a -> (a -> a)
  -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef
  :: forall a h r
   . STRef h a
  -> a
  -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom
-- | type `s`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The
-- | recommended approach is to use parentheses instead.
foreign import runST
  :: forall a r
   . (forall h. Eff (st :: ST h | r) a)
  -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be
-- | used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply
-- | this function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
pureST :: forall a. (forall h. Eff (st :: ST h) a) -> a
pureST st = runPure (runST st)

module Control.Monad.ST where

import Prelude

import Control.Monad.Eff (Eff(), runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the current value.
foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
-- | is to use parentheses instead.
pureST :: forall a. (forall h. Eff (st :: ST h) a) -> a
pureST st = runPure (runST st)


OMFG ‘text’ was shadowed

OMFG ‘text’ was shadowed

this is a good example of an opportunity for error message enhancement

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (D3Element, Index, PolyValue(SetByIndex, Value), DataBind(Keyed), AttrSetter(AttrFn, SetAttr), D3, Eff, (...), (..), transparent, opaque)
import D3.Transitions (tRemove, AttrInterpolator(TweenFn, Target), tStyle, tAttr, savedTransition, TransitionName(..), duration, d3Transition)
import Data.String (toCharArray)
import Prelude (class Show, negate, Unit, unit, pure, bind, (-), (<>), (/), (*), ($), show)

suq :: ∀ d eff. Show d => d -> Index -> Eff (d3::D3|eff) String
suq d _ = pure $ show d

tweener :: ∀ d eff. d -> Index -> D3Element -> Eff (d3::D3|eff) (Number -> Number)
tweener d i e = pure jud

jud :: Number -> Number  -- this func duplicates the D3 documentation example shown in comment below
jud i = i * 32.0

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

updateFn :: forall d eff. Array d -> Selection d -> Eff (d3::D3|eff) Unit
updateFn d g = do
  -- | set up the transition that we'll use between phases
  t <- d3Transition (Name "t")
    .. duration 750.0

  -- || JOIN new data with old elements
  myText <- g ... selectAll "text"
    .. dataBind (Keyed d (\d -> d))

  -- || EXIT old elements not present in new data
  exit <- myText ... exit
        .. attr "class" (SetAttr "exit")
      .. savedTransition t
        .. tAttr "y"     (Target 60.0)
        .. tStyle "fill-opacity" (Target transparent)
        .. tRemove

  -- || UPDATE old elements present in new data
  update <- myText ... attr "class" (SetAttr "update")
      .. attr "y" (SetAttr 0.0)
      .. style "fill-opacity" (Value opaque)
    .. savedTransition t
      .. tAttr "x" (TweenFn tweener)

  -- || ENTER new elements present in new data
  enter <- myText ... enter .. append "text"
      .. attr "class" (SetAttr "enter")
      .. attr "dy"    (SetAttr ".35em")
      .. attr "y"     (SetAttr (negate 60.0))
      .. attr "x"     (AttrFn (\d i n e -> pure (show (i * 32.0))))
      .. style "fill-opacity" (Value transparent)
      .. text (Value "foo")

  enter  ... savedTransition t
      .. tAttr "y" (Target 0.0)
      .. tStyle "fill-opacity" (Target opaque)

  pure unit

alphabet :: Array Char
alphabet = toCharArray "abcdefghijklmnopqrstuvwxyz"

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
-- general setup
  svg <- d3Select ".svg"
  w   <- svg ... getAttr "width"
  h   <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  g <- svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(32," <> show (height / 2.0) <> ")"))

  updateFn alphabet g

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (DataBind(Keyed), AttrSetter(SetAttr), D3, Eff, (...), (..))
import D3.Transitions (TransitionName(..), duration, d3Transition)
import Data.String (toCharArray)
import Prelude (Unit, unit, pure, bind, (-), (<>), (/), show)

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

update :: forall d eff. Array d -> Selection d -> Eff (d3::D3|eff) Unit
update d g = do
  -- | set up the transition that we'll use between phases
  t <- d3Transition (Name "t")
    .. duration 750.0

  -- || JOIN new data with old elements
  text <- g ... selectAll "text"
    .. dataBind (Keyed d (\d -> d))

  -- || EXIT old elements not present in new data
  -- || UPDATE old elements present in new data
  -- || ENTER new elements present in new data

  pure unit

alphabet :: Array Char
alphabet = toCharArray "abcdefghijklmnopqrstuvwxyz"

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
-- general setup
  svg <- d3Select ".svg"
  w   <- svg ... getAttr "width"
  h   <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  g <- svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(32," <> show (height / 2.0) <> ")"))

  update alphabet g

  pure unit


Write stateful fetchToCanvas

Write stateful fetchToCanvas

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 30.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

type TrackState = Array (Tuple (Feature Bp Number) (Glyph Unit))

fetchToCanvas' :: Number
               -> (View -> Fetch _)
               -> View
               -> Context2D
               -> StateT TrackState (Aff _) Unit
fetchToCanvas' h f v ctx = do
  features <- liftAff $ f v
  let gs :: TrackState
      gs = map (\f -> Tuple f (glyphify h v f)) features
  put gs
  liftEff $ renderGlyph ctx $ traverse_ snd gs
foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs gs p = filter pred gs
  where pred = \g -> unwrap (glyphBounds g) p
browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w} <- liftEff $ getScreenSize
  h <- liftEff $ getCanvasHeight canvas
  _ <- liftEff $ setCanvasWidth (w-2.0) canvas
  backCanvas <- liftEff $ newCanvas {w,h}

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      -- f = fetchWithView 100

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch & draw
    clearCanvas canvas
    _ <- launchAff $ fetchToCanvas h f v' ctx
    -- update other UI elements
    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 30.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs gs p = filter pred gs
  where pred = \g -> unwrap (glyphBounds g) p
browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w} <- liftEff $ getScreenSize
  h <- liftEff $ getCanvasHeight canvas
  _ <- liftEff $ setCanvasWidth (w-2.0) canvas
  backCanvas <- liftEff $ newCanvas {w,h}

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      -- f = fetchWithView 100

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch & draw
    clearCanvas canvas
    _ <- launchAff $ fetchToCanvas h f v' ctx
    -- update other UI elements
    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser


Add theImpossibleHappened

Add theImpossibleHappened

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Error
-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Language.PureScript.Errors where

import Prelude.Unsafe (unsafeIndex)
import Data.Array
import qualified Data.Array.Unsafe as Unsafe
import Data.String (joinWith)
import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Monoid.Last
import Data.Foldable (mconcat)

import Control.Monad.Error
import Control.Monad.Error.Class

import Language.PureScript.Declarations
{- import Language.PureScript.Pretty -}
import Language.PureScript.Types

-- |
-- Type for sources of type checking errors
--
data ErrorSource
  -- |
  -- An error which originated at a Value
  --
  = ValueError Value
  -- |
  -- An error which originated at a Type
  --
  | TypeError Type

instance showErrorSource :: Show ErrorSource where
  show (ValueError v) = "ValueError (" ++ show v ++ ")"
  show (TypeError t) = "TypeError (" ++ show t ++ ")"

-- |
-- Compilation errors
--
data CompileError = CompileError {
    -- |
    -- Error message
    --
    compileErrorMessage :: String
    -- |
    -- The value where the error occurred
    --
  , compileErrorValue :: Maybe ErrorSource
    -- |
    -- Optional source position information
    --
  , compileErrorPosition :: Maybe SourcePos
  }

mkCompileError :: String -> Maybe ErrorSource -> Maybe SourcePos -> CompileError
mkCompileError compileErrorMessage compileErrorValue compileErrorPosition =
  CompileError { compileErrorMessage: compileErrorMessage
	             , compileErrorValue: compileErrorValue
							 , compileErrorPosition: compileErrorPosition
							 }

instance showCompileError :: Show CompileError where
  show (CompileError o) = "CompileError {" ++
    "compileErrorMessage: " ++  show o.compileErrorMessage ++
    "compileErrorValue: " ++    show o.compileErrorValue ++
    "compileErrorPosition: " ++ show o.compileErrorPosition ++
	  "}"

-- |
-- A stack trace for an error
--
data ErrorStack = ErrorStack [CompileError]

runErrorStack :: ErrorStack -> [CompileError]
runErrorStack (ErrorStack es) = es

instance showErrorStack :: Show ErrorStack where
  show (ErrorStack es) = "ErrorStack (" ++ show es ++ ")"

instance semigroupErrorStack :: Semigroup ErrorStack where
  (<>) (ErrorStack es1) (ErrorStack es2) = ErrorStack (es1 <> es2)

instance monoidErrorStack :: Monoid ErrorStack where
  mempty = ErrorStack []

instance errorErrorStack :: Error ErrorStack where
  strMsg s = ErrorStack [mkCompileError s Nothing Nothing]
  noMsg = ErrorStack []

prettyPrintErrorStack :: Boolean -> ErrorStack -> String
prettyPrintErrorStack printFullStack (ErrorStack es) =
  case mconcat $ map (\(CompileError o) -> Last o.compileErrorPosition) es of
    Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
    _ -> prettyPrintErrorStack'
  where

    prettyPrintErrorStack' :: String
    prettyPrintErrorStack' =
		  if printFullStack
	    then
		  	joinWith "\n" (map showError (filter isErrorNonEmpty es))
      else
		  	let
          es' = filter isErrorNonEmpty es
        in case length es' of
          1 -> showError (Unsafe.head es')
          _ -> showError (Unsafe.head es') ++ "\n" ++ showError (unsafeLast es')

-- TODO: move this to Data.Array.Unsafe
unsafeLast :: forall a. [a] -> a
unsafeLast xs = unsafeIndex xs (length xs - 1)

stringifyErrorStack :: forall a. Boolean -> Either ErrorStack a -> Either String a
stringifyErrorStack printFullStack = either (Left <<< prettyPrintErrorStack printFullStack) Right

isErrorNonEmpty :: CompileError -> Boolean
isErrorNonEmpty (CompileError { compileErrorMessage = "" }) = false
isErrorNonEmpty _ = true

showError :: CompileError -> String
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Nothing }) = msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (ValueError val) }) = "Error in value " ++ {- prettyPrintValue -} show val ++ ":\n" ++ msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (TypeError ty) }) = "Error in type " ++ {- prettyPrintType -} show ty ++ ":\n" ++ msg

mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [mkCompileError msg t Nothing]

positionError :: SourcePos -> ErrorStack
positionError pos = ErrorStack [mkCompileError "" Nothing (Just pos)]

-- |
-- Rethrow an error with a more detailed error message in the case of failure
--
rethrow :: forall e m a. (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)

-- |
-- Rethrow an error with source position information
--
rethrowWithPosition :: forall m a. (MonadError ErrorStack m) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow ((<>) (positionError pos))

-- |
-- Throw a runtime error for a situation where something unexpected (and
-- supposedly impossible) happened
--
foreign import theImpossibleHappened
  "function theImpossibleHappened(msg) {\
  \  throw new Error(msg);\
  \}" :: forall a. String -> a