Fix offsets in UI clicking test -- almost works!

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (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

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

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo s 0.25 box dat
                         in map dd

newtype CanvasX = CX Number

newtype ViewX = ViewX (Ratio BigInt)

canvasToView :: Pixels
             -> CanvasX
             -> ViewX
canvasToView w (CX x) = ViewX $ x' % w'
  where w' = BigInt.fromInt $ Int.round w
        x' = BigInt.fromInt $ Int.round x

newtype BrowserX = BX BigInt

viewToGlobal :: Tuple BrowserX BrowserX
             -> ViewX
             -> BrowserX
viewToGlobal (Tuple (BX l) (BX r)) (ViewX p) =
  let r' = r % one
      l' = l % one
      p' = (p * (r' - l')) + l'
  in BX $ (Ratio.numerator p') / (Ratio.denominator p')

-- findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))

findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))
             -> BigInt
             -> Maybe (Tuple ChrId (Tuple BigInt BigInt))
findInterval ivals p =
  Array.find (\(Tuple i (Tuple l r)) -> l <= p && p <= r) intervals

-- this could be done in a more generic manner by extracting the view interval
-- using the applicative on (->)
globalToFrame :: Array (Tuple ChrId (Tuple BigInt BigInt))
              -> BrowserX
              -> Maybe (Tuple ChrId ViewX)
globalToFrame ivals (BX p) = do
  (Tuple i (Tuple l r)) <- findInterval ivals p

  pure $ Tuple i $ ViewX $ (p - l) % (r - l)

frameToChr :: Array (Tuple ChrId BigInt)
           -> Tuple ChrId ViewX
           -> Maybe (Tuple ChrId BigInt)
frameToChr chrs (Tuple i (ViewX x)) = do
  (Tuple _ size) <- Array.find ((==) i <<< fst) chrs
  let x' = x * (size % one)
  pure $ Tuple i $ Ratio.numerator x'

chrsToView :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Array ChrId
           -> Tuple BrowserX BrowserX
chrsToView chrs view = fromMaybe (Tuple (BX zero) (BX one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ (Tuple start _)) <- Array.find ((==) f <<< fst) chrs
  (Tuple _ (Tuple _ end)) <- Array.find ((==) l <<< fst) chrs

  pure $ Tuple (BX start) (BX end)

viewRange :: Array (Tuple ChrId (Tuple BigInt BigInt))
          -> Event (Array ChrId)
          -> Event (Tuple BrowserX BrowserX)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r.
              CanvasElement
           -> Event CanvasX
clickEvent el = (CX <<< _.x)<$> canvasEvent "mousedown" el

viewClick :: forall r.
             { width :: Pixels | r}
          -> Event CanvasX
          -> Event ViewX
viewClick {width} = map (canvasToView width)

globalClick :: Event (Tuple BrowserX BrowserX)
            -> Event ViewX
            -> Event BrowserX
globalClick vs vx = viewToGlobal <$> vs <*> vx

frameClick :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Event BrowserX
           -- -> Event ViewX
           -> Event (Maybe (Tuple ChrId ViewX))
frameClick ivals = map (globalToFrame ivals)

chrClick :: Array (Tuple ChrId BigInt)
         -> Event (Maybe (Tuple ChrId ViewX))
         -> Event (Maybe (Tuple ChrId BigInt))
chrClick chrs ev = (frameToChr chrs =<< _) <$> ev

showView :: Tuple BrowserX BrowserX -> String
showView (Tuple (BX l) (BX r)) = "< " <> show l <> " -- " <> show r <> " >"

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Tuple BrowserX BrowserX)
      viewEv' = viewRange intervals viewEvent

      click :: Event CanvasX
      click = clickEvent canvas

      vClick :: Event ViewX
      vClick = viewClick {width: w} click

      gClick :: Event BrowserX
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe (Tuple ChrId ViewX))
      fClick = frameClick intervals gClick

      cClick :: Event (Maybe (Tuple ChrId BigInt))
      cClick = chrClick mouseChrSizes fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

      showVX :: ViewX -> String
      showVX (ViewX x) = (BigInt.toString $ Ratio.numerator   x) <> "/"
                      <> (BigInt.toString $ Ratio.denominator x)

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sC (CX x)    = "
Canvas click: " <> show x <> "
"
               sV x         = "
View click: " <> showVX x <> "
"
               sG (BX x)    = "
Global click: " <> BigInt.toString x <> "
"
               sF :: _
               sF = show <<< (map <<< map) showVX
               sChr :: _
               sChr = show <<< (map <<< map) BigInt.toString

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> sC ev.canvasClick
                    <> sV ev.vClick
                    <> sG ev.gClick
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

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

intervals :: Array (Tuple ChrId (Tuple BigInt BigInt))
intervals = Array.zip ids $ Array.zip (zero `Array.cons` os) os
  where (Tuple ids sizes) = Array.unzip mouseChrSizes
        os = Array.scanl (+) zero sizes

-- mkIntervals :: Array BigInt
--             -> Array (Tuple BigInt BigInt)
-- mkIntervals bps = Array.zip (zero `Array.cons` os) os
--   where os :: Array BigInt
--         os = Array.scanl (+) zero bps

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (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

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

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo s 0.25 box dat
                         in map dd

newtype CanvasX = CX Number

newtype ViewX = ViewX (Ratio BigInt)

canvasToView :: Pixels
             -> CanvasX
             -> ViewX
canvasToView w (CX x) = ViewX $ x' % w'
  where w' = BigInt.fromInt $ Int.round w
        x' = BigInt.fromInt $ Int.round x

newtype BrowserX = BX BigInt

viewToGlobal :: Tuple BrowserX BrowserX
             -> ViewX
             -> BrowserX
viewToGlobal (Tuple (BX l) (BX r)) (ViewX p) =
  let p' = p * ((r - l) % one)
  in BX $ (Ratio.numerator p') / (Ratio.denominator p')

-- findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))

findInterval :: Array (Tuple ChrId (Tuple BigInt BigInt))
             -> BigInt
             -> Maybe (Tuple ChrId (Tuple BigInt BigInt))
findInterval ivals p =
  Array.find (\(Tuple i (Tuple l r)) -> l <= p && p <= r) intervals

-- this could be done in a more generic manner by extracting the view interval
-- using the applicative on (->)
globalToFrame :: Array (Tuple ChrId (Tuple BigInt BigInt))
              -> BrowserX
              -> Maybe (Tuple ChrId ViewX)
globalToFrame ivals (BX p) = do
  (Tuple i (Tuple l r)) <- findInterval ivals p

  pure $ Tuple i $ ViewX $ (p - l) % (r - l)

frameToChr :: Array (Tuple ChrId BigInt)
           -> Tuple ChrId ViewX
           -> Maybe (Tuple ChrId BigInt)
frameToChr chrs (Tuple i (ViewX x)) = do
  (Tuple _ size) <- Array.find ((==) i <<< fst) chrs
  let x' = x * (size % one)
  pure $ Tuple i $ Ratio.numerator x'

chrsToView :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Array ChrId
           -> Tuple BrowserX BrowserX
chrsToView chrs view = fromMaybe (Tuple (BX zero) (BX one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ (Tuple start _)) <- Array.find ((==) f <<< fst) chrs
  (Tuple _ (Tuple _ end)) <- Array.find ((==) l <<< fst) chrs

  pure $ Tuple (BX start) (BX end)

viewRange :: Array (Tuple ChrId (Tuple BigInt BigInt))
          -> Event (Array ChrId)
          -> Event (Tuple BrowserX BrowserX)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r.
              CanvasElement
           -> Event CanvasX
clickEvent el = (CX <<< _.x)<$> canvasEvent "mousedown" el

viewClick :: forall r.
             { width :: Pixels | r}
          -> Event CanvasX
          -> Event ViewX
viewClick {width} = map (canvasToView width)

globalClick :: Event (Tuple BrowserX BrowserX)
            -> Event ViewX
            -> Event BrowserX
globalClick vs vx = viewToGlobal <$> vs <*> vx

frameClick :: Array (Tuple ChrId (Tuple BigInt BigInt))
           -> Event BrowserX
           -- -> Event ViewX
           -> Event (Maybe (Tuple ChrId ViewX))
frameClick ivals = map (globalToFrame ivals)

chrClick :: Array (Tuple ChrId BigInt)
         -> Event (Maybe (Tuple ChrId ViewX))
         -> Event (Maybe (Tuple ChrId BigInt))
chrClick chrs ev = (frameToChr chrs =<< _) <$> ev

showView :: Tuple BrowserX BrowserX -> String
showView (Tuple (BX l) (BX r)) = "< " <> show l <> " -- " <> show r <> " >"

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Tuple BrowserX BrowserX)
      viewEv' = viewRange intervals viewEvent

      click :: Event CanvasX
      click = clickEvent canvas

      vClick :: Event ViewX
      vClick = viewClick {width: w} click

      gClick :: Event BrowserX
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe (Tuple ChrId ViewX))
      fClick = frameClick intervals gClick

      cClick :: Event (Maybe (Tuple ChrId BigInt))
      cClick = chrClick mouseChrSizes fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

      showVX :: ViewX -> String
      showVX (ViewX x) = (BigInt.toString $ Ratio.numerator   x) <> "/"
                      <> (BigInt.toString $ Ratio.denominator x)

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sC (CX x)    = "
Canvas click: " <> show x <> "
"
               sV x         = "
View click: " <> showVX x <> "
"
               sG (BX x)    = "
Global click: " <> BigInt.toString x <> "
"
               sF :: _
               sF = show <<< (map <<< map) showVX
               sChr :: _
               sChr = show <<< (map <<< map) BigInt.toString

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> sC ev.canvasClick
                    <> sV ev.vClick
                    <> sG ev.gClick
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

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

intervals :: Array (Tuple ChrId (Tuple BigInt BigInt))
intervals = Array.zip ids $ Array.zip (zero `Array.cons` os) os
  where (Tuple ids sizes) = Array.unzip mouseChrSizes
        os = Array.scanl (+) zero sizes

-- mkIntervals :: Array BigInt
--             -> Array (Tuple BigInt BigInt)
-- mkIntervals bps = Array.zip (zero `Array.cons` os) os
--   where os :: Array BigInt
--         os = Array.scanl (+) zero bps


Start wiring up scrolling-compatible events etc. in UI

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, drawDemo', getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), BrowserPoint(..), ChrId(..), CoordSys(..), Interval(..), IntervalPoint, LocalPoint(..), Point, canvasToBrowserOffset, canvasToView, frameToChr, globalToFrame, intervalSize, localToGlobal, mkCoordSys)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (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

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

-- 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 canvasEvent :: String -> CanvasElement -> Event Point

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

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BrowserPoint
  | Zoom (Ratio BigInt)
  | NoOp

-- btnScroll :: Event UpdateView
-- btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
--             const GoRight <$> buttonEvent "scrollRight"

-- btnZoom :: Event UpdateView
-- btnZoom = const Out <$> buttonEvent "zoomOut" <|>
--           const In  <$> buttonEvent "zoomIn"

-- btnUpdateView :: Event UpdateView
-- btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

scrollView :: BrowserPoint
           -> BrowserView
           -> BrowserView
scrollView (BPoint p) (Interval (BPoint l) (BPoint r)) =
  Interval (BPoint $ l - p) (BPoint $ r - p)

zoomView :: Ratio BigInt
         -> BrowserView
         -> BrowserView
zoomView (BPoint p) iv@(Interval (BPoint l) (BPoint r)) = iv

updateViewFold :: UpdateView
               -> BrowserView
               -> BrowserView
updateViewFold uv iv@(Interval l r) of
  Scroll p  -> scrollView p iv
  Zoom r    -> zoomView r iv
  NoOp -> iv

browserViewEvent :: BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent start ev = Event.fold updateViewFold ev start

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event BrowserView
             -> Event Drawing
drawingEvent s box dat = let dd = drawDemo' s 0.25 box dat
                         in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> localToGlobal $ Local iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint -> Event BrowserPoint -> Event (Maybe (Tuple ChrId IntervalPoint))
frameClick csys = map (globalToFrame csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (Tuple ChrId IntervalPoint))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = f <$> ev
  where f x = do
          p@(Tuple i _) <- x
          Tuple i <$> frameToChr csys p

showView :: Interval BrowserPoint -> String
showView (Interval (BPoint l) (BPoint r)) = "< " <> BigInt.toString l <> " -- " <> BigInt.toString r <> " >"

showLP :: IntervalPoint -> String
showLP (Local iv p) = "Interval: " <> showView iv <> ";\t" <> show p

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)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event (Interval BrowserPoint)
            -> Event Number
            -> Event BrowserPoint
browserDrag w v ev = canvasToBrowserOffset w
                     <$> map intervalSize v
                     <*> ev

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv = canvasDrag canvas

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Interval BrowserPoint)
      viewEv' = viewRange coordSys viewEvent

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe _)
      fClick = frameClick coordSys gClick

      cClick :: Event (Maybe _)
      cClick = chrClick coordSys fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just (Tuple chr i)) = "Frame: " <> show chr <> showLP i
               sF Nothing = "No Frame"
               sChr (Just (Tuple chr bp)) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

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

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), BrowserPoint(..), ChrId(..), CoordSys(..), Interval(..), IntervalPoint, LocalPoint(..), Point, canvasToBrowserOffset, canvasToView, frameToChr, globalToFrame, intervalSize, intervalToGlobal, mkCoordSys)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (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

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

-- 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 canvasEvent :: String -> CanvasElement -> Event Point

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

-- type View = { lHand :: ChrId, rHand :: ChrId }

-- type ZipperRange a =
--   { left  :: List a
--   , focus :: List a
--   , right :: List a
--   }

-- zipSlideLeft :: forall a.
--                 ZipperRange a
--              -> ZipperRange a
-- zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
--     Nothing, _  -> zr
--     _ , Nothing -> zr
--     Just l, Just f ->
--       let left'  = l.tail
--           focus' = l.head : f.init
--           right' = f.last : right
--       in {left: left', focus: focus', right: right'}

-- zipSlideRight :: forall a.
--                  ZipperRange a
--               -> ZipperRange a
-- zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
--     Nothing, _  -> zr
--     _ , Nothing -> zr
--     Just f, Just r ->
--       let left'  = f.head : left
--           focus' = f.tail <> List.singleton r.head
--           right' = r.tail
--       in {left: left', focus: focus', right: right'}

-- zipZoomIn :: forall a.
--              ZipperRange a
--           -> ZipperRange a
-- zipZoomIn zr@{left, focus, right} = case List.uncons focus of
--   Nothing -> zr
--   Just {head, tail} -> case List.unsnoc tail of
--     Nothing -> zr
--     Just {init, last} ->
--       let left'  = head : left
--           focus' = init
--           right' = last : right
--       in {left: left', focus: focus', right: right'}

-- zipZoomOut :: forall a.
--               ZipperRange a
--            -> ZipperRange a
-- zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
--   Nothing, Nothing -> zr
--   Nothing, Just r ->
--     let focus' = focus <> List.singleton r.head
--         right' = r.tail
--     in zr { focus = focus', right = right' }
--   Just l, Nothing ->
--     let left' = l.tail
--         focus' = l.head : focus
--     in zr { focus = focus', left = left' }
--   Just l, Just r ->
--     let left' = l.tail
--         focus' = l.head : focus <> List.singleton r.head
--         right' = r.tail
--     in { left: left', focus: focus', right: right' }

-- focusArray :: forall a.
--               ZipperRange a
--            -> Array a
-- focusArray {focus} = Array.fromFoldable focus

-- unfocusArray :: forall a.
--                 Array a
--              -> ZipperRange a
-- unfocusArray arr = { left: Nil
--                    , focus: List.fromFoldable arr
--                    , right: Nil
--                    }

-- data UpdateView =
--     GoLeft
--   | GoRight
--   | Out
--   | In
--   | NoOp

-- btnScroll :: Event UpdateView
-- btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
--             const GoRight <$> buttonEvent "scrollRight"

-- btnZoom :: Event UpdateView
-- btnZoom = const Out <$> buttonEvent "zoomOut" <|>
--           const In  <$> buttonEvent "zoomIn"

-- btnUpdateView :: Event UpdateView
-- btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

-- mkFoldView :: UpdateView
--            -> ZipperRange ChrId
--            -> ZipperRange ChrId
-- mkFoldView uv zr = case uv of
--   GoLeft  -> zipSlideLeft zr
--   GoRight -> zipSlideRight zr
--   Out     -> zipZoomOut zr
--   In      -> zipZoomIn zr
--   NoOp    -> zr

-- chrZREvent :: Array ChrId
--            -> Event UpdateView
--            -> Event (ZipperRange ChrId)
-- chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

-- chrsArrayEvent :: Event (ZipperRange ChrId)
--                -> Event (Array ChrId)
-- chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

type BrowserView = Interval BrowserPoint

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -- -> Event (Array ChrId)
             -> Event (BrowserView)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo' s 0.25 box dat
                         in map dd

chrsToView :: CoordSys ChrId BrowserPoint
           -> Array ChrId
           -> Interval BrowserPoint
chrsToView (CoordSys csys) view = fromMaybe (Interval (BPoint zero) (BPoint one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ ivS) <- Array.find ((==) f <<< fst) csys.intervals
  (Tuple _ ivE) <- Array.find ((==) l <<< fst) csys.intervals

  let (Interval start _) = ivS.interval
      (Interval _   end) = ivE.interval

  pure $ Interval start end

viewRange :: CoordSys ChrId BrowserPoint
          -> Event (Array ChrId)
          -> Event (Interval BrowserPoint)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal $ Local iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint -> Event BrowserPoint -> Event (Maybe (Tuple ChrId IntervalPoint))
frameClick csys = map (globalToFrame csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (Tuple ChrId IntervalPoint))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = f <$> ev
  where f x = do
          p@(Tuple i _) <- x
          Tuple i <$> frameToChr csys p

showView :: Interval BrowserPoint -> String
showView (Interval (BPoint l) (BPoint r)) = "< " <> BigInt.toString l <> " -- " <> BigInt.toString r <> " >"

showLP :: IntervalPoint -> String
showLP (Local iv p) = "Interval: " <> showView iv <> ";\t" <> show p

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)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event (Interval BrowserPoint)
            -> Event Number
            -> Event BrowserPoint
browserDrag w v ev = canvasToBrowserOffset w
                     <$> map intervalSize v
                     <*> ev

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv = canvasDrag canvas

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Interval BrowserPoint)
      viewEv' = viewRange coordSys viewEvent

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe _)
      fClick = frameClick coordSys gClick

      cClick :: Event (Maybe _)
      cClick = chrClick coordSys fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just (Tuple chr i)) = "Frame: " <> show chr <> showLP i
               sF Nothing = "No Frame"
               sChr (Just (Tuple chr bp)) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

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


make it bigger

make it bigger

module Rendering where

import Data.Array
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
import Control.Monad.Eff

import ExtraDom
import LevelMap
import Types
import Utils

pxPerBlock :: Number
pxPerBlock = 3

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

setupRendering :: forall e. Eff (canvas :: Canvas | e) Context2D
setupRendering = do
  c <- getCanvasElementById "canvas"
        >>= setCanvasHeight canvasSize
        >>= setCanvasWidth canvasSize
  getContext2D c

renderBackground :: forall e.
  Context2D -> Eff (canvas :: Canvas | e) Context2D
renderBackground ctx =
  let r = {x: 0, y: 0, h: canvasSize, w: canvasSize}
  in fillRect ctx r

-- render a row at the given y-coordinate on the canvas
renderRow :: forall e.
  Context2D
  -> [Block]
  -> Number
  -> Eff (canvas :: Canvas | e) Unit
renderRow ctx blocks y =
  eachWithIndex_ blocks $ \block n ->
    case block of
      Empty -> void $ fillRect ctx $ getRect n
      Wall -> return unit
  where
  getRect n = {x: n * pxPerBlock, y: y, h: pxPerBlock, w: pxPerBlock}

renderMap :: forall e.
  Context2D
  -> LevelMap
  -> Eff (canvas :: Canvas | e) Unit
renderMap ctx map =
  withContext ctx go
  where
  go = do
    setFillStyle "gray" ctx
    eachWithIndex_ (getBlocks map) $ \row n -> do
      renderRow ctx row (n * pxPerBlock)
      return unit

---

-- renderElems :: forall e a.
--   (a -> Eff (dom :: DOM | e) HTMLElement) -- rendering action
--   -> [a]                                  -- list of things to render
--   -> HTMLElement                          -- container
--   -> Eff (dom :: DOM | e) HTMLElement
-- renderElems f xs container = do
--   let acts = f <$> xs
--   renderedElems <- sequence acts
--   for_ renderedElems (appendChild container)
--   return container

-- renderInDiv :: forall e a.
--   String                                     -- class of container
--   -> (a -> Eff (dom :: DOM | e) HTMLElement) -- rendering action
--   -> [a]                                     -- list of things to render
--   -> Eff (dom :: DOM | e) HTMLElement
-- renderInDiv class_ f xs = do
--   c <- createElement "div"
--   classAdd class_ c
--   renderElems f xs c

-- renderMap :: forall e. LevelMap -> Eff (dom :: DOM | e) HTMLElement
-- renderMap (LevelMap blockRows) =
--   renderInDiv "levelmap" renderBlockRow blockRows

-- renderBlockRow :: forall e. [Block] -> Eff (dom :: DOM | e) HTMLElement
-- renderBlockRow blocks =
--   renderInDiv "row" renderBlock blocks

-- renderBlock :: forall e. Block -> Eff (dom :: DOM | e) HTMLElement
-- renderBlock b =
--   case b of
--     Wall -> go "wall"
--     Empty -> go "empty"
--   where
--   go extraClass = do
--     e <- createElement "div"
--     classAdd "block" e
--     classAdd extraClass e
--     return e

module Rendering where

import Data.Array
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
import Control.Monad.Eff

import ExtraDom
import LevelMap
import Types
import Utils

pxPerBlock :: Number
pxPerBlock = 2

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

setupRendering :: forall e. Eff (canvas :: Canvas | e) Context2D
setupRendering = do
  c <- getCanvasElementById "canvas"
        >>= setCanvasHeight canvasSize
        >>= setCanvasWidth canvasSize
  getContext2D c

renderBackground :: forall e.
  Context2D -> Eff (canvas :: Canvas | e) Context2D
renderBackground ctx =
  let r = {x: 0, y: 0, h: canvasSize, w: canvasSize}
  in fillRect ctx r

-- render a row at the given y-coordinate on the canvas
renderRow :: forall e.
  Context2D
  -> [Block]
  -> Number
  -> Eff (canvas :: Canvas | e) Unit
renderRow ctx blocks y =
  eachWithIndex_ blocks $ \block n ->
    case block of
      Empty -> void $ fillRect ctx $ getRect n
      Wall -> return unit
  where
  getRect n = {x: n * pxPerBlock, y: y, h: pxPerBlock, w: pxPerBlock}

renderMap :: forall e.
  Context2D
  -> LevelMap
  -> Eff (canvas :: Canvas | e) Unit
renderMap ctx map =
  withContext ctx go
  where
  go = do
    setFillStyle "gray" ctx
    eachWithIndex_ (getBlocks map) $ \row n -> do
      renderRow ctx row (n * pxPerBlock)
      return unit

---

-- renderElems :: forall e a.
--   (a -> Eff (dom :: DOM | e) HTMLElement) -- rendering action
--   -> [a]                                  -- list of things to render
--   -> HTMLElement                          -- container
--   -> Eff (dom :: DOM | e) HTMLElement
-- renderElems f xs container = do
--   let acts = f <$> xs
--   renderedElems <- sequence acts
--   for_ renderedElems (appendChild container)
--   return container

-- renderInDiv :: forall e a.
--   String                                     -- class of container
--   -> (a -> Eff (dom :: DOM | e) HTMLElement) -- rendering action
--   -> [a]                                     -- list of things to render
--   -> Eff (dom :: DOM | e) HTMLElement
-- renderInDiv class_ f xs = do
--   c <- createElement "div"
--   classAdd class_ c
--   renderElems f xs c

-- renderMap :: forall e. LevelMap -> Eff (dom :: DOM | e) HTMLElement
-- renderMap (LevelMap blockRows) =
--   renderInDiv "levelmap" renderBlockRow blockRows

-- renderBlockRow :: forall e. [Block] -> Eff (dom :: DOM | e) HTMLElement
-- renderBlockRow blocks =
--   renderInDiv "row" renderBlock blocks

-- renderBlock :: forall e. Block -> Eff (dom :: DOM | e) HTMLElement
-- renderBlock b =
--   case b of
--     Wall -> go "wall"
--     Empty -> go "empty"
--   where
--   go extraClass = do
--     e <- createElement "div"
--     classAdd "block" e
--     classAdd extraClass e
--     return e


Fix option parser application

Fix option parser application

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type ValueMapping = Tuple D.Argument D.Value
type Parser a = P.ParserT (List Token) (Reader D.Env) a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- Fold over a list of parsers, applying each in turn onto the result of the
-- previous, keeping both errors and results.
collect :: forall s m a. (Monad m)
    => List (P.ParserT s m a)
    -> P.ParserT s m (List (Either P.ParseError a))
collect xs = foldl step (pure mempty) xs
  where
    step :: forall s m a. (Monad m)
          => P.ParserT s m (List (Either P.ParseError a))
          -> P.ParserT s m a
          -> P.ParserT s m (List (Either P.ParseError a))
    step acc p = do
      a <- acc
      b <- P.ParserT $ \s -> P.unParserT p s >>= \o ->
            case o.result of
              Left e ->
                return {
                  input: o.input
                , result: Right (Left e)
                , consumed: o.consumed
                , position: o.position }
              Right a ->
                return {
                  input: o.input
                , result: Right (Right a)
                , consumed: o.consumed
                , position: o.position }
      return $ a ++ singleton b

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = do
  results <- collect $ xs <#> \x ->
              rmapScoreResult (Tuple x) <$> do
                genBranchParser x

  -- if there's just nothing but 0-scores, result in an ambiguity
  -- error, since there is no way we can know which branch the user
  -- wanted to complete. (XXX: or should all branches complete?)

  (Tuple zeros as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult)
             $ mrights results

  maybe'
    (\_ ->
      maybe'
        (\_ -> if (length xs == 1)
          then return $ _.result $ unScoredResult $ LU.head zeros
          else P.fail "ambigious match"
        )
        (\e -> do
          (P.ParseError err) <- return e
          P.ParserT $ \_ -> pure { input: Nil
                                  , result: Left $ P.ParseError err
                                  , consumed: true
                                  , position: err.position
                                  }
        )
        (head $ mlefts results)
    )
    (return <<< _.result <<< unScoredResult)
    (maximum as)

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ reverse ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> missing)
            else return mempty

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs
        rss <- genParser y
        return $ r ++ rs ++ rss

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "no long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then many go else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where go = if length bs > 0
                    then snd <$> genBranchesParser bs
                    else return mempty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type ValueMapping = Tuple D.Argument D.Value
type Parser a = P.ParserT (List Token) (Reader D.Env) a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- Fold over a list of parsers, applying each in turn onto the result of the
-- previous, keeping both errors and results.
collect :: forall s m a. (Monad m)
    => List (P.ParserT s m a)
    -> P.ParserT s m (List (Either P.ParseError a))
collect xs = foldl step (pure mempty) xs
  where
    step :: forall s m a. (Monad m)
          => P.ParserT s m (List (Either P.ParseError a))
          -> P.ParserT s m a
          -> P.ParserT s m (List (Either P.ParseError a))
    step acc p = do
      a <- acc
      b <- P.ParserT $ \s -> P.unParserT p s >>= \o ->
            case o.result of
              Left e ->
                return {
                  input: o.input
                , result: Right (Left e)
                , consumed: o.consumed
                , position: o.position }
              Right a ->
                return {
                  input: o.input
                , result: Right (Right a)
                , consumed: o.consumed
                , position: o.position }
      return $ a ++ singleton b

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = do
  results <- collect $ xs <#> \x ->
              rmapScoreResult (Tuple x) <$> do
                genBranchParser x

  -- if there's just nothing but 0-scores, result in an ambiguity
  -- error, since there is no way we can know which branch the user
  -- wanted to complete. (XXX: or should all branches complete?)

  (Tuple zeros as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult)
             $ mrights results

  maybe'
    (\_ ->
      maybe'
        (\_ -> if (length xs == 1)
          then return $ _.result $ unScoredResult $ LU.head zeros
          else P.fail "ambigious match"
        )
        (\e -> do
          (P.ParseError err) <- return e
          P.ParserT $ \_ -> pure { input: Nil
                                  , result: Left $ P.ParseError err
                                  , consumed: true
                                  , position: err.position
                                  }
        )
        (head $ mlefts results)
    )
    (return <<< _.result <<< unScoredResult)
    (maximum as)

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ reverse ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> missing)
            else return mempty

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs
        rss <- genParser y
        return $ r ++ rs ++ rss

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "no long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) = do
      vs <- concat <$>
          let mod    = if optional then P.option empty else \p -> p
              parser = if repeated then many go else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where go = if length bs > 0
                    then snd <$> genBranchesParser bs
                    else return mempty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false