-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.ParseMonad
-- Copyright   :  (c) The GHC Team, 1997-2000
-- License     :  BSD-3-Clause
--
-- Maintainer  :  Andreas Abel
-- Stability   :  stable
-- Portability :  portable
--
-- Monads for the Haskell parser and lexer.
--
-----------------------------------------------------------------------------

{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ >= 902
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
#endif

module Language.Haskell.ParseMonad(
                -- * Parsing
                P, ParseResult(..), atSrcLoc, LexContext(..),
                ParseMode(..), defaultParseMode,
                runParserWithMode, runParser,
                getSrcLoc, pushCurrentContext, popContext,
                -- * Lexing
                Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
                alternative, checkBOL, setBOL, startToken, getOffside,
                pushContextL, popContextL
        ) where

import           Control.Applicative     as App
import           Control.Monad           (ap, liftM)
import qualified Control.Monad.Fail      as Fail
import           Data.Semigroup          as Semi
import           Language.Haskell.Syntax (SrcLoc (..))

-- | The result of a parse.
data ParseResult a
        = ParseOk a             -- ^ The parse succeeded, yielding a value.
        | ParseFailed SrcLoc String
                                -- ^ The parse failed at the specified
                                -- source location, with an error message.
        deriving Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
showsPrec :: Int -> ParseResult a -> ShowS
$cshow :: forall a. Show a => ParseResult a -> String
show :: ParseResult a -> String
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
showList :: [ParseResult a] -> ShowS
Show

instance Functor ParseResult where
  fmap :: forall a b. (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
f (ParseOk a
x)           = b -> ParseResult b
forall a. a -> ParseResult a
ParseOk (b -> ParseResult b) -> b -> ParseResult b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  fmap a -> b
_ (ParseFailed SrcLoc
loc String
msg) = SrcLoc -> String -> ParseResult b
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg

instance App.Applicative ParseResult where
  pure :: forall a. a -> ParseResult a
pure = a -> ParseResult a
forall a. a -> ParseResult a
ParseOk
  ParseOk a -> b
f           <*> :: forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
<*> ParseResult a
x = a -> b
f (a -> b) -> ParseResult a -> ParseResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseResult a
x
  ParseFailed SrcLoc
loc String
msg <*> ParseResult a
_ = SrcLoc -> String -> ParseResult b
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg

instance Monad ParseResult where
  return :: forall a. a -> ParseResult a
return = a -> ParseResult a
forall a. a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParseOk a
x           >>= :: forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= a -> ParseResult b
f = a -> ParseResult b
f a
x
  ParseFailed SrcLoc
loc String
msg >>= a -> ParseResult b
_ = SrcLoc -> String -> ParseResult b
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg

-- TODO: relax constraint to 'Semigroup s => Semigroup (ParseResult
-- s)' in the long distant future

-- | @since 1.0.3.0
instance Monoid m => Semi.Semigroup (ParseResult m) where
  ParseOk m
x <> :: ParseResult m -> ParseResult m -> ParseResult m
<> ParseOk m
y = m -> ParseResult m
forall a. a -> ParseResult a
ParseOk (m -> ParseResult m) -> m -> ParseResult m
forall a b. (a -> b) -> a -> b
$ m
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
y
  ParseOk m
_ <> ParseResult m
err       = ParseResult m
err
  ParseResult m
err       <> ParseResult m
_         = ParseResult m
err -- left-biased

instance Monoid m => Monoid (ParseResult m) where
  mempty :: ParseResult m
mempty = m -> ParseResult m
forall a. a -> ParseResult a
ParseOk m
forall a. Monoid a => a
mempty
  mappend :: ParseResult m -> ParseResult m -> ParseResult m
mappend = ParseResult m -> ParseResult m -> ParseResult m
forall a. Semigroup a => a -> a -> a
(<>)

-- internal version
data ParseStatus a = Ok ParseState a | Failed SrcLoc String
        deriving Int -> ParseStatus a -> ShowS
[ParseStatus a] -> ShowS
ParseStatus a -> String
(Int -> ParseStatus a -> ShowS)
-> (ParseStatus a -> String)
-> ([ParseStatus a] -> ShowS)
-> Show (ParseStatus a)
forall a. Show a => Int -> ParseStatus a -> ShowS
forall a. Show a => [ParseStatus a] -> ShowS
forall a. Show a => ParseStatus a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ParseStatus a -> ShowS
showsPrec :: Int -> ParseStatus a -> ShowS
$cshow :: forall a. Show a => ParseStatus a -> String
show :: ParseStatus a -> String
$cshowList :: forall a. Show a => [ParseStatus a] -> ShowS
showList :: [ParseStatus a] -> ShowS
Show

data LexContext = NoLayout | Layout Int
        deriving (LexContext -> LexContext -> Bool
(LexContext -> LexContext -> Bool)
-> (LexContext -> LexContext -> Bool) -> Eq LexContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LexContext -> LexContext -> Bool
== :: LexContext -> LexContext -> Bool
$c/= :: LexContext -> LexContext -> Bool
/= :: LexContext -> LexContext -> Bool
Eq,Eq LexContext
Eq LexContext =>
(LexContext -> LexContext -> Ordering)
-> (LexContext -> LexContext -> Bool)
-> (LexContext -> LexContext -> Bool)
-> (LexContext -> LexContext -> Bool)
-> (LexContext -> LexContext -> Bool)
-> (LexContext -> LexContext -> LexContext)
-> (LexContext -> LexContext -> LexContext)
-> Ord LexContext
LexContext -> LexContext -> Bool
LexContext -> LexContext -> Ordering
LexContext -> LexContext -> LexContext
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LexContext -> LexContext -> Ordering
compare :: LexContext -> LexContext -> Ordering
$c< :: LexContext -> LexContext -> Bool
< :: LexContext -> LexContext -> Bool
$c<= :: LexContext -> LexContext -> Bool
<= :: LexContext -> LexContext -> Bool
$c> :: LexContext -> LexContext -> Bool
> :: LexContext -> LexContext -> Bool
$c>= :: LexContext -> LexContext -> Bool
>= :: LexContext -> LexContext -> Bool
$cmax :: LexContext -> LexContext -> LexContext
max :: LexContext -> LexContext -> LexContext
$cmin :: LexContext -> LexContext -> LexContext
min :: LexContext -> LexContext -> LexContext
Ord,Int -> LexContext -> ShowS
ParseState -> ShowS
LexContext -> String
(Int -> LexContext -> ShowS)
-> (LexContext -> String)
-> (ParseState -> ShowS)
-> Show LexContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LexContext -> ShowS
showsPrec :: Int -> LexContext -> ShowS
$cshow :: LexContext -> String
show :: LexContext -> String
$cshowList :: ParseState -> ShowS
showList :: ParseState -> ShowS
Show)

type ParseState = [LexContext]

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

-- | 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
                ParseMode -> String
parseFilename :: String
                }

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

defaultParseMode :: ParseMode
defaultParseMode :: ParseMode
defaultParseMode = ParseMode {
                parseFilename :: String
parseFilename = String
"<unknown>"
                }

-- | Monad for parsing

newtype P a = P { forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
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 -> ParseResult a
runParserWithMode :: forall a. ParseMode -> P a -> String -> ParseResult a
runParserWithMode ParseMode
mode (P String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m) String
s = case String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m String
s Int
0 Int
1 SrcLoc
start [] ParseMode
mode of
        Ok ParseState
_ a
a         -> a -> ParseResult a
forall a. a -> ParseResult a
ParseOk a
a
        Failed SrcLoc
loc String
msg -> SrcLoc -> String -> ParseResult a
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg
    where start :: SrcLoc
start = SrcLoc {
                srcFilename :: String
srcFilename = ParseMode -> String
parseFilename ParseMode
mode,
                srcLine :: Int
srcLine = Int
1,
                srcColumn :: Int
srcColumn = Int
1
        }

runParser :: P a -> String -> ParseResult a
runParser :: forall a. P a -> String -> ParseResult a
runParser = ParseMode -> P a -> String -> ParseResult a
forall a. ParseMode -> P a -> String -> ParseResult a
runParserWithMode ParseMode
defaultParseMode

-- | @since 1.0.2.0
instance Functor P where
        fmap :: forall a b. (a -> b) -> P a -> P b
fmap = (a -> b) -> P a -> P b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

-- | @since 1.0.2.0
instance Applicative P where
        pure :: forall a. a -> P a
pure a
a = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
_i Int
_x Int
_y SrcLoc
_l ParseState
s ParseMode
_m -> ParseState -> a -> ParseStatus a
forall a. ParseState -> a -> ParseStatus a
Ok ParseState
s a
a
        <*> :: forall a b. P (a -> b) -> P a -> P b
(<*>) = P (a -> b) -> P a -> P b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad P where
        return :: forall a. a -> P a
return = a -> P a
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        P String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
k = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus b)
-> P b
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus b)
 -> P b)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus b)
-> P b
forall a b. (a -> b) -> a -> b
$ \String
i Int
x Int
y SrcLoc
l ParseState
s ParseMode
mode ->
                case String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m String
i Int
x Int
y SrcLoc
l ParseState
s ParseMode
mode of
                    Failed SrcLoc
loc String
msg -> SrcLoc -> String -> ParseStatus b
forall a. SrcLoc -> String -> ParseStatus a
Failed SrcLoc
loc String
msg
                    Ok ParseState
s' a
a        -> P b
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus b
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (a -> P b
k a
a) String
i Int
x Int
y SrcLoc
l ParseState
s' ParseMode
mode
#if !(MIN_VERSION_base(4,13,0))
        fail = Fail.fail
#endif

-- | @since 1.0.3.0
instance Fail.MonadFail P where
        fail :: forall a. String -> P a
fail String
s = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
_r Int
_col Int
_line SrcLoc
loc ParseState
_stk ParseMode
_m -> SrcLoc -> String -> ParseStatus a
forall a. SrcLoc -> String -> ParseStatus a
Failed SrcLoc
loc String
s

atSrcLoc :: P a -> SrcLoc -> P a
P String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m atSrcLoc :: forall a. P a -> SrcLoc -> P a
`atSrcLoc` SrcLoc
loc = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
i Int
x Int
y SrcLoc
_l -> String
-> Int -> Int -> SrcLoc -> ParseState -> ParseMode -> ParseStatus a
m String
i Int
x Int
y SrcLoc
loc

getSrcLoc :: P SrcLoc
getSrcLoc :: P SrcLoc
getSrcLoc = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus SrcLoc)
-> P SrcLoc
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus SrcLoc)
 -> P SrcLoc)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus SrcLoc)
-> P SrcLoc
forall a b. (a -> b) -> a -> b
$ \String
_i Int
_x Int
_y SrcLoc
l ParseState
s ParseMode
_m -> ParseState -> SrcLoc -> ParseStatus SrcLoc
forall a. ParseState -> a -> ParseStatus a
Ok ParseState
s SrcLoc
l

-- 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 :: P ()
pushCurrentContext = do
        loc <- P SrcLoc
getSrcLoc
        indent <- currentIndent
        pushContext (Layout (max (indent+1) (srcColumn loc)))

currentIndent :: P Int
currentIndent :: P Int
currentIndent = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus Int)
-> P Int
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus Int)
 -> P Int)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus Int)
-> P Int
forall a b. (a -> b) -> a -> b
$ \String
_r Int
_x Int
_y SrcLoc
_loc ParseState
stk ParseMode
_mode -> ParseState -> Int -> ParseStatus Int
forall a. ParseState -> a -> ParseStatus a
Ok ParseState
stk (ParseState -> Int
indentOfParseState ParseState
stk)

pushContext :: LexContext -> P ()
pushContext :: LexContext -> P ()
pushContext LexContext
ctxt =
--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
        (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus ())
-> P ()
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus ())
 -> P ())
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus ())
-> P ()
forall a b. (a -> b) -> a -> b
$ \String
_i Int
_x Int
_y SrcLoc
_l ParseState
s ParseMode
_m -> ParseState -> () -> ParseStatus ()
forall a. ParseState -> a -> ParseStatus a
Ok (LexContext
ctxtLexContext -> ParseState -> ParseState
forall a. a -> [a] -> [a]
:ParseState
s) ()

popContext :: P ()
popContext :: P ()
popContext = (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus ())
-> P ()
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus ())
 -> P ())
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus ())
-> P ()
forall a b. (a -> b) -> a -> b
$ \String
_i Int
_x Int
_y SrcLoc
_l ParseState
stk ParseMode
_m ->
      case ParseState
stk of
        (LexContext
_:ParseState
s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $
            ParseState -> () -> ParseStatus ()
forall a. ParseState -> a -> ParseStatus a
Ok ParseState
s ()
        []    -> String -> ParseStatus ()
forall a. HasCallStack => String -> a
error String
"Internal error: empty context in popContext"

-- Monad for lexical analysis:
-- a continuation-passing version of the parsing monad

newtype Lex r a = Lex { forall r a. Lex r a -> (a -> P r) -> P r
runL :: (a -> P r) -> P r }

-- | @since 1.0.2.0
instance Functor (Lex r) where
        fmap :: forall a b. (a -> b) -> Lex r a -> Lex r b
fmap = (a -> b) -> Lex r a -> Lex r b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

-- | @since 1.0.2.0
instance Applicative (Lex r) where
        pure :: forall a. a -> Lex r a
pure a
a = ((a -> P r) -> P r) -> Lex r a
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((a -> P r) -> P r) -> Lex r a) -> ((a -> P r) -> P r) -> Lex r a
forall a b. (a -> b) -> a -> b
$ \a -> P r
k -> a -> P r
k a
a
        <*> :: forall a b. Lex r (a -> b) -> Lex r a -> Lex r b
(<*>) = Lex r (a -> b) -> Lex r a -> Lex r b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
        Lex (a -> P r) -> P r
v *> :: forall a b. Lex r a -> Lex r b -> Lex r b
*> Lex (b -> P r) -> P r
w = ((b -> P r) -> P r) -> Lex r b
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((b -> P r) -> P r) -> Lex r b) -> ((b -> P r) -> P r) -> Lex r b
forall a b. (a -> b) -> a -> b
$ \b -> P r
k -> (a -> P r) -> P r
v (\a
_ -> (b -> P r) -> P r
w b -> P r
k)

instance Monad (Lex r) where
        return :: forall a. a -> Lex r a
return = a -> Lex r a
forall a. a -> Lex r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Lex (a -> P r) -> P r
v >>= :: forall a b. Lex r a -> (a -> Lex r b) -> Lex r b
>>= a -> Lex r b
f = ((b -> P r) -> P r) -> Lex r b
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((b -> P r) -> P r) -> Lex r b) -> ((b -> P r) -> P r) -> Lex r b
forall a b. (a -> b) -> a -> b
$ \b -> P r
k -> (a -> P r) -> P r
v (\a
a -> Lex r b -> (b -> P r) -> P r
forall r a. Lex r a -> (a -> P r) -> P r
runL (a -> Lex r b
f a
a) b -> P r
k)
        >> :: forall a b. Lex r a -> Lex r b -> Lex r b
(>>) = Lex r a -> Lex r b -> Lex r b
forall a b. Lex r a -> Lex r b -> Lex r b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
#if !(MIN_VERSION_base(4,13,0))
        fail = Fail.fail
#endif

-- | @since 1.0.3.0
instance Fail.MonadFail (Lex r) where
        fail :: forall a. String -> Lex r a
fail String
s = ((a -> P r) -> P r) -> Lex r a
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((a -> P r) -> P r) -> Lex r a) -> ((a -> P r) -> P r) -> Lex r a
forall a b. (a -> b) -> a -> b
$ \a -> P r
_ -> String -> P r
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s

-- Operations on this monad

getInput :: Lex r String
getInput :: forall r. Lex r String
getInput = ((String -> P r) -> P r) -> Lex r String
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((String -> P r) -> P r) -> Lex r String)
-> ((String -> P r) -> P r) -> Lex r String
forall a b. (a -> b) -> a -> b
$ \String -> P r
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus r)
-> P r
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus r)
 -> P r)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus r)
-> P r
forall a b. (a -> b) -> a -> b
$ \String
r -> P r
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus r
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (String -> P r
cont String
r) String
r

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

discard :: Int -> Lex r ()
discard :: forall r. Int -> Lex r ()
discard Int
n = ((() -> P r) -> P r) -> Lex r ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P r) -> P r) -> Lex r ())
-> ((() -> P r) -> P r) -> Lex r ()
forall a b. (a -> b) -> a -> b
$ \() -> P r
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus r)
-> P r
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus r)
 -> P r)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus r)
-> P r
forall a b. (a -> b) -> a -> b
$ \String
r Int
x -> P r
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus r
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P r
cont ()) (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n String
r) (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)

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

lexNewline :: Lex a ()
lexNewline :: forall a. Lex a ()
lexNewline = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \(Char
_:String
r) Int
_x Int
y -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r Int
1 (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

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

lexTab :: Lex a ()
lexTab :: forall a. Lex a ()
lexTab = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \(Char
_:String
r) Int
x -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r (Int -> Int
nextTab Int
x)

nextTab :: Int -> Int
nextTab :: Int -> Int
nextTab Int
x = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
tAB_LENGTH Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tAB_LENGTH)

tAB_LENGTH :: Int
tAB_LENGTH :: Int
tAB_LENGTH = Int
8

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

lexWhile :: (Char -> Bool) -> Lex a String
lexWhile :: forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
p = ((String -> P a) -> P a) -> Lex a String
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((String -> P a) -> P a) -> Lex a String)
-> ((String -> P a) -> P a) -> Lex a String
forall a b. (a -> b) -> a -> b
$ \String -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x ->
        let (String
cs,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
p String
r in
        P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (String -> P a
cont String
cs) String
rest (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs)

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

alternative :: Lex a v -> Lex a (Lex a v)
alternative :: forall a v. Lex a v -> Lex a (Lex a v)
alternative (Lex (v -> P a) -> P a
v) = ((Lex a v -> P a) -> P a) -> Lex a (Lex a v)
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((Lex a v -> P a) -> P a) -> Lex a (Lex a v))
-> ((Lex a v -> P a) -> P a) -> Lex a (Lex a v)
forall a b. (a -> b) -> a -> b
$ \Lex a v -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x Int
y ->
        P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (Lex a v -> P a
cont (((v -> P a) -> P a) -> Lex a v
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((v -> P a) -> P a) -> Lex a v) -> ((v -> P a) -> P a) -> Lex a v
forall a b. (a -> b) -> a -> b
$ \v -> P a
cont' -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
_r Int
_x Int
_y ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP ((v -> P a) -> P a
v v -> P a
cont') String
r Int
x Int
y)) String
r Int
x Int
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 :: forall a. Lex a Bool
checkBOL = ((Bool -> P a) -> P a) -> Lex a Bool
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((Bool -> P a) -> P a) -> Lex a Bool)
-> ((Bool -> P a) -> P a) -> Lex a Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x Int
y SrcLoc
loc ->
                if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (Bool -> P a
cont Bool
True) String
r (SrcLoc -> Int
srcColumn SrcLoc
loc) Int
y SrcLoc
loc
                        else P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (Bool -> P a
cont Bool
False) String
r Int
x Int
y SrcLoc
loc

setBOL :: Lex a ()
setBOL :: forall a. Lex a ()
setBOL = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
_ -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r Int
0

-- Set the loc to the current position

startToken :: Lex a ()
startToken :: forall a. Lex a ()
startToken = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
s Int
x Int
y SrcLoc
_ ParseState
stk ParseMode
mode ->
        let loc :: SrcLoc
loc = SrcLoc {
                srcFilename :: String
srcFilename = ParseMode -> String
parseFilename ParseMode
mode,
                srcLine :: Int
srcLine = Int
y,
                srcColumn :: Int
srcColumn = Int
x
        } in
        P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
s Int
x Int
y SrcLoc
loc ParseState
stk ParseMode
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 :: forall a. Lex a Ordering
getOffside = ((Ordering -> P a) -> P a) -> Lex a Ordering
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((Ordering -> P a) -> P a) -> Lex a Ordering)
-> ((Ordering -> P a) -> P a) -> Lex a Ordering
forall a b. (a -> b) -> a -> b
$ \Ordering -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x Int
y SrcLoc
loc ParseState
stk ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (Ordering -> P a
cont (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x (ParseState -> Int
indentOfParseState ParseState
stk))) String
r Int
x Int
y SrcLoc
loc ParseState
stk

pushContextL :: LexContext -> Lex a ()
pushContextL :: forall a. LexContext -> Lex a ()
pushContextL LexContext
ctxt = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x Int
y SrcLoc
loc ParseState
stk ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r Int
x Int
y SrcLoc
loc (LexContext
ctxtLexContext -> ParseState -> ParseState
forall a. a -> [a] -> [a]
:ParseState
stk)

popContextL :: String -> Lex a ()
popContextL :: forall a. String -> Lex a ()
popContextL String
fn = ((() -> P a) -> P a) -> Lex a ()
forall r a. ((a -> P r) -> P r) -> Lex r a
Lex (((() -> P a) -> P a) -> Lex a ())
-> ((() -> P a) -> P a) -> Lex a ()
forall a b. (a -> b) -> a -> b
$ \() -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> ParseState
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> ParseState
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> ParseState
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \String
r Int
x Int
y SrcLoc
loc ParseState
stk -> case ParseState
stk of
                (LexContext
_:ParseState
ctxt) -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> ParseState
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r Int
x Int
y SrcLoc
loc ParseState
ctxt
                []       -> String -> ParseMode -> ParseStatus a
forall a. HasCallStack => String -> a
error (String
"Internal error: empty context in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fn)