packages feed

regex-applicative (empty) → 0.1

raw patch · 10 files changed

+513/−0 lines, 10 filesdep +basedep +containerssetup-changed

Dependencies added: base, containers

Files

+ CREDITS.md view
@@ -0,0 +1,4 @@+The implementation is heavily based on the ideas from ["A Play on Regular+Expressions"][play] by Sebastian Fischer, Frank Huch and Thomas Wilke.++[play]: http://sebfisch.github.com/haskell-regexp/regexp-play.pdf
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2011 Roman Cheplyaka++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,4 @@+regex-applicative+=================++*regex-applicative* is a Haskell library for parsing using regular expressions.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Regex/Applicative.hs view
@@ -0,0 +1,23 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.Regex.Applicative+-- Copyright : (c) Roman Cheplyaka+-- License   : MIT+--+-- Maintainer: Roman Cheplyaka <roma@ro-che.info>+-- Stability : experimental+--+--------------------------------------------------------------------++module Text.Regex.Applicative+    ( RE+    , sym+    , psym+    , anySym+    , reFoldl+    , (=~)+    , module Control.Applicative+    )+    where+import Text.Regex.Applicative.Interface+import Control.Applicative
+ Text/Regex/Applicative/Implementation.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE GADTs, TupleSections, DeriveFunctor #-}+module Text.Regex.Applicative.Implementation where+import Control.Applicative hiding (empty)+import qualified Control.Applicative as Applicative+import Data.List+import qualified Data.Sequence as Sequence++-- | An applicative functor similar to Maybe, but it's '<|>' method honors+-- priority.+data Priority a = Priority { priority :: !PrSeq, pValue :: a } | Fail+    deriving Functor+type PrSeq = Sequence.Seq PrNum+type PrNum = Int++instance Applicative Priority where+    pure x = Priority Sequence.empty x+    Priority p1 f <*> Priority p2 x = Priority (p1 Sequence.>< p2) (f x)+    _ <*> _ = Fail++instance Alternative Priority where+    empty = Fail+    p@Priority {} <|> Fail = p+    Fail <|> p@Priority {} = p+    Fail <|> Fail = Fail+    p1@Priority {} <|> p2@Priority {} =+        case compare (priority p1) (priority p2) of+            LT -> p2+            GT -> p1+            EQ -> error $+                "Two priorities are the same! Should not happen.\n" ++ show (priority p1)+++-- Adds priority to the end+withPriority :: PrNum -> Priority a -> Priority a+withPriority p (Priority ps x) = Priority (ps Sequence.|> p) x+withPriority _ Fail = Fail++-- Overwrite the priority+--setPriority :: PrSeq -> Priority a -> Priority a++-- Discards priority information+priorityToMaybe :: Priority a -> Maybe a+priorityToMaybe p =+    case p of+        Priority { pValue = x } -> Just x+        Fail -> Nothing++data Regexp s r a where+    Eps :: Regexp s r a+    Symbol :: (s -> Bool) -> Regexp s r s+    Alt :: RegexpNode s r a -> RegexpNode s r a -> Regexp s r a+    App :: RegexpNode s (a -> r) (a -> b) -> RegexpNode s r a -> Regexp s r b+    Fmap :: (a -> b) -> RegexpNode s r a -> Regexp s r b+    Rep :: (b -> a -> b) -- folding function (like in foldl)+        -> b             -- the value for zero matches, and also the initial value+                         -- for the folding function+        -> RegexpNode s (b, b -> r) a+                         -- Elements of the 2-tuple are the value accumulated so far+                         -- and the continuation+        -> Regexp s r b++data RegexpNode s r a = RegexpNode+    { active :: !Bool+    , empty  :: !(Priority a)+    , final_ :: !(Priority r)+    , reg    :: !(Regexp s r a)+    }++zero = Fail+isOK p =+    case p of+        Fail -> False+        Priority {} -> True++emptyChoice p1 p2 = withPriority 1 p1 <|> withPriority 0 p2++final r = if active r then final_ r else zero++epsNode :: RegexpNode s r a+epsNode = RegexpNode+    { active = False+    , empty  = pure $ error "epsNode"+    , final_ = zero+    , reg    = Eps+    }++symbolNode :: (s -> Bool) -> RegexpNode s r s+symbolNode c = RegexpNode+    { active = False+    , empty  = zero+    , final_ = zero+    , reg    = Symbol c+    }++altNode :: RegexpNode s r a -> RegexpNode s r a -> RegexpNode s r a+altNode a1 a2 = RegexpNode+    { active = active a1 || active a2+    , empty  = empty a1 `emptyChoice` empty a2+    , final_ = final a1 <|> final a2+    , reg    = Alt a1 a2+    }++appNode :: RegexpNode s (a -> r) (a -> b) -> RegexpNode s r a -> RegexpNode s r b+appNode a1 a2 = RegexpNode+    { active = active a1 || active a2+    , empty  = empty a1 <*> empty a2+    , final_ = final a1 <*> empty a2 <|> final a2+    , reg    = App a1 a2+    }++fmapNode :: (a -> b) -> RegexpNode s r a -> RegexpNode s r b+fmapNode f a = RegexpNode+    { active = active a+    , empty = fmap f $ empty a+    , final_ = final a+    , reg = Fmap f a+    }++repNode :: (b -> a -> b) -> b -> RegexpNode s (b, b -> r) a -> RegexpNode s r b+repNode f b a = RegexpNode+    { active = active a+    , empty = withPriority 0 $ pure b+    , final_ = withPriority 0 $ (\(b, f) -> f b) <$> final a+    , reg = Rep f b a+    }++shift :: Priority (a -> r) -> RegexpNode s r a -> s -> RegexpNode s r a+shift Fail r _ | not $ active r = r+shift k re s =+    case reg re of+        Eps -> re+        Symbol predicate ->+            let f = k <*> if predicate s then pure s else zero+            in re { final_ = f, active = isOK f }+        Alt a1 a2 -> altNode (shift (withPriority 1 k) a1 s) (shift (withPriority 0 k) a2 s)+        App a1 a2 -> appNode+            (shift kc a1 s)+            (shift (kc <*> empty a1 <|> final a1) a2 s)+            where kc = fmap (.) k+        Fmap f a -> fmapNode f $ shift (fmap (. f) k) a s+        Rep f b a -> repNode f b $ shift k' a s+            where+            k' = withPriority 1 $+                    (\(b, k) -> \a -> (f b a, k)) <$>+                        ((b,) <$> k <|> final a)++match :: RegexpNode s r r -> [s] -> Priority r+match r [] = empty r+match r (s:ss) = final $+    foldl' (\r s -> shift zero r s) (shift (pure id) r s) ss
+ Text/Regex/Applicative/Interface.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE Rank2Types #-}+module Text.Regex.Applicative.Interface where+import Control.Applicative hiding (empty)+import qualified Control.Applicative+import Data.Traversable+import Text.Regex.Applicative.Implementation++-- | Type of regular expressions that recognize symbols of type @s@ and+-- produce a result of type @a@.+--+-- Regular expressions can be built using 'Functor', 'Applicative' and+-- 'Alternative' instances in the following natural way:+--+-- * @f@ '<$>' @ra@ matches iff @ra@ matches, and its return value is the result+-- of applying @f@ to the return value of @ra@.+--+-- * 'pure' @x@ matches the empty string (i.e. it does not consume any symbols),+-- and its return value is @x@+--+-- * @rf@ '<*>' @ra@ matches a string iff it is a concatenation of two+-- strings: one matched by @rf@ and the other matched by @ra@. The return value+-- is @f a@, where @f@ and @a@ are the return values of @rf@ and @ra@+-- respectively.+--+-- * @ra@ '<|>' @rb@ matches a string which is accepted by either @ra@ or @rb@.+-- It is left-biased, so if both can match, the result of @ra@ is used.+--+-- * 'Control.Applicative.empty' is a regular expression which does not match any string.+--+-- * 'many' @ra@ matches concatenation of zero or more strings matched by @ra@+-- and returns the list of @ra@'s return values on those strings.+newtype RE s a = RE { unRE :: forall r . RegexpNode s r a }++instance Functor (RE s) where+    fmap f (RE a) = RE $ fmapNode f a++instance Applicative (RE s) where+    pure x = const x <$> RE epsNode+    (RE a1) <*> (RE a2) = RE $ RegexpNode+        { active = False+        , empty = empty a1 <*> empty a2+        , final_ = zero+        , reg = App a1 a2+        }++instance Alternative (RE s) where+    (RE a1) <|> (RE a2) = RE $ RegexpNode+        { active = False+        , empty = empty a1 `emptyChoice` empty a2+        , final_ = zero+        , reg = Alt a1 a2+        }+    empty = error "noMatch" <$> psym (const False)+    many a = reverse <$> reFoldl (flip (:)) [] a++-- | Matches and returns a single symbol which satisfies the predicate+psym :: (s -> Bool) -> RE s s+psym p = RE $ symbolNode p++-- | Matches and returns the given symbol+sym :: Eq s => s -> RE s s+sym s = psym (s ==)++-- | Matches and returns any single symbol+anySym :: RE s s+anySym = psym (const True)++-- | Matches and returns the given sequence of symbols+string :: Eq a => [a] -> RE a [a]+string = sequenceA . map sym++-- | Greedily matches zero or more symbols, which are combined using the given+-- folding function+reFoldl :: (b -> a -> b) -> b -> RE s a -> RE s b+reFoldl f b (RE a) = RE $ RegexpNode+    { active = False+    , empty = pure b+    , final_ = zero+    , reg = Rep f b a+    }++-- | Attempts to match a string of symbols against the regular expression+(=~) :: [s] -> RE s a -> Maybe a+s =~ (RE r) = priorityToMaybe $ match r s
+ Text/Regex/Applicative/Reference.hs view
@@ -0,0 +1,73 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.Regex.Applicative.Reference+-- Copyright : (c) Roman Cheplyaka+-- License   : MIT+--+-- Maintainer: Roman Cheplyaka <roma@ro-che.info>+-- Stability : experimental+--+-- Reference implementation (using backtracking)+--------------------------------------------------------------------++{-# LANGUAGE GADTs #-}+module Text.Regex.Applicative.Reference (reference) where+import Prelude hiding (getChar)+import Text.Regex.Applicative.Implementation hiding (empty)+import Text.Regex.Applicative.Interface+import Control.Applicative+import Control.Monad+++-- A simple parsing monad+newtype P s a = P { unP :: [s] -> [(a, [s])] }++instance Monad (P s) where+    return x = P $ \s -> [(x, s)]+    (P a) >>= k = P $ \s ->+        a s >>= \(x,s) -> unP (k x) s++instance Functor (P s) where+    fmap = liftM++instance Applicative (P s) where+    (<*>) = ap+    pure = return++instance Alternative (P s) where+    empty = P $ const []+    P a1 <|> P a2 = P $ \s ->+        a1 s ++ a2 s++getChar :: P s s+getChar = P $ \s ->+    case s of+        [] -> []+        c:cs -> [(c,cs)]++re2monad :: RegexpNode s r a -> P s a+re2monad r =+    case reg r of+        Eps -> return $ error "eps"+        Symbol p -> do+            c <- getChar+            if p c then return c else empty+        Alt a1 a2 -> re2monad a1 <|> re2monad a2+        App a1 a2 -> re2monad a1 <*> re2monad a2+        Fmap f a -> fmap f $ re2monad a+        Rep f b a -> rep b+            where+            am = re2monad a+            rep b = (do a <- am; rep $ f b a) <|> return b++runP :: P s a -> [s] -> Maybe a+runP m s = case filter (null . snd) $ unP m s of+    (r, _) : _ -> Just r+    _ -> Nothing++-- | 'reference' @r@ @s@ should give the same results as @s@ '=~' @r@.+--+-- However, this is not very efficient implementation and is supposed to be+-- used for testing only.+reference :: RE s a -> [s] -> Maybe a+reference (RE r) s = runP (re2monad r) s
+ regex-applicative.cabal view
@@ -0,0 +1,72 @@+-- regex-applicative.cabal auto-generated by cabal init. For+-- additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                regex-applicative++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1++-- A short (one-line) description of the package.+Synopsis:            Regex-based parsing with applicative interface++-- A longer description of the package.+Description:         +    regex-applicative is a Haskell library for parsing using regular expressions.+    Parsers can be built using Applicative interface.++-- URL for the project homepage or repository.+Homepage:            https://github.com/feuerbach/regex-applicative++-- The license under which the package is released.+License:             MIT++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Roman Cheplyaka++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          Roman Cheplyaka <roma@ro-che.info>++-- A copyright notice.+-- Copyright:           ++Category:            Text++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files:  README.md CREDITS.md test.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.6++Source-repository head+  type:     git+  location: git://github.com/feuerbach/regex-applicative.git++Source-repository this+  type:     git+  location: git://github.com/feuerbach/regex-applicative.git+  tag:      v0.1++Library+  -- Modules exported by the library.+  Exposed-modules:     Text.Regex.Applicative, Text.Regex.Applicative.Reference+  +  -- Packages needed in order to build this package.+  Build-depends:       base == 4.3.*, containers == 0.3.*+  +  -- Modules not exported by this package.+  Other-modules:       Text.Regex.Applicative.Interface,+                       Text.Regex.Applicative.Implementation+  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +
+ test.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ViewPatterns #-}+import Text.Regex.Applicative+import Text.Regex.Applicative.Reference+import Control.Applicative+import Control.Monad+import Test.SmallCheck+import Data.Traversable+import Text.Printf++-- Small alphabets as SmallCheck's series+newtype A = A { a :: Char } deriving Show+instance Serial A where+    series = cons0 $ A 'a'+    coseries = error "No coseries, sorry"++newtype AB = AB { ab :: Char } deriving Show+instance Serial AB where+    series = cons0 (AB 'a') \/ cons0 (AB 'b')+    coseries = error "No coseries, sorry"++newtype ABC = ABC { abc :: Char } deriving Show+instance Serial ABC where+    series = cons0 (ABC 'a') \/ cons0 (ABC 'b') \/ cons0 (ABC 'c')+    coseries = error "No coseries, sorry"++re1 =+    let one = pure 1 <* sym 'a'+        two = pure 2 <* sym 'a' <* sym 'a'+    in (,) <$> (one <|> two) <*> (two <|> one)++re2 = sequenceA $+    [ pure 1 <* sym 'a' <* sym 'a' <|>+      pure 2 <* sym 'a'+    , pure 3 <* sym 'b'+    , pure 4 <* sym 'b' <|>+      pure 5 <* sym 'a' ]++re3 = sequenceA $+    [ pure 0 <|> pure 1+    , pure 1 <* sym 'a' <* sym 'a' <|>+      pure 2 <* sym 'a'+    , pure 3 <* sym 'b' <|> pure 6+    , fmap (+1) $+      pure 4 <* sym 'b' <|>+      pure 7 <|>+      pure 5 <* sym 'a' ]++re4 = sym 'a' *> many (sym 'b') <* sym 'a'++re5 = (sym 'a' <|> sym 'a' *> sym 'a') *> many (sym 'a')++re6 = many (pure 3 <* sym 'a' <* sym 'a' <* sym 'a' <|> pure 1 <* sym 'a')++-- Regular expression from the weighted regexp paper.+re7 =+    let many_A_or_B = many (sym 'a' <|> sym 'b')+    in (,) <$>+        many ((,,,) <$> many_A_or_B <*> sym 'c' <*> many_A_or_B <*> sym 'c') <*>+        many_A_or_B+++prop re f (map f -> s) = reference re s == s =~ re++tests =+   [ depthCheck 10 $ prop re1 a+   , depthCheck 10 $ prop re2 ab+   , depthCheck 10 $ prop re3 ab+   , depthCheck 10 $ prop re4 ab+   , depthCheck 10 $ prop re5 a+   , depthCheck 10 $ prop re6 a+   , depthCheck 7  $ prop re7 abc+   ]++main = do+    foldM runTest (1 :: Int) tests+    return ()+    where+    runTest n test = do+        printf "Running test case %d...\n" n+        test+        printf "\n"+        return $ n+1