{-
 *  SAD / Alice / Parser -- defines the parser monad and base combinators
 *  Copyright (C) 2001-2004  SAD Development Team (see ../README)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License along
 *  with this program; if not, write to the Free Software Foundation, Inc.,
 *  59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 -}

module Parser where

import Control.Monad (MonadPlus,mplus,mzero,liftM2)
import Data.Char (isAlphaNum,isSpace,toLower)
import Data.List (isPrefixOf)

-- Parser state:

type PS = ([Token], Int, Int, String)

data PR st res  = Res res st PS | Err String st PS

-- Parser monad:

newtype PM st res = PM { runPM :: st -> PS -> [PR st res] }

instance Monad (PM st) where
  return r  = PM $ \ s q -> [Res r s q]

  m >>= k   = PM $ \ s q -> concatMap apply (runPM m s q)
    where
      apply (Res r' s' q')  = runPM (k r') s' q'
      apply (Err e  s' q')  = [Err e s' q']

  fail e    = PM $ \ s q -> [Err e s q]

ntfail e    = PM $ \ s (t, p, l, z) -> [Err e s (t, succ p, l, z)]
lfail l e   = PM $ \ s (t, p, _, z) -> [Err e s (t, succ p, l, z)]

getState :: (st -> a) -> PM st a
getState f  = PM $ \ s q -> [Res (f s) s q]

setState :: (st -> st) -> PM st ()
setState f  = PM $ \ s q -> [Res () (f s) q]

getPos  = PM $ \ s q@(_, p, _, _) -> [Res p s q]
getLin  = PM $ \ s q@(_, _, l, _) -> [Res l s q]
getTxt  = PM $ \ s q@(_, _, _, z) -> [Res (reverse z) s q]
nulTxt  = PM $ \ s (t, p, l, _) -> [Res () s (t, p, l, "")]


instance MonadPlus (PM st) where
  mzero     = PM $ \ _ _ -> []
  mplus m k = reduce $ PM $ \ s q -> runPM m s q ++ runPM k s q

infixr 1 -|-
(-|-) :: PM st res -> PM st res -> PM st res
(-|-) = mplus

infixr 1 -/-
(-/-) :: PM st res -> PM st res -> PM st res
m -/- k = firstr $ PM $ \ s q -> runPM m s q ++ runPM k s q

opt,optx :: res -> PM st res -> PM st res
opt a m   = m -|- return a
optx a m  = m -/- return a

after a b = a >>= ((b >>) . return) -- guess, what is it?

chain o p   = liftM2 (:) p (opt [] $ op_tail o p)
op_tail o p = o >> chain o p


-- Cleaning routines

reduce :: PM st res -> PM st res
reduce  = PM . sieve red
  where
    red res mxe _ = mxe : res

firstr :: PM st res -> PM st res
firstr  = PM . sieve fir
  where
    fir (r:_) _ _ = [r]
    fir _   mxe _ = [mxe]

narrow :: (Show res) => PM st res -> PM st res
narrow  = PM . sieve nar
  where
    nar [r] _   _ = [r]
    nar []  mxe _ = [mxe]
    nar res _ amb = [amb $ concatMap msg res]

    msg (Res r _ _) = "\n    " ++ show r

sieve sie m s q@(t, p, l, z) = sie res mxe amb
  where
    out = runPM m s q
    res = [ x | x@(Res _ _ _) <- out ]
    err = [ x | x@(Err _ _ _) <- out ]
    mxr = foldr sup zer res
    mxe = foldr sup zer err
    zer = Err "unknown error" s q
    amb msg = Err ("ambiguity: " ++ msg) s (t, pos mxr, l, txt mxr)
    sup a b = if pos a > pos b then a else b
    pos (Res _ _ (_, p, _, _)) = p
    pos (Err _ _ (_, p, _, _)) = p
    txt (Res _ _ (_, _, _, z)) = z
    txt (Err _ _ (_, _, _, z)) = z


-- Lexical Primitives

readChar :: PM st Char
readChar  = PM $ \ s (t, p, l, z) ->
  case t of
    Ch c : r  ->  [Res c s (r, succ p, l, c:z)]
    x : r     ->  [Err ("unexpected token " ++ show x) s (r, succ p, l, deTok x ++ z)]
    _         ->  [Err "unexpected end of input" s (t, succ p, l, z)]

readWord :: PM st String
readWord  = PM $ \ s (t, p, l, z) ->
  case t of
    Tk w : r  ->  [Res w s (r, succ p, l, deTok (Tk w) ++ z)]
    x : r     ->  [Err ("unexpected token " ++ show x) s (r, succ p, l, deTok x ++ z)]
    _         ->  [Err "unexpected end of input" s (t, succ p, l, z)]

space :: res -> PM st res
space a   = PM $ \ s q@(t, p, l, z) ->
  case t of
    Sp m : r  ->  [Res a s (r, p, (l + m), ' ':z)]
    _         ->  [Res a s q]

readEOI :: PM st ()
readEOI   = PM $ \ s (t, p, l, z) ->
  case t of
    x : r     ->  [Err ("unexpected token " ++ show x) s (r, succ p, l, deTok x ++ z)]
    _         ->  [Res () s (t, succ p, l, z)]


token :: PM st res -> PM st res
token p = p >>= space

charOf_ :: [Char] -> PM a Char
charOf_ cs  = do  c <- readChar; if (c `elem` cs) then return c
                    else fail ("unexpected char " ++ show c)

charOf cs   = token (charOf_ cs)

char_ c = charOf_ [c]
char c  = token (char_ c)

alpha_  s = do  w <- readWord; if (w `isPrefixOf` s)
                  then string_ $ drop (length w) s
                  else fail ("unexpected word " ++ show w)

string_ s@(c:cs)  = (char_ c >> string_ cs) -|- alpha_ s
string_ _ = return ()
string s  = token (string_ s)

wordOf_ :: [String] -> PM a String
wordOf_ ws  = do  x <- readWord; let w = map toLower x
                  if (w `elem` ws) then return w
                    else fail ("unexpected word " ++ show w)

wordOf ws   = token (wordOf_ ws)

word_ w = wordOf_ [w]
word w  = token (word_ w)


-- Tokenizer

data Token = Tk String | Ch Char | Sp Int

tokenize :: String -> [Token]
tokenize s  =
      case (span isValid s) of
      ([], _) ->  case (span isSpace s) of
                  ([], _) ->  case s of
                              ('#':t) ->  tokenize (dropWhile (/= '\n') t)
                              (c:t)   ->  Ch c : tokenize t
                              _       ->  []
                  (w, t)  ->  let n = length (filter (== '\n') w)
                              in case (tokenize t) of
                              (Sp m : r)  ->  Sp (n + m) : r
                              r           ->  Sp n : r
      (w, t)  ->  Tk w : tokenize t
  where
    isValid c = isAlphaNum c || c == '_'

deTok :: Token -> String
deTok (Tk w)  = reverse w
deTok (Ch c)  = [c]
deTok (Sp _)  = " "

instance Show Token where
  showsPrec _ (Tk w)  = shows w
  showsPrec _ (Ch c)  = shows c
  showsPrec _ _       = showString "<space>"

