module Text.Luthor.Indent (
ParsecIT, ParsecI, IndentState
, IndentPolicy(..)
, runParserIT, runParserI, runPIT, runPI
, plusBlankline
, indent, nextline, dedent
, dedent'
, startIndent, endIndent
, isIndentEnabled
, getIndentDepth
, withIndentation, withoutIndentation
, getState, putState, modifyState
, peekIndentation, popIndentation, pushIndentation
, module Text.Parsec.Prim
, ParseError, errorPos
, SourcePos
, SourceName, Line, Column
, sourceName, sourceLine, sourceColumn
) where
import Text.Parsec.Prim hiding (lookAhead, getState, putState, modifyState, many)
import Control.Monad
import Control.Monad.Identity
import Text.Luthor hiding (getState, putState, modifyState)
import Text.Luthor.Syntax
import qualified Text.Parsec.Prim as P
data IndentState s u m = IS { _policy :: IndentPolicy
, _depth :: [Int]
, _enabled :: Bool
, _ws :: ParsecIT s u m ()
}
startIndent :: (Stream s m Char) => IndentPolicy -> [ParsecIT s u m ()] -> IndentState s u m
startIndent policy ws = IS policy [0] True (plusBlankline ws)
endIndent :: (Stream s m Char) => ParsecIT s u m ()
endIndent = do
s <- snd <$> P.getState
unless (_enabled s || null (_depth s) || _depth s == [0]) $
dedent *> endIndent
type ParsecIT s u m = ParsecT s (u, IndentState s u m) m
type ParsecI s u = Parsec s (u, IndentState s u Identity)
runParserIT :: Stream s m Char
=> ParsecIT s u m a
-> IndentPolicy
-> [ParsecIT s u m ()]
-> u
-> SourceName
-> s
-> m (Either ParseError a)
runParserIT p policy ws u = runParserT p (u, startIndent policy ws)
runParserI :: Stream s Identity Char
=> ParsecI s u a
-> IndentPolicy
-> [ParsecI s u ()]
-> u
-> SourceName
-> s
-> Either ParseError a
runParserI p policy ws u = runParser p (u, startIndent policy ws)
runPIT :: Stream s m Char
=> ParsecIT s u m a
-> IndentPolicy -> [ParsecIT s u m ()]
-> u -> SourceName -> s -> m (Either ParseError a)
runPIT = runParserIT
runPI :: Stream s Identity Char
=> ParsecI s u a
-> IndentPolicy -> [ParsecI s u ()]
-> u -> SourceName -> s -> Either ParseError a
runPI = runParserI
indent :: (Stream s m Char) => ParsecIT s u m ()
indent = expect "indent" . try $ do
(n, policy) <- _prepForDentation
n' <- dentation policy
case n' `compare` n of
LT -> unexpected "dedent"
EQ -> unexpected "nextline"
GT -> return ()
(u, s) <- P.getState
let s' = s { _depth = n' : _depth s }
P.putState (u, s')
nextline :: (Stream s m Char) => ParsecIT s u m ()
nextline = expect "nextline" . try $ do
(n, policy) <- _prepForDentation
n' <- dentation policy
case n' `compare` n of
LT -> unexpected "dedent"
EQ -> return ()
GT -> unexpected "indent"
dedent :: (Stream s m Char) => ParsecIT s u m ()
dedent = expect "dedent" . try $ do
(n, policy) <- _prepForDentation
n' <- lookAhead $ dentation policy
case n' `compare` n of
LT -> return ()
EQ -> unexpected "nextline"
GT -> unexpected "indent"
(u, s) <- P.getState
let depth' = tail $ _depth s
s' = s { _depth = depth' }
when (n' `notElem` depth') $ fail "dedent has no corresponding indent"
P.putState (u, s')
_prepForDentation :: (Stream s m Char) => ParsecIT s u m (Int, IndentPolicy)
_prepForDentation = do
() <- _ws =<< snd <$> P.getState
n <- getIndentDepth
policy <- _policy . snd <$> P.getState
return (n, policy)
dedent' :: (Stream s m Char) => ParsecIT s u m ()
dedent' = dedent <* optional_ nextline
isIndentEnabled :: (Stream s m t) => ParsecIT s u m Bool
isIndentEnabled = _enabled . snd <$> P.getState
getIndentDepth :: (Stream s m t) => ParsecIT s u m Int
getIndentDepth = do
s <- snd <$> P.getState
unless (_enabled s) (fail "indentation disabled")
let stack = _depth s
if null stack
then fail "empty indent depth stack"
else return (head stack)
withIndentation :: (Stream s m t) => ParsecIT s u m a -> ParsecIT s u m a
withIndentation = _withIndentationSet True
withoutIndentation :: (Stream s m t) => ParsecIT s u m a -> ParsecIT s u m a
withoutIndentation = _withIndentationSet False
_withIndentationSet yn p = do
(u, s) <- P.getState
let enabled0 = _enabled s
s' = s { _enabled = yn }
try $ do
P.putState (u, s')
result <- p
(u, s) <- P.getState
let s' = s { _enabled = enabled0 }
P.putState (u, s')
return result
plusBlankline :: (Stream s m Char) => [ParsecIT s u m ()] -> ParsecIT s u m ()
plusBlankline ps = manyOf_ $ ps ++ [blankline]
where
blankline = expect "" . try $ newline *> manyOf ps *> lookAhead lineBreak
getState :: (Monad m) => ParsecIT s u m u
getState = fst <$> P.getState
putState :: (Monad m) => u -> ParsecIT s u m ()
putState x = void $ P.updateParserState $
\s@State {stateUser = (_, i)} -> s { stateUser = (x, i) }
modifyState :: (Monad m) => (u -> u) -> ParsecIT s u m ()
modifyState f = void $ P.updateParserState $
\s@State {stateUser = (u, i)} -> s { stateUser = (f u, i) }
peekIndentation :: (Monad m) => ParsecIT s u m Int
peekIndentation = do
stack <- _depth . snd <$> P.getState
when (null stack) $ fail "empty indent depth stack"
return $ head stack
popIndentation :: (Monad m) => ParsecIT s u m Int
popIndentation = do
(u, s) <- P.getState
let stack = _depth s
when (null stack) $ fail "empty indent depth stack"
P.putState (u, s { _depth = tail stack })
return $ head stack
pushIndentation :: (Monad m) => Int -> ParsecIT s u m ()
pushIndentation n = do
(u, s) <- P.getState
let stack = _depth s
P.putState (u, s { _depth = n:stack })