{-+
Command-Line Parsing Combinators
================================
-}
module CmdLineParser4(
  -- Parser type:
  P,
  -- Parser constructors:
  token,cmd,(!),(<@),(#@),chk,nil,many,arg,kw,opt,flag,(--:),
  -- Parser destructors:
  run,usage,parseAll
  ) where
import Pretty
import Monad(msum,join,liftM,MonadPlus(..),ap)
import Maybe(isJust)
import System(getArgs)
import PM
import Grammar

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

{-+
The Parser Data Type
--------------------
-}
data P res = P Grammar (PM res)

instance Functor P where fmap f (P g p) = P g (fmap f p)

{-+
Parsing combinators
-------------------
-}

nil x = P Empty (return x)
P g1 f <@ P g2 a = P (Seq g1 g2) (f `ap` a)
named nt (P g p) = P (Nonterminal nt g) p
P g p --: descr = P (g :--- descr) p
token f s = P (Terminal s) (tokenP f s)
P g1 p1 ! P g2 p2 = P (Alt g1 g2) (p1 `mplus` p2)
many (P g p) = P (Many g) (manyP p)
opt (P g p) = P (Opt g) (fmap Just p `mplus` return Nothing)

chk p p' = const `fmap` p <@ p'
cmd s p = nil p `chk` kw s

f #@ p = fmap f p

arg = token Just
kw s = token check s
  where check a = if a==s then Just () else Nothing

flag s = isJust `fmap` opt (kw s)

{-+
Extracting the documentation from a grammar
------------------------------------------
-}

usage prefix p = render (usageDoc prefix p)
usageDoc prefix (P g _) =
    (text "Usage:" $$
        nest 2 (nest 2 (text prefix<+>main) $$
                if null aux then empty else text "where" $$ vcat aux))
  where
    (main,aux) = ppGrammar g

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

parseAll (P g p) = runPM p