export ListT constructor

export ListT constructor

Addresses #83.

Independent of PR #89.

This brings ListT into line with the other transformers.

-- | This module defines the list monad transformer, `ListT`.

module Control.Monad.List.Trans
  ( ListT(..)
  , Step(..)
  , catMaybes
  , cons
  , drop
  , dropWhile
  , filter
  , foldl
  , foldl'
  , fromEffect
  , head
  , iterate
  , mapMaybe
  , nil
  , prepend
  , prepend'
  , repeat
  , scanl
  , singleton
  , tail
  , take
  , takeWhile
  , uncons
  , unfold
  , wrapEffect
  , wrapLazy
  , zipWith
  , zipWith'
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Lazy (Lazy, defer, force)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Unfoldable (class Unfoldable)

-- | The list monad transformer.
-- |
-- | This monad transformer extends the base monad with _non-determinism_.
-- | That is, the transformed monad supports the same effects as the base monad
-- | but with multiple return values.
newtype ListT f a = ListT (f (Step a (ListT f a)))

-- | The result of a single step in a `ListT` computation. Either:
-- |
-- | - Computation has finished (`Done`), or
-- | - A result has been returned, along with the next part of the computation (`Yield`).
-- |
-- | The `Skip` constructor allows us to avoid traversing lists during certain operations.
data Step a s
  = Yield a (Lazy s)
  | Skip (Lazy s)
  | Done

-- | Run a computation in the `ListT` monad.
runListT :: forall f a. ListT f a -> f (Step a (ListT f a))
runListT (ListT fa) = fa

-- | The empty list.
nil :: forall f a. Applicative f => ListT f a
nil = ListT $ pure Done

-- | Attach an element to the front of a list.
cons :: forall f a. Applicative f => Lazy a -> Lazy (ListT f a) -> ListT f a
cons lh t = ListT $ pure $ Yield (force lh) t

-- | Prepend an element to a lazily-evaluated list.
prepend' :: forall f a. Applicative f => a -> Lazy (ListT f a) -> ListT f a
prepend' h t = ListT $ pure (Yield h t)

-- | Prepend an element to a list.
prepend :: forall f a. Applicative f => a -> ListT f a -> ListT f a
prepend h t = prepend' h (defer $ const t)

-- | Lift a computation on list steps to a computation on whole lists.
stepMap :: forall f a b. Functor f => (Step a (ListT f a) -> Step b (ListT f b)) -> ListT f a -> ListT f b
stepMap f (ListT l) = ListT $ f <$> l

-- | Append one list to another.
concat :: forall f a. Applicative f => ListT f a -> ListT f a -> ListT f a
concat x y = stepMap f x where
  f (Yield a s) = Yield a ((_ <> y) <$> s)
  f (Skip s)    = Skip ((_ <> y) <$> s)
  f Done        = Skip (defer $ const y)

-- | Create a list with one element.
singleton :: forall f a. Applicative f => a -> ListT f a
singleton a = prepend a nil

-- | Lift a computation from the base functor.
fromEffect :: forall f a. Applicative f => f a -> ListT f a
fromEffect fa = ListT $ (flip Yield (defer $ \_ -> nil)) <$> fa

-- | Lift a computation from the base monad.
wrapEffect :: forall f a. Functor f => f (ListT f a) -> ListT f a
wrapEffect v = ListT $ Skip <<< defer <<< const <$> v

-- | Defer evaluation of a list.
wrapLazy :: forall f a. Applicative f => Lazy (ListT f a) -> ListT f a
wrapLazy v = ListT $ pure (Skip v)

-- | Unfold a list using an effectful generator function.
unfold :: forall f a z. Monad f => (z -> f (Maybe (Tuple z a))) -> z -> ListT f a
unfold f z = ListT $ g <$> f z
  where
  g (Just (Tuple z' a)) = Yield a (defer \_ -> unfold f z')
  g Nothing            = Done

-- | Generate an infinite list by iterating a function.
iterate :: forall f a. Monad f => (a -> a) -> a -> ListT f a
iterate f a = unfold g a
  where
  g x = pure $ Just (Tuple (f x) x)

-- | Generate an infinite list by repeating a value.
repeat :: forall f a. Monad f => a -> ListT f a
repeat = iterate id

-- | Take a number of elements from the front of a list.
take :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
take 0 fa = nil
take n fa = stepMap f fa where
  f (Yield a s) = Yield a (take (n - 1) <$> s)
  f (Skip s)    = Skip (take n <$> s)
  f Done        = Done

-- | Take elements from the front of a list while a predicate holds.
takeWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
takeWhile f = stepMap g where
  g (Yield a s) = if f a then Yield a (takeWhile f <$> s) else Done
  g (Skip s)    = Skip $ takeWhile f <$> s
  g Done        = Done

-- | Drop a number of elements from the front of a list.
drop :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
drop 0 fa = fa
drop n fa = stepMap f fa where
  f (Yield a s) = Skip (drop (n - 1) <$> s)
  f (Skip s)    = Skip (drop n <$> s)
  f Done        = Done

-- | Drop elements from the front of a list while a predicate holds.
dropWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
dropWhile f = stepMap g where
  g (Yield a s) = if f a then Skip (dropWhile f <$> s) else Yield a s
  g (Skip s)    = Skip $ dropWhile f <$> s
  g Done        = Done

-- | Remove elements from a list for which a predicate fails to hold.
filter :: forall f a. Functor f => (a -> Boolean) -> ListT f a -> ListT f a
filter f = stepMap g where
  g (Yield a s) = if f a then Yield a s' else Skip s' where s' = filter f <$> s
  g (Skip s)    = Skip s' where s' = filter f <$> s
  g Done        = Done

-- | Apply a function to the elements of a list, keeping only those return values which contain a result.
mapMaybe :: forall f a b. Functor f => (a -> Maybe b) -> ListT f a -> ListT f b
mapMaybe f = stepMap g where
  g (Yield a s) = (fromMaybe Skip (Yield <$> (f a))) (mapMaybe f <$> s)
  g (Skip s)    = Skip $ mapMaybe f <$> s
  g Done        = Done

-- | Remove elements from a list which do not contain a value.
catMaybes :: forall f a. Functor f => ListT f (Maybe a) -> ListT f a
catMaybes = mapMaybe id

-- | Perform the first step of a computation in the `ListT` monad.
uncons :: forall f a. Monad f => ListT f a -> f (Maybe (Tuple a (ListT f a)))
uncons (ListT l) = l >>= g
  where
  g (Yield a s) = pure $ Just $ Tuple a (force s)
  g (Skip s)    = uncons (force s)
  g Done        = pure Nothing

-- | Extract the first element of a list.
head :: forall f a. Monad f => ListT f a -> f (Maybe a)
head l = ((<$>) fst) <$> uncons l

-- | Extract all but the first element of a list.
tail :: forall f a. Monad f => ListT f a -> f (Maybe (ListT f a))
tail l = ((<$>) snd) <$> uncons l

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
foldl' :: forall f a b. Monad f => (b -> a -> f b) -> b -> ListT f a -> f b
foldl' f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = (f b a) >>= (flip loop as)

-- | Fold a list from the left, accumulating the result using the specified function.
foldl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> f b
foldl f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = loop (f b a) as

-- | Fold a list from the left, accumulating the list of results using the specified function.
scanl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> ListT f b
scanl f b l = unfold g (Tuple b l)
  where
  g (Tuple b' (ListT l')) = h <$> l'
    where
    h (Yield a s) = let b'' = f b' a in Just $ Tuple (Tuple b'' (force s)) b'
    h (Skip s)    = Just $ Tuple (Tuple b' (force s)) b'
    h Done        = Nothing

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith' :: forall f a b c. Monad f => (a -> b -> f c) -> ListT f a -> ListT f b -> ListT f c
zipWith' f = loop where
  loop fa fb = wrapEffect do
    ua <- uncons fa
    ub <- uncons fb
    g ua ub

  g _ Nothing = pure nil
  g Nothing _ = pure nil
  g (Just (Tuple ha ta)) (Just (Tuple hb tb)) = (flip prepend') (defer \_ -> zipWith' f ta tb) <$> (f ha hb)

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith :: forall f a b c. Monad f => (a -> b -> c) -> ListT f a -> ListT f b -> ListT f c
zipWith f = zipWith' g
  where
  g a b = pure $ f a b

derive instance newtypeListT :: Newtype (ListT f a) _

instance semigroupListT :: Applicative f => Semigroup (ListT f a) where
  append = concat

instance monoidListT :: Applicative f => Monoid (ListT f a) where
  mempty = nil

instance functorListT :: Functor f => Functor (ListT f) where
  map f = stepMap g where
    g (Yield a s) = Yield (f a) ((<$>) f <$> s)
    g (Skip s)    = Skip ((<$>) f <$> s)
    g Done        = Done

instance unfoldableListT :: Monad f => Unfoldable (ListT f) where
  unfoldr f b = go (f b)
    where go Nothing = nil
          go (Just (Tuple x y)) = cons (pure x) (defer \_ -> (go (f y)))

instance applyListT :: Monad f => Apply (ListT f) where
  apply = ap

instance applicativeListT :: Monad f => Applicative (ListT f) where
  pure = singleton

instance bindListT :: Monad f => Bind (ListT f) where
  bind fa f = stepMap g fa where
    g (Yield a s) = Skip (h <$> s)
      where
      h s' = f a <> (s' >>= f)
    g (Skip s) = Skip ((_ >>= f) <$> s)
    g Done = Done

instance monadListT :: Monad f => Monad (ListT f)

instance monadTransListT :: MonadTrans ListT where
  lift = fromEffect

instance altListT :: Applicative f => Alt (ListT f) where
  alt = concat

instance plusListT :: Monad f => Plus (ListT f) where
  empty = nil

instance alternativeListT :: Monad f => Alternative (ListT f)

instance monadZeroListT :: Monad f => MonadZero (ListT f)

instance monadPlusListT :: Monad f => MonadPlus (ListT f)

instance monadEffListT :: MonadEff eff m => MonadEff eff (ListT m) where
  liftEff = lift <<< liftEff

-- | This module defines the list monad transformer, `ListT`.

module Control.Monad.List.Trans
  ( ListT
  , catMaybes
  , cons
  , drop
  , dropWhile
  , filter
  , foldl
  , foldl'
  , fromEffect
  , head
  , iterate
  , mapMaybe
  , nil
  , prepend
  , prepend'
  , repeat
  , scanl
  , singleton
  , tail
  , take
  , takeWhile
  , uncons
  , unfold
  , wrapEffect
  , wrapLazy
  , zipWith
  , zipWith'
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Lazy (Lazy, defer, force)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Unfoldable (class Unfoldable)

-- | The list monad transformer.
-- |
-- | This monad transformer extends the base monad with _non-determinism_.
-- | That is, the transformed monad supports the same effects as the base monad
-- | but with multiple return values.
newtype ListT f a = ListT (f (Step a (ListT f a)))

-- | The result of a single step in a `ListT` computation. Either:
-- |
-- | - Computation has finished (`Done`), or
-- | - A result has been returned, along with the next part of the computation (`Yield`).
-- |
-- | The `Skip` constructor allows us to avoid traversing lists during certain operations.
data Step a s
  = Yield a (Lazy s)
  | Skip (Lazy s)
  | Done

-- | Run a computation in the `ListT` monad.
runListT :: forall f a. ListT f a -> f (Step a (ListT f a))
runListT (ListT fa) = fa

-- | The empty list.
nil :: forall f a. Applicative f => ListT f a
nil = ListT $ pure Done

-- | Attach an element to the front of a list.
cons :: forall f a. Applicative f => Lazy a -> Lazy (ListT f a) -> ListT f a
cons lh t = ListT $ pure $ Yield (force lh) t

-- | Prepend an element to a lazily-evaluated list.
prepend' :: forall f a. Applicative f => a -> Lazy (ListT f a) -> ListT f a
prepend' h t = ListT $ pure (Yield h t)

-- | Prepend an element to a list.
prepend :: forall f a. Applicative f => a -> ListT f a -> ListT f a
prepend h t = prepend' h (defer $ const t)

-- | Lift a computation on list steps to a computation on whole lists.
stepMap :: forall f a b. Functor f => (Step a (ListT f a) -> Step b (ListT f b)) -> ListT f a -> ListT f b
stepMap f (ListT l) = ListT $ f <$> l

-- | Append one list to another.
concat :: forall f a. Applicative f => ListT f a -> ListT f a -> ListT f a
concat x y = stepMap f x where
  f (Yield a s) = Yield a ((_ <> y) <$> s)
  f (Skip s)    = Skip ((_ <> y) <$> s)
  f Done        = Skip (defer $ const y)

-- | Create a list with one element.
singleton :: forall f a. Applicative f => a -> ListT f a
singleton a = prepend a nil

-- | Lift a computation from the base functor.
fromEffect :: forall f a. Applicative f => f a -> ListT f a
fromEffect fa = ListT $ (flip Yield (defer $ \_ -> nil)) <$> fa

-- | Lift a computation from the base monad.
wrapEffect :: forall f a. Functor f => f (ListT f a) -> ListT f a
wrapEffect v = ListT $ Skip <<< defer <<< const <$> v

-- | Defer evaluation of a list.
wrapLazy :: forall f a. Applicative f => Lazy (ListT f a) -> ListT f a
wrapLazy v = ListT $ pure (Skip v)

-- | Unfold a list using an effectful generator function.
unfold :: forall f a z. Monad f => (z -> f (Maybe (Tuple z a))) -> z -> ListT f a
unfold f z = ListT $ g <$> f z
  where
  g (Just (Tuple z' a)) = Yield a (defer \_ -> unfold f z')
  g Nothing            = Done

-- | Generate an infinite list by iterating a function.
iterate :: forall f a. Monad f => (a -> a) -> a -> ListT f a
iterate f a = unfold g a
  where
  g x = pure $ Just (Tuple (f x) x)

-- | Generate an infinite list by repeating a value.
repeat :: forall f a. Monad f => a -> ListT f a
repeat = iterate id

-- | Take a number of elements from the front of a list.
take :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
take 0 fa = nil
take n fa = stepMap f fa where
  f (Yield a s) = Yield a (take (n - 1) <$> s)
  f (Skip s)    = Skip (take n <$> s)
  f Done        = Done

-- | Take elements from the front of a list while a predicate holds.
takeWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
takeWhile f = stepMap g where
  g (Yield a s) = if f a then Yield a (takeWhile f <$> s) else Done
  g (Skip s)    = Skip $ takeWhile f <$> s
  g Done        = Done

-- | Drop a number of elements from the front of a list.
drop :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
drop 0 fa = fa
drop n fa = stepMap f fa where
  f (Yield a s) = Skip (drop (n - 1) <$> s)
  f (Skip s)    = Skip (drop n <$> s)
  f Done        = Done

-- | Drop elements from the front of a list while a predicate holds.
dropWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
dropWhile f = stepMap g where
  g (Yield a s) = if f a then Skip (dropWhile f <$> s) else Yield a s
  g (Skip s)    = Skip $ dropWhile f <$> s
  g Done        = Done

-- | Remove elements from a list for which a predicate fails to hold.
filter :: forall f a. Functor f => (a -> Boolean) -> ListT f a -> ListT f a
filter f = stepMap g where
  g (Yield a s) = if f a then Yield a s' else Skip s' where s' = filter f <$> s
  g (Skip s)    = Skip s' where s' = filter f <$> s
  g Done        = Done

-- | Apply a function to the elements of a list, keeping only those return values which contain a result.
mapMaybe :: forall f a b. Functor f => (a -> Maybe b) -> ListT f a -> ListT f b
mapMaybe f = stepMap g where
  g (Yield a s) = (fromMaybe Skip (Yield <$> (f a))) (mapMaybe f <$> s)
  g (Skip s)    = Skip $ mapMaybe f <$> s
  g Done        = Done

-- | Remove elements from a list which do not contain a value.
catMaybes :: forall f a. Functor f => ListT f (Maybe a) -> ListT f a
catMaybes = mapMaybe id

-- | Perform the first step of a computation in the `ListT` monad.
uncons :: forall f a. Monad f => ListT f a -> f (Maybe (Tuple a (ListT f a)))
uncons (ListT l) = l >>= g
  where
  g (Yield a s) = pure $ Just $ Tuple a (force s)
  g (Skip s)    = uncons (force s)
  g Done        = pure Nothing

-- | Extract the first element of a list.
head :: forall f a. Monad f => ListT f a -> f (Maybe a)
head l = ((<$>) fst) <$> uncons l

-- | Extract all but the first element of a list.
tail :: forall f a. Monad f => ListT f a -> f (Maybe (ListT f a))
tail l = ((<$>) snd) <$> uncons l

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
foldl' :: forall f a b. Monad f => (b -> a -> f b) -> b -> ListT f a -> f b
foldl' f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = (f b a) >>= (flip loop as)

-- | Fold a list from the left, accumulating the result using the specified function.
foldl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> f b
foldl f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = loop (f b a) as

-- | Fold a list from the left, accumulating the list of results using the specified function.
scanl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> ListT f b
scanl f b l = unfold g (Tuple b l)
  where
  g (Tuple b' (ListT l')) = h <$> l'
    where
    h (Yield a s) = let b'' = f b' a in Just $ Tuple (Tuple b'' (force s)) b'
    h (Skip s)    = Just $ Tuple (Tuple b' (force s)) b'
    h Done        = Nothing

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith' :: forall f a b c. Monad f => (a -> b -> f c) -> ListT f a -> ListT f b -> ListT f c
zipWith' f = loop where
  loop fa fb = wrapEffect do
    ua <- uncons fa
    ub <- uncons fb
    g ua ub

  g _ Nothing = pure nil
  g Nothing _ = pure nil
  g (Just (Tuple ha ta)) (Just (Tuple hb tb)) = (flip prepend') (defer \_ -> zipWith' f ta tb) <$> (f ha hb)

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith :: forall f a b c. Monad f => (a -> b -> c) -> ListT f a -> ListT f b -> ListT f c
zipWith f = zipWith' g
  where
  g a b = pure $ f a b

derive instance newtypeListT :: Newtype (ListT f a) _

instance semigroupListT :: Applicative f => Semigroup (ListT f a) where
  append = concat

instance monoidListT :: Applicative f => Monoid (ListT f a) where
  mempty = nil

instance functorListT :: Functor f => Functor (ListT f) where
  map f = stepMap g where
    g (Yield a s) = Yield (f a) ((<$>) f <$> s)
    g (Skip s)    = Skip ((<$>) f <$> s)
    g Done        = Done

instance unfoldableListT :: Monad f => Unfoldable (ListT f) where
  unfoldr f b = go (f b)
    where go Nothing = nil
          go (Just (Tuple x y)) = cons (pure x) (defer \_ -> (go (f y)))

instance applyListT :: Monad f => Apply (ListT f) where
  apply = ap

instance applicativeListT :: Monad f => Applicative (ListT f) where
  pure = singleton

instance bindListT :: Monad f => Bind (ListT f) where
  bind fa f = stepMap g fa where
    g (Yield a s) = Skip (h <$> s)
      where
      h s' = f a <> (s' >>= f)
    g (Skip s) = Skip ((_ >>= f) <$> s)
    g Done = Done

instance monadListT :: Monad f => Monad (ListT f)

instance monadTransListT :: MonadTrans ListT where
  lift = fromEffect

instance altListT :: Applicative f => Alt (ListT f) where
  alt = concat

instance plusListT :: Monad f => Plus (ListT f) where
  empty = nil

instance alternativeListT :: Monad f => Alternative (ListT f)

instance monadZeroListT :: Monad f => MonadZero (ListT f)

instance monadPlusListT :: Monad f => MonadPlus (ListT f)

instance monadEffListT :: MonadEff eff m => MonadEff eff (ListT m) where
  liftEff = lift <<< liftEff


Remove 'profileA' call

Remove 'profileA' call

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.MonadPlus (guard)
import Data.Either (Either(..), fromRight)
import Data.Identity (Identity())
import Data.Foldable (foldMap)
import Data.List (List(..), many, catMaybes, toUnfoldable, (:), some)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String (singleton) as String
import Data.String.Regex (Regex(), regex)
import Data.String.Regex (parseFlags, replace) as Regex
import Partial.Unsafe (unsafePartial)
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | Optimal: Faster P.skipSpaces since it does not accumulate into a list.
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit

-- | Optimal: Translate [[<anything>-]options] to @anything
-- | this saves us looking ahead repeatedly when parsing '['.
referenceRegex :: Regex
referenceRegex
  = unsafePartial $ fromRight $
      regex
        "\\[(([^\\]](?!\\s*-?\\s*options\\s*))*?.?)\\s*-?\\s*options\\s*\\]"
        (Regex.parseFlags "gmi")

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  -- perform a simple transformation to avoid 'manyTill' and safe some millis
  -- lexing. Hopefully this won't be necessary when purescript-parsing improves
  -- performance, a faster parsing library shows up or the purescript compiler
  -- improves in performance.
  let
    input' = if isUsageMode m
                then Regex.replace referenceRegex "@$1" input
                else input

  P.runParser input' (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos: pos, token: tok }) =
    (show tok) <> " at " <> (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

parsePositionedToken :: (P.Parser String Token) -> P.Parser String PositionedToken
parsePositionedToken p = do
  pos <- getPosition
  tok <- p
  pure $ PositionedToken { sourcePos: pos, token: tok }

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.char   '['   $> LSquare
  , _reference
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

white :: P.Parser String Unit
white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

_stdin :: P.Parser String Token
_stdin = do
  P.char '-'
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char '|'
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.string "..."
  ])
  pure Dash

_eoa :: P.Parser String Token
_eoa = do
  P.string "--"
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char ']'
  , void $ P.char ')'
  ])
  pure DoubleDash

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.char '@'
  foldMap String.singleton <$> many (P.noneOf [' ', '\n'])

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  P.choice $ P.try <$> [
    withValue
  , withoutValue
  ]

  where
    withValue = do
      many white
      k <- foldMap String.singleton <$> many (P.noneOf [':'])
      P.char ':'
      many white
      v <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      many white
      pure (Tag k (Just v))
    withoutValue = do
      k <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      pure (Tag k Nothing)

_shoutName :: P.Parser String String
_shoutName = do
  n <- foldMap String.singleton <$> do
    (:)
      <$> upperAlpha
      <*> (many (upperAlpha <|> P.oneOf ['-', '_']))
  P.notFollowedBy lowerAlpha
  pure n

_name :: P.Parser String String
_name = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]

_angleName :: P.Parser String String
_angleName = do
  P.char '<'
  n <- foldMap String.singleton <$> do
    some $ P.choice [
      identLetter
      -- disallow swallowing new `<`s in order to avoid creating hard to trace
      -- errors for the user
    , P.noneOf [ '<', '>' ]
    ]
  P.char '>'
  pure $ "<" <> n <> ">"

_shortOption :: P.Parser String Token
_shortOption = do
  let validChar = alphaNum <|> P.oneOf [ '?' ]

  P.char '-'
  x  <- validChar
  xs <- A.many validChar

  arg <- P.choice $ P.try <$> [

    -- Case 1: -foo=BAR
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure  { name:     n
            , optional: false
            }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure  { name:     n
            , optional: true
            }

    -- Case 3: Option<ARG>
  , Just <$> do
      n <- _angleName
      pure { name:     n
            , optional: false
            }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ SOpt x xs arg

_longOption :: P.Parser String Token
_longOption = do
  P.string "--"

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

  arg <- P.choice $ P.try <$> [

    -- Case 1: OPTION=ARG
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure { name:     n
              , optional: true
              }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

identLetter :: P.Parser String Char
identLetter = alphaNum <|> P.oneOf ['_', '-']

flag :: P.Parser String Char
flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

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

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: TokenParser Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.MonadPlus (guard)
import Data.Either (Either(..), fromRight)
import Data.Identity (Identity())
import Data.Foldable (foldMap)
import Data.List (List(..), many, catMaybes, toUnfoldable, (:), some)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String (singleton) as String
import Data.String.Regex (Regex(), regex)
import Data.String.Regex (parseFlags, replace) as Regex
import Partial.Unsafe (unsafePartial)
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | Optimal: Faster P.skipSpaces since it does not accumulate into a list.
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit

-- | Optimal: Translate [[<anything>-]options] to @anything
-- | this saves us looking ahead repeatedly when parsing '['.
referenceRegex :: Regex
referenceRegex
  = unsafePartial $ fromRight $
      regex
        "\\[(([^\\]](?!\\s*-?\\s*options\\s*))*?.?)\\s*-?\\s*options\\s*\\]"
        (Regex.parseFlags "gmi")

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  -- perform a simple transformation to avoid 'manyTill' and safe some millis
  -- lexing. Hopefully this won't be necessary when purescript-parsing improves
  -- performance, a faster parsing library shows up or the purescript compiler
  -- improves in performance.
  let
    input' = if isUsageMode m
                then Regex.replace referenceRegex "@$1" input
                else input

  profileA "lex spec" \_->
    P.runParser input' (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos: pos, token: tok }) =
    (show tok) <> " at " <> (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

parsePositionedToken :: (P.Parser String Token) -> P.Parser String PositionedToken
parsePositionedToken p = do
  pos <- getPosition
  tok <- p
  pure $ PositionedToken { sourcePos: pos, token: tok }

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.char   '['   $> LSquare
  , _reference
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

white :: P.Parser String Unit
white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

_stdin :: P.Parser String Token
_stdin = do
  P.char '-'
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char '|'
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.string "..."
  ])
  pure Dash

_eoa :: P.Parser String Token
_eoa = do
  P.string "--"
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char ']'
  , void $ P.char ')'
  ])
  pure DoubleDash

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.char '@'
  foldMap String.singleton <$> many (P.noneOf [' ', '\n'])

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  P.choice $ P.try <$> [
    withValue
  , withoutValue
  ]

  where
    withValue = do
      many white
      k <- foldMap String.singleton <$> many (P.noneOf [':'])
      P.char ':'
      many white
      v <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      many white
      pure (Tag k (Just v))
    withoutValue = do
      k <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      pure (Tag k Nothing)

_shoutName :: P.Parser String String
_shoutName = do
  n <- foldMap String.singleton <$> do
    (:)
      <$> upperAlpha
      <*> (many (upperAlpha <|> P.oneOf ['-', '_']))
  P.notFollowedBy lowerAlpha
  pure n

_name :: P.Parser String String
_name = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]

_angleName :: P.Parser String String
_angleName = do
  P.char '<'
  n <- foldMap String.singleton <$> do
    some $ P.choice [
      identLetter
      -- disallow swallowing new `<`s in order to avoid creating hard to trace
      -- errors for the user
    , P.noneOf [ '<', '>' ]
    ]
  P.char '>'
  pure $ "<" <> n <> ">"

_shortOption :: P.Parser String Token
_shortOption = do
  let validChar = alphaNum <|> P.oneOf [ '?' ]

  P.char '-'
  x  <- validChar
  xs <- A.many validChar

  arg <- P.choice $ P.try <$> [

    -- Case 1: -foo=BAR
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure  { name:     n
            , optional: false
            }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure  { name:     n
            , optional: true
            }

    -- Case 3: Option<ARG>
  , Just <$> do
      n <- _angleName
      pure { name:     n
            , optional: false
            }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ SOpt x xs arg

_longOption :: P.Parser String Token
_longOption = do
  P.string "--"

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

  arg <- P.choice $ P.try <$> [

    -- Case 1: OPTION=ARG
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure { name:     n
              , optional: true
              }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

identLetter :: P.Parser String Char
identLetter = alphaNum <|> P.oneOf ['_', '-']

flag :: P.Parser String Char
flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

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

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: TokenParser Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })


Sensible name

Sensible name

module Component.Blog where

import Prelude

import Data.Generic (Generic, gEq, gCompare)
import Data.Functor.Coproduct (Coproduct())

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E
import qualified Halogen.HTML.Properties.Indexed as P

import Model
import Component.Article (article)
import qualified Component.Article as Article
import Control.Monad.Aff (Aff())
import Network.HTTP.Affjax (AJAX())
import qualified Network.HTTP.Affjax as Ajax

import Data.Foreign
import Data.Foreign.Class
import Data.Either (Either(..))

type State = Blog
-- | The state of the component
type FState g = InstalledState Blog Article Query Article.Query g ArticleSlot

newtype ArticleSlot = ArticleSlot ArticleId

derive instance articleSlot :: Generic ArticleSlot
instance eqArticleSlot :: Eq ArticleSlot where eq = gEq
instance ordArticleSlot :: Ord ArticleSlot where compare = gCompare

type FQuery = Coproduct Query (ChildF ArticleSlot Article.Query)

-- | The query algebra for the component
data Query a =
  Load a

-- | The component definition9
blog :: forall eff. Component (FState (Aff(Article.ArticleEffects eff))) FQuery (Aff(Article.ArticleEffects eff))
blog = parentComponent render eval
  where

  render :: State -> ParentHTML Article Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot
  render state =
    H.div [P.initializer \_ -> action Load]
      [ H.h1_
          [ H.text "Toby's Blog" ]
      , H.div_
        (map renderArticle state.articles)
      ]

  eval :: Natural Query (ParentDSL State Article.State Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot)
  eval (Load a) = do
    ids <- liftH $ liftAff' getBlogIds
    modify (\s -> s {articles = ids})
    pure a

  renderArticle :: ArticleId -> ParentHTML Article Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot
  renderArticle articleId = H.slot (ArticleSlot articleId) \_ -> {component: article, initialState: initialArticle articleId}

getBlogIds :: forall eff. Aff (ajax :: AJAX | eff) (Array ArticleId)
getBlogIds =
let url = "api/blogs" in
  do
    resp <- Ajax.get url
    return case
      readJSON resp.response :: F (Array Int)
      of
        Right ids -> ids
        Left _ -> []

module Component.Blog where

import Prelude

import Data.Generic (Generic, gEq, gCompare)
import Data.Functor.Coproduct (Coproduct())

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E
import qualified Halogen.HTML.Properties.Indexed as P

import Model
import Component.Article (article)
import qualified Component.Article as Article
import Control.Monad.Aff (Aff())
import Network.HTTP.Affjax (AJAX())
import qualified Network.HTTP.Affjax as Ajax

import Data.Foreign
import Data.Foreign.Class
import Data.Either (Either(..))

type State = Blog
-- | The state of the component
type FState g = InstalledState Blog Article Query Article.Query g ArticleSlot

newtype ArticleSlot = ArticleSlot ArticleId

derive instance articleSlot :: Generic ArticleSlot
instance eqArticleSlot :: Eq ArticleSlot where eq = gEq
instance ordArticleSlot :: Ord ArticleSlot where compare = gCompare

type FQuery = Coproduct Query (ChildF ArticleSlot Article.Query)

-- | The query algebra for the component
data Query a =
  Load a

-- | The component definition9
blog :: forall eff. Component (FState (Aff(Article.ArticleEffects eff))) FQuery (Aff(Article.ArticleEffects eff))
blog = parentComponent render eval
  where

  render :: State -> ParentHTML Article Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot
  render state =
    H.div [P.initializer \_ -> action Load]
      [ H.h1_
          [ H.text "Awesome Blog" ]
      , H.div_
        (map renderArticle state.articles)
      ]

  eval :: Natural Query (ParentDSL State Article.State Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot)
  eval (Load a) = do
    ids <- liftH $ liftAff' getBlogIds
    modify (\s -> s {articles = ids})
    pure a

  renderArticle :: ArticleId -> ParentHTML Article Query Article.Query (Aff(Article.ArticleEffects eff)) ArticleSlot
  renderArticle articleId = H.slot (ArticleSlot articleId) \_ -> {component: article, initialState: initialArticle articleId}

getBlogIds :: forall eff. Aff (ajax :: AJAX | eff) (Array ArticleId)
getBlogIds =
let url = "api/blogs" in
  do
    resp <- Ajax.get url
    return case
      readJSON resp.response :: F (Array Int)
      of
        Right ids -> ids
        Left _ -> []


deleted a mystical -

deleted a mystical -

see title

module Parser where

import Prelude (Unit, void, class Monad, bind, return, ($), (<$>), (<<<), (>>=), (+), (*), (++), id, flip, negate)
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>), lift2)
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, PState(..), runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Qual(..), ExprQual, Op(..))
import IndentParser

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> return a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> return true
      <|> string "False" *> return false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  return c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = toList $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.fromChar) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String Expr
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String Expr
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String Expr
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          return $ \e -> case e of
            Atom (AInt ai) -> (Atom (AInt (-ai)))
            _              -> Unary Sub e

    infixOperator :: Operator m String Expr
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          return $ \e1 e2 -> Binary (InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> return op)) <$> x) $ concat $ (\x -> toList <$> x) $ toList infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      return $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String Expr -> IndentParser String Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String Expr -> IndentParser String Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String Expr -> IndentParser String Expr
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String Expr -> IndentParser String Expr
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String Expr -> IndentParser String Expr
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String Expr -> IndentParser String Expr
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String Expr -> IndentParser String Expr
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ List exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String Expr -> IndentParser String Expr
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  return $ ArithmSeq start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String Expr -> IndentParser String Expr
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ ListComp start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String Expr -> IndentParser String ExprQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          return $ Let b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          return $ Gen b e
        parseGuard = ilexe expr >>= (return <<< Guard)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  skipWhite
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String Expr -> IndentParser String Expr
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  return $ Lambda binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String Expr -> IndentParser String Expr
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  return $ LetExpr binds body
  where
    bindingItem :: IndentParser String Expr -> IndentParser String (Tuple Binding Expr)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      return $ Tuple b e

    bindingBlock :: IndentParser String Expr -> IndentParser String (List (Tuple Binding Expr))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> return x)

-- | Parse an arbitrary expression
expression :: IndentParser String Expr
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT (PState {input: src,position: initialPos}) p

parseExpr :: String -> Either ParseError Expr
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m Binding
lit = Lit <$> atom

consLit :: IndentParser String Binding -> IndentParser String Binding
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  return b
  where
    consLit' :: IndentParser String Binding
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      return $ ConsLit b bs

listLit :: IndentParser String Binding -> IndentParser String Binding
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ ListLit bs

tupleLit :: IndentParser String Binding -> IndentParser String Binding
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  return $ NTupleLit (Cons b bs)

binding :: IndentParser String Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  return $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

module Parser where

import Prelude (Unit, void, class Monad, bind, return, ($), (<$>), (<<<), (>>=), (+), (*), (++), id, flip, negate)
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>), lift2)
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, PState(..), runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Qual(..), ExprQual, Op(..))
import IndentParser

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> return a-

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> return true
      <|> string "False" *> return false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  return c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = toList $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.fromChar) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String Expr
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String Expr
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String Expr
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          return $ \e -> case e of
            Atom (AInt ai) -> (Atom (AInt (-ai)))
            _              -> Unary Sub e

    infixOperator :: Operator m String Expr
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          return $ \e1 e2 -> Binary (InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> return op)) <$> x) $ concat $ (\x -> toList <$> x) $ toList infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      return $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String Expr -> IndentParser String Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String Expr -> IndentParser String Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String Expr -> IndentParser String Expr
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String Expr -> IndentParser String Expr
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String Expr -> IndentParser String Expr
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String Expr -> IndentParser String Expr
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String Expr -> IndentParser String Expr
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ List exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String Expr -> IndentParser String Expr
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  return $ ArithmSeq start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String Expr -> IndentParser String Expr
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ ListComp start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String Expr -> IndentParser String ExprQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          return $ Let b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          return $ Gen b e
        parseGuard = ilexe expr >>= (return <<< Guard)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  skipWhite
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String Expr -> IndentParser String Expr
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  return $ Lambda binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String Expr -> IndentParser String Expr
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  return $ LetExpr binds body
  where
    bindingItem :: IndentParser String Expr -> IndentParser String (Tuple Binding Expr)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      return $ Tuple b e

    bindingBlock :: IndentParser String Expr -> IndentParser String (List (Tuple Binding Expr))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> return x)

-- | Parse an arbitrary expression
expression :: IndentParser String Expr
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT (PState {input: src,position: initialPos}) p

parseExpr :: String -> Either ParseError Expr
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m Binding
lit = Lit <$> atom

consLit :: IndentParser String Binding -> IndentParser String Binding
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  return b
  where
    consLit' :: IndentParser String Binding
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      return $ ConsLit b bs

listLit :: IndentParser String Binding -> IndentParser String Binding
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  return $ ListLit bs

tupleLit :: IndentParser String Binding -> IndentParser String Binding
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  return $ NTupleLit (Cons b bs)

binding :: IndentParser String Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  return $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions