Split into lines

Split into lines

module Scansion where

import Prelude
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import CSS (ex, fromHexString, rgba, nil)
import CSS.Common (auto)
import CSS.Transform (transform, translate)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (evalStateT, get, put)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement)
import Data.Array (reverse, mapWithIndex, filter) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Identity (Identity(..))
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust)
import Data.String (Pattern(..), indexOf, joinWith, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, test, split)
import Data.String.Regex.Flags (global, ignoreCase)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.Traversable (sequence)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import UIHelpers (textarea, (/>), scale, no_user_select, spacer, zindex, no_pointer_events)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

class HalogenDisplay displayable where
    display :: forall a b. displayable -> HH.HTML a b

instance displayLine :: HalogenDisplay Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ map mapper line
            divstyle = style do
                CSS.height (1.0#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = HH.br_
            mapper (Punct s) = spacer $ HH.text s
            mapper (Verb { syllables, gloss }) =
                HH.span_ $ map display syllables

y_mark =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center

instance displaySyllable :: HalogenDisplay Syllable where
    display (Syllable { value, stype }) =
        HH.div
            [ style do
                CSS.display CSS.inlineBlock
                CSS.height nil
            ]
            [ HH.div [ y_mark ] [ HH.text $ show stype ]
            , spacer $ HH.text value
            ]

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

ugly :: forall i r. Array (State i r) -> i -> Array r
ugly monad init =
    case evalStateT (sequence monad) init of
        Identity res -> res

ugly2 :: forall i r. Array (State i r) -> i -> Array r
ugly2 monad init =
    case evalStateT (sequence (Array.reverse monad)) init of
        Identity res -> Array.reverse res

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype}) _ = stype
{-
reform syllable bias =
    case bias of
        Elidable | test r_elision syllable.value ->
            Elided
        IntoDoubleConsonant ->
            Long
        _ -> case syllable.stype of
            Short
                | bias == LineEnd ->
                    Ambiguous Nothing
            Ambiguous Nothing
                | bias == IntoVowel
                || bias == Elidable ->
                    Ambiguous $ Just false
                | bias == IntoConsonant ->
                    Ambiguous $ Just true
            st -> st
-}

inner :: Syllable -> State ScanBias Syllable
inner syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = reform syllable bias
    pure (Syllable { value, stype })

middle :: Array Syllable -> State ScanBias (Array Syllable)
middle syllables = map Array.reverse $ sequence $ Array.reverse $ map inner syllables

outer :: Res -> State ScanBias Res
outer (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer (res@Punct "\n") = do
    put LineEnd
    pure res
outer res = pure res

rescan :: Line -> Line
rescan (Line line) = Line $ ugly2 (map outer line) LineEnd

v :: String
v =
    "(?:(?:a[eu]|oe)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: String -> Line
mkline content =
    content # mkwords # Array.filter nonempty # Line # rescan
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: String -> Array Line
mklines content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

prescanned :: Line
prescanned = Line $ mkwords "arma virumque canō, Trōjae quī prīmus ab ōrīs"

rescanned :: Line
rescanned = rescan prescanned

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { on :: Boolean
    , text :: String
    }

initialState :: UIState
initialState =
    { on: false
    , text: "arma virumque canō, Trōjae quī prīmus ab ōrīs"
    }

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        ([ HH.h2_/>"Pantheum"
        , textarea (HE.input UserInput) [] "Text to scan" 5 state.text
        , HH.br_
        ] <> (map (display <<< mkline) $ String.split (Pattern "\n") state.text))

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body

module Scansion where

import Prelude
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import CSS (ex, fromHexString, rgba, nil)
import CSS.Common (auto)
import CSS.Transform (transform, translate)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (evalStateT, get, put)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement)
import Data.Array (reverse, mapWithIndex, filter) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Identity (Identity(..))
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust)
import Data.String (Pattern(..), indexOf, joinWith, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, test, split)
import Data.String.Regex.Flags (global, ignoreCase)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.Traversable (sequence)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import UIHelpers (textarea, (/>), scale, no_user_select, spacer, zindex, no_pointer_events)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

class HalogenDisplay displayable where
    display :: forall a b. displayable -> HH.HTML a b

instance displayLine :: HalogenDisplay Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ map mapper line
            divstyle = style do
                CSS.height (1.0#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = HH.br_
            mapper (Punct s) = spacer $ HH.text s
            mapper (Verb { syllables, gloss }) =
                HH.span_ $ map display syllables

y_mark =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center

instance displaySyllable :: HalogenDisplay Syllable where
    display (Syllable { value, stype }) =
        HH.div
            [ style do
                CSS.display CSS.inlineBlock
                CSS.height nil
            ]
            [ HH.div [ y_mark ] [ HH.text $ show stype ]
            , spacer $ HH.text value
            ]

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

ugly :: forall i r. Array (State i r) -> i -> Array r
ugly monad init =
    case evalStateT (sequence monad) init of
        Identity res -> res

ugly2 :: forall i r. Array (State i r) -> i -> Array r
ugly2 monad init =
    case evalStateT (sequence (Array.reverse monad)) init of
        Identity res -> Array.reverse res

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype}) _ = stype
{-
reform syllable bias =
    case bias of
        Elidable | test r_elision syllable.value ->
            Elided
        IntoDoubleConsonant ->
            Long
        _ -> case syllable.stype of
            Short
                | bias == LineEnd ->
                    Ambiguous Nothing
            Ambiguous Nothing
                | bias == IntoVowel
                || bias == Elidable ->
                    Ambiguous $ Just false
                | bias == IntoConsonant ->
                    Ambiguous $ Just true
            st -> st
-}

inner :: Syllable -> State ScanBias Syllable
inner syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = reform syllable bias
    pure (Syllable { value, stype })

middle :: Array Syllable -> State ScanBias (Array Syllable)
middle syllables = map Array.reverse $ sequence $ Array.reverse $ map inner syllables

outer :: Res -> State ScanBias Res
outer (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer (res@Punct "\n") = do
    put LineEnd
    pure res
outer res = pure res

rescan :: Line -> Line
rescan (Line line) = Line $ ugly2 (map outer line) LineEnd

v :: String
v =
    "(?:(?:a[eu]|oe)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: String -> Line
mkline content =
    content # mkwords # Array.filter nonempty # Line # rescan
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: String -> Array Line
mklines content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

prescanned :: Line
prescanned = Line $ mkwords "arma virumque canō, Trōjae quī prīmus ab ōrīs"

rescanned :: Line
rescanned = rescan prescanned

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { on :: Boolean
    , text :: String
    }

initialState :: UIState
initialState =
    { on: false
    , text: "arma virumque canō, Trōjae quī prīmus ab ōrīs"
    }

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum"
        , textarea (HE.input UserInput) [] "Text to scan" 5 state.text
        , HH.br_
        , display $ mkline state.text
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body


Add some examples to intercalate documentation

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap identity

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (a -> b -> m a) -> a -> f b -> m a
foldM f a0 = foldl (\ma b -> ma >>= flip f b) (pure a0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ identity

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > intercalate ", " ["Lorem", "ipsum", "dolor"]
-- | = "Lorem, ipsum, dolor"
-- |
-- | > intercalate "*" ["a", "b", "c"]
-- | = "a*b*c"
-- | ```
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d identity

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all identity

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any identity

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor a =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go a cursor =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap identity

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (a -> b -> m a) -> a -> f b -> m a
foldM f a0 = foldl (\ma b -> ma >>= flip f b) (pure a0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ identity

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d identity

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all identity

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any identity

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor a =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go a cursor =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero


Lock browser view to coord sys

Lock browser view to coord sys

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, Producer, connect, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap, lmap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, for_, length, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant)
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

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

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: 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 :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "17103129"
      , Tuple "Y"   "9174469"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewState   :: AVar BrowserState
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ _)}
           -> Aff _ _
renderLoop cSys browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      tracks = browser.tracks vState.visible

  liftEff do
    log $ "current scale: " <> show scale <> " bps/pixel"

  renderer <- forkAff $ renderGlyphs vState.visible scale tracks canvases

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay
    Drawing.render trackCtx $ browser.relativeUI vState.visible
    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

      -- update view using received cmd, limiting view to coordsys
  let (Pair l' r') = updateViewFold cmd vState.visible
      newState =
        Pair (max zero l')
             (min (max r'  -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                      (l' + BigInt.fromInt 400))
                  (cSys^._TotalSize))

  putVar { visible: newState } state.viewState

  liftEff $ log $ "new view: " <> show newState

  pure unit

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  {width, height} <- liftEff $ Canvas.getCanvasDimensions canvases.track
  let bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  trackCtx   <- liftEff $ getContext2D canvases.track
  overlayCtx <- liftEff $ getContext2D canvases.overlay

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  liftEff do
    log $ "offset: " <> show offset
    log $ "pixels view: " <> show vw'
    Drawing.render trackCtx bg

  -- Shift canvas so we render to the visible part
  void $ liftEff $ Canvas.translate { translateX: (-offset), translateY: zero } trackCtx

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
  let pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      predB p = p.x - 10.0 > pxL'
             && p.x + 10.0 < pxR'
      predS s = s.width >= one
             && s.point.x - s.width > pxL'
             && s.point.x + s.width < pxR'

  for_ (List.reverse ts) \segs -> do
    liftEff $ foreachE segs $ case _ of

      Left {drawing, points}  -> do
        let points' = filter predB points
        -- log $ "rendering " <> show (Array.length points') <> " glyphs, out of " <> show (Array.length points)
        renderBatch canvases.buffer {drawing, points: points'} trackCtx

      Right gs -> do
        let gs' = filter predS gs
        -- log $ "rendering " <> show (Array.length gs') <> " glyphs, out of " <> show (Array.length gs)
        foreachE gs' \s ->
          Drawing.render trackCtx
            $ Drawing.translate s.point.x s.point.y
            $ s.drawing

  void $ liftEff $ Canvas.translate { translateX: offset, translateY: zero } trackCtx

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

-- browserLoopN :: CoordSys _ _
--              -> BrowserCanvas
--              ->

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 40.0
      legendWidth = 100.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    maybe
      (throwError $ error "Could not find browser element")
      (\el -> liftEff $ createBrowserCanvas el browserDimensions)
      cont

  trackData <- do
    genes <- traverse (getBedGenes cSys) (Just "./mouse.json")
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, Producer, connect, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap, lmap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, for_, length, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant)
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

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

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: 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 :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "17103129"
      , Tuple "Y"   "9174469"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

browserLoop :: { tracks     :: Pair BigInt -> List (Array RenderedTrack)
               , relativeUI :: Pair BigInt -> Drawing
               , fixedUI :: Drawing }
            -> Number
            -> BrowserCanvas
            -> { viewState   :: AVar BrowserState
               , viewCmds    :: AVar UpdateView
               , renderFiber :: AVar (Fiber _ _)}
            -> Aff _ _
browserLoop browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      tracks = browser.tracks vState.visible

  liftEff do
    log $ "current scale: " <> show scale <> " bps/pixel"

  renderer <- forkAff $ renderGlyphs vState.visible scale tracks canvases

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay
    Drawing.render trackCtx $ browser.relativeUI vState.visible
    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

  let newState = updateViewFold cmd vState.visible

  putVar { visible: newState } state.viewState

  liftEff $ log $ "new view: " <> show newState

  pure unit

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  {width, height} <- liftEff $ Canvas.getCanvasDimensions canvases.track
  let bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  trackCtx   <- liftEff $ getContext2D canvases.track
  overlayCtx <- liftEff $ getContext2D canvases.overlay

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  liftEff do
    log $ "offset: " <> show offset
    log $ "pixels view: " <> show vw'
    Drawing.render trackCtx bg

  -- Shift canvas so we render to the visible part
  void $ liftEff $ Canvas.translate { translateX: (-offset), translateY: zero } trackCtx

  -- Predicates to filter out glyphs that would not be visible on screen
  let predB p = p.x - 10.0 > pxL
             && p.x + 10.0 < pxR
      predS s = s.width >= one
             && s.point.x - s.width > pxL
             && s.point.x + s.width < pxR

  for_ (List.reverse ts) \segs -> do
    liftEff $ foreachE segs $ case _ of

      Left {drawing, points}  -> do
        let points' = filter predB points
        log $ "rendering " <> show (Array.length points') <> " glyphs, out of " <> show (Array.length points)
        renderBatch canvases.buffer {drawing, points: points'} trackCtx

      Right gs -> do
        let gs' = filter predS gs
        log $ "rendering " <> show (Array.length gs') <> " glyphs, out of " <> show (Array.length gs)
        foreachE gs' \s ->
          Drawing.render trackCtx
            $ Drawing.translate s.point.x s.point.y
            $ s.drawing

  void $ liftEff $ Canvas.translate { translateX: offset, translateY: zero } trackCtx

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

-- browserLoopN :: CoordSys _ _
--              -> BrowserCanvas
--              ->

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 40.0
      legendWidth = 100.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    maybe
      (throwError $ error "Could not find browser element")
      (\el -> liftEff $ createBrowserCanvas el browserDimensions)
      cont

  trackData <- do
    genes <- traverse (getBedGenes cSys) (Just "./mouse.json")
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ browserLoop mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  {-
  prod <- produceBed "./mouse.json"

  res <- makeVar []
  let cnsm = bedConsumer res

  let prcs :: Process (Aff _) Unit
      prcs = prod `connect` cnsm

  liftEff $ log "starting process"

  _ <- forkAff do
    runProcess prcs
    bedData <- readVar res
    liftEff $ log $ "process complete, loaded: " <> show (Array.length bedData) <> " lines"
  -}

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c