-----------------------------------------------------------------------------
-- |
-- 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 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
showList :: [ParseResult a] -> ShowS
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
show :: ParseResult a -> String
$cshow :: forall a. Show a => ParseResult a -> String
showsPrec :: Int -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
Show

instance Functor ParseResult where
  fmap :: (a -> b) -> ParseResult a -> ParseResult b
fmap f :: a -> b
f (ParseOk x :: 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 _ (ParseFailed loc :: SrcLoc
loc msg :: String
msg) = SrcLoc -> String -> ParseResult b
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg

instance App.Applicative ParseResult where
  pure :: a -> ParseResult a
pure = a -> ParseResult a
forall a. a -> ParseResult a
ParseOk
  ParseOk f :: a -> b
f           <*> :: ParseResult (a -> b) -> ParseResult a -> ParseResult b
<*> x :: 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 loc :: SrcLoc
loc msg :: String
msg <*> _ = SrcLoc -> String -> ParseResult b
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
loc String
msg

instance Monad ParseResult where
  ParseOk x :: a
x           >>= :: ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= f :: a -> ParseResult b
f = a -> ParseResult b
f a
x
  ParseFailed loc :: SrcLoc
loc msg :: String
msg >>= _ = 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 x :: m
x <> :: ParseResult m -> ParseResult m -> ParseResult m
<> ParseOk y :: 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 _ <> err :: ParseResult m
err       = ParseResult m
err
  err :: ParseResult m
err       <> _         = 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

-- 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
showList :: [ParseStatus a] -> ShowS
$cshowList :: forall a. Show a => [ParseStatus a] -> ShowS
show :: ParseStatus a -> String
$cshow :: forall a. Show a => ParseStatus a -> String
showsPrec :: Int -> ParseStatus a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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
/= :: LexContext -> LexContext -> Bool
$c/= :: LexContext -> LexContext -> Bool
== :: LexContext -> LexContext -> Bool
$c== :: 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
min :: LexContext -> LexContext -> LexContext
$cmin :: LexContext -> LexContext -> LexContext
max :: LexContext -> LexContext -> LexContext
$cmax :: LexContext -> LexContext -> LexContext
>= :: LexContext -> LexContext -> Bool
$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
compare :: LexContext -> LexContext -> Ordering
$ccompare :: LexContext -> LexContext -> Ordering
$cp1Ord :: Eq LexContext
Ord,Int -> LexContext -> ShowS
[LexContext] -> ShowS
LexContext -> String
(Int -> LexContext -> ShowS)
-> (LexContext -> String)
-> ([LexContext] -> ShowS)
-> Show LexContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexContext] -> ShowS
$cshowList :: [LexContext] -> ShowS
show :: LexContext -> String
$cshow :: LexContext -> String
showsPrec :: Int -> LexContext -> ShowS
$cshowsPrec :: Int -> LexContext -> ShowS
Show)

type ParseState = [LexContext]

indentOfParseState :: ParseState -> Int
indentOfParseState :: [LexContext] -> Int
indentOfParseState (Layout n :: Int
n:_) = Int
n
indentOfParseState _            = 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 :: String -> ParseMode
ParseMode {
                parseFilename :: String
parseFilename = "<unknown>"
                }

-- | Monad for parsing

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

runParser :: P a -> String -> ParseResult a
runParser :: 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 :: (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 :: a -> P a
pure a :: a
a = (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \_i :: String
_i _x :: Int
_x _y :: Int
_y _l :: SrcLoc
_l s :: [LexContext]
s _m :: ParseMode
_m -> [LexContext] -> a -> ParseStatus a
forall a. [LexContext] -> a -> ParseStatus a
Ok [LexContext]
s a
a
        <*> :: 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
        P m :: String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
m >>= :: P a -> (a -> P b) -> P b
>>= k :: a -> P b
k = (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus b)
-> P b
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus b)
 -> P b)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus b)
-> P b
forall a b. (a -> b) -> a -> b
$ \i :: String
i x :: Int
x y :: Int
y l :: SrcLoc
l s :: [LexContext]
s mode :: ParseMode
mode ->
                case String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
m String
i Int
x Int
y SrcLoc
l [LexContext]
s ParseMode
mode of
                    Failed loc :: SrcLoc
loc msg :: String
msg -> SrcLoc -> String -> ParseStatus b
forall a. SrcLoc -> String -> ParseStatus a
Failed SrcLoc
loc String
msg
                    Ok s' :: [LexContext]
s' a :: a
a        -> P b
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus b
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (a -> P b
k a
a) String
i Int
x Int
y SrcLoc
l [LexContext]
s' ParseMode
mode

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

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

getSrcLoc :: P SrcLoc
getSrcLoc :: P SrcLoc
getSrcLoc = (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus SrcLoc)
-> P SrcLoc
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus SrcLoc)
 -> P SrcLoc)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus SrcLoc)
-> P SrcLoc
forall a b. (a -> b) -> a -> b
$ \_i :: String
_i _x :: Int
_x _y :: Int
_y l :: SrcLoc
l s :: [LexContext]
s _m :: ParseMode
_m -> [LexContext] -> SrcLoc -> ParseStatus SrcLoc
forall a. [LexContext] -> a -> ParseStatus a
Ok [LexContext]
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
        SrcLoc
loc <- P SrcLoc
getSrcLoc
        Int
indent <- P Int
currentIndent
        LexContext -> P ()
pushContext (Int -> LexContext
Layout (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
indentInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (SrcLoc -> Int
srcColumn SrcLoc
loc)))

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

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

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

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

newtype Lex r a = Lex { 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 :: (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 :: a -> Lex r a
pure a :: 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
$ \k :: a -> P r
k -> a -> P r
k a
a
        <*> :: 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 v :: (a -> P r) -> P r
v *> :: Lex r a -> Lex r b -> Lex r b
*> Lex w :: (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
$ \k :: b -> P r
k -> (a -> P r) -> P r
v (\_ -> (b -> P r) -> P r
w b -> P r
k)

instance Monad (Lex r) where
        Lex v :: (a -> P r) -> P r
v >>= :: Lex r a -> (a -> Lex r b) -> Lex r b
>>= f :: 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
$ \k :: b -> P r
k -> (a -> P r) -> P r
v (\a :: 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)
        >> :: Lex r a -> Lex r b -> Lex r b
(>>) = Lex r a -> Lex r b -> Lex r b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

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

-- Operations on this monad

getInput :: Lex r String
getInput :: 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
$ \cont :: String -> P r
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus r)
-> P r
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus r)
 -> P r)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus r)
-> P r
forall a b. (a -> b) -> a -> b
$ \r :: String
r -> P r
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus r
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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 :: Int -> Lex r ()
discard n :: 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
$ \cont :: () -> P r
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus r)
-> P r
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus r)
 -> P r)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus r)
-> P r
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x -> P r
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus r
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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 :: 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
$ \cont :: () -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \(_:r :: String
r) _x :: Int
_x y :: Int
y -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r 1 (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)

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

lexTab :: Lex a ()
lexTab :: 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
$ \cont :: () -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \(_:r :: String
r) x :: Int
x -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r (Int -> Int
nextTab Int
x)

nextTab :: Int -> Int
nextTab :: Int -> Int
nextTab x :: 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
-1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tAB_LENGTH)

tAB_LENGTH :: Int
tAB_LENGTH :: Int
tAB_LENGTH = 8

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

lexWhile :: (Char -> Bool) -> Lex a String
lexWhile :: (Char -> Bool) -> Lex a String
lexWhile p :: 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
$ \cont :: String -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x ->
        let (cs :: String
cs,rest :: 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
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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 (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 :: Lex a v -> Lex a (Lex a v)
alternative (Lex v :: (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
$ \cont :: Lex a v -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x y :: Int
y ->
        P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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
$ \cont' :: v -> P a
cont' -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \_r :: String
_r _x :: Int
_x _y :: Int
_y ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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 :: 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
$ \cont :: Bool -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x y :: Int
y loc :: SrcLoc
loc ->
                if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> 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
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (Bool -> P a
cont Bool
False) String
r Int
x Int
y SrcLoc
loc

setBOL :: Lex a ()
setBOL :: 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
$ \cont :: () -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r _ -> P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r 0

-- Set the loc to the current position

startToken :: Lex a ()
startToken :: 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
$ \cont :: () -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \s :: String
s x :: Int
x y :: Int
y _ stk :: [LexContext]
stk mode :: ParseMode
mode ->
        let loc :: SrcLoc
loc = SrcLoc :: String -> Int -> Int -> SrcLoc
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
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
s Int
x Int
y SrcLoc
loc [LexContext]
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 :: 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
$ \cont :: Ordering -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x y :: Int
y loc :: SrcLoc
loc stk :: [LexContext]
stk ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (Ordering -> P a
cont (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x ([LexContext] -> Int
indentOfParseState [LexContext]
stk))) String
r Int
x Int
y SrcLoc
loc [LexContext]
stk

pushContextL :: LexContext -> Lex a ()
pushContextL :: LexContext -> Lex a ()
pushContextL ctxt :: 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
$ \cont :: () -> P a
cont -> (String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
forall a.
(String
 -> Int
 -> Int
 -> SrcLoc
 -> [LexContext]
 -> ParseMode
 -> ParseStatus a)
-> P a
P ((String
  -> Int
  -> Int
  -> SrcLoc
  -> [LexContext]
  -> ParseMode
  -> ParseStatus a)
 -> P a)
-> (String
    -> Int
    -> Int
    -> SrcLoc
    -> [LexContext]
    -> ParseMode
    -> ParseStatus a)
-> P a
forall a b. (a -> b) -> a -> b
$ \r :: String
r x :: Int
x y :: Int
y loc :: SrcLoc
loc stk :: [LexContext]
stk ->
                P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
forall a.
P a
-> String
-> Int
-> Int
-> SrcLoc
-> [LexContext]
-> ParseMode
-> ParseStatus a
runP (() -> P a
cont ()) String
r Int
x Int
y SrcLoc
loc (LexContext
ctxtLexContext -> [LexContext] -> [LexContext]
forall a. a -> [a] -> [a]
:[LexContext]
stk)

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