{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, TupleSections #-}
{-# OPTIONS -Wall #-}
module Text.Parsec.Indentation (module Text.Parsec.Indentation, I.IndentationRel(..), Indentation, infIndentation) where
-- Implements "Indentation Senstivie Parising: Landin Revisited"
--
-- Primary functions are:
-- - 'localIndent':
-- - 'absoluteIndent':
-- - 'localTokenMode':
--
-- Primary driver functions are:
-- - TODO
-- TODO:
-- Grace style indentation stream
import Control.Monad
--import Text.Parsec.Prim
import Text.Parsec.Prim (ParsecT, mkPT, runParsecT,
Stream(..), Consumed(..), Reply(..),
State(..), getInput, setInput)
import Text.Parsec.Error (Message (Message), addErrorMessage)
import Text.Parser.Indentation.Implementation as I
------------------------
-- Indentable Stream
------------------------
data IndentStream s = IndentStream { indentationState :: !IndentationState, tokenStream :: !s } deriving (Show)
--data IndentationToken t = IndentationToken !t | InvalidIndentation String
type IndentationToken t = t
{-# INLINE mkIndentStream #-}
mkIndentStream :: Indentation -> Indentation -> Bool -> IndentationRel -> s -> IndentStream s
mkIndentStream lo hi mode rel s = IndentStream (mkIndentationState lo hi mode rel) s
instance (Monad m, Stream s m (t, Indentation)) => Stream (IndentStream s) m (IndentationToken t) where
uncons (IndentStream is s) = do
x <- uncons s
case x of
Nothing -> return Nothing
Just ((t, i), s') -> return $ updateIndentation is i ok err where
ok is' = Just ({-IndentationToken-} t, IndentStream is' s')
err _ = Nothing --(InvalidIndentation msg, IndentStream is s)
-- HACK: Sigh! We have no way to properly signal the
-- sort of failure that occurs here. We would do 'fail
-- "Invalid indentation. "++msg', but that triggers a
-- non-backtracking error. 'return Nothing' will make
-- Parsec think the stream is empty (which is wrong),
-- but at least it is a backtracking error. The
-- fundamental problem is that 'm' *not* ParsecT (where
-- we could signal a parsing error) but is whatever
-- monad 'm' happens to be the argument to ParsecT.
{-# INLINE localState #-}
localState :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a)
localState pre post m = do
IndentStream is s <- getInput
setInput (IndentStream (pre is) s)
x <- m
IndentStream is' s' <- getInput
setInput (IndentStream (post is is') s')
return x
{-# INLINE localStateUnlessAbsMode #-}
localStateUnlessAbsMode :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a)
localStateUnlessAbsMode pre post m = do
a <- liftM (indentationStateAbsMode . indentationState) getInput
if a then m else localState pre post m
------------------------
-- Operations
------------------------
{-# INLINE localTokenMode #-}
localTokenMode :: (Monad m) => (IndentationRel -> IndentationRel) -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
localTokenMode = I.localTokenMode localState
{-# INLINE localIndentation #-}
localIndentation :: (Monad m) => IndentationRel -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
localIndentation = I.localIndentation localStateUnlessAbsMode
{-# INLINE absoluteIndentation #-}
absoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
absoluteIndentation = I.absoluteIndentation localState
-- post _ i2 = when (absMode i2) (fail "absoluteIndent: no tokens consumed") >>
{-# INLINE ignoreAbsoluteIndentation #-}
ignoreAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
ignoreAbsoluteIndentation = I.ignoreAbsoluteIndentation localState
{-# INLINE localAbsoluteIndentation #-}
localAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
localAbsoluteIndentation = I.localAbsoluteIndentation localState
------------------------
-- Indent Stream Impls
------------------------
streamToList :: (Monad m, Stream s m t) => s -> m [t]
streamToList s = do
x <- uncons s
case x of
Nothing -> return []
Just (c, s') -> do s'' <- streamToList s'
return (c : s'')
----------------
-- SourcePos
{-
mkSourcePosIndentStream s = SourcePosIndentStream s
newtype SourcePosIndentStream s = SourcePosIndentStream s
instance (Stream s m t) => Stream (SourcePosIndentStream s) m (Indent, t) where
uncons (SourcePosIndentStream s) = do
col <- liftM sourceColumn $ getPosition
x <- uncons s
case x of
Nothing -> return Nothing
Just x -> return (Just ((col, x), SourcePosIndentStream s))
-}
----------------
-- TODO: parser based on first non-whitespace char
----------------
-- First token of line indents
----------------
-- Based on Indents
-- Note that if 'p' consumes input but is at the wrong indentation, then
-- 'indentStreamParser p' signals an error but does *not* consume input.
-- This allows Parsec primitives like 'string' to be properly backtracked.
{-# INLINE indentStreamParser #-}
indentStreamParser :: (Monad m) => ParsecT s u m (t, Indentation) -> ParsecT (IndentStream s) u m (IndentationToken t)
indentStreamParser p = mkPT $ \state ->
let IndentStream is s = stateInput state
go f (Ok (a, i) state' e) = updateIndentation is i ok err where
ok is' = return $ f $ return (Ok ({-IndentationToken-} a) (state' {stateInput = IndentStream is' (stateInput state') }) e)
err msg = return $ Empty $ return $ Error (Message ("Invalid indentation. "++msg++show ((stateInput state) { tokenStream = ""})) `addErrorMessage` e)
go f (Error e) = return $ f $ return (Error e)
in runParsecT p (state { stateInput = s }) >>= consumed (go Consumed) (go Empty)
{-# INLINE consumed #-}
consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b
consumed c _ (Consumed m) = m >>= c
consumed _ e (Empty m) = m >>= e
-- lifting operator
-- token, tokens, tokenPrim, tokenPrimEx ???
-- whiteSpace
-- ByteString
-- ByteString.Lazy
-- Text
{-
delimitedLayout :: Stream (IndentStream s) m t =>
ParsecT (IndentStream s) u m open -> Bool ->
ParsecT (IndentStream s) u m close -> Bool ->
ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
delimitedLayout open openAny close closeAny body = between open' close' (localIndent (Const 0) body) where
open' | openAny = localIndent (Const 0) open
| otherwise = open
close' | closeAny = localIndent (Const 0) close
| otherwise = close
indentedLayout :: Stream (IndentStream s) m t =>
(Maybe (ParsecT (IndentStream s) u m sep)) ->
ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m [a]
indentedLayout (Nothing ) clause = localIndent Gt $ many $ absoluteIndent $ clause
indentedLayout (Just sep) clause = liftM concat $ localIndent Gt $ many $ absoluteIndent $ sepBy1 clause sep
-}
{-
layout p = delimitedLayout (symbol "{") False (symbol "}") True (semiSep p)
<|> indentedLayout (Just semi) p
identifier pred = liftM fromString $ try $ identifier >>= \x -> guard (pred x) >> return x
operator pred = liftM fromString $ try $ operator >>= \x -> guard (pred x) >> return x
reserved name = (if name `elem` middleKeywords then localFirstTokenMode (const Ge) else id) $ reserved name
Numbers, Integers and Naturals are custom
dotSep
dotSep1
-}
{-
test :: String
test = foo where
foo = "abc \
\def" ++ ""
test2 :: Int
test2 = foo where
foo = let { x = 1;
} in x
--- All code indented?
foo = 3
bar = 4
-}