Fix zooming -- view center is now constant

module Genetics.Browser.UI.Native where

import Prelude

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

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

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

genF :: String -> Bp -> Bp -> Aff _ (Feature Bp Number)
genF chr' min max = liftEff do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

fileFetch :: String
          -> View
          -- -> Aff _ Json
          -> Fetch _
fileFetch url view = do

  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
        -- TODO this might get fucked up due to exponential notation
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-5.0) * (Math.log score / Math.log 10.0))

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

glyphify :: View
         -> Feature Bp Number
         -> Glyph Unit
glyphify v (Feature chr min max score) = do
  let height = 30.0
      color  = "red"
      x = bpToPixels v.scale (min - v.min)
      -- x = unwrap min
      -- midX   = min + ((max - min) / 2.0)
  stroke color
  circle { x: x, y: height } 3.0
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

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

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

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

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

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

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

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

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

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

  -- toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
-- horDragEv :: Event (Maybe Point) -> Event Number
-- horDragEv ev = ptSum `sampleOn_` doneEv
--   where doneEv = filter isNothing ev
--         ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

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

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

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

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

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

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

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

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

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

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

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

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

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

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

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

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

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    launchAff $ fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx

main :: Eff _ _
main = launchAff do
  x <- fileFetch "http://localhost:8080/gwas.json" (unsafeCoerce unit)
  liftEff $ log $ unsafeStringify x
  browser

module Genetics.Browser.UI.Native where

import Prelude

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

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

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

genF :: String -> Bp -> Bp -> Aff _ (Feature Bp Number)
genF chr' min max = liftEff do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

fileFetch :: String
          -> View
          -- -> Aff _ Json
          -> Fetch _
fileFetch url view = do

  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
        -- TODO this might get fucked up due to exponential notation
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-5.0) * (Math.log score / Math.log 10.0))

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

glyphify :: View
         -> Feature Bp Number
         -> Glyph Unit
glyphify v (Feature chr min max score) = do
  let height = 30.0
      color  = "red"
      x = bpToPixels v.scale (min - v.min)
      -- x = unwrap min
      -- midX   = min + ((max - min) / 2.0)
  stroke color
  circle { x: x, y: height } 3.0
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

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

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

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

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

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

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

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

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

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

  -- toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
-- horDragEv :: Event (Maybe Point) -> Event Number
-- horDragEv ev = ptSum `sampleOn_` doneEv
--   where doneEv = filter isNothing ev
--         ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

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

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

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

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

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

        f (ModScale g) v' = v' { scale = g v'.scale }

        f (SetScale s) v' = v' { scale = s }

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

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

-- TODO: set a range to jump the view to
-- TODO: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

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

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

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      s :: BpPerPixel
      s = BpPerPixel $ 100000.0 / w
      v :: View
      v = { min: minView, max: maxView, scale: s }
      f :: View -> Fetch _
      f = fileFetch "http://localhost:8080/gwas.json"
      -- f = fetchWithView 100

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

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    launchAff $ fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx

main :: Eff _ _
main = launchAff do
  x <- fileFetch "http://localhost:8080/gwas.json" (unsafeCoerce unit)
  liftEff $ log $ unsafeStringify x
  browser


Remove unused DeckLevel

Remove unused DeckLevel

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Deck.DeckLevel
  ( DeckLevel
  , runDeckLevel
  , root
  , succ
  ) where

import SlamData.Prelude

newtype DeckLevel = DeckLevel Int

derive instance eqDeckLevel ∷ Eq DeckLevel
derive instance ordDeckLevel ∷ Ord DeckLevel

runDeckLevel ∷ DeckLevel → Int
runDeckLevel (DeckLevel i) = i

root ∷ DeckLevel
root = DeckLevel 0

succ ∷ DeckLevel → DeckLevel
succ (DeckLevel i) = DeckLevel (i + 1)


Removed subscribeToBus

Removed subscribeToBus

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Halogen.Component.Utils where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff, later', runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Eff.Class (liftEff)

import Data.Either as E
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Query.EventSource as ES

import Math as Math

withCanceler
  ∷ ∀ a eff g
  . (Bind g, Affable (avar ∷ AVAR | eff) g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → g Unit)
  → Aff (avar ∷ AVAR | eff) a
  → g a
withCanceler act aff = do
  v ← fromAff makeVar
  canceler ← fromAff $ forkAff do
    res ← aff
    putVar v res
  act canceler
  fromAff $ takeVar v

liftWithCanceler
  ∷ ∀ s f g eff a
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.ComponentDSL s f g a
liftWithCanceler f aff = do
  withCanceler (\c → void <$> sendAfter zero $ f c unit) aff

liftWithCanceler'
  ∷ ∀ s s' f f' g p a eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.ParentDSL s s' f f' g p a
liftWithCanceler' f aff = do
  withCanceler (\c → void <$> sendAfter' zero $ f c unit) aff

sendAfter
  ∷ ∀ s f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → H.ComponentDSL s f g (Canceler (avar ∷ AVAR | eff))
sendAfter ms action = do
  cancelerVar ← H.fromAff makeVar
  H.subscribe $ oneTimeEventSource ms action cancelerVar
  H.fromAff $ takeVar cancelerVar

sendAfter'
  ∷ ∀ s s' f f' g p eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → H.ParentDSL s s' f f' g p (Canceler (avar ∷ AVAR | eff))
sendAfter' ms action = do
  cancelerVar ← H.fromAff makeVar
  H.subscribe' $ oneTimeEventSource ms action cancelerVar
  H.fromAff $ takeVar cancelerVar

raise
  ∷ ∀ s f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ f Unit
  → H.ComponentDSL s f g Unit
raise = void <$> sendAfter (Milliseconds 0.0)

raise'
  ∷ ∀ s s' f f' g p eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ f Unit
  → H.ParentDSL s s' f f' g p Unit
raise' = void <$> sendAfter' (Milliseconds 0.0)

oneTimeEventSource
  ∷ ∀ f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → AVar (Canceler (avar ∷ AVAR | eff))
  → H.EventSource f g
oneTimeEventSource (Milliseconds n) action cancelerVar =
  ES.EventSource
    $ ES.produce \emit →
        void
          $ runAff (const $ pure unit) (const $ pure unit)
          $ putVar cancelerVar =<< (forkAff $ delay $ emitAndEnd emit)
  where
  delay = later' (Int.floor $ Math.max n zero)
  emitAndEnd emit = liftEff $ emit (E.Left action) *> emit (E.Right unit)

subscribeToBus'
  ∷ ∀ s s' f f' g p a r eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (a → f Unit)
  → Bus.Bus (read ∷ Bus.Cap | r) a
  → H.ParentDSL s s' f f' g p (EventLoop.Breaker Unit)
subscribeToBus' k bus = do
  breaker ← fromAff makeVar
  H.subscribe'
    $ ES.EventSource
    $ ES.produce \emit →
        void $ runAff (const $ pure unit) (const $ pure unit) do
          loop ← EventLoop.forever do
            a ← Bus.read bus
            forkAff $ H.fromEff $ emit $ E.Left (k a)
          putVar breaker loop.breaker
          loop.run
  H.fromAff $ takeVar breaker

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Halogen.Component.Utils where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff, later', runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Eff.Class (liftEff)

import Data.Either as E
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Query.EventSource as ES

import Math as Math

withCanceler
  ∷ ∀ a eff g
  . (Bind g, Affable (avar ∷ AVAR | eff) g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → g Unit)
  → Aff (avar ∷ AVAR | eff) a
  → g a
withCanceler act aff = do
  v ← fromAff makeVar
  canceler ← fromAff $ forkAff do
    res ← aff
    putVar v res
  act canceler
  fromAff $ takeVar v

liftWithCanceler
  ∷ ∀ s f g eff a
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.ComponentDSL s f g a
liftWithCanceler f aff = do
  withCanceler (\c → void <$> sendAfter zero $ f c unit) aff

liftWithCanceler'
  ∷ ∀ s s' f f' g p a eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.ParentDSL s s' f f' g p a
liftWithCanceler' f aff = do
  withCanceler (\c → void <$> sendAfter' zero $ f c unit) aff

sendAfter
  ∷ ∀ s f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → H.ComponentDSL s f g (Canceler (avar ∷ AVAR | eff))
sendAfter ms action = do
  cancelerVar ← H.fromAff makeVar
  H.subscribe $ oneTimeEventSource ms action cancelerVar
  H.fromAff $ takeVar cancelerVar

sendAfter'
  ∷ ∀ s s' f f' g p eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → H.ParentDSL s s' f f' g p (Canceler (avar ∷ AVAR | eff))
sendAfter' ms action = do
  cancelerVar ← H.fromAff makeVar
  H.subscribe' $ oneTimeEventSource ms action cancelerVar
  H.fromAff $ takeVar cancelerVar

raise
  ∷ ∀ s f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ f Unit
  → H.ComponentDSL s f g Unit
raise = void <$> sendAfter (Milliseconds 0.0)

raise'
  ∷ ∀ s s' f f' g p eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ f Unit
  → H.ParentDSL s s' f f' g p Unit
raise' = void <$> sendAfter' (Milliseconds 0.0)

oneTimeEventSource
  ∷ ∀ f g eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ Milliseconds
  → f Unit
  → AVar (Canceler (avar ∷ AVAR | eff))
  → H.EventSource f g
oneTimeEventSource (Milliseconds n) action cancelerVar =
  ES.EventSource
    $ ES.produce \emit →
        void
          $ runAff (const $ pure unit) (const $ pure unit)
          $ putVar cancelerVar =<< (forkAff $ delay $ emitAndEnd emit)
  where
  delay = later' (Int.floor $ Math.max n zero)
  emitAndEnd emit = liftEff $ emit (E.Left action) *> emit (E.Right unit)

subscribeToBus
  ∷ ∀ s f g a r eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (a → f Unit)
  → Bus.Bus (read ∷ Bus.Cap | r) a
  → H.ComponentDSL s f g (EventLoop.Breaker Unit)
subscribeToBus k bus = do
  breaker ← fromAff makeVar
  H.subscribe
    $ ES.EventSource
    $ ES.produce \emit →
        void $ runAff (const $ pure unit) (const $ pure unit) do
          loop ← EventLoop.forever do
            a ← Bus.read bus
            forkAff $ H.fromEff $ emit $ E.Left (k a)
          putVar breaker loop.breaker
          loop.run
  H.fromAff $ takeVar breaker

subscribeToBus'
  ∷ ∀ s s' f f' g p a r eff
  . (Affable (avar ∷ AVAR | eff) g, Functor g)
  ⇒ (a → f Unit)
  → Bus.Bus (read ∷ Bus.Cap | r) a
  → H.ParentDSL s s' f f' g p (EventLoop.Breaker Unit)
subscribeToBus' k bus = do
  breaker ← fromAff makeVar
  H.subscribe'
    $ ES.EventSource
    $ ES.produce \emit →
        void $ runAff (const $ pure unit) (const $ pure unit) do
          loop ← EventLoop.forever do
            a ← Bus.read bus
            forkAff $ H.fromEff $ emit $ E.Left (k a)
          putVar breaker loop.breaker
          loop.run
  H.fromAff $ takeVar breaker

-- TODO: Fix infinite type
--subscribeToBus'
--  ∷ ∀ s s' f f' g p a r eff
--  . (Affable (avar ∷ AVAR | eff) g, Functor g)
--  ⇒ (a → f Unit)
--  → Bus.Bus (read ∷ Bus.Cap | r) a
--  → H.ParentDSL s s' f f' g p Unit --(EventLoop.Breaker Unit)
--subscribeToBus' k bus = do
--  eventSourceAndBreaker ← busToEventSourceAndBreaker k bus
--  H.subscribe' eventSourceAndBreaker.eventSource
--  --pure eventSourceAndBreaker.breaker
--
--subscribeToBus
--  ∷ ∀ s f g a r eff
--  . (Affable (avar ∷ AVAR | eff) g, Functor g)
--  ⇒ (a → f Unit)
--  → Bus.Bus (read ∷ Bus.Cap | r) a
--  → H.ComponentDSL s f g Unit --(EventLoop.Breaker Unit)
--subscribeToBus k bus = do
--  eventSourceAndBreaker ← busToEventSourceAndBreaker k bus
--  H.subscribe eventSourceAndBreaker.eventSource
--  --pure eventSourceAndBreaker.breaker
--
--busToEventSourceAndBreaker
--  ∷ ∀ f g a r eff
--  . (Affable (avar ∷ AVAR | eff) g, Monad g)
--  ⇒ (a → f Unit)
--  → Bus.Bus (read ∷ Bus.Cap | r) a
--  → g { eventSource ∷ ES.EventSource f g, breaker ∷ EventLoop.Breaker Unit }
--busToEventSourceAndBreaker k bus = do
--  breakerAVar ← fromAff makeVar
--  let eventSource =
--        ES.EventSource
--          $ ES.produce \emit →
--            void $ runAff (const $ pure unit) (const $ pure unit) do
--              loop ← EventLoop.forever do
--                a ← Bus.read bus
--                forkAff $ H.fromEff $ emit $ E.Left (k a)
--              putVar breakerAVar loop.breaker
--              loop.run
--  breaker ← H.fromAff $ takeVar breakerAVar
--  pure { eventSource, breaker }


Nested types, first draft for CSharp

Nested types, first draft for CSharp

Original commit 3f93c2ddeee06d182fccacb2a35311d00ed83226

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data CSharpClass = CSClass { name :: String, properties :: StrMap.StrMap CSharpType }
data CSharpType
    = CSClassType CSharpClass
    | CSArray CSharpType
    | CSObject
    | CSBool
    | CSDouble
    | CSString

gatherCSharpClassesFromJson :: String -> Json -> Tuple CSharpType (Array CSharpClass)
gatherCSharpClassesFromJson name json = foldJson
    (const $ Tuple CSObject [])
    (\b -> Tuple CSBool [])
    (\x -> Tuple CSDouble [])
    (\s -> Tuple CSString [])
    (case _ of
        [] -> Tuple (CSArray CSObject) []
        a ->
            let Tuple et classes = gatherCSharpClassesFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            Tuple (CSArray et) classes)
    (\o ->
        let Tuple props classes = mapProperties o
            c = CSClass { name: name, properties: props } in
        Tuple (CSClassType c) (c : classes))
    json

mapStrMap :: forall a b. (String -> a -> b) -> StrMap.StrMap a -> Array b
mapStrMap f sm = map (uncurry f) (StrMap.toUnfoldable sm)

singularize :: String -> String
singularize s = "OneOf" <> s

mapProperties :: StrMap.StrMap Json -> Tuple (StrMap.StrMap CSharpType) (Array CSharpClass)
mapProperties sm = Tuple propMap classes
  where mapper (Tuple n j) = let Tuple t classes = gatherCSharpClassesFromJson n j
                              in Tuple (Tuple n t) classes
        results = map mapper (StrMap.toUnfoldable sm)
        propMap = StrMap.fromFoldable $ map fst results
        classes = concat $ map snd results

renderCSharpType :: CSharpType -> String
renderCSharpType (CSArray a) = (renderCSharpType a) <> "[]"
renderCSharpType (CSClassType (CSClass { name, properties })) = name
renderCSharpType CSObject = "object"
renderCSharpType CSBool = "bool"
renderCSharpType CSDouble = "double"
renderCSharpType CSString = "string"

renderCSharpClass :: CSharpClass -> String
renderCSharpClass (CSClass { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name csType = "    public " <> (renderCSharpType csType) <> " " <> name <> " { get; set; }"

renderCSharpClasses :: Array CSharpClass -> String
renderCSharpClasses classes =
    foldMap (\c -> (renderCSharpClass c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> gatherCSharpClassesFromJson "TopLevel"
    <#> snd
    <#> renderCSharpClasses

module Main where

import Prelude

import Data.Argonaut.Core (Json, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (foldMap)
import Data.StrMap as StrMap

data CSharpType = Class { name :: String, properties :: Array String }

jsonToCSharpType :: Json -> CSharpType
jsonToCSharpType j = Class { name: "MyValue", properties }
    where properties = foldJsonObject [] StrMap.keys j

renderCSharpType :: CSharpType -> String
renderCSharpType (Class { name, properties }) = "class " <> name <> """
{""" <>
    foldMap (\n -> "\n" <> nameToProperty n) properties
    <> """
}
"""
    where nameToProperty name = "    public string " <> name <> " { get; set; }"

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> jsonToCSharpType
    <#> renderCSharpType


passing typecheck but not for composition

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

fub :: forall d eff. Eff (d3::D3|eff) (Transition d)
fub = d3Transition "erg"
        .. duration 750.0

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do

  d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      .. makeTransition

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

fub :: forall d eff. Eff (d3::D3|eff) (Transition d)
fub = d3Transition "erg"
        .. duration 750.0

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)

  chart1 ... enter .. append "div"
        .. style "width" (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed "sweet sixteen" (ClassFn cep)
        .. attr "name"             (AttrV "fred")
        .. text                    (FnD (\d -> show d))
        .. on mouseenter         awn
        .. on mouseleave         awn
        .. on' click "magic" "snape" bel

  d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      .. makeTransition
  pure unit


parse adjacent arguments in desc parser

parse adjacent arguments in desc parser

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length
                 , singleton, many, head, catMaybes, filter)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, maybe', isJust)
import Data.Generic
import Data.String (toLower, fromChar)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Value
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lex)
import qualified Language.Docopt.Parser.Lexer as L

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe String
getDefaultValue (Default v) = Just v
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lex x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = StringValue <$> default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt

          arg <- maybe'
                  (\_ -> do P.optionMaybe (L.shoutName <|> L.angleName))
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$>  opt.arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just a) (Just b) | (a == b) = return (pure a)
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length
                 , singleton, many, head, catMaybes, filter)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Generic
import Data.String (toLower, fromChar)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Value
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lex)
import qualified Language.Docopt.Parser.Lexer as L

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe String
getDefaultValue (Default v) = Just v
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lex x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = StringValue <$> default
                }
            }

      where

        -- XXX: This parser needs to be extended to parse adjacent 'name'
        --      tokens as potential arguments:
        --      `-p PATH`, `-p, --path PATH`, `-p PATH, --path PATH`.

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt
          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> opt.arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt
          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$>  opt.arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just a) (Just b) | (a == b) = return (pure a)
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt


Remove WIP comment

Remove WIP comment

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length, fromList
                 , singleton, many, head, catMaybes, filter)
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 Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, maybe', isJust)
import Data.Generic
import Data.String (toLower, fromChar, fromCharArray)
import Data.Array as A
import Data.String as Str
import Data.String.Ext ((^=))

import Language.Docopt.Value hiding (parse, read)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lexDescs)
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Value as Value

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name     :: String
, default  :: Maybe Value
, optional :: Boolean
}

runArgument :: Argument -> {
  name     :: String
, default  :: Maybe Value
, optional :: Boolean
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe Value
getDefaultValue (Default v) = either (const Nothing) Just (Value.parse v)
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $
          (if a.optional then "[" else "")
            ++ "=" ++ a.name
            ++ (if a.optional then "]" else "")
            ++ (maybe ""
                      (\v -> "[default: " ++ prettyPrintValue v ++ "]")
                      a.default)

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { optional: o, name: n, default: d })
  = (if o then "[" else "") ++ n ++ (if o then "]" else "")
    ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String
         -> Boolean
         -> Maybe Value
         -> Argument
argument name optional default = Argument { name:   name
                                          , default:  default
                                          , optional: optional
                                          }

run :: String -> Either P.ParseError (List Desc)
run x = lexDescs x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt

          -- Grab the adjacent positional-looking argument
          -- in case the token did not have an explicit
          -- binding via `=`.
          arg <- maybe
                  (P.optionMaybe do
                    n <- L.shoutName <|> L.angleName
                    return { name: n, optional: false }
                  )
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Flag opt.flag
                          , arg:  Argument <$> do
                              a <- arg
                              return {
                                name:     a.name
                              , optional: a.optional
                              , default:  Nothing
                              }
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt

          -- Grab the adjacent positional-looking argument
          -- in case the token did not have an explicit
          -- binding via `=`.
          arg <- maybe
                  (P.optionMaybe do
                    n <- L.shoutName <|> L.angleName
                    return { name: n, optional: false }
                  )
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Long opt.name
                          , arg:  Argument <$> do
                              a <- arg
                              return {
                                name:     a.name
                              , optional: a.optional
                              , default:  Nothing
                              }
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just (Argument a)) (Just (Argument a'))
                  | (a.name ^= a'.name) = return $ Just
                      $ Argument { name:     a.name
                                 , optional: a.optional || a'.optional
                                 , default:  a.default <|> a'.default
                                 }
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe { name :: String
                                                       , optional :: Boolean
                                                       } }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe { name :: String
                                                         , optional :: Boolean
                                                         } }
    lopt = L.lopt

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length, fromList
                 , singleton, many, head, catMaybes, filter)
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 Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, maybe', isJust)
import Data.Generic
import Data.String (toLower, fromChar, fromCharArray)
import Data.Array as A
import Data.String as Str
import Data.String.Ext ((^=))

import Language.Docopt.Value hiding (parse, read)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lexDescs)
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Value as Value

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name     :: String
, default  :: Maybe Value
, optional :: Boolean
}

runArgument :: Argument -> {
  name     :: String
, default  :: Maybe Value
, optional :: Boolean
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe Value
getDefaultValue (Default v) = either (const Nothing) Just (Value.parse v)
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $
          (if a.optional then "[" else "")
            ++ "=" ++ a.name
            ++ (if a.optional then "]" else "")
            ++ (maybe ""
                      (\v -> "[default: " ++ prettyPrintValue v ++ "]")
                      a.default)

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { optional: o, name: n, default: d })
  = (if o then "[" else "") ++ n ++ (if o then "]" else "")
    ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String
         -> Boolean
         -> Maybe Value
         -> Argument
argument name optional default = Argument { name:   name
                                          , default:  default
                                          , optional: optional
                                          }

run :: String -> Either P.ParseError (List Desc)
run x = lexDescs x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt

          -- Grab the adjacent positional-looking argument
          -- in case the token did not have an explicit
          -- binding via `=`.
          arg <- maybe
                  (P.optionMaybe do
                    n <- L.shoutName <|> L.angleName
                    return { name: n, optional: false }
                  )
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Flag opt.flag
                          , arg:  Argument <$> do
                              a <- arg
                              return {
                                name:     a.name
                              , optional: a.optional
                              , default:  Nothing
                              } -- XXX: IMPLEMENT (SEE ABOVE)
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt

          -- Grab the adjacent positional-looking argument
          -- in case the token did not have an explicit
          -- binding via `=`.
          arg <- maybe
                  (P.optionMaybe do
                    n <- L.shoutName <|> L.angleName
                    return { name: n, optional: false }
                  )
                  (return <<< Just)
                  opt.arg

          return $ Option { name: Long opt.name
                          , arg:  Argument <$> do
                              a <- arg
                              return {
                                name:     a.name
                              , optional: a.optional
                              , default:  Nothing
                              } -- XXX: IMPLEMENT (SEE ABOVE)
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just (Argument a)) (Just (Argument a'))
                  | (a.name ^= a'.name) = return $ Just
                      $ Argument { name:     a.name
                                 , optional: a.optional || a'.optional
                                 , default:  a.default <|> a'.default
                                 }
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe { name :: String
                                                       , optional :: Boolean
                                                       } }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe { name :: String
                                                         , optional :: Boolean
                                                         } }
    lopt = L.lopt