text-lips-0.1: src/Text/Lips.hs
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
-- | Monadic parsing combinator library with attention to locations.
module Text.Lips
( ParsedLines(..)
, Parser
, ParserResult(..)
, ParserStep(..)
, startParser
, startParserAtLine
, starveParser
, parseText
, LocParsing(..)
, ResetLineParsing(..)
) where
import Data.Typeable (Typeable)
import Data.Monoid (Monoid(..))
import Data.Word (Word)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Unsafe as T
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
import Text.Loc
import Text.Parser.Combinators (Parsing(..))
import Text.Parser.Char (CharParsing(..))
import Control.Applicative
import Control.Monad (MonadPlus(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Identity (IdentityT(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
data SavedInput = SavedInput { siSave ∷ Text → SavedInput
, siLoad ∷ [Text] → [Text]
, siPop ∷ SavedInput }
doNotSave ∷ SavedInput
doNotSave = SavedInput { siSave = const doNotSave
, siLoad = id
, siPop = doNotSave }
save ∷ SavedInput → SavedInput
save = go []
where go is p = SavedInput { siSave = \i → go (i : is) (siSave p i)
, siLoad = (++ reverse is)
, siPop = p }
data Error = Error { errLoc ∷ LineCol
, errCtx ∷ [String]
, errMsg ∷ String }
data LastLine = LastLine Text {-# UNPACK #-} !Int
| NoLastLine
data AccLines = AccLines { lsLines ∷ Seq Text
, lsLastPre ∷ Text
, lsLast ∷ LastLine }
updateLines ∷ Text → Char → Bool → LineCol → AccLines
→ (LineCol → AccLines → α) → α
updateLines _ '\n' _ l ls cont = cont l' ls'
where
!l' = nextLine l
!ls' = case lsLast ls of
LastLine txt len →
AccLines { lsLines = lsLines ls |>
(lsLastPre ls `mappend`
T.take len txt)
, lsLastPre = T.empty
, lsLast = NoLastLine }
NoLastLine →
ls { lsLines = lsLines ls |> lsLastPre ls
, lsLastPre = T.empty }
updateLines i _ itIsNull l ls cont = cont l' ls'
where
!l' = nextCol l
!ls' = case lsLast ls of
LastLine txt len →
ls { lsLast = LastLine txt (len + 1) }
NoLastLine | itIsNull →
ls { lsLastPre = lsLastPre ls `mappend` i }
NoLastLine →
ls { lsLast = LastLine i 1 }
forceUpdateLines ∷ Text → Char → Bool → LineCol → AccLines
→ (LineCol → AccLines → α) → α
forceUpdateLines _ '\n' _ l ls cont = cont l' ls'
where !l' = nextLine l
!ls' = AccLines { lsLines = lsLines ls |> lsLastPre ls
, lsLastPre = T.empty
, lsLast = NoLastLine }
forceUpdateLines i _ itIsNull l ls cont = cont l' ls'
where !l' = nextCol l
!ls' | itIsNull = ls { lsLastPre = lsLastPre ls `mappend` i }
| otherwise = ls { lsLast = LastLine i 1 }
-- | Lines of text consumed by a parser (fully or partially).
data ParsedLines = ParsedLines { plFull ∷ Seq Text -- ^ Fully consumed lines
, plPartial ∷ Maybe Text
-- ^ Partially consumed line
}
deriving (Typeable, Show)
type WithSt r = [String] → LineCol → LineCol → AccLines
→ [Text] → SavedInput → ParserStep r
-- | Opaque parser type.
newtype Parser α =
Parser { runParser ∷ ∀ r . (α → WithSt r)
→ (α → WithSt r)
→ (Error → WithSt r)
→ (Error → WithSt r)
→ WithSt r }
-- | Parser result.
data ParserResult α = ParserSuccess { prLeftovers ∷ [Text] -- ^ Unparsed input
, prLines ∷ ParsedLines -- ^ Parsed input
, prLoc ∷ LineCol -- ^ Last location
, prResult ∷ α -- ^ Parsed value
}
| ParserFailure { prLeftovers ∷ [Text]
, prLines ∷ ParsedLines
, prLoc ∷ LineCol
, prErrCtx ∷ [String] -- ^ Error context
, prErrMsg ∷ String -- ^ Error message
}
deriving (Typeable, Show)
-- | Parser continuation.
data ParserStep α = ParserCont (Text → ParserStep α) (ParserResult α)
| ParserDone (ParserResult α)
-- | Start a parser.
startParser ∷ Parser α → ParserStep α
startParser = startParserAtLine 1 T.empty
-- | Start a parser on a specific line number and provide it with a first
-- chunk of the input.
startParserAtLine ∷ Word → Text → Parser α → ParserStep α
startParserAtLine ln₀ pre₀ (Parser p) =
p fc fc fh fh [] (LineCol ln₀ col₀) (LineCol ln₀ (col₀ + 1))
lines₀ [] doNotSave
where fc a _ _ nl ls is si =
ParserDone (ParserSuccess { prLeftovers = lo
, prLines = ls'
, prLoc = nl
, prResult = a })
where lo = siLoad si is
ls' = calcLines lo ls
fh e _ _ _ ls is si =
ParserDone (ParserFailure { prLeftovers = lo
, prLines = ls'
, prLoc = errLoc e
, prErrCtx = reverse (errCtx e)
, prErrMsg = errMsg e })
where lo = siLoad si is
ls' = calcLines lo ls
col₀ = fromIntegral (T.length pre₀)
lines₀ = AccLines { lsLines = Seq.empty
, lsLastPre = pre₀
, lsLast = NoLastLine }
calcLines lo (AccLines {..}) = go [] lo
where lastLine = case lsLast of
LastLine txt len → lsLastPre `mappend`
T.take len txt
NoLastLine → lsLastPre
go acc [] = ParsedLines lsLines
$ Just
$ mconcat
$ reverse (lastLine : acc)
go acc (h : t) | (h₁, h₂) ← T.break (== '\n') h
, not (T.null h₂)
, line ← mconcat
$ reverse
$ h₁ : lastLine : acc
= ParsedLines (lsLines |> line) Nothing
| otherwise
= go (h : acc) t
-- | Feed a parser continuation with empty input.
starveParser ∷ ParserStep α → ParserResult α
starveParser (ParserCont _ r) = r
starveParser (ParserDone r) = r
-- | Run a parser on a text.
parseText ∷ Text → Parser α → ParserResult α
parseText t p = case startParser p of
ParserCont c _ → starveParser (c t)
ParserDone r → r
instance Functor Parser where
fmap f (Parser p) = Parser $ \c cc → p (c . f) (cc . f)
instance Applicative Parser where
pure a = Parser $ \c _ _ _ → c a
{-# INLINE pure #-}
Parser p₁ <*> Parser p₂ = Parser $ \c cc h ch →
p₁ (\f → p₂ (c . f) (cc . f) h ch) (\f → p₂ (cc . f) (cc . f) ch ch) h ch
{-# INLINE (<*>) #-}
instance Alternative Parser where
empty = Parser $ \_ _ h _ ctx pl nl →
h (Error nl ctx "Empty alternative") ctx pl nl
{-# INLINE empty #-}
Parser p₁ <|> Parser p₂ =
Parser $ \c cc h ch ctx pl nl ls →
p₁ c cc (\_ _ _ _ _ → p₂ c cc h ch ctx pl nl ls) ch ctx pl nl ls
instance Monad Parser where
return = pure
{-# INLINE return #-}
Parser p >>= f = Parser $ \c cc h ch →
p (\a → runParser (f a) c cc h ch) (\a → runParser (f a) cc cc ch ch) h ch
{-# INLINE (>>=) #-}
fail msg = Parser $ \_ _ h _ ctx pl nl →
h (Error nl ctx msg) ctx pl nl
{-# INLINE fail #-}
instance MonadPlus Parser where
mzero = empty
{-# INLINE mzero #-}
mplus = (<|>)
{-# INLINE mplus #-}
instance Parsing Parser where
try (Parser p) =
Parser $ \c cc h _ ctx pl nl ls is si →
p (\a ctx' pl' nl' ls' is' si' → c a ctx' pl' nl' ls' is' (siPop si'))
(\a ctx' pl' nl' ls' is' si' → cc a ctx' pl' nl' ls' is' (siPop si'))
(\e _ _ _ _ _ si' → h e ctx pl nl ls
(siLoad si' is) (siPop si'))
(\e _ _ _ _ _ si' → h e ctx pl nl ls
(siLoad si' is) (siPop si'))
ctx pl nl ls is (save si)
Parser p <?> label = Parser $ \c cc h ch ctx →
p (\a _ → c a ctx) (\a _ → cc a ctx)
(\e _ → h e ctx) (\e _ → ch e ctx)
(label : ctx)
{-# INLINE (<?>) #-}
skipMany p = Parser $ \c cc h ch ctx pl nl ls →
runParser p (\_ → runParser (skipMany p) c cc h ch)
(\_ → runParser (skipMany p) cc cc ch ch)
(\_ _ _ _ _ → c () ctx pl nl ls)
ch ctx pl nl ls
skipSome p = Parser $ \c cc h ch →
runParser p (\_ → runParser (skipMany p) c cc h ch)
(\_ → runParser (skipMany p) cc cc ch ch)
h ch
{-# INLINE skipSome #-}
unexpected = fail . ("Unexpected " ++)
{-# INLINE unexpected #-}
notFollowedBy (Parser p) = Parser $ \c _ h _ ctx pl nl ls is si →
p (\a _ _ _ _ _ si' → h (Error nl ctx ("Unexpected " ++ show a))
ctx pl nl ls (siLoad si' is) (siPop si'))
(\a _ _ _ _ _ si' → h (Error nl ctx ("Unexpected " ++ show a))
ctx pl nl ls (siLoad si' is) (siPop si'))
(\_ _ _ _ _ _ si' → c () ctx pl nl ls (siLoad si' is) (siPop si'))
(\_ _ _ _ _ _ si' → c () ctx pl nl ls (siLoad si' is) (siPop si'))
ctx pl nl ls is (save si)
eof = Parser $ \c _ h _ ctx pl nl ls is si →
let go = ParserCont
(\i → if T.null i
then go
else h (Error nl ctx "End of input expected")
ctx pl nl ls [i] (siSave si i))
(starveParser $ c () ctx pl nl ls is si) in
if null is
then go
else h (Error nl ctx "End of input expected")
ctx pl nl ls is si
instance CharParsing Parser where
satisfy p = Parser $ \_ cc h _ ctx pl nl ls is si →
case is of
i : tl | !ih ← T.unsafeHead i, p ih
, !it ← T.unsafeTail i, !itIsNull ← T.null it
→ updateLines i ih itIsNull nl ls $ \nl' ls' →
cc ih ctx nl nl' ls'
(if itIsNull then tl else it : tl) si
_ : _ → h (Error nl ctx "Unexpected input") ctx pl nl ls is si
[] → go
where
go = ParserCont
(\i → case T.uncons i of
Just (!ih, it) | p ih, !itIsNull ← T.null it →
forceUpdateLines i ih itIsNull nl ls $ \nl' ls' →
cc ih ctx nl nl' ls'
(if itIsNull then [] else [it])
(siSave si i)
Just _ → h (Error nl ctx "Unexpected input")
ctx pl nl ls [i] (siSave si i)
Nothing → go)
(starveParser $ h (Error nl ctx "Unexpected end of input")
ctx pl nl ls [] si)
char c = satisfy (== c) <?> ("A " ++ show c)
notChar c = satisfy (/= c) <?> ("Not a " ++ show c)
anyChar = Parser $ \_ cc h _ ctx pl nl ls is si →
let ctx' = "Any character" : ctx in
case is of
i : tl | !ih ← T.unsafeHead i
, !it ← T.unsafeTail i , !itIsNull ← T.null it
→ updateLines i ih itIsNull nl ls $ \nl' ls' →
cc ih ctx' nl nl' ls'
(if itIsNull then tl else it : tl) si
[] → go
where
go = ParserCont
(\i → case T.uncons i of
Just (!ih, it) | !itIsNull ← T.null it →
forceUpdateLines i ih itIsNull nl ls $ \nl' ls' →
cc ih ctx' nl nl' ls'
(if itIsNull then [] else [it])
(siSave si i)
Nothing → go)
(starveParser $ h (Error nl ctx' "Unexpected end of input")
ctx' pl nl ls [] si)
instance α ~ String ⇒ IsString (Parser α) where
fromString = string
{-# INLINE fromString #-}
-- | Parsers that provide location information.
class CharParsing p ⇒ LocParsing p where
-- | Parser location type.
type ParserLoc p
-- | The current location.
location ∷ p (ParserLoc p)
default location ∷ (MonadTrans t, Monad p) ⇒ t p (ParserLoc p)
location = lift location
-- | Attach the starting location to the parsed value.
located ∷ p α → p (Located (ParserLoc p) α)
-- | Attach the spanned location to the parsed value.
spanned ∷ p α → p (Located (Span (ParserLoc p)) α)
-- | Parsers with resettable line numbers.
class LocParsing p ⇒ ResetLineParsing p where
-- | Reset the current line number and return the text lines fully consumed
-- by the parser so far.
resetLineNr ∷ Word → p (Seq Text)
default resetLineNr ∷ (MonadTrans t, Monad p) ⇒ Word → t p (Seq Text)
resetLineNr = lift . resetLineNr
instance LocParsing Parser where
type ParserLoc Parser = LineCol
location = Parser $ \c _ _ _ ctx pl nl → c nl ctx pl nl
{-# INLINE location #-}
located (Parser p) = Parser $ \c cc h ch ctx pl nl →
p (c . Located nl) (cc . Located nl) h ch ctx pl nl
{-# INLINE located #-}
spanned (Parser p) = Parser $ \c cc h ch ctx pl nl →
p (\a ctx' pl' → c (Located (Span nl (max nl pl')) a) ctx' pl')
(\a ctx' pl' → cc (Located (Span nl (max nl pl')) a) ctx' pl')
h ch ctx pl nl
{-# INLINABLE spanned #-}
instance ResetLineParsing Parser where
resetLineNr ln =
Parser $ \c _ _ _ ctx _ nl ls@(AccLines {..}) →
let col = locCol nl in
c lsLines ctx (LineCol ln (col - 1)) (LineCol ln col)
(ls { lsLines = Seq.empty })
instance (MonadPlus p, LocParsing p) ⇒ LocParsing (IdentityT p) where
type ParserLoc (IdentityT p) = ParserLoc p
located (IdentityT p) = IdentityT $ located p
spanned (IdentityT p) = IdentityT $ spanned p
instance (MonadPlus p, ResetLineParsing p) ⇒ ResetLineParsing (IdentityT p) where
instance (MonadPlus p, LocParsing p) ⇒ LocParsing (ReaderT r p) where
type ParserLoc (ReaderT r p) = ParserLoc p
located (ReaderT p) = ReaderT $ located . p
spanned (ReaderT p) = ReaderT $ spanned . p
instance (MonadPlus p, ResetLineParsing p) ⇒ ResetLineParsing (ReaderT r p) where
instance (Monoid w, MonadPlus p, LocParsing p)
⇒ LocParsing (Lazy.WriterT w p) where
type ParserLoc (Lazy.WriterT w p) = ParserLoc p
located (Lazy.WriterT p) = Lazy.WriterT $ do
Located l (a, w) ← located p
return (Located l a, w)
spanned (Lazy.WriterT p) = Lazy.WriterT $ do
Located l (a, w) ← spanned p
return (Located l a, w)
instance (Monoid w, MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Lazy.WriterT w p) where
instance (Monoid w, MonadPlus p, LocParsing p)
⇒ LocParsing (Strict.WriterT w p) where
type ParserLoc (Strict.WriterT w p) = ParserLoc p
located (Strict.WriterT p) = Strict.WriterT $ do
Located l (a, w) ← located p
return (Located l a, w)
spanned (Strict.WriterT p) = Strict.WriterT $ do
Located l (a, w) ← spanned p
return (Located l a, w)
instance (Monoid w, MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Strict.WriterT w p) where
instance (MonadPlus p, LocParsing p) ⇒ LocParsing (Lazy.StateT s p) where
type ParserLoc (Lazy.StateT s p) = ParserLoc p
located (Lazy.StateT p) = Lazy.StateT $ \s → do
Located l (a, s') ← located (p s)
return (Located l a, s')
spanned (Lazy.StateT p) = Lazy.StateT $ \s → do
Located l (a, s') ← spanned (p s)
return (Located l a, s')
instance (MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Lazy.StateT s p) where
instance (MonadPlus p, LocParsing p) ⇒ LocParsing (Strict.StateT s p) where
type ParserLoc (Strict.StateT s p) = ParserLoc p
located (Strict.StateT p) = Strict.StateT $ \s → do
Located l (a, s') ← located (p s)
return (Located l a, s')
spanned (Strict.StateT p) = Strict.StateT $ \s → do
Located l (a, s') ← spanned (p s)
return (Located l a, s')
instance (MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Strict.StateT s p) where
instance (Monoid w, MonadPlus p, LocParsing p)
⇒ LocParsing (Lazy.RWST r w s p) where
type ParserLoc (Lazy.RWST r w s p) = ParserLoc p
located (Lazy.RWST p) = Lazy.RWST $ \r s → do
Located l (a, w, s') ← located (p r s)
return (Located l a, w, s')
spanned (Lazy.RWST p) = Lazy.RWST $ \r s → do
Located l (a, w, s') ← spanned (p r s)
return (Located l a, w, s')
instance (Monoid w, MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Lazy.RWST r w s p) where
instance (Monoid w, MonadPlus p, LocParsing p)
⇒ LocParsing (Strict.RWST r w s p) where
type ParserLoc (Strict.RWST r w s p) = ParserLoc p
located (Strict.RWST p) = Strict.RWST $ \r s → do
Located l (a, w, s') ← located (p r s)
return (Located l a, w, s')
spanned (Strict.RWST p) = Strict.RWST $ \r s → do
Located l (a, w, s') ← spanned (p r s)
return (Located l a, w, s')
instance (Monoid w, MonadPlus p, ResetLineParsing p)
⇒ ResetLineParsing (Strict.RWST r w s p) where