ParseMonad.hs

module ParseMonad(PM,HToken,thenPM,returnPM,parseError,getSrcLoc,
	          State,get,set,setreturn,eof,eoftoken,
		  parseFile,parseTokens) where
import HsTokens(Token(GotEOF))
import HsLexerPass1(lexerPass1Only,lexerPass0,Pos(..),line,column)
import MUtils
import SrcLoc
import SrcLocPretty
import PrettyPrint(pp)
import Monad(liftM,MonadPlus(..))
--import ExceptM()
import Control.Monad.Error()
 --import IOExts(trace) -- for debugging only

default(Int)

type HToken = (Token,(SrcLoc,String))
 --type Pos = (Int,Int)
type Error = String
type LayoutContext = Int
type State = ([HToken],[LayoutContext])

-- Parser monad type:
newtype PM a = PM {unPM::(State->Either Error (a,State))}

returnPM x = PM $ Right . (,) x
PM p1 `thenPM` xp2 = PM $ \ ts->uncurry (unPM . xp2) =<< p1 ts
failPM msg = PM $ \ _ -> Left msg

{-
emapPM f (PM p) = PM $ \ ts -> case p ts of
				 Right ans -> Right ans
				 Left err -> Left (f err)
-}

get = PM $ \ st -> Right (st,st)
set st = PM $ \ _ -> Right ((),st)
setreturn x st = PM $ \ _ -> Right (x,st)

instance Monad PM where
  return=returnPM
  (>>=) = thenPM
  fail = parseError

instance Functor PM where fmap = liftM

instance MonadPlus PM where
  mzero = fail "parser failed"
  PM p1 `mplus` PM p2 = PM $ \ s -> case p1 s of
			              y@(Right _) -> y
				      Left _ -> p2 s

getSrcLoc = fst.snd # peek

peek = tok1 # get
  where
    tok1 (ts,_) = case ts of
		    t:_ -> t
		    []  -> eoftoken

parseError msg = err =<< peek
  where err (t,(p,s)) =
            failPM $ pos++": "++msg
          where pos = if p==eof
	              then "at end of file"
	              else pp p++", before "++s

parseFile pm f = parseTokens pm f . lexerPass0

parseTokens (PM p) f ts =
  case p (map convPos $ lexerPass1Only ts,initial_layout_context_stack) of
    Left err    -> fail ({-f++": "++-}err)
    Right (x,_) -> return x
  where
    convPos (t,(Pos n l c,s)) = {-seq loc-} (t,(loc,s))
      where loc = SrcLoc f n l c

eoftoken = (GotEOF,(eof,""))
eof = SrcLoc "?" 0 (-1) (-1) -- hmm

initial_layout_context_stack = []