Prim.hs

{-# LANGUAGE FlexibleContexts #-}
{-|

In general, an indentation structure is a predicate on the position
which tells us whether the token is acceptable or not. Besides the
predicate to check if a token at a given position is acceptable, we
also need to specify how indentations can be nested. This is captured
by the type class `Indentation`.

-}

module Text.Parsec.IndentParsec.Prim
       ( Indentation(..)
       , GenIndentParsecT
       , tokeniser
       , nest
       , neglectIndent
       , HaskellLike(..)
       -- * Running parsers
       , runGIPT', runGIPT
       -- * Some convenient type aliases.
       , IndentT
       , GenIndentParsec
       , IndentParsecT
       , IndentParsec
       ) where

import Control.Monad.State
import Control.Monad.Identity

import Text.Parsec.Prim
import Text.Parsec.Error
import Text.Parsec.Pos
import Text.Parsec.Combinator

{-|

Type class that captures generic indentation rule. It should follow
the condition that @`acceptable` `never` = `const` `False`@.

-}

class Indentation i where
      never      :: i  -- ^ an indentation state where no tokens are
                       -- accepted.
      always     :: i  -- ^ an indentation that will always accept
                       -- tokens.
      acceptable :: i -> SourcePos -> Bool -- ^ Check if the current
                                           -- position is acceptable.
      nestableIn :: i -- ^ Inner indentation.
                 -> i -- ^ Outer indentation.
                 -> Bool -- ^ True if the inner indentation can nest
                         -- inside the outer indentations.

-- | The inner monad for indent parsers.
type IndentT i m = StateT i m

-- | The indentation parser.
type GenIndentParsecT i s u m a = ParsecT s u (IndentT i m) a

-- | Build indentation awareness into the parser
tokeniser :: (Indentation i, Monad m)
             => GenIndentParsecT i s u m a
             -> GenIndentParsecT i s u m a
tokeniser p = do pos <- getPosition
                 i   <- lift get
                 if acceptable i pos then p
                    else fail $ "unexpected token at " ++ show pos

{-|

Any nested indentation starts at a position. Given an indentor
function, i.e. a function to compute the indentation state from the
current position, and a parser to parse the body of the indentation,
runs the parser inside the nested indentation context given by the
indentor.

-}

nest :: (Indentation i, Show i, Monad m, Stream s (IndentT i m) t, Show t)
     => (SourcePos -> i) -- ^ indentor function.
     -> GenIndentParsecT i s u m body -- ^ The nested parser to run
     -> GenIndentParsecT i s u m body
nest indentor p = do outerI <- lift get
                     curPos <- getPosition
                     let innerI = indentor curPos
                         in if innerI `nestableIn` outerI
                            then nestP innerI outerI p
                            else nestP never  outerI p

nestP :: (Indentation i, Show i, Monad m, Stream s (IndentT i m) t, Show t)
      => i -- ^ Inner indentation
      -> i -- ^ Outer indentation
      -> GenIndentParsecT i s u m body -- ^ body parser
      -> GenIndentParsecT i s u m body

nestP i o p = do lift $ put i
                 x <- p
                 notFollowedBy (tokeniser anyToken)
                               <?> "unterminated " ++ show i
                 lift $ put o
                 return x

-- | run a given parser neglecting indentation.
neglectIndent :: (Monad m, Show t, Show i, Indentation i,
                        Stream s (IndentT i m) t)
              => GenIndentParsecT i s u m a
              -> GenIndentParsecT i s u m a

neglectIndent p = do o <- get
                     lift $ put always
                     x <- p
                     lift $ put o
                     return x

-- | Run a given indentation aware parser with a starting indentation.
runGIPT' :: (Monad m, Stream s (IndentT i m) t)
         => i                          -- ^ The starting indentation,
         -> GenIndentParsecT i s u m a -- ^ The parser to run,
         -> u                          -- ^ The user state,
         -> SourceName                 -- ^ Name of the input source,
         -> s                          -- ^ The actual stream,
         -> m (Either ParseError a)    -- ^ The result

runGIPT' i p u sname s = evalStateT (runPT p u sname s) i

-- | Same as @`runGIPT'` always@.
runGIPT :: (Monad m, Indentation i, Stream s (IndentT i m) t)
        => GenIndentParsecT i s u m a -- ^ The parser to run,
        -> u                          -- ^ The user state,
        -> SourceName                 -- ^ Name of the input source,
        -> s                          -- ^ The actual stream,
        -> m (Either ParseError a)    -- ^ The result.

runGIPT  = runGIPT' always

{-|

Type to capture Haskell like indentation. Besides `always` and `never`
the important indentations are blocks and line folds. A block starting
at position @p@ consists of all tokens that have indentation at least
as much as @p@. A folded like starting at position @p@ is

-}
data HaskellLike   = Never
                   | Neglect
                   | Block SourcePos
                   | LineFold SourcePos

instance Indentation HaskellLike where
         never  = Never
         always = Neglect

         acceptable Never          _ = False
         acceptable Neglect        _ = True
         acceptable (Block bp)     p = sourceColumn bp <= sourceColumn p
         acceptable (LineFold lp)  p = sourceColumn lp < sourceColumn p ||
                                            lp == p
         nestableIn (Block i)    (Block o)    = sourceColumn o < sourceColumn i
         nestableIn (Block i)    (LineFold o) = sourceColumn o < sourceColumn i
         nestableIn (LineFold i) (LineFold o) = sourceColumn o < sourceColumn i
         nestableIn (LineFold i) (Block o)    = sourceColumn o <= sourceColumn i
         nestableIn _            _            = True

instance Show HaskellLike where
         show Never   = "empty block"
         show Neglect = "unindented chunk"
         show (Block pos)    = "block started at " ++ show pos
         show (LineFold pos) = "line fold started at " ++ show pos

type GenIndentParsec i s u a = GenIndentParsecT i s u Identity a
type IndentParsecT s u m a = GenIndentParsecT HaskellLike s u m a
type IndentParsec  s u a   = IndentParsecT s u Identity a