{-+
Command-Line Parsing Combinators
================================
-}
module CmdLineParser3(
  -- Parser type:
  P,
  -- Parser constructors:
  token,cmd,(!),(<@),(#@),chk,nil,many,arg,kw,opt,flag,(--:),
  -- Parser destructors:
  run,usage,parseAll
  ) where
import Pretty
import Monad(ap,mplus)
import Maybe(isJust)
import System(getArgs)
import PM
import qualified Grammar as G
import Grammar hiding (Many)

infixl 3 <@,`chk`,#@
infix 2 :--,--:
infixr 1 :!,!

{-+
The Parser Data Type
--------------------
-}
data P res
    = Nil res
    | forall arg . Ap (P (arg->res)) (P arg)
    | Named String (P res)
    | P res :-- String
    | Token (String->Maybe res) String
    | P res :! P res
    | forall item . Many (res->[item]) ([item]->res) (P item)

instance Functor P where fmap f p = Nil f `Ap` p

{-+
Parsing combinators
-------------------
-}
chk p p' = const `fmap` p `Ap` p'
cmd s p = Nil p `chk` kw s

f #@ p = fmap f p
(!) = (:!)
(<@) = Ap
(--:) = (:--)
nil = Nil
token = Token
arg = token Just
many p = Many id id p
kw s = token check s
  where check a = if a==s then Just () else Nothing

opt p = fmap Just p ! nil Nothing
flag s = isJust `fmap` opt (kw s)

{-+
Extracting the documentation from a grammar
------------------------------------------
-}
usage prefix p = render (usageDoc prefix p)
usageDoc prefix p =
    (text "Usage:" $$
        nest 2 (nest 2 (text prefix<+>main) $$
                if null aux then empty else text "where" $$ vcat aux))
  where
    (main,aux) = ppGrammar (grammar p)

    grammar :: P a -> Grammar
    grammar p =
      case p of
        Nil _ -> Empty
	Ap p1 p2 -> Seq (grammar p1) (grammar p2)
  	Named s p -> Nonterminal s (grammar p)
        p :-- s -> grammar p :--- s
        Token to s -> Terminal s
	p1 :! Nil _ -> Opt (grammar p1)
	p1 :! p2 -> Alt (grammar p1) (grammar p2)
        Many _ _ p -> G.Many (grammar p)

{-+
Running a parser
----------------
-}
run p = parseAll p =<< getArgs

parseAll p = runPM (parse p)

{-+
Converting a command line parser into a conventional parser
-----------------------------------------------------------
-}
parse :: P res -> PM res
parse p =
  case p of
    Nil res -> return res
    Ap pf pa -> parse pf `ap` parse pa
    Named _ p -> parse p
    p :-- s -> parse p
    Token check s -> tokenP check s
    p1 :! p2 -> parse p1 `mplus` parse p2
    Many to from p ->
        parse (cons `fmap` p `Ap` Many to from p ! Nil (from []))
      where cons x xs = from (x:to xs)