CmdLineParser3.hs

module CmdLineParser3(
  P((:--),Token),cmd,(!),(<@),( #@ ),chk,nil,many,arg,kw,opt,flag,named,
  run,usage,parseAll
  ) where
import PrettyPrint hiding (kw)
import Monad(msum,join,liftM,MonadPlus(..),ap)
import Maybe(isJust)
import System(getArgs)

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

data P res
  = Return 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 = Return f `Ap` p

chk p p' = const `fmap` p `Ap` p'
cmd s p = Return p `chk` kw s

f #@ p = fmap f p
(!) = (:!)
(<@) = Ap
nil = Return
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)
named = Named

usage prefix p = pp (usageDoc prefix p)
usageDoc prefix p =
    sep [ppi "Usage:", nest 4 (prefix<+>main)] $$
    if null aux
    then empty
    else sep [nest 2 "where", nest 4 (vcat aux)]
  where
    (main,aux) = usage' p

    usage' :: P a -> (Doc,[Doc])
    usage' p =
      case p of
        Return _ -> (empty,[])
	Ap p1 p2 -> (m1<+>m2,a1++a2)
          where (m1,a1) = usage' p1
		(m2,a2) = usage' p2
	Named s p -> (nt,sep [nt<+>"=",nest 2 m]:a)
          where nt = "<"<>s<>">"
                (m,a) = usage' p
        p :-- s -> (m<+>"--"<+>s,a) where (m,a) = usage' p
        Token to s -> (text s,[])
	p1 :! Return _ -> (brackets m,as)
          where (m,as) = usage' p1
	p1 :! p2 -> (vcat ms,concat as)
          where (ms,as) = unzip (map usage' [p1,p2])
        Many _ _ p -> (braces m,a) where (m,a) = usage' p

run p = parseAll p =<< getArgs

parseAll p args =
  case unPM (parse p) args of
    Right (r,[]) -> r
    Right (_,args) -> fail $ "Unrecognized arguments: "++unwords args
    Left (args,errs) ->
        fail $ ('\n':) $
            pp $ "Expected one of:"<+>ppiFSeq errs
               $$ (if null args then empty else "Found: "<+>sep args)
	       -- $$ usageDoc p
               $$ text ""

newtype PM res = PM {unPM ::[String] -> Either ([String],[String]) (res,[String])}

instance Functor PM where fmap = liftM
instance Monad PM where
  fail s = PM $ \ args->Left (args,[s])
  return x = PM $ \args->Right (x,args)
  PM p1>>=xp2 = PM $ \ args->case p1 args of
			       Left err -> Left err
			       Right (x,args') -> unPM (xp2 x) args'
instance MonadPlus PM where
  mzero = fail "no parse"
  mplus (PM p1) (PM p2) =
    PM $ \ args -> case (p1 args,p2 args) of
		     (Right res,_) -> Right res
		     (r1@(Left (a1,errs1)),r2@(Left (a2,errs2))) ->
			 case compare (length a1) (length a2) of
                           LT -> r1
			   EQ -> Left (a1,errs1++errs2)
			   GT -> r2
		     (_,r2) -> r2

get = PM $ \ args -> Right (args,args)
set args = PM $ \ _ -> Right ((),args)

parse :: P res -> PM res
parse p =
  case p of
    Return res -> return res
    Ap pf pa -> parse pf `ap` parse pa
    Named _ p -> parse p
    p :-- s -> parse p
    Token check s ->
      do args <- get
	 case args of
	   a:as -> maybe (fail s)
			 (\a->set as>>return a)
			 (check a)
	   [] -> fail s
    p1 :! p2 -> parse p1 `mplus` parse p2
    Many to from p ->
        parse (cons `fmap` p `Ap` Many to from p ! Return (from []))
      where cons x xs = from (x:to xs)