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 !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 }
data ParsedLines = ParsedLines { plFull ∷ Seq Text
, plPartial ∷ Maybe Text
}
deriving (Typeable, Show)
type WithSt r = [String] → LineCol → LineCol → AccLines
→ [Text] → SavedInput → ParserStep r
newtype Parser α =
Parser { runParser ∷ ∀ r . (α → WithSt r)
→ (α → WithSt r)
→ (Error → WithSt r)
→ (Error → WithSt r)
→ WithSt r }
data ParserResult α = ParserSuccess { prLeftovers ∷ [Text]
, prLines ∷ ParsedLines
, prLoc ∷ LineCol
, prResult ∷ α
}
| ParserFailure { prLeftovers ∷ [Text]
, prLines ∷ ParsedLines
, prLoc ∷ LineCol
, prErrCtx ∷ [String]
, prErrMsg ∷ String
}
deriving (Typeable, Show)
data ParserStep α = ParserCont (Text → ParserStep α) (ParserResult α)
| ParserDone (ParserResult α)
startParser ∷ Parser α → ParserStep α
startParser = startParserAtLine 1 T.empty
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
starveParser ∷ ParserStep α → ParserResult α
starveParser (ParserCont _ r) = r
starveParser (ParserDone r) = r
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
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
instance Alternative Parser where
empty = Parser $ \_ _ h _ ctx pl nl →
h (Error nl ctx "Empty alternative") ctx pl nl
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
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
fail msg = Parser $ \_ _ h _ ctx pl nl →
h (Error nl ctx msg) ctx pl nl
instance MonadPlus Parser where
mzero = empty
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)
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
unexpected = fail . ("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
class CharParsing p ⇒ LocParsing p where
type ParserLoc p
location ∷ p (ParserLoc p)
default location ∷ (MonadTrans t, Monad m, LocParsing m, p ~ t m, ParserLoc p ~ ParserLoc m) ⇒ p (ParserLoc p)
location = lift location
located ∷ p α → p (Located (ParserLoc p) α)
spanned ∷ p α → p (Located (Span (ParserLoc p)) α)
class LocParsing p ⇒ ResetLineParsing p where
resetLineNr ∷ Word → p (Seq Text)
default resetLineNr ∷ (MonadTrans t, Monad m, ResetLineParsing m, p ~ t m) ⇒ Word → 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
located (Parser p) = Parser $ \c cc h ch ctx pl nl →
p (c . Located nl) (cc . Located nl) h ch ctx pl nl
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
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