text-lips (empty) → 0.1
raw patch · 4 files changed
+530/−0 lines, 4 filesdep +basedep +containersdep +parserssetup-changed
Dependencies added: base, containers, parsers, text, text-loc, transformers
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- src/Text/Lips.hs +466/−0
- text-lips.cabal +35/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014-2016 Mikhail Vorozhtsov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/Lips.hs view
@@ -0,0 +1,466 @@+{-# 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
+ text-lips.cabal view
@@ -0,0 +1,35 @@+Name: text-lips+Version: 0.1+Category: Text, Parsing+Stability: experimental+Synopsis: Monadic parsing combinator library with attention to locations+Description:+ Monadic parsing combinator library with attention to locations.++Homepage: https://github.com/mvv/text-lips+Bug-Reports: https://github.com/mvv/text-lips/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2014-2016 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Cabal-Version: >= 1.6.0+Build-Type: Simple++Source-Repository head+ Type: git+ Location: https://github.com/mvv/text-lips.git++Library+ Build-Depends: base >= 4 && < 5+ , text >= 0.10+ , text-loc >= 0.1+ , containers >= 0.5+ , parsers >= 0.5+ , transformers >= 0.3+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules:+ Text.Lips