Filter glyphs before rendering

Filter glyphs before rendering

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
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.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, for_, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), fromJust)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(Bp), BpPerPixel(BpPerPixel), Chr(Chr), bpToPixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

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

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

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

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

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = score
                x = bpToPixels v.scale (min - v.min)
                -- z = traceShow x \_ -> unit
                -- x = 100.0
                -- x = 100.0
            stroke "black"
            fill "red"
            circle { x, y } 3.0

-- add function (Array (Glyph Unit)) -> Context2D -> Context2D -> Eff _ Unit,
-- where a single glyph is drawn many times by filling a backbuffer and copying it.
-- probably won't work with GlyphF; the glyphs are in fact not the same,
-- each one has its own position etc.
-- can we have a way to simplify this so each track only gets one glyph?
-- an explicit mapping from feature to pair of glyph and offset, or something like that.
-- then we could construct a tree, with the stroke & fill at the root. woop.
-- worth thinking about. & reading about optimizing these things
-- basically traversing/sequence something like
-- [Stroke "black" (Circle _ _ _), Stroke "black" (Circle _ _ _) ...]
-- into
-- Stroke "black" [Circle _ _ _, Circle _ _ _...]
-- though that is fundamentally different from the idea of drawing a single glyph
-- to a backbuffer.
-- *that* idea makes more sense with the idea of a glyph being somehow atomic;
-- a glyph should only describe what it looks like, in its own system -- not its
-- height, nothing like that. hmm.
-- the glyph would be more a function of the track than the feature.
-- however, it shouldn't necessarily be so; a track should be able to display different
-- glyphs depending on the feature values.
-- Buuut they should also memoize based on feature, so if the features in a track
-- only produce like 10 glyphs that are identical except for color, then those
-- renderings should be optimized.
-- need research!!!

filterFeatures :: forall f a b.
                  Filterable f
               => View
               -> f (Tuple (Feature Bp b) a)
               -> f a
filterFeatures view = map snd <<< Filterable.filter f
  where f :: _
        f (Tuple (Feature _ min max _) g) = min > view.min && max < view.max

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> View
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx v gs = withContext ctx do
  void $ translate tt ctx
  foreachE (Array.fromFoldable gs) $ void <$> renderGlyph ctx

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

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

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

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

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

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

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

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

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

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

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

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

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

foreign import canvasWheelEvent :: CanvasElement -> Event Number

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

-- TODO: fetching could (should) be done completely async,
-- and done on subscribing to the Event View. Like now,
-- but less clumsy -- model rendering around the fetch function,
-- and add some caching to it

-- fetcho :: String -> Event View -> Aff _ _
-- fetcho uri ev = launchAff do

browser :: String -> Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 20000.0
      maxView = Bp 3000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri
      renderer :: _
      -- renderer = renderGlyphs (browserTransform h) ctx
      renderer = renderGlyphs {translateX: 0.0, translateY: 0.0} ctx
      fetch :: View -> Aff _ _
      fetch v = do

        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        liftEff $ log $ unsafeStringify gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do

    _ <- launchAff $ fetch v'

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  -- _ <- liftEff $ unsafeCoerceEff $
  --      FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
  --        state <- tryPeekVar browserState
  --        liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
  --        case state of
  --          Nothing -> liftEff $ log "no state!"
  --          Just s' -> do
  --            liftEff $ log "state!"
  --            let gs' :: _
  --                gs' = clickAnnGlyphs s'.annotatedGlyphs p

  --            traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch v

main :: Eff _ _
main = launchAff $ browser "./alot.json"

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
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.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (zip)
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), fromJust)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(Bp), BpPerPixel(BpPerPixel), Chr(Chr), bpToPixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

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

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

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

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

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = 100.0
                x = bpToPixels v.scale (min - v.min)
                -- z = traceShow x \_ -> unit
                -- x = 100.0
                -- x = 100.0
            stroke "black"
            fill "red"
            circle { x, y } 3.0

-- add function (Array (Glyph Unit)) -> Context2D -> Context2D -> Eff _ Unit,
-- where a single glyph is drawn many times by filling a backbuffer and copying it.
-- probably won't work with GlyphF; the glyphs are in fact not the same,
-- each one has its own position etc.
-- can we have a way to simplify this so each track only gets one glyph?
-- an explicit mapping from feature to pair of glyph and offset, or something like that.
-- then we could construct a tree, with the stroke & fill at the root. woop.
-- worth thinking about. & reading about optimizing these things
-- basically traversing/sequence something like
-- [Stroke "black" (Circle _ _ _), Stroke "black" (Circle _ _ _) ...]
-- into
-- Stroke "black" [Circle _ _ _, Circle _ _ _...]
-- though that is fundamentally different from the idea of drawing a single glyph
-- to a backbuffer.
-- *that* idea makes more sense with the idea of a glyph being somehow atomic;
-- a glyph should only describe what it looks like, in its own system -- not its
-- height, nothing like that. hmm.
-- the glyph would be more a function of the track than the feature.
-- however, it shouldn't necessarily be so; a track should be able to display different
-- glyphs depending on the feature values.
-- Buuut they should also memoize based on feature, so if the features in a track
-- only produce like 10 glyphs that are identical except for color, then those
-- renderings should be optimized.
-- need research!!!

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx gs = withContext ctx do
  -- log $ show $ (length gs) :: Int
  _ <- translate tt ctx
  foreachE (Array.fromFoldable gs) $ void <$> renderGlyph ctx

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

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

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

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

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

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

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

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

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

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

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

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

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

foreign import canvasWheelEvent :: CanvasElement -> Event Number

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

-- TODO: fetching could (should) be done completely async,
-- and done on subscribing to the Event View. Like now,
-- but less clumsy -- model rendering around the fetch function,
-- and add some caching to it

-- fetcho :: String -> Event View -> Aff _ _
-- fetcho uri ev = launchAff do

browser :: String -> Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 20000.0
      maxView = Bp 3000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri
      renderer :: _
      -- renderer = renderGlyphs (browserTransform h) ctx
      renderer = renderGlyphs {translateX: 0.0, translateY: 0.0} ctx
      fetch :: View -> Aff _ _
      fetch v = do

        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        liftEff $ log $ unsafeStringify gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer gs

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do

    _ <- launchAff $ fetch v'

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  -- _ <- liftEff $ unsafeCoerceEff $
  --      FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
  --        state <- tryPeekVar browserState
  --        liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
  --        case state of
  --          Nothing -> liftEff $ log "no state!"
  --          Just s' -> do
  --            liftEff $ log "state!"
  --            let gs' :: _
  --                gs' = clickAnnGlyphs s'.annotatedGlyphs p

  --            traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch v

main :: Eff _ _
main = launchAff $ browser "./alot.json"


added style to default container

added style to default container

-- | Thermite provides a simple model-view-action abstraction on top of `purescript-react`:
-- |
-- | - A `Spec` defines a `state` type which acts as the _model_.
-- | - The `Spec` also defines an `action` type which acts as the set of _actions_.
-- | - The `view` is a `Render` function which produces a React element for the current state.
-- | - The `PerformAction` function can be used to update the state based on an action.
-- |
-- | A `Spec` can be created using `simpleSpec`, and turned into a React component class using
-- | `createClass`.
-- |
-- | Thermite also provides type class instances and lens combinators for composing `Spec`s.

module Thermite
  ( PerformAction
  , defaultPerformAction
  , EventHandler
  , Render
  , defaultRender
  , writeState
  , modifyState
  , Spec
  , _performAction
  , _render
  , simpleSpec
  , createClass
  , createReactSpec
  , createReactSpec'
  , withState
  , focus
  , focusState
  , match
  , split
  , foreach
  , cmapProps
  , module T
  ) where

import Control.Coroutine (CoTransform(CoTransform), CoTransformer, cotransform, transform, transformCoTransformL, transformCoTransformR)
import Control.Coroutine (CoTransformer, cotransform) as T
import Control.Monad.Aff (Aff, launchAff, makeAff, nonCanceler)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free.Trans (resume)
import Control.Monad.Rec.Class (Step(..), forever, tailRecM)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Lens (Prism', Lens', matching, view, review, preview, lens, over)
import Data.List (List(..), (!!), modifyAt)
import Data.Maybe (Maybe(Just), fromMaybe)
import Data.Monoid (class Monoid)
import Data.Tuple (Tuple(..))
import Prelude (class Semigroup, Unit, bind, const, discard, id, map, pure, unit, void, ($), (+), (<$>), (<*>), (<<<), (<>), (>>=))
import RNX.Color (strColor)
import RNX.Components (view')
import RNX.Styles (AlignItems(..), JustifyContent(..), Style(..), StyleSheet, alignItems, backgroundColor, createStyleSheet, flex, getStyleId, justifyContent, style)
import React as React

-- | A type synonym for an action handler, which takes an action, the current props
-- | and state for the component, and return a `CoTransformer` which will emit
-- | state updates asynchronously.
-- |
-- | `Control.Coroutine.cotransform` can be used to emit state update functions
-- | and wait for the new state value. If `cotransform` returns `Nothing`, then
-- | the state could not be updated. Usually, this will not happen, but it is possible
-- | in certain use cases involving `split` and `foreach`.
type PerformAction eff state props action
   = action
  -> props
  -> state
  -> CoTransformer (Maybe state) (state -> state) (Aff eff) Unit

-- | A default `PerformAction` action implementation which ignores all actions.
defaultPerformAction :: forall eff state props action. PerformAction eff state props action
defaultPerformAction _ _ _ = pure unit

-- | Replace the current component state.
writeState :: forall state eff. state -> CoTransformer (Maybe state) (state -> state) (Aff eff) (Maybe state)
writeState st = cotransform (const st)

-- | An alias for `cotransform` - apply a function to the current component state.
modifyState :: forall state eff. (state -> state) -> CoTransformer (Maybe state) (state -> state) (Aff eff) (Maybe state)
modifyState = cotransform

-- | A type synonym for an event handler which can be used to construct
-- | `purescript-react`'s event attributes.
type EventHandler =
  forall eff refs.
    Eff ( props :: React.ReactProps
        , state :: React.ReactState React.ReadWrite
        , refs :: React.ReactRefs refs
        | eff
        ) Unit

-- | A rendering function, which takes an action handler function, the current state and
-- | props, an array of child nodes and returns a HTML document.
type Render state props action
   = (action -> EventHandler)
  -> props
  -> state
  -> Array React.ReactElement
  -> Array React.ReactElement

-- | A default `Render` implementation which renders nothing.
-- |
-- | This is useful when just `append`ing action handlers.
defaultRender :: forall state props action. Render state props action
defaultRender _ _ _ _ = []

-- | A component specification, which can be passed to `createClass`.
-- |
-- | A minimal `Spec` can be built using `simpleSpec`.
-- |
-- | The `Monoid` instance for `Spec` will compose `Spec`s by placing rendered
-- | HTML elements next to one another, and performing actions in sequence.
newtype Spec eff state props action = Spec
  { performAction      :: PerformAction eff state props action
  , render             :: Render state props action
  }

cmapProps
  :: forall eff state props props' action
   . (props' -> props)
  -> Spec eff state props action
  -> Spec eff state props' action
cmapProps f (Spec sp) = Spec { performAction, render }
  where
    performAction a = sp.performAction a <<< f
    render a = sp.render a <<< f

-- | A `Lens` for accessing the `PerformAction` portion of a `Spec`.
_performAction :: forall eff state props action. Lens' (Spec eff state props action) (PerformAction eff state props action)
_performAction = lens (\(Spec s) -> s.performAction) (\(Spec s) pa -> Spec (s { performAction = pa }))

-- | A `Lens` for accessing the `Render` portion of a `Spec`.
-- |
-- | This can be useful when wrapping a `Render` function in order to frame a
-- | set of controls with some containing element. For example:
-- |
-- | ```purescript
-- | wrap :: Spec _ State _ Action -> Spec _ State _ Action
-- | wrap = over _render \child dispatch props state childre  ->
-- |   [ R.div [ RP.className "wrapper" ] [ child dispatch props state children ] ]
-- | ```
_render :: forall eff state props action. Lens' (Spec eff state props action) (Render state props action)
_render = lens (\(Spec s) -> s.render) (\(Spec s) r -> Spec (s { render = r }))

-- | Create a minimal `Spec`. The arguments are, in order:
-- |
-- | - The `PerformAction` function for performing actions
-- | - The `Render` function for rendering the current state as a HTML document
-- |
-- | For example:
-- |
-- | ```purescript
-- | import qualified React.DOM as R
-- |
-- | data Action = Increment
-- |
-- | spec :: Spec _ Int _ Action
-- | spec = simpleSpec performAction render
-- |   where
-- |   render :: Render _ Int _
-- |   render _ _ n _ = [ R.text (show n) ]
-- |
-- |   performAction :: PerformAction _ Int _ Action
-- |   performAction Increment _ n k = k (n + 1)
-- | ```
simpleSpec
  :: forall eff state props action
   . PerformAction eff state props action
  -> Render state props action
  -> Spec eff state props action
simpleSpec performAction render =
  Spec { performAction: performAction
       , render: render
       }

instance semigroupSpec :: Semigroup (Spec eff state props action) where
  append (Spec spec1) (Spec spec2) =
    Spec { performAction:       \a p s -> do spec1.performAction a p s
                                             spec2.performAction a p s
         , render:              \k p s   -> spec1.render k p s <> spec2.render k p s
         }

instance monoidSpec :: Monoid (Spec eff state props action) where
  mempty = simpleSpec (\_ _ _ -> pure unit)
                      (\_ _ _ _ -> [])

-- | Create a React component class from a Thermite component `Spec`.
createClass
  :: forall eff state props action
   . Spec eff state props action
  -> state
  -> React.ReactClass props
createClass spec state = React.createClass <<< _.spec $ createReactSpec spec state

-- | Create a React component spec from a Thermite component `Spec`.
-- |
-- | This function is a low-level alternative to `createClass`, used when the React
-- | component spec needs to be modified before being turned into a component class,
-- | e.g. by adding additional lifecycle methods.
createReactSpec
  :: forall eff state props action
   . Spec eff state props action
  -> state
  -> { spec :: React.ReactSpec props state eff
     , dispatcher :: React.ReactThis props state -> action -> EventHandler
     }
createReactSpec = createReactSpec' (view' [style $ getStyleId styleSheet "container"])

-- | Create a React component spec from a Thermite component `Spec` with an additional
-- | function for converting the rendered Array of ReactElement's into a single ReactElement
-- | as is required by React.
-- |
-- | This function is a low-level alternative to `createClass`, used when the React
-- | component spec needs to be modified before being turned into a component class,
-- | e.g. by adding additional lifecycle methods.
createReactSpec'
  :: forall eff state props action
   . (Array React.ReactElement -> React.ReactElement)
  -> Spec eff state props action
  -> state
  -> { spec :: React.ReactSpec props state eff
     , dispatcher :: React.ReactThis props state -> action -> EventHandler
     }
createReactSpec' wrap (Spec spec) =
    \state ->
      { spec: React.spec state render
      , dispatcher
      }
  where
    dispatcher :: React.ReactThis props state -> action -> EventHandler
    dispatcher this action = void do
      props <- React.getProps this
      state <- React.readState this
      let coerceEff :: forall eff1 a. Eff eff1 a -> Eff eff a
          coerceEff = unsafeCoerceEff

          step :: CoTransformer (Maybe state) (state -> state) (Aff eff) Unit
               -> Aff eff (Step (CoTransformer (Maybe state) (state -> state) (Aff eff) Unit) Unit)
          step cot = do
            e <- resume cot
            case e of
              Left _ -> pure (Done unit)
              Right (CoTransform f k) -> do
                st <- liftEff (coerceEff (React.readState this))
                let newState = f st
                _ <- makeAff \cb -> unsafeCoerceEff do
                  void $ React.writeStateWithCallback this newState (unsafeCoerceEff (cb (Right newState)))
                  pure nonCanceler
                pure (Loop (k (Just newState)))

          cotransformer :: CoTransformer (Maybe state) (state -> state) (Aff eff) Unit
          cotransformer = spec.performAction action props state
      -- Step the coroutine manually, since none of the existing coroutine
      -- functions do quite what we want here.
      unsafeCoerceEff (launchAff (tailRecM step cotransformer))

    render :: React.Render props state eff
    render this = map wrap $
      spec.render (dispatcher this)
        <$> React.getProps this
        <*> React.readState this
        <*> React.getChildren this

-- | This function captures the state of the `Spec` as a function argument.
-- |
-- | This can sometimes be useful in complex scenarios involving the `focus` and
-- | `foreach` combinators.
withState
  :: forall eff state props action
   . (state -> Spec eff state props action)
  -> Spec eff state props action
withState f = simpleSpec performAction render
  where
    performAction :: PerformAction eff state props action
    performAction a p st = view _performAction (f st) a p st

    render :: Render state props action
    render k p st = view _render (f st) k p st

-- | Change the state type, using a lens to focus on a part of the state.
-- |
-- | For example, to combine two `Spec`s, combining state types using `Tuple`
-- | and action types using `Either`:
-- |
-- | ```purescript
-- | spec1 :: Spec _ S1 _ A1
-- | spec2 :: Spec _ S2 _ A2
-- |
-- | spec :: Spec _ (Tuple S1 S2) _ (Either A1 A2)
-- | spec = focus _1 _Left spec1 <> focus _2 _Right spec2
-- | ```
-- |
-- | Actions will only be handled when the prism matches its input, otherwise
-- | the action will be ignored, and should be handled by some other component.
focus
  :: forall eff props state2 state1 action1 action2
   . Lens' state2 state1
  -> Prism' action2 action1
  -> Spec eff state1 props action1
  -> Spec eff state2 props action2
focus lens prism (Spec spec) = Spec { performAction, render }
  where
    performAction :: PerformAction eff state2 props action2
    performAction a p st =
      case matching prism a of
        Left _ -> pure unit
        Right a' -> forever (transform (map (view lens)))
                    `transformCoTransformL` spec.performAction a' p (view lens st)
                    `transformCoTransformR` forever (transform (over lens))

    render :: Render state2 props action2
    render k p st = spec.render (k <<< review prism) p (view lens st)

-- | A variant of `focus` which only changes the state type, by applying a `Lens`.
focusState
  :: forall eff props state2 state1 action
   . Lens' state2 state1
  -> Spec eff state1 props action
  -> Spec eff state2 props action
focusState lens = focus lens id

-- | A variant of `focus` which only changes the action type, by applying a `Prism`,
-- | effectively matching some subset of a larger action type.
match
  :: forall eff props state action1 action2
   . Prism' action2 action1
  -> Spec eff state props action1
  -> Spec eff state props action2
match prism = focus id prism

-- | Create a component which renders an optional subcomponent.
split
  :: forall eff props state1 state2 action
   . Prism' state1 state2
  -> Spec eff state2 props action
  -> Spec eff state1 props action
split prism (Spec spec) = Spec { performAction, render }
  where
    performAction :: PerformAction eff state1 props action
    performAction a p st =
      case matching prism st of
        Left _ -> pure unit
        Right st2 -> forever (transform (_ >>= preview prism))
                     `transformCoTransformL` spec.performAction a p st2
                     `transformCoTransformR` forever (transform (over prism))

    render :: Render state1 props action
    render k p st children =
      case matching prism st of
        Left _ -> []
        Right st' -> spec.render k p st' children

-- | Create a component whose state is described by a list, displaying one subcomponent
-- | for each entry in the list.
-- |
-- | The action type is modified to take the index of the originating subcomponent as an
-- | additional argument.
foreach
  :: forall eff props state action
   . (Int -> Spec eff state props action)
  -> Spec eff (List state) props (Tuple Int action)
foreach f = Spec
    { performAction: performAction
    , render: render
    }
  where
    performAction :: PerformAction eff (List state) props (Tuple Int action)
    performAction (Tuple i a) p sts =
        for_ (sts !! i) \st ->
          case f i of
            Spec s -> forever (transform (_ >>= (_ !! i)))
                      `transformCoTransformL` s.performAction a p st
                      `transformCoTransformR` forever (transform (modifying i))
      where
        modifying :: Int -> (state -> state) -> List state -> List state
        modifying j g sts' = fromMaybe sts' (modifyAt j g sts')

    render :: Render (List state) props (Tuple Int action)
    render k p sts _ = foldWithIndex (\i st els -> case f i of Spec s -> els <> s.render (k <<< Tuple i) p st []) sts []

    foldWithIndex :: forall a r. (Int -> a -> r -> r) -> List a -> r -> r
    foldWithIndex g = go 0
      where
      go _ Nil         r = r
      go i (Cons x xs) r = go (i + 1) xs (g i x r)

styleSheet ::  StyleSheet
styleSheet =
  createStyleSheet
  [ Style "container"
    [ flex 1
    , backgroundColor $ strColor "#fff"
    , alignItems AlignItemsCenter
    , justifyContent JustifyContentCenter
    ]
  ]

-- | Thermite provides a simple model-view-action abstraction on top of `purescript-react`:
-- |
-- | - A `Spec` defines a `state` type which acts as the _model_.
-- | - The `Spec` also defines an `action` type which acts as the set of _actions_.
-- | - The `view` is a `Render` function which produces a React element for the current state.
-- | - The `PerformAction` function can be used to update the state based on an action.
-- |
-- | A `Spec` can be created using `simpleSpec`, and turned into a React component class using
-- | `createClass`.
-- |
-- | Thermite also provides type class instances and lens combinators for composing `Spec`s.

module Thermite
  ( PerformAction
  , defaultPerformAction
  , EventHandler
  , Render
  , defaultRender
  , writeState
  , modifyState
  , Spec
  , _performAction
  , _render
  , simpleSpec
  , createClass
  , createReactSpec
  , createReactSpec'
  , withState
  , focus
  , focusState
  , match
  , split
  , foreach
  , cmapProps
  , module T
  ) where

import Control.Coroutine (CoTransform(CoTransform), CoTransformer, cotransform, transform, transformCoTransformL, transformCoTransformR)
import Control.Coroutine (CoTransformer, cotransform) as T
import Control.Monad.Aff (Aff, launchAff, makeAff, nonCanceler)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free.Trans (resume)
import Control.Monad.Rec.Class (Step(..), forever, tailRecM)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Lens (Prism', Lens', matching, view, review, preview, lens, over)
import Data.List (List(..), (!!), modifyAt)
import Data.Maybe (Maybe(Just), fromMaybe)
import Data.Monoid (class Monoid)
import Data.Tuple (Tuple(..))
import Prelude (class Semigroup, Unit, bind, const, discard, id, map, pure, unit, void, ($), (+), (<$>), (<*>), (<<<), (<>), (>>=))
import RNX.Components (view')
import React as React

-- | A type synonym for an action handler, which takes an action, the current props
-- | and state for the component, and return a `CoTransformer` which will emit
-- | state updates asynchronously.
-- |
-- | `Control.Coroutine.cotransform` can be used to emit state update functions
-- | and wait for the new state value. If `cotransform` returns `Nothing`, then
-- | the state could not be updated. Usually, this will not happen, but it is possible
-- | in certain use cases involving `split` and `foreach`.
type PerformAction eff state props action
   = action
  -> props
  -> state
  -> CoTransformer (Maybe state) (state -> state) (Aff eff) Unit

-- | A default `PerformAction` action implementation which ignores all actions.
defaultPerformAction :: forall eff state props action. PerformAction eff state props action
defaultPerformAction _ _ _ = pure unit

-- | Replace the current component state.
writeState :: forall state eff. state -> CoTransformer (Maybe state) (state -> state) (Aff eff) (Maybe state)
writeState st = cotransform (const st)

-- | An alias for `cotransform` - apply a function to the current component state.
modifyState :: forall state eff. (state -> state) -> CoTransformer (Maybe state) (state -> state) (Aff eff) (Maybe state)
modifyState = cotransform

-- | A type synonym for an event handler which can be used to construct
-- | `purescript-react`'s event attributes.
type EventHandler =
  forall eff refs.
    Eff ( props :: React.ReactProps
        , state :: React.ReactState React.ReadWrite
        , refs :: React.ReactRefs refs
        | eff
        ) Unit

-- | A rendering function, which takes an action handler function, the current state and
-- | props, an array of child nodes and returns a HTML document.
type Render state props action
   = (action -> EventHandler)
  -> props
  -> state
  -> Array React.ReactElement
  -> Array React.ReactElement

-- | A default `Render` implementation which renders nothing.
-- |
-- | This is useful when just `append`ing action handlers.
defaultRender :: forall state props action. Render state props action
defaultRender _ _ _ _ = []

-- | A component specification, which can be passed to `createClass`.
-- |
-- | A minimal `Spec` can be built using `simpleSpec`.
-- |
-- | The `Monoid` instance for `Spec` will compose `Spec`s by placing rendered
-- | HTML elements next to one another, and performing actions in sequence.
newtype Spec eff state props action = Spec
  { performAction      :: PerformAction eff state props action
  , render             :: Render state props action
  }

cmapProps
  :: forall eff state props props' action
   . (props' -> props)
  -> Spec eff state props action
  -> Spec eff state props' action
cmapProps f (Spec sp) = Spec { performAction, render }
  where
    performAction a = sp.performAction a <<< f
    render a = sp.render a <<< f

-- | A `Lens` for accessing the `PerformAction` portion of a `Spec`.
_performAction :: forall eff state props action. Lens' (Spec eff state props action) (PerformAction eff state props action)
_performAction = lens (\(Spec s) -> s.performAction) (\(Spec s) pa -> Spec (s { performAction = pa }))

-- | A `Lens` for accessing the `Render` portion of a `Spec`.
-- |
-- | This can be useful when wrapping a `Render` function in order to frame a
-- | set of controls with some containing element. For example:
-- |
-- | ```purescript
-- | wrap :: Spec _ State _ Action -> Spec _ State _ Action
-- | wrap = over _render \child dispatch props state childre  ->
-- |   [ R.div [ RP.className "wrapper" ] [ child dispatch props state children ] ]
-- | ```
_render :: forall eff state props action. Lens' (Spec eff state props action) (Render state props action)
_render = lens (\(Spec s) -> s.render) (\(Spec s) r -> Spec (s { render = r }))

-- | Create a minimal `Spec`. The arguments are, in order:
-- |
-- | - The `PerformAction` function for performing actions
-- | - The `Render` function for rendering the current state as a HTML document
-- |
-- | For example:
-- |
-- | ```purescript
-- | import qualified React.DOM as R
-- |
-- | data Action = Increment
-- |
-- | spec :: Spec _ Int _ Action
-- | spec = simpleSpec performAction render
-- |   where
-- |   render :: Render _ Int _
-- |   render _ _ n _ = [ R.text (show n) ]
-- |
-- |   performAction :: PerformAction _ Int _ Action
-- |   performAction Increment _ n k = k (n + 1)
-- | ```
simpleSpec
  :: forall eff state props action
   . PerformAction eff state props action
  -> Render state props action
  -> Spec eff state props action
simpleSpec performAction render =
  Spec { performAction: performAction
       , render: render
       }

instance semigroupSpec :: Semigroup (Spec eff state props action) where
  append (Spec spec1) (Spec spec2) =
    Spec { performAction:       \a p s -> do spec1.performAction a p s
                                             spec2.performAction a p s
         , render:              \k p s   -> spec1.render k p s <> spec2.render k p s
         }

instance monoidSpec :: Monoid (Spec eff state props action) where
  mempty = simpleSpec (\_ _ _ -> pure unit)
                      (\_ _ _ _ -> [])

-- | Create a React component class from a Thermite component `Spec`.
createClass
  :: forall eff state props action
   . Spec eff state props action
  -> state
  -> React.ReactClass props
createClass spec state = React.createClass <<< _.spec $ createReactSpec spec state

-- | Create a React component spec from a Thermite component `Spec`.
-- |
-- | This function is a low-level alternative to `createClass`, used when the React
-- | component spec needs to be modified before being turned into a component class,
-- | e.g. by adding additional lifecycle methods.
createReactSpec
  :: forall eff state props action
   . Spec eff state props action
  -> state
  -> { spec :: React.ReactSpec props state eff
     , dispatcher :: React.ReactThis props state -> action -> EventHandler
     }
createReactSpec = createReactSpec' (view' [])

-- | Create a React component spec from a Thermite component `Spec` with an additional
-- | function for converting the rendered Array of ReactElement's into a single ReactElement
-- | as is required by React.
-- |
-- | This function is a low-level alternative to `createClass`, used when the React
-- | component spec needs to be modified before being turned into a component class,
-- | e.g. by adding additional lifecycle methods.
createReactSpec'
  :: forall eff state props action
   . (Array React.ReactElement -> React.ReactElement)
  -> Spec eff state props action
  -> state
  -> { spec :: React.ReactSpec props state eff
     , dispatcher :: React.ReactThis props state -> action -> EventHandler
     }
createReactSpec' wrap (Spec spec) =
    \state ->
      { spec: React.spec state render
      , dispatcher
      }
  where
    dispatcher :: React.ReactThis props state -> action -> EventHandler
    dispatcher this action = void do
      props <- React.getProps this
      state <- React.readState this
      let coerceEff :: forall eff1 a. Eff eff1 a -> Eff eff a
          coerceEff = unsafeCoerceEff

          step :: CoTransformer (Maybe state) (state -> state) (Aff eff) Unit
               -> Aff eff (Step (CoTransformer (Maybe state) (state -> state) (Aff eff) Unit) Unit)
          step cot = do
            e <- resume cot
            case e of
              Left _ -> pure (Done unit)
              Right (CoTransform f k) -> do
                st <- liftEff (coerceEff (React.readState this))
                let newState = f st
                _ <- makeAff \cb -> unsafeCoerceEff do
                  void $ React.writeStateWithCallback this newState (unsafeCoerceEff (cb (Right newState)))
                  pure nonCanceler
                pure (Loop (k (Just newState)))

          cotransformer :: CoTransformer (Maybe state) (state -> state) (Aff eff) Unit
          cotransformer = spec.performAction action props state
      -- Step the coroutine manually, since none of the existing coroutine
      -- functions do quite what we want here.
      unsafeCoerceEff (launchAff (tailRecM step cotransformer))

    render :: React.Render props state eff
    render this = map wrap $
      spec.render (dispatcher this)
        <$> React.getProps this
        <*> React.readState this
        <*> React.getChildren this

-- | This function captures the state of the `Spec` as a function argument.
-- |
-- | This can sometimes be useful in complex scenarios involving the `focus` and
-- | `foreach` combinators.
withState
  :: forall eff state props action
   . (state -> Spec eff state props action)
  -> Spec eff state props action
withState f = simpleSpec performAction render
  where
    performAction :: PerformAction eff state props action
    performAction a p st = view _performAction (f st) a p st

    render :: Render state props action
    render k p st = view _render (f st) k p st

-- | Change the state type, using a lens to focus on a part of the state.
-- |
-- | For example, to combine two `Spec`s, combining state types using `Tuple`
-- | and action types using `Either`:
-- |
-- | ```purescript
-- | spec1 :: Spec _ S1 _ A1
-- | spec2 :: Spec _ S2 _ A2
-- |
-- | spec :: Spec _ (Tuple S1 S2) _ (Either A1 A2)
-- | spec = focus _1 _Left spec1 <> focus _2 _Right spec2
-- | ```
-- |
-- | Actions will only be handled when the prism matches its input, otherwise
-- | the action will be ignored, and should be handled by some other component.
focus
  :: forall eff props state2 state1 action1 action2
   . Lens' state2 state1
  -> Prism' action2 action1
  -> Spec eff state1 props action1
  -> Spec eff state2 props action2
focus lens prism (Spec spec) = Spec { performAction, render }
  where
    performAction :: PerformAction eff state2 props action2
    performAction a p st =
      case matching prism a of
        Left _ -> pure unit
        Right a' -> forever (transform (map (view lens)))
                    `transformCoTransformL` spec.performAction a' p (view lens st)
                    `transformCoTransformR` forever (transform (over lens))

    render :: Render state2 props action2
    render k p st = spec.render (k <<< review prism) p (view lens st)

-- | A variant of `focus` which only changes the state type, by applying a `Lens`.
focusState
  :: forall eff props state2 state1 action
   . Lens' state2 state1
  -> Spec eff state1 props action
  -> Spec eff state2 props action
focusState lens = focus lens id

-- | A variant of `focus` which only changes the action type, by applying a `Prism`,
-- | effectively matching some subset of a larger action type.
match
  :: forall eff props state action1 action2
   . Prism' action2 action1
  -> Spec eff state props action1
  -> Spec eff state props action2
match prism = focus id prism

-- | Create a component which renders an optional subcomponent.
split
  :: forall eff props state1 state2 action
   . Prism' state1 state2
  -> Spec eff state2 props action
  -> Spec eff state1 props action
split prism (Spec spec) = Spec { performAction, render }
  where
    performAction :: PerformAction eff state1 props action
    performAction a p st =
      case matching prism st of
        Left _ -> pure unit
        Right st2 -> forever (transform (_ >>= preview prism))
                     `transformCoTransformL` spec.performAction a p st2
                     `transformCoTransformR` forever (transform (over prism))

    render :: Render state1 props action
    render k p st children =
      case matching prism st of
        Left _ -> []
        Right st' -> spec.render k p st' children

-- | Create a component whose state is described by a list, displaying one subcomponent
-- | for each entry in the list.
-- |
-- | The action type is modified to take the index of the originating subcomponent as an
-- | additional argument.
foreach
  :: forall eff props state action
   . (Int -> Spec eff state props action)
  -> Spec eff (List state) props (Tuple Int action)
foreach f = Spec
    { performAction: performAction
    , render: render
    }
  where
    performAction :: PerformAction eff (List state) props (Tuple Int action)
    performAction (Tuple i a) p sts =
        for_ (sts !! i) \st ->
          case f i of
            Spec s -> forever (transform (_ >>= (_ !! i)))
                      `transformCoTransformL` s.performAction a p st
                      `transformCoTransformR` forever (transform (modifying i))
      where
        modifying :: Int -> (state -> state) -> List state -> List state
        modifying j g sts' = fromMaybe sts' (modifyAt j g sts')

    render :: Render (List state) props (Tuple Int action)
    render k p sts _ = foldWithIndex (\i st els -> case f i of Spec s -> els <> s.render (k <<< Tuple i) p st []) sts []

    foldWithIndex :: forall a r. (Int -> a -> r -> r) -> List a -> r -> r
    foldWithIndex g = go 0
      where
      go _ Nil         r = r
      go i (Cons x xs) r = go (i + 1) xs (g i x r)


add isRampage

add isRampage

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 300

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap excludes bigDots
  , countdown: Just 90
  , rampage: Nothing
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  excludes = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId =
  (\g -> maybe false (fst >>> (==) pId) g.rampage) <$> getGame

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \(Tuple pId counter) ->
    changeRampage (Tuple pId <$> decrementOrNothing counter)

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
-- * put a big dot in every given space
makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap excludes bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos excludes) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 300

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap excludes bigDots
  , countdown: Just 90
  , rampage: Nothing
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  excludes = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \(Tuple pId counter) ->
    changeRampage (Tuple pId <$> decrementOrNothing counter)

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
-- * put a big dot in every given space
makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap excludes bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos excludes) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x


sample 100

sample 100

module Test.Math where

import Prelude
import Data.Traversable (for)
import Control.Monad.Eff.Class
import Data.Array
import Data.Either
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
import Susurrant.Types
import Susurrant.MultivariateGaussian
import Susurrant.Matrix
import Data.Tuple
import Data.Maybe (fromMaybe)
import Data.Unfoldable (class Unfoldable, replicate)
import Data.List.Lazy (replicateM)
import Test.QuickCheck ((===), (/==), (<?>))
import Test.QuickCheck.Gen (chooseInt, vectorOf, uniform)
import Test.Spec (describe, it, pending)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.QuickCheck (quickCheck)

newtype ArbMatrix = ArbMatrix (Matrix Number)

instance arbMatrix :: Arbitrary ArbMatrix where
  arbitrary = do
    n <- chooseInt 1 32
    m <- chooseInt 1 32
    mat <- vectorOf n (vectorOf m uniform)
    either (const arbitrary) (pure <<< ArbMatrix) (matrix' mat)

newtype ArbSquare = ArbSquare (Matrix Number)

instance arbSquare :: Arbitrary ArbSquare where
  arbitrary = do
    n <- chooseInt 1 32
    mat <- vectorOf n (vectorOf n uniform)
    either (const arbitrary) (pure <<< ArbSquare) (matrix' mat)

newtype ArbNormal = ArbNormal MultivariateGaussian

instance arbNormal :: Arbitrary ArbNormal where
  arbitrary = do
    (ArbSquare mat) <- arbitrary
    let dims = dimensions mat
    mean <- vectorOf dims.rows uniform
    either (const arbitrary) (pure <<< ArbNormal) (multivariateGaussian' mean mat)

matrixRowSpec =
  describe "Matrix" $ do
    it "has a number of rows, all the same length" $
      quickCheck (\(ArbMatrix m) -> let mat = unMatrix m
                                        matN = length mat
                                        matM = fromMaybe 0 (map length (head mat))
                                    in map length mat === replicate matN matM)

dimensionsSpec =
  describe "dimensions" $ do
    it "gets the dimensions of a matrix" $ do
      quickCheck $ (\(ArbMatrix mat) -> let dims = dimensions mat
                                        in (dims.rows <= 32 && dims.cols <= 32) === true)

gaussianSpec =
 describe "MultivariateGaussian" $ do
    it "has a mean and a covariance matrix of the same size" $
      quickCheck $ (\(Tuple (ArbSquare cov) mean) -> let dim = dimensions cov
                                                         isSquare = dim.rows == dim.cols
                                                         mg = multivariateGaussian' mean cov
                                                     in isRight mg === (isSquare && length mean == dim.rows))
    it "can be sampled" do
      let mean = [0.0, 0.0]
          gauss = do covariance <- matrix' [[1.0, 0.0], [0.0, 1.0]]
                     multivariateGaussian' mean covariance
      case gauss of
        Left err -> true `shouldEqual` false
        Right gauss' -> do
          x <- liftEff $ sample gauss'
          length x `shouldEqual` length mean
    it "can be sampled a large number of times" do
      let mean = [0.0, 0.0]
          gauss = do covariance <- matrix' [[1.0, 0.0], [0.0, 1.0]]
                     multivariateGaussian' mean covariance
      case gauss of
        Left err -> true `shouldEqual` false
        Right gauss' -> do
          xs <- liftEff $ replicateM 100 (sample gauss')
          for xs $ \x ->
            length x `shouldEqual` length mean
          pure unit

mathSpec = do
  matrixRowSpec
  dimensionsSpec
  gaussianSpec

module Test.Math where

import Prelude
import Control.Monad.Eff.Class
import Data.Array
import Data.Either
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
import Susurrant.Types
import Susurrant.MultivariateGaussian
import Susurrant.Matrix
import Data.Tuple
import Data.Maybe (fromMaybe)
import Data.Unfoldable (replicate)
import Test.QuickCheck ((===), (/==), (<?>))
import Test.QuickCheck.Gen (chooseInt, vectorOf, uniform)
import Test.Spec (describe, it, pending)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.QuickCheck (quickCheck)

newtype ArbMatrix = ArbMatrix (Matrix Number)

instance arbMatrix :: Arbitrary ArbMatrix where
  arbitrary = do
    n <- chooseInt 1 32
    m <- chooseInt 1 32
    mat <- vectorOf n (vectorOf m uniform)
    either (const arbitrary) (pure <<< ArbMatrix) (matrix' mat)

newtype ArbSquare = ArbSquare (Matrix Number)

instance arbSquare :: Arbitrary ArbSquare where
  arbitrary = do
    n <- chooseInt 1 32
    mat <- vectorOf n (vectorOf n uniform)
    either (const arbitrary) (pure <<< ArbSquare) (matrix' mat)

newtype ArbNormal = ArbNormal MultivariateGaussian

instance arbNormal :: Arbitrary ArbNormal where
  arbitrary = do
    (ArbSquare mat) <- arbitrary
    let dims = dimensions mat
    mean <- vectorOf dims.rows uniform
    either (const arbitrary) (pure <<< ArbNormal) (multivariateGaussian' mean mat)

matrixRowSpec =
  describe "Matrix" $ do
    it "has a number of rows, all the same length" $
      quickCheck (\(ArbMatrix m) -> let mat = unMatrix m
                                        matN = length mat
                                        matM = fromMaybe 0 (map length (head mat))
                                    in map length mat === replicate matN matM)

dimensionsSpec =
  describe "dimensions" $ do
    it "gets the dimensions of a matrix" $ do
      quickCheck $ (\(ArbMatrix mat) -> let dims = dimensions mat
                                        in (dims.rows <= 32 && dims.cols <= 32) === true)

gaussianSpec =
 describe "MultivariateGaussian" $ do
    it "has a mean and a covariance matrix of the same size" $
      quickCheck $ (\(Tuple (ArbSquare cov) mean) -> let dim = dimensions cov
                                                         isSquare = dim.rows == dim.cols
                                                         mg = multivariateGaussian' mean cov
                                                     in isRight mg === (isSquare && length mean == dim.rows))
    it "can be sampled" do
      let mean = [0.0, 0.0]
          gauss = do covariance <- matrix' [[1.0, 0.0], [0.0, 1.0]]
                     multivariateGaussian' mean covariance
      case gauss of
        Left err -> true `shouldEqual` false
        Right gauss' -> do
          x <- liftEff $ sample gauss'
          length x `shouldEqual` length mean

mathSpec = do
  matrixRowSpec
  dimensionsSpec
  gaussianSpec


Introduce type classes

Introduce type classes

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

type Description = Maybe String
data OptionSpec
  = FullOptionSpec  ShortOption LongOption Description
  | ShortOptionSpec ShortOption Description
  | LongOptionSpec  LongOption Description

data OptionArgument
  = Explicit String
  | Implicit String
  | None

data LongOption = LongOption String OptionArgument
data ShortOption = ShortOption Char (Array Char) OptionArgument
data Command = Command String
data Positional = Positional String

type Option = Either LongOption ShortOption

-- -- | Represent a meta token, derived from a usage line
-- data Meta
--   = MetaCommand String
--   | MetaPositional String
--   | MetaLongOption LongOption
--   | MetaShortOption ShortOption
class Meta where

-- | Represent a single usage
type Usage a = forall a. (Meta a) => List a
type UsageBlock = List Usage

instance showArgument :: Show OptionArgument where
  show (Explicit s) = "Explicit " ++ s
  show (Implicit s) = "Implicit " ++ s
  show None         = "None"

instance showLongOption :: Show LongOption where
  show (LongOption name arg) = "LongOption " ++ name ++ " " ++ show arg

instance showShortOption :: Show ShortOption where
  show (ShortOption name stack arg) = "ShortOption "
    ++ (fromChar name) ++ " "
    ++ (fromCharArray stack) ++ " "
    ++ show arg

-- instance showMeta :: Show Meta where
--   show (MetaCommand opt)    = "MetaCommand " ++ show opt
--   show (MetaPositional opt) = "MetaPositional " ++ show opt
--   show (MetaLongOption opt)  = "MetaLongOption " ++ show opt
--   show (MetaShortOption opt) = "MetaShortOption " ++ show opt

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  fromCharArray <$> (Array.cons
    <$> (matches "[A-Z]")
    <*> (Array.many $ matches "[A-Z]"))

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  *> (fromCharArray <$> (Array.some $ matches "[a-z]")) <*
  char '>'

-- | Parse a positional argument
-- |
-- | A positional argument is a simple identifier of the shape:
-- | ```bash
-- | naval-fate <foo>
-- | naval-fata FOO
-- | ```
-- |
positional :: forall a. (Meta a) => Parser String a
positional = Positional <$> (_ARGNAME <|> _argname_)

-- | Parse the argument binding of an options.
-- | An option can either have an `Explicit`, an `Implicit` or no
-- | argument binding at all.
-- |
-- | `Explicit` are those that are either assigned via an `=`, or where the
-- | argument is directly adjacent (no space). There is no question as to
-- | whether the following identifier is an argument or a `Positional`.
-- |
-- | `Implicit` are those that are seperated only by spaces. It is impossible
-- | to know, without "solving" using further constraints, if we are dealing
-- | with a `Positional` or a bound argument. Note that the docopt spec dictates
-- | that without further prove, an `Implicit` argument is treated as a
-- | `Positional`.
-- |
optionArgument :: Parser String OptionArgument
optionArgument = do
  (try do
    char '='
    Explicit <$> do _ARGNAME <|> _argname_)
  <|>
  (try do
    Explicit <$> do _ARGNAME <|> _argname_)
  <|>
  (try do
    many space
    Implicit <$> do _ARGNAME <|> _argname_)
  <|> do
    return None

-- | Parse a long option.
-- |
-- | A short option may or may not have an argument.
-- | The argument may be specified explicitly by way of an equal sign `=`,
-- | or ambiguosly, by way of a space. Where a space is used, it is unclear at
-- | first as to whether the token is an argument to the option or a positional
-- | option. It is only through the parsing of the `Options` block, that the
-- | answer can be dervied.
-- |
-- | By default, the adjacent token, if parsed correctly, is assigned as the
-- | argument to the preceding option and must be proved otherwise.
-- |
-- | ```bash
-- | naval-fate --verbose
-- | naval-fate --verbose=<argument>|ARGUMENT
-- | naval-fate --verbose <argument>|ARGUMENT
-- | ```
-- |
longOption :: Parser String LongOption
longOption = do
  string "--"
  LongOption
    <$> (fromCharArray <$> (Array.some $ matches "[a-z]"))
    <*> optionArgument

-- | Parse a short option.
-- |
-- | A short option may or may not have an argument.
-- | The argument may be specified explicitly by way of an equal sign `=`,
-- | or ambiguosly, by way of a space. Where a space is used, it is unclear at
-- | first as to whether the token is an argument to the option or a positional
-- | option. It is only through the parsing of the `Options` block, that the
-- | answer can be dervied.
-- |
-- | By default, the adjacent token, if parsed correctly, is assigned as the
-- | argument to the preceding option and must be proved otherwise.
-- |
-- | ```bash
-- | naval-fate -v
-- | naval-fate -vv
-- | naval-fate -xvzf
-- | naval-fate -v <argument>|ARGUMENT
-- | naval-fate -v=<argument>|ARGUMENT
-- | naval-fate -vv <argument>|ARGUMENT
-- | naval-fate -vv=<argument>|ARGUMENT
-- | ```
-- |
shortOption :: Boolean -> Parser String ShortOption
shortOption allowStacked = do
  char '-'
  ShortOption
    <$> (matches "[a-z]")
    <*> (if allowStacked then
          Array.many $ matches "[a-z]"
        else
          return mempty)
    <*> optionArgument

-- | Parse any type of option
option :: Parser String Option
option = (Left <$> longOption) <|> (Right <$> shortOption true)

-- | Parse any valid usage token
usageToken :: forall a. (Meta a) => Parser String a
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* many space
  Position { column: col } <- getPosition

  -- Parse the first and any consecutive usage rows.
  concat <$> ((:)
    <$> (usageToken `sepBy` many space)
    <*> (many $ try do
          many space *> eol
          indent (col - 1)
          many space
          usageToken `sepBy` many space))

-- | Parse a complete usage block
-- |
-- | ```
-- | Usage:
-- | / naval-fate -vvv --qux
-- | //////////// --foo --bar
-- | / naval-fate --debug
-- | ```
-- |
-- | TODO: Add support for the following notation:
-- |
-- | ```
-- | Usage: naval-fate -vvv --qux
-- | ///////////////// --foo --bar
-- | ////// naval-fate --debug
-- | ```
-- |
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do

  -- Title
  string "Usage:" <* chompRight
  many space
  Position { column: col } <- getPosition

  -- Usage lines (at least one)
  (:)
    <$> (usage program)
    <*> (many $ try do
          eol
          indent (col - 1)
          usage program <* many space)

optionLine :: Parser String Unit
optionLine = do
  return unit

  -- ((try do
  --     FullOptionSpec
  --       <$> (shortOption false)
  --       <*> (do char ','
  --               many space
  --               longOption))
  --   <|> (try do ShortOptionSpec <$> shortOption false)
  --   <|> (try do LongOptionSpec <$> longOption)
  -- ) <*> Nothing

  --
  -- char ','
  -- many space
  -- lopt <- longOption
  --
  -- -- The description is expected to start
  -- --  with at least 2 spaces distance.
  -- space
  -- space
  -- many space
  --
  -- desc <- description
  --
  -- return unit

optionsBlock :: Parser String Unit
optionsBlock = do

  -- Title
  string "Options:" <* chompRight
  many space
  Position { column: col } <- getPosition

  -- Option lines
  x <- optionLine

  return unit

meta :: String -> Parser String Unit
meta program = do
  skipSpaces

  -- Parse the `Usage` section
  usage <- usageBlock program
  debug "Usage:"
  debug usage

  many $ try $ many space *> eol

  -- Parse the `Options` section
  opts <- optionsBlock
  debug "Options:"
  debug opts

  return unit

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

type Description = Maybe String
data OptionSpec
  = FullOptionSpec  ShortOption LongOption Description
  | ShortOptionSpec ShortOption Description
  | LongOptionSpec  LongOption Description

data OptionArgument
  = Explicit String
  | Implicit String
  | None

data LongOption = LongOption String OptionArgument
data ShortOption = ShortOption Char (Array Char) OptionArgument

type Option = Either LongOption ShortOption

-- | Represent a meta token, derived from a usage line
data Meta
  = MetaCommand String
  | MetaPositional String
  | MetaLongOption LongOption
  | MetaShortOption ShortOption

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showArgument :: Show OptionArgument where
  show (Explicit s) = "Explicit " ++ s
  show (Implicit s) = "Implicit " ++ s
  show None         = "None"

instance showLongOption :: Show LongOption where
  show (LongOption name arg) = "LongOption " ++ name ++ " " ++ show arg

instance showShortOption :: Show ShortOption where
  show (ShortOption name stack arg) = "ShortOption "
    ++ (fromChar name) ++ " "
    ++ (fromCharArray stack) ++ " "
    ++ show arg

instance showMeta :: Show Meta where
  show (MetaCommand opt)    = "MetaCommand " ++ show opt
  show (MetaPositional opt) = "MetaPositional " ++ show opt
  show (MetaLongOption opt)  = "MetaLongOption " ++ show opt
  show (MetaShortOption opt) = "MetaShortOption " ++ show opt

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  fromCharArray <$> (Array.cons
    <$> (matches "[A-Z]")
    <*> (Array.many $ matches "[A-Z]"))

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  *> (fromCharArray <$> (Array.some $ matches "[a-z]")) <*
  char '>'

-- | Parse a positional argument
-- |
-- | A positional argument is a simple identifier of the shape:
-- | ```bash
-- | naval-fate <foo>
-- | naval-fata FOO
-- | ```
-- |
positional :: Parser String Meta
positional = MetaPositional <$> (_ARGNAME <|> _argname_)

-- | Parse the argument binding of an options.
-- | An option can either have an `Explicit`, an `Implicit` or no
-- | argument binding at all.
-- |
-- | `Explicit` are those that are either assigned via an `=`, or where the
-- | argument is directly adjacent (no space). There is no question as to
-- | whether the following identifier is an argument or a `Positional`.
-- |
-- | `Implicit` are those that are seperated only by spaces. It is impossible
-- | to know, without "solving" using further constraints, if we are dealing
-- | with a `Positional` or a bound argument. Note that the docopt spec dictates
-- | that without further prove, an `Implicit` argument is treated as a
-- | `Positional`.
-- |
optionArgument :: Parser String OptionArgument
optionArgument = do
  (try do
    char '='
    Explicit <$> do _ARGNAME <|> _argname_)
  <|>
  (try do
    Explicit <$> do _ARGNAME <|> _argname_)
  <|>
  (try do
    many space
    Implicit <$> do _ARGNAME <|> _argname_)
  <|> do
    return None

-- | Parse a long option.
-- |
-- | A short option may or may not have an argument.
-- | The argument may be specified explicitly by way of an equal sign `=`,
-- | or ambiguosly, by way of a space. Where a space is used, it is unclear at
-- | first as to whether the token is an argument to the option or a positional
-- | option. It is only through the parsing of the `Options` block, that the
-- | answer can be dervied.
-- |
-- | By default, the adjacent token, if parsed correctly, is assigned as the
-- | argument to the preceding option and must be proved otherwise.
-- |
-- | ```bash
-- | naval-fate --verbose
-- | naval-fate --verbose=<argument>|ARGUMENT
-- | naval-fate --verbose <argument>|ARGUMENT
-- | ```
-- |
longOption :: Parser String LongOption
longOption = do
  string "--"
  LongOption
    <$> (fromCharArray <$> (Array.some $ matches "[a-z]"))
    <*> optionArgument

-- | Parse a short option.
-- |
-- | A short option may or may not have an argument.
-- | The argument may be specified explicitly by way of an equal sign `=`,
-- | or ambiguosly, by way of a space. Where a space is used, it is unclear at
-- | first as to whether the token is an argument to the option or a positional
-- | option. It is only through the parsing of the `Options` block, that the
-- | answer can be dervied.
-- |
-- | By default, the adjacent token, if parsed correctly, is assigned as the
-- | argument to the preceding option and must be proved otherwise.
-- |
-- | ```bash
-- | naval-fate -v
-- | naval-fate -vv
-- | naval-fate -xvzf
-- | naval-fate -v <argument>|ARGUMENT
-- | naval-fate -v=<argument>|ARGUMENT
-- | naval-fate -vv <argument>|ARGUMENT
-- | naval-fate -vv=<argument>|ARGUMENT
-- | ```
-- |
shortOption :: Boolean -> Parser String ShortOption
shortOption allowStacked = do
  char '-'
  ShortOption
    <$> (matches "[a-z]")
    <*> (if allowStacked then
          Array.many $ matches "[a-z]"
        else
          return mempty)
    <*> optionArgument

-- | Parse any type of option
option :: Parser String Option
option = (Left <$> longOption) <|> (Right <$> shortOption true)

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* many space
  Position { column: col } <- getPosition

  -- Parse the first and any consecutive usage rows.
  concat <$> ((:)
    <$> (usageToken `sepBy` many space)
    <*> (many $ try do
          many space *> eol
          indent (col - 1)
          many space
          usageToken `sepBy` many space))

-- | Parse a complete usage block
-- |
-- | ```
-- | Usage:
-- | / naval-fate -vvv --qux
-- | //////////// --foo --bar
-- | / naval-fate --debug
-- | ```
-- |
-- | TODO: Add support for the following notation:
-- |
-- | ```
-- | Usage: naval-fate -vvv --qux
-- | ///////////////// --foo --bar
-- | ////// naval-fate --debug
-- | ```
-- |
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do

  -- Title
  string "Usage:" <* chompRight
  many space
  Position { column: col } <- getPosition

  -- Usage lines (at least one)
  (:)
    <$> (usage program)
    <*> (many $ try do
          eol
          indent (col - 1)
          usage program <* many space)

optionLine :: Parser String Unit
optionLine = do
  return unit

  -- ((try do
  --     FullOptionSpec
  --       <$> (shortOption false)
  --       <*> (do char ','
  --               many space
  --               longOption))
  --   <|> (try do ShortOptionSpec <$> shortOption false)
  --   <|> (try do LongOptionSpec <$> longOption)
  -- ) <*> Nothing

  --
  -- char ','
  -- many space
  -- lopt <- longOption
  --
  -- -- The description is expected to start
  -- --  with at least 2 spaces distance.
  -- space
  -- space
  -- many space
  --
  -- desc <- description
  --
  -- return unit

optionsBlock :: Parser String Unit
optionsBlock = do

  -- Title
  string "Options:" <* chompRight
  many space
  Position { column: col } <- getPosition

  -- Option lines
  x <- optionLine

  return unit

meta :: String -> Parser String Unit
meta program = do
  skipSpaces

  -- Parse the `Usage` section
  usage <- usageBlock program
  debug "Usage:"
  debug usage

  many $ try $ many space *> eol

  -- Parse the `Options` section
  opts <- optionsBlock
  debug "Options:"
  debug opts

  return unit


Add test for trim lines

Add test for trim lines

module Test.Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Prelude
import Test.Unit (suite, test)
import Test.Unit.Assert (assert)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)
import Color (Color, rgba)

import Util.Parse (parse)

c0 = rgba  0  0  0 1.0 :: Color
c1 = rgba 17 17 17 1.0 :: Color
c2 = rgba 34 34 34 1.0 :: Color
c3 = rgba 51 51 51 1.0 :: Color

css :: String
css = ".selector {\n\t\n\t  border : 1px solid #000;\n\t  color: #111;\n\t  background: #222;\n\t  /* even#333*/\n\t\n\t\n\t}\n"

main :: forall e. Eff (avar :: AVAR, testOutput :: TESTOUTPUT, console :: CONSOLE | e) Unit
main = runTest do
  suite "Parser" do
    test "HEX" do

      assert "an empty string should be []" $
        (parse "") == []

      assert "Six hex digits should parse as a single color"  $
        (parse "000000") == [c0]

      assert "Three hex digits should parse to a single color" $
        (parse "000") == [c0]

      assert "Six hex digits preceded by # should parse to a single color" $
        (parse "#000000") == [c0]

      assert "Three hex digits preceded by # should parse to a single color" $
        (parse "#000") == [c0]

      assert "A hex with out of bounds values shall not parse" $
        (parse "#GGG") == []

      assert "Multiple hexes on one trim line shall be parsed" $
        (parse "#000 #111 #222") == [c0, c1, c2]

      assert "Multiple hexes on one line shall be parsed" $
        (parse " #000 #111 #222 ") == [c0, c1, c2]

      assert "Multiple hexes on multiple lines shall be parsed" $
        (parse " #000 #111\n #222 #333") == [c0, c1, c2, c3]

      assert "Hexes can be parsed from CSS" $
        (parse css) == [c0, c1, c2, c3]

module Test.Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Prelude
import Test.Unit (suite, test)
import Test.Unit.Assert (assert)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)
import Color (Color, rgba)

import Util.Parse (parse)

c0 = rgba  0  0  0 1.0 :: Color
c1 = rgba 17 17 17 1.0 :: Color
c2 = rgba 34 34 34 1.0 :: Color
c3 = rgba 51 51 51 1.0 :: Color

css :: String
css = ".selector {\n\t\n\t  border : 1px solid #000;\n\t  color: #111;\n\t  background: #222;\n\t  /* even#333*/\n\t\n\t\n\t}\n"

main :: forall e. Eff (avar :: AVAR, testOutput :: TESTOUTPUT, console :: CONSOLE | e) Unit
main = runTest do
  suite "Parser" do
    test "HEX" do

      assert "an empty string should be []" $
        (parse "") == []

      assert "Six hex digits should parse as a single color"  $
        (parse "000000") == [c0]

      assert "Three hex digits should parse to a single color" $
        (parse "000") == [c0]

      assert "Six hex digits preceded by # should parse to a single color" $
        (parse "#000000") == [c0]

      assert "Three hex digits preceded by # should parse to a single color" $
        (parse "#000") == [c0]

      assert "A hex with out of bounds values shall not parse" $
        (parse "#GGG") == []

      assert "Multiple hexes on one line shall be parsed" $
        (parse " #000 #111 #222 ") == [c0, c1, c2]

      assert "Multiple hexes on multiple lines shall be parsed" $
        (parse " #000 #111\n #222 #333") == [c0, c1, c2, c3]

      assert "Hexes can be parsed from CSS" $
        (parse css) == [c0, c1, c2, c3]


Add execWriter

Add execWriter

module Control.Monad.Writer where

import Prelude
import Control.Monad.Identity
import Control.Monad.Writer.Trans
import Data.Monoid
import Data.Tuple

type Writer w a = WriterT w Identity a

runWriter :: forall w a. Writer w a -> Tuple a w
runWriter = runIdentity <<< runWriterT

execWriter :: forall w a. Writer w a -> w
execWriter m = snd (runWriter m)

mapWriter :: forall w1 w2 a b. (Tuple a w1 -> Tuple b w2) -> Writer w1 a -> Writer w2 b
mapWriter f = mapWriterT (Identity <<< f <<< runIdentity)

module Control.Monad.Writer where

import Prelude
import Control.Monad.Identity
import Control.Monad.Writer.Trans
import Data.Monoid
import Data.Tuple

type Writer w a = WriterT w Identity a

runWriter :: forall w a. Writer w a -> Tuple a w
runWriter = runIdentity <<< runWriterT

mapWriter :: forall w1 w2 a b. (Tuple a w1 -> Tuple b w2) -> Writer w1 a -> Writer w2 b
mapWriter f = mapWriterT (Identity <<< f <<< runIdentity)