Handle both batched (e.g. GWAS) and single (gene & annots) glyphs correctly

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (partition, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, foldl, foldr, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal, Traversal', over, re, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Index (ix)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, isJust, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, inj, on, onMatch, prj)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Interval Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Interval (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> NormalizedGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type BatchedDrawings = { drawing :: Drawing, points :: Array Point }
type SingleDrawing   = { drawing :: Drawing, point :: Point }

type Glyph = Variant ( batched :: BatchedDrawings
                     , single  :: SingleDrawing  )

type FixedUIComponent    = CanvasReadyDrawing
type RelativeUIComponent = Interval BrowserPoint -> CanvasReadyDrawing

type Browser = { tracks     :: Array Glyph
               , relativeUI :: Array RelativeUIComponent
               , fixedUI    :: Array FixedUIComponent }

type CanvasSingleGlyph = { drawing :: Drawing, point :: Point }
type CanvasBatchGlyph  = { drawing :: Drawing, points :: Array Point }

type BatchedTrack = Array CanvasBatchGlyph

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

_LHS :: Getter' HPos (Normalized Number)
_LHS = to $ case_
         # onMatch { point: \x -> x, range: \(Pair l _) -> l}

renderNormalizedGlyphs ::  forall f r a.
                          Canvas.Dimensions
                       -> { width :: Pixels, offset :: Pixels }
                       -> Array NormalizedGlyph
                       -> { toBatch :: Array SingleDrawing
                          , singles :: Array SingleDrawing }
renderNormalizedGlyphs {height} {width, offset} gs =
    (\ {left, right} -> {toBatch: left, singles: right})
    $ partitioned $ map drawIt gs

  where drawIt {drawing, horPos, verPos} =
          let x = width * unwrap (horPos ^. _LHS)
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
              res = { drawing: d, point: { x: (x + offset), y } }
          in if isJust $ prj _point drawing
                then Left res else Right res

batchDrawings :: Array SingleDrawing
              -> Array BatchedDrawings
batchDrawings = unfoldr f
  where f gs = Array.uncons gs >>= \ {head, tail} ->
                 let { no, yes } = partition (\ {drawing} -> head.drawing == drawing) tail
                     points = Array.cons head.point $ map _.point yes
                 in pure $ Tuple { drawing: head.drawing, points } no

batchNormalizedGlyphs :: forall f r a.
                         Canvas.Dimensions
                      -> { width :: Pixels, offset :: Pixels }
                      -> Array NormalizedGlyph
                      -> Array Glyph
batchNormalizedGlyphs h wo gs =
  let {toBatch, singles} = renderNormalizedGlyphs h wo gs
      batched = inj (SProxy :: SProxy "batched") <$> batchDrawings toBatch
      single  = inj (SProxy :: SProxy "single")  <$> singles
  in batched <> single

drawIntervalFeature :: forall f r a.
                       Foldable f
                    => Canvas.Dimensions
                    -> { width :: Pixels, offset :: Pixels }
                    -> f NormalizedGlyph
                    -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

drawRelativeUI :: forall f i a.
                  Ord i
               => Foldable f
               => CoordSys i BrowserPoint
               -> Map i (f NormalizedGlyph)
               -> Canvas.Dimensions
               -> RelativeUIComponent
drawRelativeUI cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

pureTrackGlyphs :: forall f i a.
                   Ord i
                => CoordSys i BrowserPoint
                -> Map i (Array NormalizedGlyph)
                -> Canvas.Dimensions
                -> Interval BrowserPoint
                -> Map i (Array Glyph)
pureTrackGlyphs cs glyphs cd v =
  zipMapsWith (\v gs -> batchNormalizedGlyphs cd v gs) (viewportIntervals cs cd v) glyphs

renderTrackGlyphs ::  forall f i a.
                      Ord i
                  => Foldable f
                  => Traversable f
                  => CoordSys i BrowserPoint
                  -> Renderer a
                  -> Map i (f a)
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Array Glyph
renderTrackGlyphs cs r trackData =
  let data' = map Array.fromFoldable trackData
      glyphs = (map <<< map) (render r) data'
  in \cd v -> fold $ pureTrackGlyphs cs glyphs cd v

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BrowserPoint
              -> Canvas.Dimensions
              -> RelativeUIComponent
chrLabelTrack cs = drawRelativeUI cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> NormalizedGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> Canvas.Dimensions
           -> RelativeUIComponent
boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: NormalizedGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Pixels
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Pixels
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Pixels
               , horizontal :: Pixels
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Filterable (partition)
import Data.Foldable (class Foldable, fold, foldMap, foldl, foldr, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal', Traversal, over, to, traverseOf, traversed, view, viewOn, (^.), (^?))
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(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, inj, on, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Interval Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Interval (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type ReadyGlyph = { drawing :: DrawingV
                  , horPos  :: HPos
                  , verPos  :: Normalized Number
                  }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> ReadyGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type CanvasSingleGlyph = { drawing :: Drawing, point :: Point }
type CanvasBatchGlyph  = { drawing :: Drawing, points :: Array Point }

type BatchedTrack = Array CanvasBatchGlyph

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

renderGlyphs :: forall f r a.
                Canvas.Dimensions
             -> { width :: Pixels, offset :: Pixels }
             -> Array ReadyGlyph
             -> Array CanvasSingleGlyph
renderGlyphs {height} {width, offset} gs = map drawIt gs
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in { drawing: d, point: { x: (x + offset), y } }

batchGlyphs :: Array CanvasSingleGlyph
            -> Array CanvasBatchGlyph
batchGlyphs = unfoldr f
  where f gs = Array.uncons gs >>= \ {head, tail} ->
                 let { no, yes } = partition (\ {drawing} -> head.drawing == drawing) tail
                     points = Array.cons head.point $ map _.point yes
                 in pure $ Tuple { drawing: head.drawing, points } no

drawIntervalFeature :: forall f r a.
                       Foldable f
                    => Canvas.Dimensions
                    -> { width :: Pixels, offset :: Pixels }
                    -> f ReadyGlyph
                    -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

pureTrack :: forall f i a.
             Ord i
          => Foldable f
          => CoordSys i BrowserPoint
          -> Map i (f ReadyGlyph)
          -> BrowserTrack
pureTrack cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

pureBatchTrack :: forall f i a.
                  Ord i
               => CoordSys i BrowserPoint
               -> Map i (Array ReadyGlyph)
               -> Canvas.Dimensions
               -> Interval BrowserPoint
               -> Map i (Array CanvasBatchGlyph)
pureBatchTrack cs glyphs cd v =
  zipMapsWith (\v gs -> batchGlyphs $ renderGlyphs cd v gs) (viewportIntervals cs cd v) glyphs

renderBatchTrack ::  forall f i a.
                     Ord i
                  => Foldable f
                  => Traversable f
                  => CoordSys i BrowserPoint
                  -> Renderer a
                  -> Map i (f a)
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Array CanvasBatchGlyph
renderBatchTrack cs r trackData =
  let data' = map Array.fromFoldable trackData
      glyphs = (map <<< map) (render r) data'
  in \cd v -> fold $ pureBatchTrack cs glyphs cd v

renderTrack :: forall f i a.
               Ord i
            => Foldable f
            => Traversable f
            => CoordSys i BrowserPoint
            -> Renderer a
            -> Map i (f a)
            -> BrowserTrack
renderTrack cs r trackData =
  let validDrawings :: Map i (f ReadyGlyph)
      validDrawings = Debug.trace ("Creating ReadyGlyphs for some track")
                      \_ -> (map <<< map) (render r) trackData
  in pureTrack cs validDrawings

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BrowserPoint
              -> BrowserTrack
chrLabelTrack cs = pureTrack cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> ReadyGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> BrowserTrack
boxesTrack h cs = pureTrack cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: ReadyGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Pixels
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Pixels
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Pixels
               , horizontal :: Pixels
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as


Remove commented out caching code

Remove commented out caching code

The new parser type runs fast enough w/o the need to cache at all

-- The neodoc arg parser
--
-- Parse the tokenized argv input in accordance with the layout rules specified
-- in the neodoc specification provided by the developer.
--
-- For example:
--
--      usage: prog -a -b -c
--         or: prog -d -e -f=FILE
--
--      options:
--          -f, --file FILE
--
-- This specification has 2 top-level branches, each of which need to be
-- considered individually and scored. The highest ranking top-level wins.
-- Should an error occur during parsing, the "deepest" parse error is elected
-- to be shown. This requires a single parser to track it's own depth.
--
-- Multiple permutations are trialed by runnign the parser on each branch,
-- provided with the same input state.
--
-- The arg parser, during it's operation, yields values of shape:
--
--      Alias => { Origin, Value }
--
-- where `Origin` denotes the origin of the value: provided as an argument to
-- the program, derived from the environment or a default value.
--
--
-- Parsing semantics
-- -----------------
--
-- The neodoc parser parses chunks of adjacent arguments as a unit.
-- These chunks come in 2 flavours: "free" and "fixed". "free" chunks are those
-- chunks where the contained arguments can be parsed freely in any order.
-- "fixed" chunks, on the other hand enforce a strict parse from left to right.
-- When neodoc operates in `lax-placement` mode, the entire list of arguments
-- become a single "free" chunk, but positionals and commands remain fixed
-- amongst each other, but options can be interspersed anywhere.
--
-- For example:
--
--      usage: prog foo bar -a -b -c qux
--
-- is "chunked" into: `<! foo bar !> <* -a -b -c *>`, where `<! ... !>` denotes
-- a "fixed" chunk and a `<* ... *>` denotes a free chunk.
--
-- Generally speaking, elements are elected as part of a "free" chunk if they
-- are options, or "fixed" otherwise.

module Neodoc.ArgParser.Parser where

import Prelude
import Debug.Trace
import Data.List (
  List(..), some, singleton, filter, fromFoldable, last, groupBy, sortBy, (:)
, null, concat, mapWithIndex, length, take, drop, toUnfoldable)
import Data.Array as Array
import Data.List.Partial as LU
import Data.Bifunctor (lmap)
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Data.Function (on)
import Data.Tuple (Tuple(..), snd)
import Data.Tuple.Nested ((/\))
import Data.Either (Either(..))
import Data.String as String
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.Maybe (Maybe(..), isJust, maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Foldable (
  class Foldable, maximumBy, all, intercalate, sum, any, elem)
import Data.Map as Map
import Data.Map (Map)
import Data.Pretty (pretty, class Pretty)
import Control.Alt ((<|>))
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Partial.Unsafe

import Neodoc.Value (Value(..))
import Neodoc.Value as Value
import Neodoc.Value.RichValue (RichValue(..), unRichValue)
import Neodoc.Value.RichValue as RichValue
import Neodoc.Value.Origin (Origin(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Spec (Spec(..), Toplevel)
import Neodoc.Env
import Neodoc.Data.Layout
import Neodoc.Data.Layout as Layout
import Neodoc.Data.Description
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.Chunk
import Neodoc.Data.Indexed
import Neodoc.OptionAlias as OptionAlias
import Neodoc.ArgKey (ArgKey)
import Neodoc.ArgKey.Class (toArgKey)
import Neodoc.ArgParser.Type
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Token as Token
import Neodoc.ArgParser.Argument
import Neodoc.ArgParser.Lexer as L
import Neodoc.ArgParser.Evaluate
import Neodoc.ArgParser.Required
import Neodoc.ArgParser.Combinators
import Neodoc.ArgParser.Fallback
import Neodoc.ArgParser.Result
import Neodoc.ArgParser.KeyValue

_ENABLE_DEBUG_ :: Boolean
_ENABLE_DEBUG_ = false

initialState :: ParseState
initialState = {
  depth: 0
, hasTerminated:   false
, hasFailed: false
}

type ChunkedLayout a = Layout (Chunk a)

parse
  :: ∀ r
   . Spec SolvedLayout
  -> Options r
  -> Env
  -> List PositionedToken
  -> Either (ParseError ArgParseError) ArgParseResult
parse (spec@(Spec { layouts, descriptions })) options env tokens = lmap fixError $
  runParser { env, options, descriptions } initialState tokens $
    let toplevelBranches = concat (fromFoldable layouts)
        hasEmpty = any ((_ == 0) <<< length) layouts
        parsers = toplevelBranches <#> \toplevel ->
          traceBracket 0 ("top-level (" <> pretty toplevel <> ")") do
            unsetFailed
            vs <- do
              parseExhaustively true false 0 (fromFoldable toplevel)
            eof
            pure $ ArgParseResult (Just toplevel) vs
        parsers' =
            if hasEmpty
              then parsers <> singleton do
                    eof $> ArgParseResult Nothing Nil
              else parsers
      in if length parsers' == 0
        then eof $> ArgParseResult Nothing Nil
        else flip evalParsers parsers' \(ArgParseResult _ vs) ->
                sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs
  where
  eof :: ∀ r. ArgParser r Unit
  eof = do
    input <- getInput
    case input of
      Nil  -> pure unit
      toks -> fail' $ unexpectedInputError Nil (known <$> toks)

  fixError :: ParseError ArgParseError -> ParseError ArgParseError
  fixError = mapError go
    where
    go (UnexpectedInputError xs toks _) =
      let toks' = f <<< unIsKnown <$> toks
       in unexpectedInputError xs toks'
      where
      f tok | isKnownToken spec tok = known tok
      f tok = unknown tok
    go x = x

-- Determine if a given option is "known".
-- An option is considered to be known if either
--      (a) appears anywhere in a layout
--      (b) is mentioned anywhere in a description
--
-- note: this is a fairly expensive operation as currently lookups are not
--       cached. there are at least 2 ways to resolve this:
--          1. create an authorative map all options (but could lead into the
--             need of options solving and will conflict with #57)
--          2. memoize / cache the lookups

isKnownToken
  :: Spec SolvedLayout
  -> PositionedToken
  -> Boolean
isKnownToken (Spec { layouts, descriptions }) tok = occuresInDescs || occuresInLayouts
  where
  occuresInDescs = any (matchesDesc tok) descriptions
    where
    matchesDesc (PositionedToken { token }) (OptionDescription as _ _ _ _) = test token
      where
      test (Token.LOpt n _)   = elem (OptionAlias.Long n) as
      test (Token.SOpt s _ _) = elem (OptionAlias.Short s) as
      test _ = false
    matchesDesc _ _ = false
  occuresInLayouts = any (any (any (matchesLayout tok))) layouts
    where
    matchesLayout tok (Group _ _ xs) = any (any (matchesLayout tok)) xs
    matchesLayout (PositionedToken { token }) (Elem x) = test token x
      where
      test (Token.LOpt n _)   (Solved.Option a _ _) = OptionAlias.Long n == a
      test (Token.SOpt s _ _) (Solved.Option a _ _) = OptionAlias.Short s == a
      test (Token.Lit n)      (Solved.Command n' _) = n == n'
      test (Token.EOA _)      (Solved.EOA)          = true
      test (Token.Stdin)      (Solved.Stdin)        = true
      test _ _ = false

parseLayout
  :: ∀ r
   . Boolean  -- ^ can we skip using fallback values?
  -> Boolean  -- ^ are we currently skipping using fallback values?
  -> Int      -- ^ recursive level
  -> SolvedLayout
  -> ArgParser r (List KeyValue)
parseLayout skippable isSkipping l layout = do
  { options } <- getConfig
  traceBracket l ("layout (" <> pretty layout <> ")") do
    go options layout

  where

  -- Terminate at singleton groups that house only positionals.
  go options x | options.optionsFirst && isJust (termAs x)
    = let y = unsafePartial (fromJust (termAs x))
      in singleton <<< Tuple (toArgKey y) <<< (RichValue.from Origin.Argv) <$>
          terminate y

  go options (Group o r branches) =
    let branches' = fromFoldable branches
        nEvaluations = length branches'
        parsers = flip mapWithIndex branches' \branch ix ->
          traceBracket (l + 1) ("EVALUTATION " <> show (ix + 1) <> "/" <> show nEvaluations) do
            parseExhaustively skippable isSkipping (l + 1) (fromFoldable branch)
    in do
        vs <- (if o then option Nil else id) do
          if length parsers == 0 then pure Nil else
            flip evalParsers parsers \vs ->
              sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs
        hasInput <- not <<< null <$> getInput
        vss <- if (hasInput && r &&
                length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then loop Nil
                  else pure Nil
        pure $ vs <> vss

    where
      loop acc = do
        -- parse this group repeatedly, but make successive matches optional.
        vs <- go options (Group true r branches)
        if (length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
          then loop $ acc <> vs
          else pure acc

  go _ e@(Elem x) = getInput >>= \i -> (
    let nTimes = if Solved.isRepeatable e then some else liftM1 singleton
     in nTimes do
          Tuple (toArgKey x) <<< (RichValue.from Origin.Argv) <$> go' x
            <* modifyDepth (_ + 1)
    ) <|> fail' (unexpectedInputError (e:Nil) (known <$> i))

    where
    go' (Solved.Positional n _) = positional (pretty x) n
    go' (Solved.Command    n _) = command    (pretty x) n
    go' (Solved.Stdin         ) = stdin
    go' (Solved.EOA           ) = eoa <|> (pure $ ArrayValue [])
    go' (Solved.Option a  mA r) = do
      input       <- getInput
      { options } <- getConfig
      case input of
        (PositionedToken { token }) : _
          | case token of
              LOpt _ _   -> true
              SOpt _ _ _ -> true
              _          -> false
          -> do
            aliases /\ def /\ env <- do
              description <- lookupDescription' a
              case description of
                (OptionDescription aliases _ _ def env) ->
                  pure $ aliases /\ def /\ env
                _ -> fail' $ internalError "invalid option description"
            let
              ns = fromFoldable $ aliases <#> case _ of
                    OptionAlias.Short f -> Left  f
                    OptionAlias.Long  n -> Right n
              longAliases = mrights ns
              shortAliases = mlefts ns
              term = any (_ `elem` options.stopAt) $ aliases <#> case _ of
                        OptionAlias.Short s -> "-"  <> String.singleton s
                        OptionAlias.Long  n -> "--" <> n

            -- note: safe to be unsafe because of pattern match above
            OptRes v canTerm canRepeat <- unsafePartial case token of
              LOpt _ _ ->
                case longAliases of
                  Nil -> fail "Option has no long alias"
                  _   -> choice $ longAliases <#> \alias -> try do
                          longOption term alias mA
              SOpt _ _ _ ->
                case shortAliases of
                  Nil -> fail "Option has no short alias"
                  _   -> choice $ shortAliases <#> \alias -> try do
                          shortOption term alias mA

            -- try terminating at this option
            if term && canTerm
                then do
                  vs <- terminate x
                  pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
                else do
                  if isJust mA && r && canRepeat
                      then do
                        vs <- Array.many optionArgument
                        pure (ArrayValue (Value.intoArray v <> vs))
                      else pure v
        _ -> fail "Expected long or short option"

parseExhaustively
  :: ∀ r
   . Boolean -- ^ can we skip using fallback values?
  -> Boolean -- ^ are we currently skipping using fallback values?
  -> Int     -- ^ recursive level
  -> List SolvedLayout
  -> ArgParser r (List KeyValue)
parseExhaustively _ _ _ Nil = pure Nil
parseExhaustively skippable isSkipping l xs = skipIf hasTerminated Nil do
  { options } <- getConfig
  let chunks = chunkBranch options.laxPlacement options.optionsFirst xs
  concat <$> traverse (parseChunk skippable isSkipping (l + 2)) chunks

parseChunk
  :: ∀ r
   . Boolean  -- ^ can we skip using fallback values?
  -> Boolean  -- ^ are we currently skipping using fallback values?
  -> Int      -- ^ recursive level
  -> Chunk (List SolvedLayout)
  -> ArgParser r (List KeyValue)
parseChunk skippable isSkipping l chunk = skipIf hasTerminated Nil do
  traceBracket l ("chunk (" <> pretty chunk <> ")") do
    go chunk

  where
  traceDraw :: ∀ a. (Pretty a) => Int -> (List a) -> String -> ArgParser r Unit
  traceDraw n xss msg = trace l \input -> do
    "draw (" <> show n <> "|" <> show skippable <> "|" <> show isSkipping <> "): "
      <> (if String.length msg > 0 then " " <> msg else "")
      <> " (elems: " <> pretty xss <> ")"
      <> " (input: " <> pretty input <> ")"

  go (Fixed xs) = concat <$> for xs (parseLayout skippable isSkipping l)
  go (Free  xs) =
    -- We decorate all arguments with an index from left to right, as well as
    -- marking them "Required". The "Required" wrapper is used to make
    -- repetition work, while ensuring the parser terminates.
    let indexedLayouts = flip mapWithIndex xs \x ix -> Required (Indexed ix x)
     in draw Nothing (length xs) indexedLayouts

    where
    draw
      :: Maybe (Tuple Int (ParseError ArgParseError))
      -> Int
      -> List (Required (Indexed SolvedLayout))
      -> ArgParser r (List KeyValue)

    -- Try "drawing" from the input list
    -- We've got `n` tries left to make this work.
    draw errs n xss@(x:xs) | n >= 0 =

      let layout = getIndexedElem (unRequired x)
       in catch' (recover layout) $
          let mod = if isRequired x then id else option Nil
           in do
            traceDraw n xss ""

            -- parse the next layout. This could be a group, in which case we
            -- recursive down each of the groups branches to try and make a
            -- match. Based on wether or not `isSkipping` is set to true, allow
            -- the layout to substitute values from fallback sources.
            vs <- try $ mod do
              parseLayout
                isSkipping  -- propagate the 'isSkipping' property
                false       -- reset 'skipable' to false
                (l + 1)     -- increase the recursive level
                if not isSkipping
                    then setLayoutRequired true layout
                    else layout

            -- if the layout is marked as repeatable, try repeating the parse
            -- recursively, but mark successive matches as "optional".
            vss <- try do
              if (Solved.isRepeatable layout &&
                  length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then draw errs (length xss) (xs <> pure (toOptional x))
                  else draw errs (length xs) xs
            pure $ vs <> vss

      where
      recover layout { depth } err =
        let
          isFixed = not <<< Solved.isFreeLayout
          errs' = case errs of
                    Just (d /\ _) | depth > d -> Just (depth /\ err)
                    Nothing -> Just (depth /\ err)
                    x -> x
         in do
          -- Check if we're done trying to recover.
          -- See the `draw -1` case below (`markFailed`).
          failed <- hasFailed
          traceDraw n xss $ "! ERROR - (state.failed = " <> show failed
                            <> ", error = " <> pretty err
                            <> ", layout = " <> pretty layout
                            <> ")"
          if failed
            then do
              traceDraw n xss $ "! ABORTING (failed)"
              throw err

            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            else if false --  n == 0 || length xs == 0
              then
                -- note: ensure that layouts do not change their relative
                -- positioning, hence return the original input list, rather
                -- than pushing it onto the back.
                let xs' = if isFixed layout then xss else (xs <> singleton x)
                 in do
                    traceDraw n xs' $ "! Skipping (shortcut)"
                    draw errs' (-1) xs'
              else
                let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                    xs' =
                      if Solved.isFreeLayout layout
                        then xs <> singleton x
                        -- XXX: Future work could include slicing off those
                        -- branches in the group that are 'free' and re-queueing
                        -- those.
                        else
                            let fs = take n xss
                                rs = drop n xss
                            in sortBy (compare `on` isFixed') fs <> rs
                 in do
                    traceDraw n xss $ "...retrying"
                    draw errs' (n - 1) xs'

    -- All arguments have been matched (or have failed to be matched) at least
    -- once by now. See where we're at - is there any required argument that was
    -- not matched at all?
    draw errs n xss@(x:xs) | n < 0 = skipIf hasTerminated Nil do
      input <- getInput
      { options, env, descriptions } <- getConfig

      traceDraw n xss $ ""

      let
        -- re-align the input using the originally assigned indices
        xss' = sortBy (compare `on` (getIndex <<< unRequired)) xss
        layouts = getIndexedElem <<< unRequired <$> xss'

        -- substitute any missing values using the various fallback methods
        vs = layouts <#> case _ of
          layout@(Group _ _ _) -> Left layout
          layout@(Elem arg) -> maybe (Left layout) (Right <<< Tuple (toArgKey arg)) do
            let description = case arg of
                  (Option alias _ _) -> findDescription alias descriptions
                  _                  -> Nothing
            v <- unRichValue <$> getFallbackValue options env description arg
            pure $ RichValue v {
              value = if isRepeatable layout
                  then ArrayValue $ Value.intoArray v.value
                  else v.value
            }

        -- find those layouts that did not yield any value, not even a fallback
        -- value, but are required for a successful match.
        missing = mlefts vs `flip filter` \layout ->
          isRequired x &&
          -- This may look very counter-intuitive, yet getting fallback
          -- values for entire groups is not possible and not logical.
          -- If a group that is allowed to be omitted fails, there won't
          -- be any values to fall back onto.
          not (isGroup layout && isOptional layout)

        fallbacks = mrights vs

      { depth } <- getState
      if isSkipping && length missing > 0
        then do
          -- set the parser state to "failed".
          -- setting this will cause no more recoveries during succesive draws.
          setFailed
          unsafePartial $ throwExpectedError depth missing input
        else
          -- special case: when the input is empty, we choose to enable skipping
          -- "on the spot" as it's unlikely enough we'll find anything better.
          if skippable || null input
            then
              if not isSkipping
                then do
                  traceDraw n xss "final ditch attempt"
                  parseExhaustively true true (l + 1) layouts
                else pure fallbacks
            else unsafePartial $ throwExpectedError depth layouts input

      where
        throwExpectedError
          :: ∀ r
           . Partial
          => Int
          -> List SolvedLayout
          -> List PositionedToken
          -> ArgParser r _
        throwExpectedError depth xss@(x:xs) input =
          case errs of
            Just (d /\ e) | d >= depth -> throw e
            _ -> case input of
              Nil  -> fail' $ missingArgumentsError (x:|xs)
              toks -> fail' $ unexpectedInputError xss (known <$> toks)

    draw _ _ _ = pure Nil

setLayoutRequired :: Boolean -> SolvedLayout -> SolvedLayout
setLayoutRequired b (Group _ r xs) = Group (not b) r xs
setLayoutRequired _ x = x

-- Check if a given layout qualifies as a terminating argument for options-first
-- and if so, return the argument it should be associated with.
termAs :: SolvedLayout -> Maybe SolvedLayoutArg
termAs (Group _ gR (((Elem x@(Solved.Positional _ pR)) :| Nil) :| Nil)) | gR || pR = Just x
termAs (Elem x@(Solved.Positional _ r)) | r = Just x
termAs _ = Nothing

-- Is this layout capable of acting as a terminator for options-first?
canTerm :: SolvedLayout -> Boolean
canTerm = isJust <<< termAs

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: Boolean -- enable lax-placement mode
  -> Boolean -- enable options-first mode
  -> List SolvedLayout
  -> List (Chunk (List SolvedLayout))
chunkBranch lax optsFirst = fromFoldable >>> chunk \x ->
  (not (optsFirst && canTerm x)) && (lax || Solved.isFreeLayout x)

isFrom :: Origin -> RichValue -> Boolean
isFrom o rv = o == RichValue.getOrigin rv

-- Terminate the parser at the given argument and collect all subsequent
-- values int an array ("options-first" and "stop-at")
terminate :: ∀ r. SolvedLayoutArg -> ArgParser r Value
terminate arg = do
  input <- getInput
  let rest = ArrayValue $ toUnfoldable $ StringValue <<< Token.getSource <$> input

  -- XXX: yeah, this is functional programming, alright. this needs to be
  -- re-visited. How can we avoid at least `setDone` and `setDepth`?
  setDone
  setDepth 99999
  setInput Nil

  pure rest

trace :: ∀ r. Int -> (List PositionedToken -> String) -> ArgParser r Unit
trace l f = if _ENABLE_DEBUG_
              then do
                state <- getState
                input <- getInput
                traceA $ indent l <> stateLabel state <> (f input)
              else pure unit
  where
  stateLabel { hasFailed, hasTerminated, depth } =
    (if hasTerminated then "✓" else "·")
    <> (if hasFailed then "✘" else "·")
    <> "(" <> show depth <> ")"

traceError :: ∀ r a. Int -> String -> ArgParser r a  -> ArgParser r a
traceError l s
  = catch' (\_ e -> trace l (\_ -> "! " <> s <> ": " <> pretty e) *> throw e)

traceInput :: ∀ r. ArgParser r Unit
traceInput = traceA =<< pretty <$> getInput

indent :: Int -> String
indent l = String.fromCharArray $ LL.toUnfoldable $ LL.take (l * 4) $ LL.repeat ' '

traceBracket
  :: ∀ r a
   . (Pretty a)
  => Int
  -> String
  -> ArgParser r a
  -> ArgParser r a
traceBracket l label p = do
  input <- getInput
  state <- getState
  trace l \_ ->
    stateLabel state <> " parsing " <> label <> " (input: " <> pretty input <> ")"
  output <- traceError l (stateLabel state <> " failed to parse " <> label) p
  input <- getInput
  state <- getState
  trace l \_ ->
    stateLabel state <> " successfully parsed " <> label <> "!"
      <> " (output: " <> pretty output <> ")"
      <> " (new input: " <> pretty input <> ")"
  pure output
  where
  stateLabel { hasFailed, hasTerminated, depth } =
    (if hasTerminated then "✓" else "·")
    <> (if hasFailed then "✘" else "·")
    <> "(" <> show depth <> ")"

-- The neodoc arg parser
--
-- Parse the tokenized argv input in accordance with the layout rules specified
-- in the neodoc specification provided by the developer.
--
-- For example:
--
--      usage: prog -a -b -c
--         or: prog -d -e -f=FILE
--
--      options:
--          -f, --file FILE
--
-- This specification has 2 top-level branches, each of which need to be
-- considered individually and scored. The highest ranking top-level wins.
-- Should an error occur during parsing, the "deepest" parse error is elected
-- to be shown. This requires a single parser to track it's own depth.
--
-- Multiple permutations are trialed by runnign the parser on each branch,
-- provided with the same input state.
--
-- The arg parser, during it's operation, yields values of shape:
--
--      Alias => { Origin, Value }
--
-- where `Origin` denotes the origin of the value: provided as an argument to
-- the program, derived from the environment or a default value.
--
--
-- Parsing semantics
-- -----------------
--
-- The neodoc parser parses chunks of adjacent arguments as a unit.
-- These chunks come in 2 flavours: "free" and "fixed". "free" chunks are those
-- chunks where the contained arguments can be parsed freely in any order.
-- "fixed" chunks, on the other hand enforce a strict parse from left to right.
-- When neodoc operates in `lax-placement` mode, the entire list of arguments
-- become a single "free" chunk, but positionals and commands remain fixed
-- amongst each other, but options can be interspersed anywhere.
--
-- For example:
--
--      usage: prog foo bar -a -b -c qux
--
-- is "chunked" into: `<! foo bar !> <* -a -b -c *>`, where `<! ... !>` denotes
-- a "fixed" chunk and a `<* ... *>` denotes a free chunk.
--
-- Generally speaking, elements are elected as part of a "free" chunk if they
-- are options, or "fixed" otherwise.

module Neodoc.ArgParser.Parser where

import Prelude
import Debug.Trace
import Data.List (
  List(..), some, singleton, filter, fromFoldable, last, groupBy, sortBy, (:)
, null, concat, mapWithIndex, length, take, drop, toUnfoldable)
import Data.Array as Array
import Data.List.Partial as LU
import Data.Bifunctor (lmap)
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Data.Function (on)
import Data.Tuple (Tuple(..), snd)
import Data.Tuple.Nested ((/\))
import Data.Either (Either(..))
import Data.String as String
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.Maybe (Maybe(..), isJust, maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Foldable (
  class Foldable, maximumBy, all, intercalate, sum, any, elem)
import Data.Map as Map
import Data.Map (Map)
import Data.Pretty (pretty, class Pretty)
import Control.Alt ((<|>))
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Partial.Unsafe

import Neodoc.Value (Value(..))
import Neodoc.Value as Value
import Neodoc.Value.RichValue (RichValue(..), unRichValue)
import Neodoc.Value.RichValue as RichValue
import Neodoc.Value.Origin (Origin(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Spec (Spec(..), Toplevel)
import Neodoc.Env
import Neodoc.Data.Layout
import Neodoc.Data.Layout as Layout
import Neodoc.Data.Description
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.Chunk
import Neodoc.Data.Indexed
import Neodoc.OptionAlias as OptionAlias
import Neodoc.ArgKey (ArgKey)
import Neodoc.ArgKey.Class (toArgKey)
import Neodoc.ArgParser.Type
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Token as Token
import Neodoc.ArgParser.Argument
import Neodoc.ArgParser.Lexer as L
import Neodoc.ArgParser.Evaluate
import Neodoc.ArgParser.Required
import Neodoc.ArgParser.Combinators
import Neodoc.ArgParser.Fallback
import Neodoc.ArgParser.Result
import Neodoc.ArgParser.KeyValue

_ENABLE_DEBUG_ :: Boolean
_ENABLE_DEBUG_ = false

initialState :: ParseState
initialState = {
  depth: 0
, hasTerminated:   false
, hasFailed: false
}

type ChunkedLayout a = Layout (Chunk a)

parse
  :: ∀ r
   . Spec SolvedLayout
  -> Options r
  -> Env
  -> List PositionedToken
  -> Either (ParseError ArgParseError) ArgParseResult
parse (spec@(Spec { layouts, descriptions })) options env tokens = lmap fixError $
  runParser { env, options, descriptions } initialState tokens $
    let toplevelBranches = concat (fromFoldable layouts)
        hasEmpty = any ((_ == 0) <<< length) layouts
        parsers = toplevelBranches <#> \toplevel ->
          traceBracket 0 ("top-level (" <> pretty toplevel <> ")") do
            unsetFailed
            vs <- {-withLocalCache-} do
              parseExhaustively true false 0 (fromFoldable toplevel)
            eof
            pure $ ArgParseResult (Just toplevel) vs
        parsers' =
            if hasEmpty
              then parsers <> singleton do
                    eof $> ArgParseResult Nothing Nil
              else parsers
      in if length parsers' == 0
        then eof $> ArgParseResult Nothing Nil
        else flip evalParsers parsers' \(ArgParseResult _ vs) ->
                sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs
  where
  eof :: ∀ r. ArgParser r Unit
  eof = do
    input <- getInput
    case input of
      Nil  -> pure unit
      toks -> fail' $ unexpectedInputError Nil (known <$> toks)

  fixError :: ParseError ArgParseError -> ParseError ArgParseError
  fixError = mapError go
    where
    go (UnexpectedInputError xs toks _) =
      let toks' = f <<< unIsKnown <$> toks
       in unexpectedInputError xs toks'
      where
      f tok | isKnownToken spec tok = known tok
      f tok = unknown tok
    go x = x

-- Determine if a given option is "known".
-- An option is considered to be known if either
--      (a) appears anywhere in a layout
--      (b) is mentioned anywhere in a description
--
-- note: this is a fairly expensive operation as currently lookups are not
--       cached. there are at least 2 ways to resolve this:
--          1. create an authorative map all options (but could lead into the
--             need of options solving and will conflict with #57)
--          2. memoize / cache the lookups

isKnownToken
  :: Spec SolvedLayout
  -> PositionedToken
  -> Boolean
isKnownToken (Spec { layouts, descriptions }) tok = occuresInDescs || occuresInLayouts
  where
  occuresInDescs = any (matchesDesc tok) descriptions
    where
    matchesDesc (PositionedToken { token }) (OptionDescription as _ _ _ _) = test token
      where
      test (Token.LOpt n _)   = elem (OptionAlias.Long n) as
      test (Token.SOpt s _ _) = elem (OptionAlias.Short s) as
      test _ = false
    matchesDesc _ _ = false
  occuresInLayouts = any (any (any (matchesLayout tok))) layouts
    where
    matchesLayout tok (Group _ _ xs) = any (any (matchesLayout tok)) xs
    matchesLayout (PositionedToken { token }) (Elem x) = test token x
      where
      test (Token.LOpt n _)   (Solved.Option a _ _) = OptionAlias.Long n == a
      test (Token.SOpt s _ _) (Solved.Option a _ _) = OptionAlias.Short s == a
      test (Token.Lit n)      (Solved.Command n' _) = n == n'
      test (Token.EOA _)      (Solved.EOA)          = true
      test (Token.Stdin)      (Solved.Stdin)        = true
      test _ _ = false

parseLayout
  :: ∀ r
   . Boolean  -- ^ can we skip using fallback values?
  -> Boolean  -- ^ are we currently skipping using fallback values?
  -> Int      -- ^ recursive level
  -> SolvedLayout
  -> ArgParser r (List KeyValue)
parseLayout skippable isSkipping l layout = do
  { options } <- getConfig
  traceBracket l ("layout (" <> pretty layout <> ")") do
    go options layout

  where

  -- Terminate at singleton groups that house only positionals.
  go options x | options.optionsFirst && isJust (termAs x)
    = let y = unsafePartial (fromJust (termAs x))
      in singleton <<< Tuple (toArgKey y) <<< (RichValue.from Origin.Argv) <$>
          terminate y

  go options (Group o r branches) =
    let branches' = fromFoldable branches
        nEvaluations = length branches'
        parsers = flip mapWithIndex branches' \branch ix ->
          traceBracket (l + 1) ("EVALUTATION " <> show (ix + 1) <> "/" <> show nEvaluations) do
          {-withLocalCache do-}
            parseExhaustively skippable isSkipping (l + 1) (fromFoldable branch)
    in do
        vs <- (if o then option Nil else id) do
          if length parsers == 0 then pure Nil else
            flip evalParsers parsers \vs ->
              sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs
        hasInput <- not <<< null <$> getInput
        vss <- if (hasInput && r &&
                length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then loop Nil
                  else pure Nil
        pure $ vs <> vss

    where
      loop acc = do
        -- parse this group repeatedly, but make successive matches optional.
        vs <- go options (Group true r branches)
        if (length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
          then loop $ acc <> vs
          else pure acc

  go _ e@(Elem x) = getInput >>= \i -> (
    let nTimes = if Solved.isRepeatable e then some else liftM1 singleton
     in nTimes do
          Tuple (toArgKey x) <<< (RichValue.from Origin.Argv) <$> go' x
            <* modifyDepth (_ + 1)
    ) <|> fail' (unexpectedInputError (e:Nil) (known <$> i))

    where
    go' (Solved.Positional n _) = positional (pretty x) n
    go' (Solved.Command    n _) = command    (pretty x) n
    go' (Solved.Stdin         ) = stdin
    go' (Solved.EOA           ) = eoa <|> (pure $ ArrayValue [])
    go' (Solved.Option a  mA r) = do
      input       <- getInput
      { options } <- getConfig
      case input of
        (PositionedToken { token }) : _
          | case token of
              LOpt _ _   -> true
              SOpt _ _ _ -> true
              _          -> false
          -> do
            aliases /\ def /\ env <- do
              description <- lookupDescription' a
              case description of
                (OptionDescription aliases _ _ def env) ->
                  pure $ aliases /\ def /\ env
                _ -> fail' $ internalError "invalid option description"
            let
              ns = fromFoldable $ aliases <#> case _ of
                    OptionAlias.Short f -> Left  f
                    OptionAlias.Long  n -> Right n
              longAliases = mrights ns
              shortAliases = mlefts ns
              term = any (_ `elem` options.stopAt) $ aliases <#> case _ of
                        OptionAlias.Short s -> "-"  <> String.singleton s
                        OptionAlias.Long  n -> "--" <> n

            -- note: safe to be unsafe because of pattern match above
            OptRes v canTerm canRepeat <- unsafePartial case token of
              LOpt _ _ ->
                case longAliases of
                  Nil -> fail "Option has no long alias"
                  _   -> choice $ longAliases <#> \alias -> try do
                          longOption term alias mA
              SOpt _ _ _ ->
                case shortAliases of
                  Nil -> fail "Option has no short alias"
                  _   -> choice $ shortAliases <#> \alias -> try do
                          shortOption term alias mA

            -- try terminating at this option
            if term && canTerm
                then do
                  vs <- terminate x
                  pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
                else do
                  if isJust mA && r && canRepeat
                      then do
                        vs <- Array.many optionArgument
                        pure (ArrayValue (Value.intoArray v <> vs))
                      else pure v
        _ -> fail "Expected long or short option"

parseExhaustively
  :: ∀ r
   . Boolean -- ^ can we skip using fallback values?
  -> Boolean -- ^ are we currently skipping using fallback values?
  -> Int     -- ^ recursive level
  -> List SolvedLayout
  -> ArgParser r (List KeyValue)
parseExhaustively _ _ _ Nil = pure Nil
parseExhaustively skippable isSkipping l xs = skipIf hasTerminated Nil do
  { options } <- getConfig
  let chunks = chunkBranch options.laxPlacement options.optionsFirst xs
  concat <$> traverse (parseChunk skippable isSkipping (l + 2)) chunks

parseChunk
  :: ∀ r
   . Boolean  -- ^ can we skip using fallback values?
  -> Boolean  -- ^ are we currently skipping using fallback values?
  -> Int      -- ^ recursive level
  -> Chunk (List SolvedLayout)
  -> ArgParser r (List KeyValue)
parseChunk skippable isSkipping l chunk = skipIf hasTerminated Nil do
  traceBracket l ("chunk (" <> pretty chunk <> ")") do
    go chunk

  where
  traceDraw :: ∀ a. (Pretty a) => Int -> (List a) -> String -> ArgParser r Unit
  traceDraw n xss msg = trace l \input -> do
    "draw (" <> show n <> "|" <> show skippable <> "|" <> show isSkipping <> "): "
      <> (if String.length msg > 0 then " " <> msg else "")
      <> " (elems: " <> pretty xss <> ")"
      <> " (input: " <> pretty input <> ")"

  go (Fixed xs) = concat <$> for xs (parseLayout skippable isSkipping l)
  go (Free  xs) =
    -- We decorate all arguments with an index from left to right, as well as
    -- marking them "Required". The "Required" wrapper is used to make
    -- repetition work, while ensuring the parser terminates.
    let indexedLayouts = flip mapWithIndex xs \x ix -> Required (Indexed ix x)
     in draw Nothing (length xs) indexedLayouts

    where
    draw
      :: Maybe (Tuple Int (ParseError ArgParseError))
      -> Int
      -> List (Required (Indexed SolvedLayout))
      -> ArgParser r (List KeyValue)

    -- Try "drawing" from the input list
    -- We've got `n` tries left to make this work.
    draw errs n xss@(x:xs) | n >= 0 =

      let layout = getIndexedElem (unRequired x)
       in catch' (recover layout) $
          let mod = if isRequired x then id else option Nil
           in do
            traceDraw n xss ""

            -- parse the next layout. This could be a group, in which case we
            -- recursive down each of the groups branches to try and make a
            -- match. Based on wether or not `isSkipping` is set to true, allow
            -- the layout to substitute values from fallback sources.
            vs <- cached x $ try $ mod do
              parseLayout
                isSkipping  -- propagate the 'isSkipping' property
                false       -- reset 'skipable' to false
                (l + 1)     -- increase the recursive level
                if not isSkipping
                    then setLayoutRequired true layout
                    else layout

            -- if the layout is marked as repeatable, try repeating the parse
            -- recursively, but mark successive matches as "optional".
            vss <- try do
              if (Solved.isRepeatable layout &&
                  length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then draw errs (length xss) (xs <> pure (toOptional x))
                  else draw errs (length xs) xs
            pure $ vs <> vss

      where
      recover layout { depth } err =
        let
          isFixed = not <<< Solved.isFreeLayout
          errs' = case errs of
                    Just (d /\ _) | depth > d -> Just (depth /\ err)
                    Nothing -> Just (depth /\ err)
                    x -> x
         in do
          -- Check if we're done trying to recover.
          -- See the `draw -1` case below (`markFailed`).
          failed <- hasFailed
          traceDraw n xss $ "! ERROR - (state.failed = " <> show failed
                            <> ", error = " <> pretty err
                            <> ", layout = " <> pretty layout
                            <> ")"
          if failed
            then do
              traceDraw n xss $ "! ABORTING (failed)"
              throw err

            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            else if false --  n == 0 || length xs == 0
              then
                -- note: ensure that layouts do not change their relative
                -- positioning, hence return the original input list, rather
                -- than pushing it onto the back.
                let xs' = if isFixed layout then xss else (xs <> singleton x)
                 in do
                    traceDraw n xs' $ "! Skipping (shortcut)"
                    draw errs' (-1) xs'
              else
                let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                    xs' =
                      if Solved.isFreeLayout layout
                        then xs <> singleton x
                        -- XXX: Future work could include slicing off those
                        -- branches in the group that are 'free' and re-queueing
                        -- those.
                        else
                            let fs = take n xss
                                rs = drop n xss
                            in sortBy (compare `on` isFixed') fs <> rs
                 in do
                    traceDraw n xss $ "...retrying"
                    draw errs' (n - 1) xs'

    -- All arguments have been matched (or have failed to be matched) at least
    -- once by now. See where we're at - is there any required argument that was
    -- not matched at all?
    draw errs n xss@(x:xs) | n < 0 = skipIf hasTerminated Nil do
      input <- getInput
      { options, env, descriptions } <- getConfig

      traceDraw n xss $ ""

      let
        -- re-align the input using the originally assigned indices
        xss' = sortBy (compare `on` (getIndex <<< unRequired)) xss
        layouts = getIndexedElem <<< unRequired <$> xss'

        -- substitute any missing values using the various fallback methods
        vs = layouts <#> case _ of
          layout@(Group _ _ _) -> Left layout
          layout@(Elem arg) -> maybe (Left layout) (Right <<< Tuple (toArgKey arg)) do
            let description = case arg of
                  (Option alias _ _) -> findDescription alias descriptions
                  _                  -> Nothing
            v <- unRichValue <$> getFallbackValue options env description arg
            pure $ RichValue v {
              value = if isRepeatable layout
                  then ArrayValue $ Value.intoArray v.value
                  else v.value
            }

        -- find those layouts that did not yield any value, not even a fallback
        -- value, but are required for a successful match.
        missing = mlefts vs `flip filter` \layout ->
          isRequired x &&
          -- This may look very counter-intuitive, yet getting fallback
          -- values for entire groups is not possible and not logical.
          -- If a group that is allowed to be omitted fails, there won't
          -- be any values to fall back onto.
          not (isGroup layout && isOptional layout)

        fallbacks = mrights vs

      { depth } <- getState
      if isSkipping && length missing > 0
        then do
          -- set the parser state to "failed".
          -- setting this will cause no more recoveries during succesive draws.
          setFailed
          unsafePartial $ throwExpectedError depth missing input
        else
          -- special case: when the input is empty, we choose to enable skipping
          -- "on the spot" as it's unlikely enough we'll find anything better.
          if skippable || null input
            then
              if not isSkipping
                then do {- XXX: withLocalCache do -}
                  traceDraw n xss "final ditch attempt"
                  parseExhaustively true true (l + 1) layouts
                else pure fallbacks
            else unsafePartial $ throwExpectedError depth layouts input

      where
        throwExpectedError
          :: ∀ r
           . Partial
          => Int
          -> List SolvedLayout
          -> List PositionedToken
          -> ArgParser r _
        throwExpectedError depth xss@(x:xs) input =
          case errs of
            Just (d /\ e) | d >= depth -> throw e
            _ -> case input of
              Nil  -> fail' $ missingArgumentsError (x:|xs)
              toks -> fail' $ unexpectedInputError xss (known <$> toks)

    draw _ _ _ = pure Nil

setLayoutRequired :: Boolean -> SolvedLayout -> SolvedLayout
setLayoutRequired b (Group _ r xs) = Group (not b) r xs
setLayoutRequired _ x = x

-- Check if a given layout qualifies as a terminating argument for options-first
-- and if so, return the argument it should be associated with.
termAs :: SolvedLayout -> Maybe SolvedLayoutArg
termAs (Group _ gR (((Elem x@(Solved.Positional _ pR)) :| Nil) :| Nil)) | gR || pR = Just x
termAs (Elem x@(Solved.Positional _ r)) | r = Just x
termAs _ = Nothing

-- Is this layout capable of acting as a terminator for options-first?
canTerm :: SolvedLayout -> Boolean
canTerm = isJust <<< termAs

-- TODO: implement
cached _ = id

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: Boolean -- enable lax-placement mode
  -> Boolean -- enable options-first mode
  -> List SolvedLayout
  -> List (Chunk (List SolvedLayout))
chunkBranch lax optsFirst = fromFoldable >>> chunk \x ->
  (not (optsFirst && canTerm x)) && (lax || Solved.isFreeLayout x)

isFrom :: Origin -> RichValue -> Boolean
isFrom o rv = o == RichValue.getOrigin rv

-- Terminate the parser at the given argument and collect all subsequent
-- values int an array ("options-first" and "stop-at")
terminate :: ∀ r. SolvedLayoutArg -> ArgParser r Value
terminate arg = do
  input <- getInput
  let rest = ArrayValue $ toUnfoldable $ StringValue <<< Token.getSource <$> input

  -- XXX: yeah, this is functional programming, alright. this needs to be
  -- re-visited. How can we avoid at least `setDone` and `setDepth`?
  setDone
  setDepth 99999
  setInput Nil

  pure rest

trace :: ∀ r. Int -> (List PositionedToken -> String) -> ArgParser r Unit
trace l f = if _ENABLE_DEBUG_
              then do
                state <- getState
                input <- getInput
                traceA $ indent l <> stateLabel state <> (f input)
              else pure unit
  where
  stateLabel { hasFailed, hasTerminated, depth } =
    (if hasTerminated then "✓" else "·")
    <> (if hasFailed then "✘" else "·")
    <> "(" <> show depth <> ")"

traceError :: ∀ r a. Int -> String -> ArgParser r a  -> ArgParser r a
traceError l s
  = catch' (\_ e -> trace l (\_ -> "! " <> s <> ": " <> pretty e) *> throw e)

traceInput :: ∀ r. ArgParser r Unit
traceInput = traceA =<< pretty <$> getInput

indent :: Int -> String
indent l = String.fromCharArray $ LL.toUnfoldable $ LL.take (l * 4) $ LL.repeat ' '

traceBracket
  :: ∀ r a
   . (Pretty a)
  => Int
  -> String
  -> ArgParser r a
  -> ArgParser r a
traceBracket l label p = do
  input <- getInput
  state <- getState
  trace l \_ ->
    stateLabel state <> " parsing " <> label <> " (input: " <> pretty input <> ")"
  output <- traceError l (stateLabel state <> " failed to parse " <> label) p
  input <- getInput
  state <- getState
  trace l \_ ->
    stateLabel state <> " successfully parsed " <> label <> "!"
      <> " (output: " <> pretty output <> ")"
      <> " (new input: " <> pretty input <> ")"
  pure output
  where
  stateLabel { hasFailed, hasTerminated, depth } =
    (if hasTerminated then "✓" else "·")
    <> (if hasFailed then "✘" else "·")
    <> "(" <> show depth <> ")"