Add download property

Add download property

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , download

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

download :: ∀ r i. String -> IProp (download :: String | r) i
download = prop (PropName "download")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")


Save parsed elementsUri of CyGraphConfig

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , CyGraphConfig
       , TracksMap
       , validateConfigs
       , TrackType(..)
       , readTrackType
       , validateBDConfig
       , validateCyConfig
       )
       where

import Prelude

import Data.Argonaut (Json, _Array, _Object, _String)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Foldable (foldr)
import Data.Foreign (Foreign, toForeign)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.Traversable (sequence)

newtype TracksMap = TracksMap (StrMap Json)

getConfigs :: TracksMap -> TrackType -> Either String (Array Json)
getConfigs (TracksMap ts) tt =
  maybe (Left "Incorrect trackType") Right $ ts ^? ix (show tt) <<< _Array

data TrackType = BDTrack | CyGraph

derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType
derive instance genericTrackType :: Generic TrackType _

instance showTrackType :: Show TrackType where
  show BDTrack = "BDTrack"
  show CyGraph = "CyGraph"

readTrackType :: String -> Maybe TrackType
readTrackType "BDTrack" = Just BDTrack
readTrackType "CyGraph" = Just CyGraph
readTrackType _ = Nothing

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)

newtype BDTrackConfig = BDTrackConfig Json

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object <<< ix "name" of
  Nothing -> Left $ "BD track config does not have a name"
  Just c  -> Right $ BDTrackConfig $ json

newtype CyGraphConfig = CyGraphConfig { elementsUri :: String }
derive instance newtypeCyGraphConfig :: Newtype CyGraphConfig _

validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = case json ^? _Object <<< ix "elementsUri"  <<< _String of
  Nothing  -> Left $ "cy graph config does not have an elementsUri"
  Just uri -> Right $ CyGraphConfig { elementsUri: uri }

type ValidatedConfigs a = { errors :: Array String
                          , results :: Array a
                          }

foldErrors :: forall e r
            . Array (Either e r)
           -> { errors :: Array e
              , results :: Array r
              }
foldErrors = foldr (\c er@{errors, results} ->
                                case c of Left  e -> er { errors  = (e : errors)}
                                          Right r -> er { results = (r : results)}
                   ) { errors: [], results: [] }

foldConfig :: forall a
             . TracksMap
            -> TrackType
            -> (Json -> Either String a)
            -> ValidatedConfigs a
foldConfig tm tt f = foldErrors $ map (_ >>= f) $ sequence $ getConfigs tm tt

validateConfigs :: TracksMap
                -> { bdTracks :: ValidatedConfigs BDTrackConfig
                   , cyGraphs :: ValidatedConfigs CyGraphConfig
                   }
validateConfigs tm = { bdTracks
                     , cyGraphs
                     }
  where bdTracks = foldConfig tm BDTrack validateBDConfig
        cyGraphs = foldConfig tm CyGraph validateCyConfig

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , CyGraphConfig
       , TracksMap
       , validateConfigs
       , TrackType(..)
       , readTrackType
       , validateBDConfig
       , validateCyConfig
       )
       where

import Prelude
import Data.Argonaut (Json, _Array, _Object, _String)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Foldable (foldr)
import Data.Foreign (Foreign, toForeign)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), maybe)
import Data.StrMap (StrMap)
import Data.Traversable (sequence)

newtype TracksMap = TracksMap (StrMap Json)

getConfigs :: TracksMap -> TrackType -> Either String (Array Json)
getConfigs (TracksMap ts) tt =
  maybe (Left "Incorrect trackType") Right $ ts ^? ix (show tt) <<< _Array

data TrackType = BDTrack | CyGraph

derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType
derive instance genericTrackType :: Generic TrackType _

instance showTrackType :: Show TrackType where
  show BDTrack = "BDTrack"
  show CyGraph = "CyGraph"

readTrackType :: String -> Maybe TrackType
readTrackType "BDTrack" = Just BDTrack
readTrackType "CyGraph" = Just CyGraph
readTrackType _ = Nothing

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)

newtype BDTrackConfig = BDTrackConfig Json

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object <<< ix "name" of
  Nothing -> Left $ "BD track config does not have a name"
  Just c  -> Right $ BDTrackConfig $ json

newtype CyGraphConfig = CyGraphConfig Json

validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = case json ^? _Object <<< ix "elementsUri" of
  Nothing -> Left $ "cy graph config does not have an elementsUri"
  Just c  -> Right $ CyGraphConfig $ json

type ValidatedConfigs a = { errors :: Array String
                          , results :: Array a
                          }

foldErrors :: forall e r
            . Array (Either e r)
           -> { errors :: Array e
              , results :: Array r
              }
foldErrors = foldr (\c er@{errors, results} ->
                                case c of Left  e -> er { errors  = (e : errors)}
                                          Right r -> er { results = (r : results)}
                   ) { errors: [], results: [] }

foldConfig :: forall a
             . TracksMap
            -> TrackType
            -> (Json -> Either String a)
            -> ValidatedConfigs a
foldConfig tm tt f = foldErrors $ map (_ >>= f) $ sequence $ getConfigs tm tt

validateConfigs :: TracksMap
                -> { bdTracks :: ValidatedConfigs BDTrackConfig
                   , cyGraphs :: ValidatedConfigs CyGraphConfig
                   }
validateConfigs tm = { bdTracks
                     , cyGraphs
                     }
  where bdTracks = foldConfig tm BDTrack validateBDConfig
        cyGraphs = foldConfig tm CyGraph validateCyConfig


Fix typo

Fix typo

Close quotes to make documentation display correctly

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/))
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
import Data.Unit (Unit)

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = 0` for all `a` and `b` ``
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number
instance fieldUnit :: Field Unit

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/))
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
import Data.Unit (Unit)

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = 0` for all `a` and `b`
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number
instance fieldUnit :: Field Unit


Remove unused fileinput imports

Remove unused fileinput imports

module App.State.FileInputs where

import Prelude

import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import Data.Array (fromFoldable, head)
import Data.Either (Either(..))
import Data.Foreign (renderForeignError)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (traverse)
import Lib.Files (FileMeta, getFilesFromEvent)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (DOMEvent)

data Event =
  NoFile |
  NewFile FileMeta |
  FileError (Array String)

type State = Unit

type Effects eff =
  ( dom :: DOM
  , console :: CONSOLE
    | eff
    )

foldp ::
  forall eff.
  Event ->
  State ->
  EffModel State Event (Effects eff)
foldp (FileError err) state =
  onlyEffects state $ [ (traverse log err) *> pure Nothing ]
foldp _ state = noEffects $ state

newFilesEvent :: DOMEvent -> Event
newFilesEvent domEvent =
  case readFiles of
    Left errors ->
      FileError $ fromFoldable $ renderForeignError <$> errors
    Right files ->
      maybe NoFile (\f -> NewFile f) $ head files
  where
    readFiles = runExcept $ getFilesFromEvent domEvent

module App.State.FileInputs where

import Prelude

import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.Event (preventDefault)
import Data.Array (fromFoldable, head)
import Data.Either (Either(..))
import Data.Foreign (renderForeignError)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (traverse)
import Lib.Files (FileMeta, getFilesFromEvent)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (DOMEvent)

data Event =
  NoFile |
  NewFile FileMeta |
  FileError (Array String)

type State = Unit

type Effects eff =
  ( dom :: DOM
  , console :: CONSOLE
    | eff
    )

foldp ::
  forall eff.
  Event ->
  State ->
  EffModel State Event (Effects eff)
foldp (FileError err) state =
  onlyEffects state $ [ (traverse log err) *> pure Nothing ]
foldp _ state = noEffects $ state

newFilesEvent :: DOMEvent -> Event
newFilesEvent domEvent =
  case readFiles of
    Left errors ->
      FileError $ fromFoldable $ renderForeignError <$> errors
    Right files ->
      maybe NoFile (\f -> NewFile f) $ head files
  where
    readFiles = runExcept $ getFilesFromEvent domEvent


createImageData should yield the created data

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , fillRect
  , strokeRect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , textAlign
  , setTextAlign
  , font
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | FillRect             C.Rectangle more
  | StrokeRect           C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | TextAlign            (C.TextAlign -> more)
  | SetTextAlign         C.TextAlign more
  | Font                 (String -> more)
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      (C.ImageData -> more)
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

fillRect :: C.Rectangle -> Graphics Unit
fillRect r = liftFC $ FillRect r unit

strokeRect :: C.Rectangle -> Graphics Unit
strokeRect r = liftFC $ StrokeRect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

textAlign :: Graphics C.TextAlign
textAlign = liftFC $ TextAlign id

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

font :: Graphics String
font = liftFC $ Font id

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics C.ImageData
createImageData w h = liftFC $ CreateImageData w h id

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (FillRect r a)                         = const a <$> C.fillRect ctx r
  interp (StrokeRect r a)                       = const a <$> C.strokeRect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (TextAlign k)                          = k <$> C.textAlign ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (Font k)                               = k <$> C.font ctx
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h k)                = k <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , fillRect
  , strokeRect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , textAlign
  , setTextAlign
  , font
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | FillRect             C.Rectangle more
  | StrokeRect           C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | TextAlign            (C.TextAlign -> more)
  | SetTextAlign         C.TextAlign more
  | Font                 (String -> more)
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      more
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

fillRect :: C.Rectangle -> Graphics Unit
fillRect r = liftFC $ FillRect r unit

strokeRect :: C.Rectangle -> Graphics Unit
strokeRect r = liftFC $ StrokeRect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

textAlign :: Graphics C.TextAlign
textAlign = liftFC $ TextAlign id

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

font :: Graphics String
font = liftFC $ Font id

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (FillRect r a)                         = const a <$> C.fillRect ctx r
  interp (StrokeRect r a)                       = const a <$> C.strokeRect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (TextAlign k)                          = k <$> C.textAlign ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (Font k)                               = k <$> C.font ctx
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d


we no longer need rawSplit

we no longer need rawSplit

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  , analyzeAbyssalCTFBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- in KCAPI there are cases where the length of the HP array
-- is neither 7 or 13, and it seems terminating "-1" elements
-- have a chance to disappear, so instead of using data from KCAPI
-- directly, we make sure the array is of the correct length
-- by applying this wrapper. "Nothing" will be appended to the
-- end of the list if the length is insufficient
ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = ensureHpsLen 6 $ getInitHpsCombined battle
    escortMaxHps = ensureHpsLen 6 $ getMaxHpsCombined battle

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

getInitFleetAC :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC Ship
getInitFleetAC ds battle =
    { main: allyShips
    , enemyMain: enemyMainShips
    , enemyEscort: enemyEscortShips
    }
  where
    -- ally vs. enemy main
    allyEMainNowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = allyEMainNowHps.left
    enemyMainNowHps = allyEMainNowHps.right

    allyEMainMaxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = allyEMainMaxHps.left
    enemyMainMaxHps = allyEMainMaxHps.right

    -- <null> vs. enemy escort
    nullEEscortNowHps = normalSplit (ensureHpsLen 12 $ getMaxHpsCombined battle)
    enemyEscortNowHps = nullEEscortNowHps.right

    nullEEscortMaxHps = normalSplit (ensureHpsLen 12 $ getInitHpsCombined battle)
    enemyEscortMaxHps = nullEEscortMaxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyMainShips :: FleetInfo Ship
    enemyMainShips = zipWith mkShip enemyMainNowHps enemyMainMaxHps

    enemyEscortShips :: FleetInfo Ship
    enemyEscortShips = zipWith mkShip enemyEscortNowHps enemyEscortMaxHps

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj initFleet) (prj finalFleet)
    initFleet = getInitFleetAC ds b
    resultDV = battleEnemyCarrierTaskForceDV b
    finalFleet =
      { main: applyDamageVector resultDV.main initFleet.main
      , enemyMain: applyDamageVector resultDV.enemyMain initFleet.enemyMain
      , enemyEscort: applyDamageVector resultDV.enemyEscort initFleet.enemyEscort
      }
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  , analyzeAbyssalCTFBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> LR (Array a)
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- in KCAPI there are cases where the length of the HP array
-- is neither 7 or 13, and it seems terminating "-1" elements
-- have a chance to disappear, so instead of using data from KCAPI
-- directly, we make sure the array is of the correct length
-- by applying this wrapper. "Nothing" will be appended to the
-- end of the list if the length is insufficient
ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = ensureHpsLen 6 $ getInitHpsCombined battle
    escortMaxHps = ensureHpsLen 6 $ getMaxHpsCombined battle

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

getInitFleetAC :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC Ship
getInitFleetAC ds battle =
    { main: allyShips
    , enemyMain: enemyMainShips
    , enemyEscort: enemyEscortShips
    }
  where
    -- ally vs. enemy main
    allyEMainNowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = allyEMainNowHps.left
    enemyMainNowHps = allyEMainNowHps.right

    allyEMainMaxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = allyEMainMaxHps.left
    enemyMainMaxHps = allyEMainMaxHps.right

    -- <null> vs. enemy escort
    nullEEscortNowHps = normalSplit (ensureHpsLen 12 $ getMaxHpsCombined battle)
    enemyEscortNowHps = nullEEscortNowHps.right

    nullEEscortMaxHps = normalSplit (ensureHpsLen 12 $ getInitHpsCombined battle)
    enemyEscortMaxHps = nullEEscortMaxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyMainShips :: FleetInfo Ship
    enemyMainShips = zipWith mkShip enemyMainNowHps enemyMainMaxHps

    enemyEscortShips :: FleetInfo Ship
    enemyEscortShips = zipWith mkShip enemyEscortNowHps enemyEscortMaxHps

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj initFleet) (prj finalFleet)
    initFleet = getInitFleetAC ds b
    resultDV = battleEnemyCarrierTaskForceDV b
    finalFleet =
      { main: applyDamageVector resultDV.main initFleet.main
      , enemyMain: applyDamageVector resultDV.enemyMain initFleet.enemyMain
      , enemyEscort: applyDamageVector resultDV.enemyEscort initFleet.enemyEscort
      }
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2