ParseMonad.hs

{-# LANGUAGE NamedFieldPuns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.ParseMonad
-- Copyright   :  (c) The GHC Team, 1997-2000
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Monads for the Haskell parser and lexer.
--
-----------------------------------------------------------------------------

module FrontEnd.ParseMonad(
		-- * Parsing
		P, ParseResult(..), atSrcLoc, LexContext(..),
		ParseMode(..),
                parseModeOptions,
		runParserWithMode, runParser,
		getSrcLoc, setSrcLoc, pushCurrentContext, popContext,thenP,returnP,
		-- * Lexing
		Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
		alternative, checkBOL, setBOL, startToken, getOffside,
		pushContextL, popContextL, lexParseMode,
                pullCtxtFlag, setFlagDo
	) where

import Control.Monad
import Data.Functor
import Data.Monoid
import qualified Control.Applicative as A
import qualified Data.Set as Set

import FrontEnd.SrcLoc
import FrontEnd.Warning
import Options
import PackedString
import qualified FlagOpts as FO

-- | The result of a parse.
data ParseResult a
	= ParseOk a	-- ^ The parse succeeded, yielding a value and a set of warnings.
	| ParseFailed SrcLoc String
				-- ^ The parse failed at the specified
				-- source location, with an error message.
	deriving Show

-- internal version
data ParseStatus a = Ok ParseState a | Failed SrcLoc String
	deriving Show

data LexContext = NoLayout | Layout Int
	deriving (Eq,Ord,Show)

--type ParseState = [LexContext]
data ParseState = ParseState {
    psLexContext :: [LexContext],
    psWarnings :: [Warning],
    psInDo :: !Bool,
    psForceClose :: !Bool
    } deriving(Show)

instance Functor ParseResult where
    fmap f (ParseOk x) = ParseOk (f x)
    fmap _ (ParseFailed x y) = ParseFailed x y

instance A.Applicative ParseResult where
  pure = ParseOk
  ParseOk f <*> x = f <$> x
  ParseFailed loc msg <*> _ = ParseFailed loc msg

instance Monad ParseResult where
  return = A.pure
  ParseOk x         >>= f = f x
  ParseFailed loc msg >>= _ = ParseFailed loc msg

instance Monoid m => Monoid (ParseResult m) where
  mempty = ParseOk mempty
  ParseOk x `mappend` ParseOk y = ParseOk $ x `mappend` y
  ParseOk x `mappend` err       = err
  err       `mappend` _         = err -- left-biased

indentOfParseState :: ParseState -> Int
indentOfParseState ParseState { psLexContext = (Layout n:_) } = n
indentOfParseState _            = 0

emptyParseState = ParseState { psLexContext = [], psWarnings = [], psForceClose = False, psInDo = False }

-- | Static parameters governing a parse.
-- More to come later, e.g. literate mode, language extensions.

data ParseMode = ParseMode {
                -- | original name of the file being parsed
		parseFilename      :: FilePath,
                parseOpt           :: Opt,
                parseFFI           :: Bool,
                parseUnboxedValues :: Bool,
                parseUnboxedTuples :: Bool
		}

-- | Default parameters for a parse,
-- currently just a marker for an unknown filename.

defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
		parseFilename = "<unknown>",
                parseOpt = options,
                parseFFI = False,
                parseUnboxedValues = False,
                parseUnboxedTuples = False
		}

parseModeOptions options = defaultParseMode {
    parseUnboxedTuples = FO.UnboxedTuples `Set.member` optFOptsSet options || FO.UnboxedValues `Set.member` optFOptsSet options,
    parseUnboxedValues = FO.UnboxedValues `Set.member` optFOptsSet options,
    parseFFI = FO.Ffi `Set.member` optFOptsSet options,
    parseOpt = options
    }

-- | Monad for parsing

newtype P a = P { runP ::
		        String		-- input string
		     -> Int		-- current column
		     -> Int		-- current line
		     -> SrcLoc		-- location of last token read
		     -> ParseState	-- layout info.
		     -> ParseMode	-- parse parameters
		     -> ParseStatus a
		}

runParserWithMode :: ParseMode -> P a -> String -> ([Warning],ParseResult a)
runParserWithMode mode (P m) s = case m s 0 1 start emptyParseState mode of
	Ok s a -> (psWarnings s,ParseOk a)
	Failed loc msg -> ([],ParseFailed loc msg)
    where start = SrcLoc {
		srcLocFileName = packString $ parseFilename mode,
		srcLocLine = 1,
		srcLocColumn = 1
	}

runParser :: P a -> String -> ([Warning],ParseResult a)
runParser = runParserWithMode defaultParseMode

instance Monad P where
	return a = P $ \_i _x _y _l s _m -> Ok s a
	P m >>= k = P $ \i x y l s mode ->
		case m i x y l s mode of
		    Failed loc msg -> Failed loc msg
		    Ok s' a -> runP (k a) i x y l s' mode
	fail s = P $ \_r _col _line loc _stk _m -> Failed loc s

returnP :: a -> P a
returnP = return
thenP :: P a -> (a -> P b) -> P b
thenP = (>>=)

atSrcLoc :: P a -> SrcLoc -> P a
P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc

--getSrcLoc :: P SrcLoc

instance MonadSrcLoc P where
    getSrcLoc = P $ \_i _x _y l s _m -> Ok s l

instance MonadWarn P where
    addWarning w = P $ \_i _x _y _l s _m -> Ok s { psWarnings = w:psWarnings s } ()

-- Enter a new layout context.  If we are already in a layout context,
-- ensure that the new indent is greater than the indent of that context.
-- (So if the source loc is not to the right of the current indent, an
-- empty list {} will be inserted.)

pushCurrentContext :: P ()
pushCurrentContext = do
	lc <- getSrcLoc
	indent <- currentIndent
        let loc = srcLocColumn lc
        dob <- pullDoStatus
        when (if dob then loc < indent else loc <= indent) pushCtxtFlag
	pushContext (Layout loc)

currentIndent :: P Int
currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)

pushContext :: LexContext -> P ()
pushContext ctxt =
--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
	P $ \_i _x _y _l s _m -> Ok s { psLexContext = ctxt:psLexContext s } ()

popContext :: P ()
popContext = P $ \_i _x _y _l stk _m ->
      case psLexContext stk of
   	(_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $
            Ok stk { psLexContext = s } ()
        []    -> error "Internal error: empty context in popContext"

pullCtxtFlag :: Lex a Bool
pullCtxtFlag = Lex $ \cont -> P $ \r x y loc s ->
        runP (cont $ psForceClose s) r x y loc s { psForceClose = False }

pushCtxtFlag :: P ()
pushCtxtFlag =
    P $ \_i _x _y _l s _m -> case psForceClose s of
        False -> Ok s { psForceClose = True } ()
        _     -> error "Internal error: context flag already pushed"

pullDoStatus :: P Bool
pullDoStatus = P $ \_i _x _y _l s _m -> Ok s { psInDo = False } (psInDo s)

setFlagDo :: Lex a ()
setFlagDo = Lex $ \cont -> P $ \r x y loc s ->
        runP (cont ()) r x y loc s { psInDo = True }

-- Monad for lexical analysis:
-- a continuation-passing version of the parsing monad
--
newtype Lex r a = Lex { runL :: (a -> P r) -> P r }

instance Monad (Lex r) where
	return a = Lex $ \k -> k a
	Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)
	Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)
	fail s = Lex $ \_ -> fail s

instance MonadWarn (Lex r) where
    addWarning w = Lex $ \k -> addWarning w >> k ()
instance MonadSrcLoc (Lex r) where
    getSrcLoc = Lex $ \k -> getSrcLoc >>= k

-- Operations on this monad

getInput :: Lex r String
getInput = Lex $ \cont -> P $ \r -> runP (cont r) r

-- | Discard some input characters (these must not include tabs or newlines).

discard :: Int -> Lex r ()
discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n)

setSrcLoc :: SrcLoc -> Lex a ()
setSrcLoc srcloc = Lex $ \cont -> P $ \r x l _ -> runP (cont ()) r x l srcloc

-- | Discard the next character, which must be a newline.

lexNewline :: Lex a ()
lexNewline = Lex $ \cont -> P $ \(_:r) _x y loc -> runP (cont ()) r 1 (y+1) loc { srcLocLine = srcLocLine loc + 1 }

-- | Discard the next character, which must be a tab.

lexTab :: Lex a ()
lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x)

nextTab :: Int -> Int
nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)

tAB_LENGTH :: Int
tAB_LENGTH = 8

lexParseMode :: Lex a ParseMode
lexParseMode = Lex $ \cont -> P $ \r x y z s m -> runP (cont m) r x y z s m

-- Consume and return the largest string of characters satisfying p

lexWhile :: (Char -> Bool) -> Lex a String
lexWhile p = Lex $ \cont -> P $ \r x ->
	let (cs,rest) = span p r in
	runP (cont cs) rest (x + length cs)

-- An alternative scan, to which we can return if subsequent scanning
-- is unsuccessful.

alternative :: Lex a v -> Lex a (Lex a v)
alternative (Lex v) = Lex $ \cont -> P $ \r x y ->
	runP (cont (Lex $ \cont' -> P $ \_r _x _y ->
		runP (v cont') r x y)) r x y

-- The source location is the coordinates of the previous token,
-- or, while scanning a token, the start of the current token.

-- col is the current column in the source file.
-- We also need to remember between scanning tokens whether we are
-- somewhere at the beginning of the line before the first token.
-- This could be done with an extra Bool argument to the P monad,
-- but as a hack we use a col value of 0 to indicate this situation.

-- Setting col to 0 is used in two places: just after emitting a virtual
-- close brace due to layout, so that next time through we check whether
-- we also need to emit a semi-colon, and at the beginning of the file,
-- by runParser, to kick off the lexer.
-- Thus when col is zero, the true column can be taken from the loc.

checkBOL :: Lex a Bool
checkBOL = Lex $ \cont -> P $ \r x y loc ->
		if x == 0 then runP (cont True) r (srcLocColumn loc) y loc
			else runP (cont False) r x y loc

setBOL :: Lex a ()
setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0

-- Set the loc to the current position

startToken :: Lex a ()
startToken = Lex $ \cont -> P $ \s x y oloc stk mode ->
	let loc = oloc { srcLocColumn = x } in
	runP (cont ()) s x y loc stk mode

-- Current status with respect to the offside (layout) rule:
-- LT: we are to the left of the current indent (if any)
-- EQ: we are at the current indent (if any)
-- GT: we are to the right of the current indent, or not subject to layout

getOffside :: Lex a Ordering
getOffside = Lex $ \cont -> P $ \r x y loc stk ->
		runP (cont (compare x (indentOfParseState stk))) r x y loc stk

pushContextL :: LexContext -> Lex a ()
pushContextL ctxt = Lex $ \cont -> P $ \r x y loc stk ->
		runP (cont ()) r x y loc stk { psLexContext = ctxt:psLexContext stk }

popContextL :: String -> Lex a ()
popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case psLexContext stk of
		(_:ctxt) -> runP (cont ()) r x y loc stk { psLexContext = ctxt }
		[]       -> error ("Internal error: empty context in " ++ fn)

{-
-- ---------------------------------------------------------------------------
-- Construct a parse error

srcParseErr
  :: String       -- current buffer (placed just after the last token)
  -> Int                -- length of the previous token
  -> Message
srcParseErr buf len
  = hcat [ if null token
         then ptext SLIT("parse error (possibly incorrect indentation)")
         else hcat [ptext SLIT("parse error on input "),
                char '`', text token, char '\'']
    ]
  where token = lexemeToString (stepOnBy (-len) buf) len

-- Report a parse failure, giving the span of the previous token as
-- the location of the error.  This is the entry point for errors
-- detected during parsing.
srcParseFail :: P a
srcParseFail = P $ \buf _ _ last_loc _ _ ->
    Failed last_loc (srcParseErr buf len)

-- A lexical error is reported at a particular position in the source file,
-- not over a token range.  TODO: this is slightly wrong, because we record
-- the error at the character position following the one which caused the
-- error.  We should somehow back up by one character.
--lexError :: String -> P a
--lexError str = do
--  loc <- getSrcLoc
--  i@(end,_) <- getInput
--  failLocMsgP loc end str

-}