rere (empty) → 0.1
raw patch · 21 files changed
+3963/−0 lines, 21 filesdep +QuickCheckdep +aesondep +attoparsec
Dependencies added: QuickCheck, aeson, attoparsec, base, bytestring, clock, containers, criterion, derp, fin, parsec, quickcheck-instances, rere, semigroups, tasty, tasty-quickcheck, transformers, vec, void
Files
- LICENSE +30/−0
- bench/Bench.hs +109/−0
- bench/DerpConv.hs +47/−0
- bench/JSON.hs +104/−0
- jsverify.json +71/−0
- rere.cabal +183/−0
- src/RERE.hs +67/−0
- src/RERE/Absurd.hs +23/−0
- src/RERE/CFG.hs +162/−0
- src/RERE/CharClasses.hs +69/−0
- src/RERE/CharSet.hs +220/−0
- src/RERE/Examples.hs +429/−0
- src/RERE/Examples/JSON.hs +263/−0
- src/RERE/Gen.hs +83/−0
- src/RERE/LaTeX.hs +384/−0
- src/RERE/Ref.hs +397/−0
- src/RERE/ST.hs +555/−0
- src/RERE/Tuples.hs +26/−0
- src/RERE/Type.hs +575/−0
- src/RERE/Var.hs +59/−0
- test/Tests.hs +107/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020 Oleg Grenrus++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 name of Oleg Grenrus nor the names of other+ 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.
+ bench/Bench.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Criterion.Main (bench, defaultMain, whnf)+import RERE.Examples (ex7parsec)++import qualified Text.Parsec as P+import qualified Text.Parsec.String as P++import qualified Text.Derp as D+import qualified Data.Set as Set++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*))+#endif++#ifndef RERE_NO_CFG+import RERE (match, matchR, matchST)+import RERE.Examples (ex7)+#endif++import DerpConv++input :: String+input = "1000*(2020+202)*(20+3)*((30+20)*10000)+123123123*12313"++input2 :: String+input2 = "1000*(20+a)*((30+20)*10000)"++parsec :: P.Parser () -> String -> Bool+parsec p s = case P.parse (p <* P.eof) "<input>" s of+ Right _ -> True+ Left _ -> False++derp :: D.Parser Char () -> String -> Bool+derp p s = not $ Set.null $ D.runParse p [ D.Token c [c] | c <- s]++main :: IO ()+main = do+ print $ parsec ex7parsec input+#ifndef RERE_NO_CFG+ print $ match ex7 input+ print $ matchR ex7 input+ print $ matchST ex7 input+#endif+ print $ derp ex7derp input+#ifndef RERE_NO_CFG+ print $ derp ex7derp' input+#endif++ print $ parsec ex7parsec input2+#ifndef RERE_NO_CFG+ print $ match ex7 input2+ print $ matchR ex7 input2+ print $ matchST ex7 input2+#endif+ print $ derp ex7derp input2+#ifndef RERE_NO_CFG+ print $ derp ex7derp' input2+#endif++ defaultMain+ [ bench "parsec" $ whnf (parsec ex7parsec) input+#ifndef RERE_NO_CFG+ , bench "rere" $ whnf (match ex7) input+ , bench "ref" $ whnf (matchR ex7) input+ , bench "st" $ whnf (matchST ex7) input+#endif+ , bench "derp" $ whnf (derp ex7derp) input+#ifndef RERE_NO_CFG+ , bench "derpC" $ whnf (derp ex7derp') input+#endif++ , bench "parsec" $ whnf (parsec ex7parsec) input2+#ifndef RERE_NO_CFG+ , bench "rere" $ whnf (match ex7) input2+ , bench "ref" $ whnf (matchR ex7) input2+ , bench "st" $ whnf (matchST ex7) input2+#endif+ , bench "derp" $ whnf (derp ex7derp) input2+#ifndef RERE_NO_CFG+ , bench "derpC" $ whnf (derp ex7derp') input2+#endif+ ]++-------------------------------------------------------------------------------+-- Derp+-------------------------------------------------------------------------------++#ifndef RERE_NO_CFG+ex7derp' :: D.Parser Char ()+ex7derp' = rere2derp ex7+#endif++ex7derp :: D.Parser Char ()+ex7derp = expr+ where+ digit = foldr (D.<|>) D.emp $ map D.ter "0123456789"+ digits = derpVoid $ digit D.<~> derpStar digit++ term = digits D.<|> derpVoid (D.ter '(' D.<~> expr D.<~> D.ter ')')+ mult = derpVoid (term D.<~> D.ter '+' D.<~> mult) D.<|> term+ expr = derpVoid (mult D.<~> D.ter '*' D.<~> expr) D.<|> mult++ derpStar :: (Ord t, Ord b) => D.Parser t b -> D.Parser t [b]+ derpStar p = let ps = D.eps [] D.<|> (p D.<~> ps D.==> uncurry (:)) in ps++ derpVoid :: (Ord t, Ord b) => D.Parser t b -> D.Parser t ()+ derpVoid p = p D.==> const ()
+ bench/DerpConv.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module DerpConv where++import Data.Void (Void, vacuous)+import qualified Text.Derp as D++import RERE+import qualified RERE.CharSet as CS++rere2derp :: RE Void -> D.Parser Char ()+rere2derp = go . vacuous where+ go :: RE (D.Parser Char ()) -> D.Parser Char ()++ go Null = D.emp+ go Eps = D.eps ()+ go (Ch cs) = derpVoid + $ foldr (D.<|>) D.emp+ $ map D.ter+ $ CS.toList cs+ + go (App r s) = derpVoid $ go r D.<~> go s+ go (Alt r s) = go r D.<|> go s+ + go (Star r) = star (go r)++ go (Var a) = a+ go (Let _ r s) =+ let r' = go r+ in go (fmap (unvar r' id) s)++ go (Fix _ r) =+ let r' = go (fmap (unvar r' id) r)+ in r'++#ifdef RERE_INTERSECTION+ go Full = error "rere2derp: Full not supported"+ go (And _ _) = error "rere2derp: And not supported"+#endif++ derpVoid :: (Ord t, Ord b) => D.Parser t b -> D.Parser t ()+ derpVoid p = p D.==> const ()++ -- non-collecting star+ star :: (Ord t, Ord b) => D.Parser t b -> D.Parser t ()+ star p = r+ where+ r = D.eps () D.<|> p D.<~> r D.==> const ()
+ bench/JSON.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main, jsonRE, jsonRE', jsonNames, jsonCFG, jsonDerp, derp) where++import Prelude hiding (exponent)++import Criterion.Main (bench, defaultMain, whnf)+import Data.Either (isRight)+import System.Clock (Clock (Monotonic), diffTimeSpec, getTime)++import qualified Data.Aeson.Parser as A+import qualified Data.Attoparsec.ByteString as Atto+import qualified Data.ByteString as BS+import qualified Data.Set as Set+import qualified Text.Derp as D++#ifdef MIN_VERSION_saison+import qualified Saison.Decoding.Parser as S+import qualified Saison.Decoding.Tokens as S+#endif++import RERE+import RERE.Examples.JSON++import DerpConv++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*))+#endif++derp :: D.Parser Char () -> String -> Bool+derp p s = not $ Set.null $ D.runParse p [ D.Token c [c] | c <- s]++aeson :: BS.ByteString -> Bool+aeson bs = isRight (Atto.parseOnly (A.json <* Atto.endOfInput) bs)++#ifdef MIN_VERSION_saison+saison :: BS.ByteString -> Bool+saison = go end . S.tokens where+ end :: BS.ByteString -> Bool+ end = BS.null . S.skipSpace++ go :: (k -> Bool) -> S.Tokens k e -> Bool+ go kont (S.TkLit _ k) = kont k+ go kont (S.TkText _ k) = kont k+ go kont (S.TkNumber _ k) = kont k+ go kont (S.TkArrayOpen arr) = goArr kont arr+ go kont (S.TkRecordOpen obj) = goObj kont obj+ go _ (S.TkErr _) = False++ goArr :: (k -> Bool) -> S.TkArray k e -> Bool+ goArr kont (S.TkItem k) = go (goArr kont) k+ goArr kont (S.TkArrayEnd k) = kont k+ goArr _ (S.TkArrayErr _) = False++ goObj :: (k -> Bool) -> S.TkRecord k e -> Bool+ goObj kont (S.TkPair _ k) = go (goObj kont) k+ goObj kont (S.TkRecordEnd k) = kont k+ goObj _ (S.TkRecordErr _) = False+#endif++main :: IO ()+main = do+ contents <- readFile "jsverify.json"+ bs <- BS.readFile "jsverify.json"++ do+ putStrLn "Ref run"+ start <- getTime Monotonic+ print $ matchR jsonRE contents+ end <- getTime Monotonic+ print $ diffTimeSpec end start++ do+ putStrLn "ST run"+ start <- getTime Monotonic+ print $ matchST jsonRE contents+ end <- getTime Monotonic+ print $ diffTimeSpec end start++-- do+-- putStrLn "derp run"+-- start <- getTime Monotonic+-- print $ derp jsonDerp $ take 0 contents+-- end <- getTime Monotonic+-- print $ diffTimeSpec end start++ putStrLn "Criterion"+ defaultMain+ [ bench "aeson" $ whnf aeson bs+#ifdef MIN_VERSION_saison+ , bench "saison" $ whnf saison bs+#endif+ -- , bench "rere" $ whnf (matchR jsonRE) contents+ ]++-------------------------------------------------------------------------------+-- JSON definition+-------------------------------------------------------------------------------++jsonDerp :: D.Parser Char ()+jsonDerp = rere2derp jsonRE
+ jsverify.json view
@@ -0,0 +1,71 @@+{+ "name": "jsverify",+ "description": "Property-based testing for JavaScript.",+ "version": "0.8.4",+ "homepage": "http://jsverify.github.io/",+ "author": {+ "name": "Oleg Grenrus",+ "email": "oleg.grenrus@iki.fi",+ "url": "http://oleg.fi"+ },+ "repository": {+ "type": "git",+ "url": "git://github.com/jsverify/jsverify.git"+ },+ "bugs": {+ "url": "https://github.com/jsverify/jsverify/issues"+ },+ "license": "MIT",+ "main": "lib/jsverify.js",+ "types": "lib/jsverify.d.ts",+ "engines": {+ "node": ">= 0.8.0"+ },+ "scripts": {+ "test": "make test"+ },+ "devDependencies": {+ "@types/mocha": "^5.0.0",+ "bluebird": "^3.1.1",+ "browserify": "^16.1.1",+ "chai": "^4.1.2",+ "david": "^11.0.0",+ "eslint": "^5.8.0",+ "esprima": "^4.0.0",+ "istanbul": "^0.4.1",+ "jasmine-core": "^3.1.0",+ "jscs": "^3.0.7",+ "jshint": "^2.7.0",+ "karma": "^4.0.0",+ "karma-chrome-launcher": "^2.0.0",+ "karma-cli": "^2.0.0",+ "karma-firefox-launcher": "^1.0.0",+ "karma-jasmine": "^2.0.0",+ "karma-mocha": "^1.1.1",+ "ljs": "~0.3.0",+ "lodash": "^4.4.0",+ "mocha": "^5.0.5",+ "npm-freeze": "^0.1.3",+ "q": "~2.0.2",+ "ts-node": "^8.0.2",+ "tslint": "^5.0.0",+ "typescript": "^3.1.4",+ "underscore": "^1.8.2",+ "when": "~3.7.2"+ },+ "keywords": [+ "testing",+ "unit testing",+ "TDD",+ "property-based testing",+ "quickcheck",+ "quick check",+ "jscheck"+ ],+ "dependencies": {+ "lazy-seq": "^1.0.0",+ "rc4": "~0.1.5",+ "trampa": "^1.0.0",+ "typify-parser": "^1.1.0"+ }+}
+ rere.cabal view
@@ -0,0 +1,183 @@+cabal-version: 2.2+name: rere+version: 0.1+synopsis:+ Regular-expressions extended with fixpoints for context-free powers++category: Parsing+description:+ By extending regular expressions with (explicit) fixed points+ we can recognize context-free grammars.++author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD-3-Clause+license-file: LICENSE+extra-source-files: jsverify.json+tested-with:+ GHC ==7.0.4+ || ==7.2.2+ || ==7.4.2+ || ==7.6.3+ || ==7.8.4+ || ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.3+ || ==8.10.1++source-repository head+ type: git+ location: https://github.com/phadej/rere.git++flag rere-cfg+ description: CFG functionality, needs dependency on fin and vec+ default: True+ manual: True++flag rere-intersection+ description: Add add intersection constructor. EXPERIMENTAL+ default: False+ manual: True++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall++ if impl(ghc >=8.10)+ ghc-options: -Wmissing-safe-haskell-mode -Winferred-safe-imports++ -- GHC boot library+ build-depends:+ , base >=4.3.0.0 && <4.15+ , containers ^>=0.4.0.0 || ^>=0.5.0.0 || ^>=0.6.0.1+ , parsec ^>=3.1.12.0+ , transformers ^>=0.3.0.0 || ^>=0.4.2.0 || ^>=0.5.2.0++ -- other dependencies+ build-depends: QuickCheck ^>=2.13.2++ -- compat+ if !impl(ghc >=7.10)+ build-depends: void ^>=0.7.2++ if !impl(ghc >=8.0)+ build-depends: semigroups >=0.18.4 && <0.20++ -- expose examples first, so `cabal repl` loads them.+ exposed-modules: RERE.Examples++ if (flag(rere-cfg) && impl(ghc >=7.8))+ exposed-modules: RERE.Examples.JSON++ exposed-modules:+ RERE+ RERE.Absurd+ RERE.CharClasses+ RERE.CharSet+ RERE.Gen+ RERE.LaTeX+ RERE.Ref+ RERE.ST+ RERE.Type+ RERE.Var++ other-modules: RERE.Tuples++ if (flag(rere-cfg) && impl(ghc >=7.8))+ build-depends:+ , fin ^>=0.1.1+ , vec ^>=0.3++ exposed-modules: RERE.CFG+ else+ cpp-options: -DRERE_NO_CFG++ if flag(rere-intersection)+ cpp-options: -DRERE_INTERSECTION++benchmark simple+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Bench.hs+ other-modules: DerpConv+ ghc-options: -Wall -rtsopts+ build-depends:+ , base+ , containers+ , criterion ^>=1.5.5.0+ , derp+ , parsec+ , rere++ if !(flag(rere-cfg) && impl(ghc >=7.8))+ cpp-options: -DRERE_NO_CFG++ if flag(rere-intersection)+ cpp-options: -DRERE_INTERSECTION++ if !impl(ghc >=7.10)+ build-depends: void ^>=0.7.2++ if !impl(ghc >=7.4)+ buildable: False++benchmark json+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: JSON.hs+ other-modules: DerpConv+ ghc-options: -Wall -rtsopts+ build-depends:+ , aeson ^>=1.4.6.0+ , attoparsec+ , base+ , bytestring+ , clock ^>=0.8+ , containers+ , criterion ^>=1.5.5.0+ , derp+ , fin+ , parsec+ , rere+ , vec++ -- extras+ -- build-depends: saison++ if !impl(ghc >=8.0)+ build-depends: semigroups >=0.18.4 && <0.20++ if !impl(ghc >=7.10)+ build-depends: void ^>=0.7.2++ if flag(rere-intersection)+ cpp-options: -DRERE_INTERSECTION++ if !(flag(rere-cfg) && impl(ghc >=7.8))+ buildable: False++test-suite properties+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Tests.hs+ build-depends:+ , base+ , containers+ , QuickCheck+ , quickcheck-instances ^>=0.3.22+ , rere+ , tasty ^>=1.2.3+ , tasty-quickcheck ^>=0.10.1.1++ if flag(rere-intersection)+ cpp-options: -DRERE_INTERSECTION++ if !impl(ghc >=7.4)+ buildable: False
+ src/RERE.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Regular-expressions extended with fixpoints+-- for context-free powers.+--+-- Some examples are in "RERE.Examples" module.+--+module RERE (+ -- * Regular expressions with fixpoints+ RE (..),+ -- ** Smart constructors+ ch_, (\/), star_, let_, fix_, (>>>=),+#ifdef RERE_INTERSECTION+ (/\),+#endif+ string_,+ -- ** Operations+ nullable, derivative, compact, size,+ -- ** Matching+ match,+ -- ** Generation+ generate,++ -- * Variables+ Var (..), unvar,+ Name,++ -- * Context-free grammars+#ifndef RERE_NO_CFG+ CFG, CFGBase,+ cfgToRE,+#endif++ -- * Faster matching+ -- ** Ref+ RR, matchR, matchDebugR,+ -- ** ST+ RST, matchST, matchDebugST,++ -- * Character classes+ CharClasses,+ charClasses,+ classOfChar,++ -- * Pretty printing (as LaTeX)+ putLatex,+ putLatexTrace,+#ifndef RERE_NO_CFG+ putLatexCFG,+#endif+ ) where++import RERE.CharClasses+import RERE.Gen+import RERE.LaTeX+import RERE.Ref+import RERE.ST+import RERE.Type+import RERE.Var++#ifndef RERE_NO_CFG+import RERE.CFG+#endif
+ src/RERE/Absurd.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Absurd i.e. not inhabited types.+module RERE.Absurd (Absurd (..), vacuous) where++import qualified Data.Void as Void++-- | A vendored 'Absurd' from https://hackage.haskell.org/package/boring+--+-- We only need 'Void' instance.+class Absurd a where+ absurd :: a -> b++instance Absurd Void.Void where+ absurd = Void.absurd++-- | @fmap absurd@.+vacuous :: (Functor f, Absurd a) => f a -> f b+vacuous = fmap absurd
+ src/RERE/CFG.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+-- | Context free grammars, where+-- each production is a regular-expression.+module RERE.CFG (+ -- * Context-free grammars+ CFG,+ CFGBase,+ -- * Conversion to recursive regular expressions+ cfgToRE,+ ) where++import Data.Fin (Fin (..))+import Data.Nat (Nat (..))+import Data.Vec.Lazy (Vec (..))++import qualified Data.Type.Nat as N+import qualified Data.Vec.Lazy as V++import RERE.Type+import RERE.Var++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable (Traversable (..))+#endif++-- $setup+-- >>> :set -XOverloadedStrings++-- | Context-free grammar represented as @n@ equations+-- of 'RE' ('CFGBase') with @n@ variables.+--+type CFG n a = Vec n (CFGBase n a)++-- | Single equation in context-free-grammar equation.+type CFGBase n a = RE (Either (Fin n) a)++-- | Convert 'CFG' (with names for productions) into 'RE'.+-- Note: the start symbol have to be last equation.+--+-- >>> let a = Eps \/ ch_ 'a' <> Var (Left FZ)+-- >>> let b = Eps \/ ch_ 'b' <> Var (Left (FS FZ))+-- >>> let cfg = b ::: a ::: VNil+--+-- \[+-- \begin{aligned}+-- {\mathit{b}} &= {\varepsilon}\cup\mathtt{b}{\mathit{a}} \\+-- {\mathit{a}} &= {\varepsilon}\cup\mathtt{a}{\mathit{b}} \\+-- \end{aligned}+-- \]+--+-- >>> cfgToRE ("b" ::: "a" ::: VNil) cfg+-- Fix "a" (Let "b" (Alt Eps (App (Ch "b") (Var B))) (Alt Eps (App (Ch "a") (Var B))))+--+-- which represents \(\mathbf{fix}\,{\mathit{a}}=\mathbf{let}\,{\mathit{b}}={\varepsilon}\cup\mathtt{b}{\mathit{a}}\,\mathbf{in}\,{\varepsilon}\cup\mathtt{a}{\mathit{b}}\)+-- recursive regular expression.+--+cfgToRE :: (N.SNatI n, Ord a) => Vec ('S n) Name -> CFG ('S n) a -> RE a+cfgToRE = getCfgToRE (N.induction1 start step) where+ start = CfgToRE baseCase++ step :: Ord a => CfgToRE m a -> CfgToRE ('S m) a+ step (CfgToRE rec) = CfgToRE $ \names cfg ->+ rec (V.tail names) (consCase names cfg)++newtype CfgToRE n a = CfgToRE { getCfgToRE :: Vec ('S n) Name -> CFG ('S n) a -> RE a }++baseCase :: Ord a => Vec N.Nat1 Name -> CFG N.Nat1 a -> RE a+baseCase (name ::: VNil) (cfg ::: VNil) =+ fix' name (fmap (either (\FZ -> B) F) cfg)+#if __GLASGOW_HASKELL__ <711+baseCase _ _ = error "silly GHC"+#endif++consCase+ :: forall a n. Ord a+ => Vec ('S n) Name+ -> CFG ('S n) a+ -> CFG n a+consCase (name ::: _names) (f ::: gs) =+ V.map (\g -> let' name f' (fmap sub g)) gs+ where+ f' = fix' name (fmap sub' f)++ sub :: Either (Fin ('S n)) a -> Var (Either (Fin n) a)+ sub (Right a) = F (Right a)+ sub (Left (FS n)) = F (Left n)+ sub (Left FZ) = B++ sub' :: Either (Fin ('S n)) a -> Var (Either (Fin n) a)+ sub' (Right a) = F (Right a)+ sub' (Left (FS n)) = F (Left n)+ sub' (Left FZ) = B++-------------------------------------------------------------------------------+-- Dummier fix and let+-------------------------------------------------------------------------------++-- This functions only rearrange fix and let,+-- and don't perform other simplifications.++fix' :: Eq a => Name -> RE (Var a) -> RE a+-- fix' n (Let m r s)+-- | Just r' <- traverse (unvar Nothing Just) r+-- = Let m r' (fix' n (fmap swapVar s))+fix' n r+ | Just r' <- floatOut r (unvar Nothing Just) (fix' n)+ = r'+ | Just r' <- traverse (unvar Nothing Just) r+ = r'+fix' n r = Fix n r++floatOut+ :: (Eq a, Eq b)+ => RE (Var a) -- ^ expression+ -> (Var a -> Maybe b) -- ^ float out var+ -> (RE (Var (Var a)) -> RE (Var b)) -- ^ binder+ -> Maybe (RE b) -- ^ maybe an expression with let floaten out+floatOut (Let m r s) un mk+ | Just r' <- traverse un r+ = Just+ $ let' m r' $ mk $ fmap swapVar s+ | otherwise+ = floatOut+ s+ (unvar Nothing un)+ (mk . let' m (fmap (fmap F) r) . fmap (fmap swapVar))+floatOut _ _ _ = Nothing++let' :: Eq a => Name -> RE a -> RE (Var a) -> RE a+let' n (Let m x r) s+ = let' m x+ $ let' n r (fmap (unvar B (F . F)) s)+let' n r s = postlet' n r (go B (fmap F r) s) where+ -- This simple CSE only looks for lets. i.e+ --+ -- let x = a; y = a in ...body x y...+ -- -- >+ -- let x = a in ...body x x...+ --+ -- 'consCase' introduces same lets, so this fires a lot.+ --+ -- Note: not using let' or fix' in the bodies+ -- makes this faster.+ go :: Eq b => b -> RE b -> RE b -> RE b+ go v x (Let m a b)+ | x == a = go v x (fmap (unvar v id) b)+ | otherwise = Let m (go v x a) (go (F v) (fmap F x) b)+ go v x (Fix m a) = Fix m (go (F v) (fmap F x) a)++ go _ _ r' = r'++postlet' :: Name -> RE a -> RE (Var a) -> RE a+postlet' _ r (Var B) = r+postlet' _ _ s | Just s' <- unused s = s'+postlet' n r s = Let n r s++unused :: RE (Var a) -> Maybe (RE a)+unused = traverse (unvar Nothing Just)
+ src/RERE/CharClasses.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Charactor classes.+module RERE.CharClasses (+ CharClasses,+ charClasses,+ classOfChar,+ ) where++import RERE.Type++import qualified Data.Set as Set+import qualified RERE.CharSet as CS++-- | Character classes are represented by partition lower bounds.+type CharClasses = Set.Set Char++-- | Character classes.+--+-- We can partition 'Char' so characters in each part,+-- affect the given regular expression in the same way.+--+-- If we do some kind of memoising, we can map all characters+-- to 'classOfChar', making everything smaller.+--+charClasses :: RE a -> CharClasses+charClasses = charsetClasses . Set.toList . collect++-- | Map char to the representer of a class.+classOfChar :: CharClasses -> Char -> Char+#if MIN_VERSION_containers(0,5,0)+classOfChar cc c = case Set.lookupLE c cc of+ Just c' -> c'+ Nothing -> '\NUL'+#else+-- old containers: slow path+classOfChar _ c = c+#endif++collect :: RE a -> Set.Set CS.CharSet+collect = go where+ go :: RE a -> Set.Set CS.CharSet+ go Null = Set.empty+ go Full = Set.empty+ go Eps = Set.empty+ go (Ch cs) = Set.singleton cs+ go (App r s) = Set.union (go r) (go s)+ go (Alt r s) = Set.union (go r) (go s)+ go (Star r) = go r+#ifdef RERE_INTERSECTION+ go (And r s) = Set.union (go r) (go s)+#endif+ go (Var _) = Set.empty+ go (Let _ r s) = Set.union (go r) (go s)+ go (Fix _ r) = go r++charsetClasses :: [CS.CharSet] -> CharClasses+charsetClasses = go (Set.singleton '\NUL') where+ go acc [] = acc+ go acc (cs:css) = go+ (Set.union acc $ Set.fromList $ concatMap bounds $ CS.toIntervalList cs)+ css++ bounds (x, y) | y == maxBound = [x]+ | otherwise = [x, succ y]
+ src/RERE/CharSet.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Sets of characters.+--+-- Using this is more efficint than 'RE.Type.Alt':ng individual characters.+module RERE.CharSet (+ -- * Set of characters+ CharSet,+ -- * Construction+ empty,+ universe,+ singleton,+ insert,+ union,+ intersection,+ complement,+ difference,+ -- * Query+ size,+ null,+ member,+ -- * Conversions+ fromList,+ toList,+ fromIntervalList,+ toIntervalList,+ ) where++import Prelude hiding (null)++import Data.Char (chr, ord)+import Data.List (foldl', sortBy)+import Data.String (IsString (..))++#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as IM+#else+import qualified Data.IntMap as IM+#endif++-- | A set of 'Char's.+--+-- We use range set, which works great with 'Char'.+newtype CharSet = CS { unCS :: IM.IntMap Int }+ deriving (Eq, Ord)++-- | +--+-- >>> "foobar" :: CharSet+-- "abfor"+--+instance IsString CharSet where+ fromString = fromList++instance Show CharSet where+ showsPrec d cs+ | size cs < 20+ = showsPrec d (toList cs)+ | otherwise+ = showParen (d > 10)+ $ showString "CS.fromIntervalList "+ . showsPrec 11 (toIntervalList cs)++-- | Empty character set.+empty :: CharSet+empty = CS IM.empty++-- | universe+--+-- >>> size universe+-- 1114112+--+-- >>> universe+-- CS.fromIntervalList [('\NUL','\1114111')]+--+universe :: CharSet+universe = CS $ IM.singleton 0 0x10ffff++-- | Check whether 'CharSet' is 'empty'.+null :: CharSet -> Bool+null (CS cs) = IM.null cs++-- | Size of 'CharSet'+--+-- >>> size $ fromIntervalList [('a','f'), ('0','9')]+-- 16+--+-- >>> length $ toList $ fromIntervalList [('a','f'), ('0','9')]+-- 16+--+size :: CharSet -> Int+size (CS m) = foldl' (\ !acc (lo, hi) -> acc + (hi - lo) + 1) 0 (IM.toList m)++-- | Singleton character set.+singleton :: Char -> CharSet+singleton c = CS (IM.singleton (ord c) (ord c))++-- | Test whether character is in the set.+member :: Char -> CharSet -> Bool+#if MIN_VERSION_containers(0,5,0)+member c (CS m) = case IM.lookupLE i m of+ Nothing -> False+ Just (_, hi) -> i <= hi+ where+#else+member c (CS m) = go (IM.toList m)+ where+ go [] = False+ go ((x,y):zs) = (x <= i && i <= y) || go zs+#endif+ i = ord c++-- | Insert 'Char' into 'CharSet'.+insert :: Char -> CharSet -> CharSet+insert c (CS m) = normalise (IM.insert (ord c) (ord c) m)++-- | Union of two 'CharSet's.+union :: CharSet -> CharSet -> CharSet+union (CS xs) (CS ys) = normalise (IM.unionWith max xs ys)++-- | Intersection of two 'CharSet's+intersection :: CharSet -> CharSet -> CharSet+intersection (CS xs) (CS ys) = CS $+ IM.fromList (intersectRangeList (IM.toList xs) (IM.toList ys))++-- | Compute the intersection.+intersectRangeList :: Ord a => [(a, a)] -> [(a, a)] -> [(a, a)]+intersectRangeList aset@((x,y):as) bset@((u,v):bs)+ | y < u = intersectRangeList as bset+ | v < x = intersectRangeList aset bs+ | y < v = (max x u, y) : intersectRangeList as bset+ | otherwise = (max x u, v) : intersectRangeList aset bs+intersectRangeList _ [] = []+intersectRangeList [] _ = []++-- | Complement of a CharSet+complement :: CharSet -> CharSet+complement (CS xs) = CS $ IM.fromList $ complementRangeList (IM.toList xs)++-- | Compute the complement intersected with @[x,)@ assuming @x<u@.+complementRangeList' :: Int -> [(Int, Int)] -> [(Int, Int)]+complementRangeList' x ((u,v):s) = (x,pred u) : complementRangeList'' v s+complementRangeList' x [] = [(x,0x10ffff)]++-- | Compute the complement intersected with @(x,)@.+complementRangeList'' :: Int -> [(Int, Int)] -> [(Int, Int)]+complementRangeList'' x s+ | x == 0x10ffff = []+ | otherwise = complementRangeList' (succ x) s++-- | Compute the complement.+--+-- Note: we treat Ints as codepoints, i.e minBound is 0, and maxBound is 0x10ffff+complementRangeList :: [(Int, Int)] -> [(Int, Int)]+complementRangeList s@((x,y):s')+ | x == 0 = complementRangeList'' y s'+ | otherwise = complementRangeList' 0 s+complementRangeList [] = [(0, 0x10ffff)]++-- | Difference of two 'CharSet's.+difference :: CharSet -> CharSet -> CharSet+difference xs ys = intersection xs (complement ys)++-- | Make 'CharSet' from a list of characters, i.e. 'String'.+fromList :: String -> CharSet+fromList = normalise . foldl' (\ acc c -> IM.insert (ord c) (ord c) acc) IM.empty++-- | Convert 'CharSet' to a list of characters i.e. 'String'.+toList :: CharSet -> String+toList = concatMap (uncurry enumFromTo) . toIntervalList++-- | Convert to interval list+--+-- >>> toIntervalList $ union "01234" "56789"+-- [('0','9')]+--+toIntervalList :: CharSet -> [(Char, Char)]+toIntervalList (CS m) = [ (chr lo, chr hi) | (lo, hi) <- IM.toList m ]++-- | Convert from interval pairs.+--+-- >>> fromIntervalList []+-- ""+--+-- >>> fromIntervalList [('a','f'), ('0','9')]+-- "0123456789abcdef"+--+-- >>> fromIntervalList [('Z','A')]+-- ""+--+fromIntervalList :: [(Char,Char)] -> CharSet+fromIntervalList xs = normalise' $ sortBy (\a b -> compare (fst a) (fst b))+ [ (ord lo, ord hi)+ | (lo, hi) <- xs+ , lo <= hi+ ]++-------------------------------------------------------------------------------+-- Normalisation+-------------------------------------------------------------------------------++normalise :: IM.IntMap Int -> CharSet+normalise = normalise'. IM.toList++normalise' :: [(Int,Int)] -> CharSet+normalise' = CS . IM.fromList . go where+ go :: [(Int,Int)] -> [(Int,Int)]+ go [] = []+ go ((x,y):zs) = go' x y zs++ go' :: Int -> Int -> [(Int, Int)] -> [(Int, Int)]+ go' lo hi [] = [(lo, hi)]+ go' lo hi ws0@((u,v):ws)+ | u <= succ hi = go' lo (max v hi) ws+ | otherwise = (lo,hi) : go ws0
+ src/RERE/Examples.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+#ifndef RERE_NO_CFG+{-# LANGUAGE Trustworthy #-}+#elif __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Various examples of using @rere@,+-- as used [in the blog post](#).+module RERE.Examples where++import Control.Applicative (some, (<|>))+import Control.Monad (void)+import Data.Void (Void)++import qualified Text.Parsec as P+import qualified Text.Parsec.String as P++import RERE++#ifndef RERE_NO_CFG+import Data.Vec.Lazy (Vec (..))++import qualified Data.Fin as F+import qualified Data.Type.Nat as N+#endif++#ifdef RERE_INTERSECTION+import Data.Void (vacuous)+#endif++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++-- $setup+-- >>> import Test.QuickCheck.Random (mkQCGen)+-- >>> import Test.QuickCheck.Gen (unGen)+-- >>> import Control.Monad.ST (runST)+-- >>> let runGen seed = maybe "<<null>>" (\g' -> unGen g' (mkQCGen seed) 10)+-- >>> let showRef re = matchDebugR re ""++-------------------------------------------------------------------------------+-- * Syntax+-------------------------------------------------------------------------------++-- | Demonstrates how various constructors are pretty printed.+syntaxExamples :: IO ()+syntaxExamples = do+ putLatex Null+ putLatex Eps++ putLatex $ ch_ 'a'+ putLatex $ ch_ 'b'++ putLatex $ Let "r" Eps $ Let "r" Eps $ App (Var B) (Var (F B))+ putLatex $ Let "r" Eps $ Let "r" Eps $ Alt (Var B) (Var (F B))+ putLatex $ Let "r" Eps $ Star (Var B)++-------------------------------------------------------------------------------+-- * Example 1+-------------------------------------------------------------------------------++-- |+--+-- >>> match ex1 "abab"+-- True+--+-- >>> match ex1 "ababa"+-- False+--+-- >>> ex1+-- Star (App (Ch "a") (Ch "b"))+--+-- >>> charClasses ex1+-- fromList "\NULabc"+--+-- >>> showRef ex1+-- size: 4+-- show: Star (App (Ch "a") (Ch "b"))+-- null: True+--+-- >>> matchR ex1 "abab"+-- True+--+-- >>> matchR ex1 "ababa"+-- False+--+-- >>> runGen 42 (generate 10 20 ex1)+-- "ababab"+--+-- >>> runGen 44 (generate 10 20 ex1)+-- "abababababababababab"+--+ex1 :: RE Void+ex1 = star_ (ch_ 'a' <> ch_ 'b')++ex1run1 :: IO ()+ex1run1 = putLatexTrace ex1 "abab"++-------------------------------------------------------------------------------+-- * Example 2+-------------------------------------------------------------------------------++-- |+--+-- >>> match ex2 "aaa"+-- True+--+-- Note: how "sharing" is preserved.+--+-- >>> showRef ex2+-- size: 5+-- show: App (Star (Ch "a")) (Star (Ch "a"))+-- null: True+--+-- >> matchR ex2 "aaa"+-- True+--+-- >>> runGen 42 (generate 10 20 ex2)+-- "aaaaaaaaaaa"+--+-- >>> runGen 44 (generate 10 20 ex2)+-- "aaaaaaaaaa"+--+ex2 :: RE Void+ex2 = Let "r" (star_ (ch_ 'a')) (Var B <> Var B)++ex2run1 :: IO ()+ex2run1 = putLatexTrace ex2 "aaa"++-------------------------------------------------------------------------------+-- * Example 3+-------------------------------------------------------------------------------++-- |+--+-- >>> match ex3 "abab"+-- True+--+-- >>> match ex3 "ababa"+-- False+--+-- >>> showRef ex3+-- size: 8+-- show: Ref 0 (Alt Eps (App (Ch "a") (App (Ch "b") (Ref 0 <<loop>>))))+-- null: True+--+-- >>> matchR ex3 "abab"+-- True+--+-- >>> matchR ex3 "ababa"+-- False+--+-- >>> runGen 42 (generate 10 20 ex3)+-- "ab"+--+-- >>> runGen 50 (generate 10 20 ex3)+-- "ababab"+--+ex3 :: RE Void+ex3 = Fix "x" (Eps \/ ch_ 'a' <> ch_ 'b' <> Var B)++ex3run1 :: IO ()+ex3run1 = putLatexTrace ex3 "abab"++-------------------------------------------------------------------------------+-- * Example 4+-------------------------------------------------------------------------------++-- |+--+-- >>> match ex4 "aaaabbbb"+-- True+--+-- >>> showRef ex4+-- size: 8+-- show: Ref 0 (Alt Eps (App (Ch "a") (App (Ref 0 <<loop>>) (Ch "b"))))+-- null: True+--+-- >>> matchR ex4 "aaaabbbb"+-- True+--+-- >>> runGen 42 (generate 10 20 ex4)+-- "aabb"+--+-- >>> runGen 45 (generate 10 20 ex4)+-- "aaabbb"+--+ex4 :: RE Void+ex4 = Fix "x" (Eps \/ ch_ 'a' <> Var B <> ch_ 'b')++ex4run1 :: IO ()+ex4run1 = putLatexTrace ex4 "aaaabbbb"++-------------------------------------------------------------------------------+-- * Example 5+-------------------------------------------------------------------------------++-- |+--+-- >>> match ex5 "abab"+-- True+--+-- >>> match ex5 "ababa"+-- False+--+-- >>> showRef ex5+-- size: 8+-- show: Ref 0 (Alt Eps (App (Ref 0 <<loop>>) (App (Ch "a") (Ch "b"))))+-- null: True+--+-- >>> matchR ex5 "abab"+-- True+--+-- >>> matchR ex5 "ababa"+-- False+--+-- >>> runGen 42 (generate 10 20 ex5)+-- "ab"+--+-- >>> runGen 45 (generate 10 20 ex5)+-- "ababab"+--+ex5 :: RE Void+ex5 = Fix "x" (Eps \/ Var B <> ch_ 'a' <> ch_ 'b')++ex5run1 :: IO ()+ex5run1 = putLatexTrace ex5 "abab"++-------------------------------------------------------------------------------+-- * Example 6+-------------------------------------------------------------------------------++-- |+--+-- Using fix-point operator:+--+-- @+-- fix expr = "(" expr ")" | "1" | "2" | ... | "9" | expr "+" expr | expr "*" expr+-- @+--+-- which in BNF is almost he same+--+-- @+-- expr ::= "(" expr ")" | "1" | "2" | ... | "9" | expr "+" expr | expr "*" expr+-- @+--+-- >>> matchR ex6 "(1+2)*3"+-- True+--+-- >>> runGen 42 (generate 5 5 ex6)+-- "96+(09493+90790)*19"+--+ex6 :: RE Void+ex6 = let_ "d" (Ch "0123456789")+ $ let_ "n" (Var B <> star_ (Var B))+ $ fix_ "e"+ $ ch_ '(' <> Var B <> ch_ ')'+ \/ Var (F B)+ \/ Var B <> ch_ '+' <> Var B+ \/ Var B <> ch_ '*' <> Var B++--+-- (displayTraced . traced) is "match" function, which+-- also prints the trace of execution.+--+-- True+ex6run1 :: IO ()+ex6run1 = putLatexTrace ex6 "1*(20+3)"++-------------------------------------------------------------------------------+-- * Example 7+-------------------------------------------------------------------------------++#ifndef RERE_NO_CFG+exCfg :: Ord a => CFG N.Nat5 a+exCfg =+ digit ::: digits ::: term ::: mult ::: expr ::: VNil+ where+ expr = Alt (multV <> ch_ '*' <> exprV) multV+ mult = Alt (termV <> ch_ '+' <> multV) termV+ term = Alt digitsV (ch_ '(' <> exprV <> ch_ ')')++ digit = Ch "0123456789"+ digits = digitV <> star_ digitV++ digitV, digitsV, exprV, multV, termV :: CFGBase N.Nat5 a+ exprV = Var $ Left F.fin4+ multV = Var $ Left F.fin3+ termV = Var $ Left F.fin2+ digitsV = Var $ Left F.fin1+ digitV = Var $ Left F.fin0++exCfgN :: Vec N.Nat5 Name+exCfgN = "digit" ::: "digits" ::: "term" ::: "mult" ::: "expr" ::: VNil++-- |+--+-- >>> matchR ex7 "12"+-- True+--+-- >>> matchR ex7 "(1+2)*3"+-- True+--+-- >>> charClasses ex7+-- fromList "\NUL()*+,0:"+--+-- >>> runGen 42 (generate 5 5 ex7)+-- "(0181+912595*00+((1228)+467+(80)+(216406))*(65)+4+5*5149+994734)"+--+ex7 :: Ord a => RE a+ex7 = cfgToRE exCfgN exCfg++-- ex7 :: RE Void+-- ex7 = Let "digit" (Ch '0' \/ Ch '1' \/ Ch '2' \/ Ch '3')+-- $ Let "digits" (Var B <> star (Var B))+-- $ Fix "expr"+-- $ Let "term" (Var (F B) \/ Ch '(' <> Var B <> Ch ')')+-- $ Let "mult" (Fix "mult" $ Var (F B) <> Ch '+' <> Var B \/ Var (F B))+-- $ Var B <> Ch '*' <> Var (F B) \/ Var B++ex7run1 :: IO ()+ex7run1 = ex7run "1*(20+3)"++ex7run :: String -> IO ()+ex7run str = putLatexTrace ex7 str+#endif++ex7parsec :: P.Parser ()+ex7parsec = expr where+ expr = void $ P.try (mult >> P.char '*' >> expr) <|> mult+ mult = void $ P.try (term >> P.char '+' >> mult) <|> term+ term = P.try digits <|> void (P.char '(' *> expr *> P.char ')')+ digits = void $ some digit+ digit = P.satisfy (\c -> c >= '0' && c <= '9')++ex7parsecRun :: IO ()+ex7parsecRun = P.parseTest ex7parsec "1*(20+3)"++-------------------------------------------------------------------------------+-- * Example 8+-------------------------------------------------------------------------------++#ifdef RERE_INTERSECTION+xnyn :: Name -> Char -> Char -> RE Void+xnyn n x y = Fix n (Eps \/ ch_ x <> Var B <> ch_ y)++ambncn :: RE Void+ambncn = star_ (ch_ 'a') <> xnyn "bc" 'b' 'c'++anbncm :: RE Void+anbncm = xnyn "ab" 'a' 'b' <> star_ (ch_ 'c')++-- |+--+-- >>> match ex8 "aabbcc"+-- True+--+-- >>> match ex8 "aabbccc"+-- False+--+-- >> matchR ex8 "aabbcc"+-- True+--+-- >> matchR ex8 "aabbccc"+-- False+--+-- >>> runGen 42 (generate 10 20 ex8)+-- "<<null>>"+--+ex8 :: RE Void+ex8 = ambncn /\ anbncm++ex8run1 :: IO ()+ex8run1 = putLatexTrace ex8 "aaabbbccc"++-- |+--+-- >> matchR ex8b "aabbccaaabbbccc"+-- True+ex8b :: RE Void+ex8b = Fix "abc" (Eps \/ vacuous ex8 <> Var B)++ex8run2 :: IO ()+ex8run2 = putLatexTrace ex8b "aabbccaabbcc"++#endif++-------------------------------------------------------------------------------+-- * Example 9+-------------------------------------------------------------------------------++#ifdef RERE_INTERSECTION++evenRE :: RE Void+evenRE = star_ (ch_ 'a' <> ch_ 'a')++oddRE :: RE Void+oddRE = ch_ 'a' <> evenRE++evenRE' :: RE Void+evenRE' = fix_ "even" (Eps \/ ch_ 'a' <> ch_ 'a' <> Var B)++oddRE' :: RE Void+oddRE' = ch_ 'a' <> evenRE'++ex9 :: RE Void+ex9 = let_ "odd" oddRE+ $ let_ "even" (fmap F evenRE)+ $ Var B /\ Var (F B)++ex9run1 :: IO ()+ex9run1 = putLatexTrace ex9 "aaa"++ex9b :: RE Void+ex9b = let_ "odd" oddRE'+ $ let_ "even" (fmap F evenRE')+ $ Var B /\ Var (F B)++ex9run2 :: IO ()+ex9run2 = putLatexTrace ex9b "aaa"+#endif
+ src/RERE/Examples/JSON.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+#if __GLASGOW_HASKELL__ < 709+{-# OPTIONS_GHC -fcontext-stack=50 #-}+#endif+-- | JSON grammar example.+module RERE.Examples.JSON where++import Prelude hiding (exponent)++import Data.Vec.Lazy (Vec (..))+import Data.Void (Void)++import qualified Data.Type.Nat as N+import qualified Data.Vec.Lazy as V++import RERE+import qualified RERE.CharSet as CS++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++-- | Size of JSON grammar, 22.+type Size = N.Mult2 (N.Plus N.Nat5 N.Nat6)++-- | JSON recursive regular expression constructor from 'jsonCFG'.+--+-- @+-- 'jsonRE'' = 'compact' ('cfgToRE' 'jsonNames' 'jsonCFG')+-- @+--+-- The conversion doesn't optimize the resulting regular expression,+-- but is relatively fast.+--+-- >>> size (cfgToRE jsonNames jsonCFG)+-- 232+--+-- 'jsonRE' is pre-calculated variant.+--+-- >>> size jsonRE+-- 205+--+jsonRE' :: RE Void+jsonRE' = compact (cfgToRE jsonNames jsonCFG)++-- | Names of 'jsonCFG' productions.+jsonNames :: Vec Size Name+jsonNames = V.reverse $+ "json" ::: "value" ::: "object" ::: "members" ::: "member" ::: "array" ::: "elements" ::: "element" ::: "string" ::: "characters" ::: "character" ::: "escape" ::: "hex" ::: "number" ::: "integer" ::: "digits" ::: "digit" ::: "onenine" ::: "fraction" ::: "exponent" ::: "sign" ::: "ws" ::: VNil++-- | JSON grammar+jsonCFG :: forall a. Ord a => CFG Size a+jsonCFG = V.reverse $+ json ::: value ::: object ::: members ::: member ::: array ::: elements ::: element ::: string ::: characters ::: character ::: escape ::: hex ::: number ::: integer ::: digits ::: digit ::: onenine ::: fraction ::: exponent ::: sign ::: ws ::: VNil+ where++ _jsonV, valueV, objectV, membersV, memberV, arrayV, elementsV, elementV, stringV, charactersV, characterV, escapeV, hexV, numberV, integerV, digitsV, digitV, onenineV, fractionV, exponentV, signV, wsV :: CFGBase Size a+ _jsonV = Var $ Left 21+ valueV = Var $ Left 20+ objectV = Var $ Left 19+ membersV = Var $ Left 18+ memberV = Var $ Left 17+ arrayV = Var $ Left 16+ elementsV = Var $ Left 15+ elementV = Var $ Left 14+ stringV = Var $ Left 13+ charactersV = Var $ Left 12+ characterV = Var $ Left 11+ escapeV = Var $ Left 10+ hexV = Var $ Left 9+ numberV = Var $ Left 8+ integerV = Var $ Left 7+ digitsV = Var $ Left 6+ digitV = Var $ Left 5+ onenineV = Var $ Left 4+ fractionV = Var $ Left 3+ exponentV = Var $ Left 2+ signV = Var $ Left 1+ wsV = Var $ Left 0++ -- json+ -- element+ --+ json = elementV++ -- value+ -- object+ -- array+ -- string+ -- number+ -- "true"+ -- "false"+ -- "null"+ --+ value = unions [ objectV, arrayV, stringV, numberV, "true", "false", "null" ]++ -- object+ -- '{' ws '}'+ -- '{' members '}'+ --+ object = "{" <> wsV <> "}" \/ "{" <> membersV <> "}"++ -- members+ -- member+ -- member ',' members+ --+ members = memberV \/ memberV <> "," <> membersV++ -- member+ -- ws string ws ':' element+ --+ member = wsV <> stringV <> wsV <> ":" <> elementV++ -- array+ -- '[' ws ']'+ -- '[' elements ']'+ --+ array = "[" <> wsV <> "]" \/ "[" <> elementsV <> "]"++ -- elements+ -- element+ -- element ',' elements+ --+ elements = elementV \/ elementV <> "," <> elementsV++ -- element+ -- ws value ws+ --+ element = wsV <> valueV <> wsV++ -- string+ -- '"' characters '"'+ --+ string = "\"" <> charactersV <> "\""++ -- characters+ -- ""+ -- character characters+ --+ characters = "" \/ characterV <> charactersV++ -- character+ -- '0020' . '10FFFF' - '"' - '\'+ -- '\' escape+ --+ character = Ch chars \/ "\\" <> escapeV++ chars = CS.fromList [ c | c <- ['\x20' .. maxBound ], c /= '"', c /= '\\' ]++ -- escape+ -- '"'+ -- '\'+ -- '/'+ -- 'b'+ -- 'f'+ -- 'n'+ -- 'r'+ -- 't'+ -- 'u' hex hex hex hex+ --+ escape =+ Ch (CS.fromList "\"\\/bfnrt")+ \/ "u" <> hexV <> hexV <> hexV <> hexV++ -- hex+ -- digit+ -- 'A' . 'F'+ -- 'a' . 'f'+ hex = digitV <> Ch (CS.fromList "ABCDEFabcdef")++ -- number+ -- integer fraction exponent+ --+ number = integerV <> fractionV <> exponentV++ -- integer+ -- digit+ -- onenine digits+ -- '-' digit+ -- '-' onenine digits+ --+ integer = digitV \/ onenineV <> digitsV \/ "-" <> digitV \/ "-" <> onenineV <> digitsV++ -- digits+ -- digit+ -- digit digits+ --+ digits = digitV \/ digitV <> digitsV++ -- digit+ -- '0'+ -- onenine+ --+ digit = "0" \/ onenineV++ -- onenine+ -- '1' . '9'+ --+ onenine = Ch (CS.fromList "123456789")++ -- fraction+ -- ""+ -- '.' digits+ --+ fraction = "" \/ "." <> digitsV++ -- exponent+ -- ""+ -- 'E' sign digits+ -- 'e' sign digits+ --+ exponent = "" \/ "E" <> signV <> digitsV \/ "e" <> signV <> digitsV++ -- sign+ -- ""+ -- '+'+ -- '-'+ --+ sign = "" \/ "+" \/ "-"++ -- ws+ -- ""+ -- '0020' ws+ -- '000A' ws+ -- '000D' ws+ -- '0009' ws+ --+ ws = unions ["", "\x20" <> wsV, "\x0A" <> wsV, "\x0D" <> wsV, "\x09" <> wsV ]++ -- unions+ unions = foldr (\/) Null++-------------------------------------------------------------------------------+-- Cheat+-------------------------------------------------------------------------------++-- | Pre-calculated JSON grammar as regular expression.+--+-- >>> size jsonRE+-- 205+--+-- See 'jsonRE'' for one constructed from 'jsonCFG'.+--+jsonRE :: RE Void+jsonRE =+ Let "ws" (Fix "ws" (Alt Eps (Alt (App (Ch " ") (Var B)) (Alt (App (Ch "\n") (Var B)) (Alt (App (Ch "\r") (Var B)) (App (Ch "\t") (Var B))))))) (Let "hex" (App (Ch "0123456789") (Ch "ABCDEFabcdef")) (Let "escape" (Alt (Ch "\"/\\bfnrt") (App (Ch "u") (App (Var B) (App (Var B) (App (Var B) (Var B)))))) (Let "character" (Alt (Ch (CS.fromIntervalList [('\32','\33'),('\35','\91'),('\93','\1114111')])) (App (Ch "\\") (Var B))) (Let "characters" (Fix "characters" (Alt Eps (App (Var (F B)) (Var B)))) (Let "string" (App (Ch "\"") (App (Var B) (Ch "\""))) (Let "digits" (Fix "digits" (Alt (Ch "0123456789") (App (Ch "0123456789") (Var B)))) (Let "integer" (Alt (Ch "0123456789") (Alt (App (Ch "123456789") (Var B)) (Alt (App (Ch "-") (Ch "0123456789")) (App (Ch "-") (App (Ch "123456789") (Var B)))))) (Let "fraction" (Alt Eps (App (Ch ".") (Var (F B)))) (Let "sign" (Alt Eps (Ch "+-")) (Let "exponent" (Alt Eps (Alt (App (Ch "E") (App (Var B) (Var (F (F (F B)))))) (App (Ch "e") (App (Var B) (Var (F (F (F B)))))))) (Let "number" (App (Var (F (F (F B)))) (App (Var (F (F B))) (Var B))) (Let "value" (Fix "value" (Let "element" (App (Var (F (F (F (F (F (F (F (F (F (F (F (F B))))))))))))) (App (Var B) (Var (F (F (F (F (F (F (F (F (F (F (F (F B))))))))))))))) (Let "member" (App (Var (F (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))) (App (Var (F (F (F (F (F (F (F (F B))))))))) (App (Var (F (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))) (App (Ch ":") (Var B))))) (Let "members" (Fix "members" (Alt (Var (F B)) (App (Var (F B)) (App (Ch ",") (Var B))))) (Let "object" (Alt (App (Ch "{") (App (Var (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))))) (Ch "}"))) (App (Ch "{") (App (Var B) (Ch "}")))) (Let "elements" (Fix "elements" (Alt (Var (F (F (F (F B))))) (App (Var (F (F (F (F B))))) (App (Ch ",") (Var B))))) (Let "array" (Alt (App (Ch "[") (App (Var (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))))))) (Ch "]"))) (App (Ch "[") (App (Var B) (Ch "]")))) (Alt (Var (F (F B))) (Alt (Var B) (Alt (Var (F (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))) (Alt (Var (F (F (F (F (F (F (F B)))))))) (Alt (App (Ch "t") (App (Ch "r") (App (Ch "u") (Ch "e")))) (Alt (App (Ch "f") (App (Ch "a") (App (Ch "l") (App (Ch "s") (Ch "e"))))) (App (Ch "n") (App (Ch "u") (App (Ch "l") (Ch "l"))))))))))))))))) (App (Var (F (F (F (F (F (F (F (F (F (F (F (F B))))))))))))) (App (Var B) (Var (F (F (F (F (F (F (F (F (F (F (F (F B)))))))))))))))))))))))))))++#ifdef RERE_SLOW_DOCTEST+-- | This are slow tests, take around 90 seconds on my machine+--+-- >>> size jsonRE'+-- 205+--+-- >>> jsonRE == jsonRE'+-- True+--+_doctest1 :: ()+_doctest1 = ()+#endif
+ src/RERE/Gen.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Using 'RE' to generate example 'String's.+module RERE.Gen (generate) where++import Control.Applicative (liftA2)+import Data.Char (ord)+import Data.Void (Void, vacuous)+import Test.QuickCheck (Gen, arbitrary, choose, frequency, oneof)++import RERE.CharSet+import RERE.Type+import RERE.Var++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++-- $setup+-- >>> import Test.QuickCheck.Random (mkQCGen)+-- >>> import Test.QuickCheck.Gen (unGen)+-- >>> let runGen seed = maybe "<<null>>" (\g' -> unGen g' (mkQCGen seed) 10)++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++-- | Generate strings.+--+-- >>> runGen 42 $ generate 10 10 $ star_ (ch_ 'a')+-- "aaa"+--+-- >>> runGen 44 $ generate 10 10 $ star_ (ch_ 'a')+-- "aaaaaaaaaa"+--+generate+ :: Int -- ^ star upper size+ -> Int -- ^ fix unroll+ -> RE Void+ -> Maybe (Gen String)+generate starSize fixSize = fmap (fmap ($ "")) . go . vacuous where+ go :: RE (Maybe (Gen ShowS)) -> Maybe (Gen ShowS)+ go Null = Nothing+ go Full = Just arbitrary+ go Eps = Just (return id)+ go (Ch c) = case toIntervalList c of+ [] -> Nothing+ xs -> Just $ frequency+ [ (ord hi - ord lo + 1, showChar <$> choose (lo,hi))+ | (lo,hi) <- xs+ ]++ go (App x y) = do+ x' <- go x+ y' <- go y+ return (liftA2 (.) x' y')+ go (Alt x y) = alt (go x) (go y) where+ alt (Just x') (Just y') = Just (oneof [x', y'])+ alt x' Nothing = x'+ alt Nothing y' = y'+ go (Star x) = case go x of+ Nothing -> Just (return id)+ Just x' -> Just $ do+ n <- choose (0, starSize)+ if n <= 0+ then return id+ else foldr (\_ acc -> liftA2 (.) acc x') x' [2..n]++#ifdef RERE_INTERSECTION+ -- this is tricky.+ go (And _ _) = Nothing+#endif++ go (Var x) = x+ go (Let _ r s) = go (fmap (unvar (go r) id) s)+ go (Fix _ r) = go' fixSize where+ go' :: Int -> Maybe (Gen ShowS)+ go' n | n <= 0 = Nothing+ | otherwise = go (fmap (unvar (go' (n - 1)) id) r)
+ src/RERE/LaTeX.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+#ifndef RERE_NO_CFG+{-# LANGUAGE Trustworthy #-}+#elif __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Pretty-print structures as LaTeX code.+--+-- Note: doesn't work with MathJax.+--+-- Requires @xcolor@ package. You need to define colors, for example:+--+-- @+-- \\colorlet{rerelit}{red!80!black} % literal characters+-- \\colorlet{reresym}{green!50!black} % symbols: eps and emptyset+-- \\colorlet{rereidn}{blue} % identifiers+-- \\colorlet{rerestr}{red!50!blue} % strings (subscripts)+-- @+--+module RERE.LaTeX (+ putLatex,+ putLatexTrace,+#ifndef RERE_NO_CFG+ putLatexCFG,+#endif+ ) where++import Control.Monad.Trans.State (State, evalState, get, put)+import Data.Char (ord)+import Data.Foldable (for_)+import Data.List (intersperse)+import Data.Set (Set)+import Data.String (IsString (..))+import Data.Void (Void)++import qualified Data.Set as Set+import qualified RERE.CharSet as CS++import RERE.Absurd+import RERE.Type+import RERE.Var++#ifndef RERE_NO_CFG+import RERE.CFG++import Data.Vec.Lazy (Vec (..))+import qualified Data.Vec.Lazy as V+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++-- | Pretty-print 'RE' as LaTeX code.+putLatex :: RE Void -> IO ()+putLatex = putStrLn . latexify++-------------------------------------------------------------------------------+-- Latex utilities+-------------------------------------------------------------------------------++data Prec+ = BotPrec+ | AltPrec+#ifdef RERE_INTERSECTION+ | AndPrec+#endif+ | AppPrec+ | StarPrec+ deriving (Eq, Ord, Enum, Show)++literalColor :: String+symbolColor :: String+identColor :: String+stringColor :: String++#if !defined(NO_COLOR)+literalColor = "\\color{rerelit}"+symbolColor = "\\color{reresym}"+identColor = "\\color{rereidn}"+stringColor = "\\color{rerestr}"+#else+literalColor = ""+symbolColor = ""+identColor = ""+stringColor = ""+#endif++data Piece = Piece !Bool !Bool ShowS++instance IsString Piece where+ fromString = piece . showString++piece :: ShowS -> Piece+piece = Piece False False++unPiece :: Piece -> ShowS+unPiece (Piece _ _ ss) = ss++instance Semigroup Piece where+ Piece a b x <> Piece c d y = Piece a d (x . sep . y) where+ sep | b, c = showString "\\,"+ | otherwise = id++instance Monoid Piece where+ mempty = Piece False False id+ mappend = (<>)++latexify :: RE Void -> String+latexify re0 = unPiece (evalState (latexify' (vacuous re0)) Set.empty) ""++nullPiece :: Piece+nullPiece = fromString $ "{" ++ symbolColor ++ "\\emptyset}"++fullPiece :: Piece+fullPiece = fromString $ "{" ++ symbolColor ++ "\\Sigma^\\ast}"++epsPiece :: Piece+epsPiece = fromString $ "{" ++ symbolColor ++ "\\varepsilon}"++latexify' :: RE Piece -> State (Set NI) Piece+latexify' = go BotPrec where+ go :: Prec -> RE Piece -> State (Set NI) Piece+ go _ Null = return nullPiece+ go _ Full = return fullPiece+ go _ Eps = return epsPiece+ go _ (Ch cs) = return $ case CS.toIntervalList cs of+ [] -> nullPiece+ [(lo,hi)] | lo == hi -> latexCharPiece lo+ xs | sz < sz' -> "\\{" <> mconcat (intersperse ", " $ map latexCharRange xs) <> "\\}"+ | otherwise -> "\\{" <> mconcat (intersperse ", " $ map latexCharRange $ CS.toIntervalList ccs) <> "\\}^c"+ where+ ccs = CS.complement cs+ sz = CS.size cs+ sz' = CS.size ccs++ go d (App r s) = parens (d > AppPrec) $ do+ r' <- go AppPrec r+ s' <- go AppPrec s+ return (r' <> s')++ go d (Alt r s) = parens (d > AltPrec) $ do+ r' <- go AltPrec r+ s' <- go AltPrec s+ return $ r' <> "\\cup" <> s'++#ifdef RERE_INTERSECTION+ go d (And r s) = parens (d > AndPrec) $ do+ r' <- go AndPrec r+ s' <- go AndPrec s+ return $ r' <> "\\cap" <> s'+#endif++ go d (Star r) = parens (d > StarPrec) $ do+ r' <- go StarPrec r+ return (r' <> "^\\star")++ go _ (Var x) = return x++ go d (Let n (Fix _ r) s@Let {}) = parens (d > BotPrec) $ do+ i <- newUnique n+ let v = showVar n i+ let r' = fmap (unvar v id) r+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r'++ let acc = "\\begin{aligned}[t] \\mathbf{let}\\, &"+ <> v <> "=_R" <> r2++ goLet acc s'++ go d (Let n r s@Let {}) = parens (d > BotPrec) $ do+ i <- newUnique n+ let v = showVar n i+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r++ let acc = "\\begin{aligned}[t] \\mathbf{let}\\, &"+ <> v <> "=" <> r2++ goLet acc s'++ go d (Let n (Fix _ r) s) = parens (d > BotPrec) $ do+ i <- newUnique n+ let v = showVar n i+ let r' = fmap (unvar v id) r+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r'+ s2 <- go BotPrec s'++ return $ "\\mathbf{let}\\,"+ <> v <> "=_R" <> r2+ <> "\\,\\mathbf{in}\\,"+ <> s2++ go d (Let n r s) = parens (d > BotPrec) $ do+ i <- newUnique n+ let v = showVar n i+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r+ s2 <- go BotPrec s'++ return $ "\\mathbf{let}\\,"+ <> v <> "=" <> r2+ <> "\\,\\mathbf{in}\\,"+ <> s2++ go d (Fix n r) = parens (d > BotPrec) $ do+ i <- newUnique n+ let v = showVar n i+ let r' = fmap (unvar v id) r++ r'' <- go BotPrec r'+ return $ piece $ showString "\\mathbf{fix}\\," . unPiece v . showChar '=' . unPiece r''+++ goLet :: Piece -> RE Piece -> State (Set NI) Piece+ goLet acc0 (Let n (Fix _ r) s) = do+ i <- newUnique n+ let v = showVar n i+ let r' = fmap (unvar v id) r+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r'++ let acc = acc0 <> " \\\\ &"+ <> v <> "=_R" <> r2++ goLet acc s'++ goLet acc0 (Let n r s) = do+ i <- newUnique n+ let v = showVar n i+ let s' = fmap (unvar v id) s++ r2 <- go BotPrec r++ let acc = acc0 <> " \\\\ &"+ <> v <> "=" <> r2++ goLet acc s'++ goLet acc s = do+ s' <- go BotPrec s+ return $ acc <> "\\\\ \\mathbf{in}\\, &" <> s' <> "\\end{aligned}"++ parens :: Bool -> State (Set NI) Piece -> State (Set NI) Piece+ parens True = fmap $ \(Piece _ _ x) -> piece $ showChar '(' . x . showChar ')'+ parens False = id++latexChar :: Char -> String+latexChar = latexChar' literalColor++latexChar' :: String -> Char -> String+latexChar' col '*' = "\\text{" ++ col ++ "*}"+latexChar' col '+' = "\\text{" ++ col ++ "+}"+latexChar' col '-' = "\\text{" ++ col ++ "-}"+latexChar' col '(' = "\\text{" ++ col ++ "(}"+latexChar' col ')' = "\\text{" ++ col ++ ")}"+latexChar' col '[' = "\\text{" ++ col ++ "[}"+latexChar' col ']' = "\\text{" ++ col ++ "]}"+latexChar' col '\\' = "\\text{" ++ col ++ "\\textbackslash}"+latexChar' col '#' = "\\text{" ++ col ++ "\\#}"+latexChar' col c+ | c <= '\x20' || c >= '\127' = show (ord c)+ | otherwise = "{" ++ col ++ "\\mathtt{" ++ [c] ++ "}}"++latexCharPiece :: Char -> Piece+latexCharPiece c = "{" <> fromString (latexChar c) <> "}"++latexCharRange :: (Char, Char) -> Piece+latexCharRange (lo, hi)+ | lo == hi = latexCharPiece lo+ | otherwise = latexCharPiece lo <> " \\ldots " <> latexCharPiece hi++data NI = NI String [Char] Int deriving (Eq, Ord)++newUnique :: Name -> State (Set NI) Int+newUnique (N n cs) = get >>= go 0 where+ go i s | Set.member (NI n cs i) s = go (i + 1) s+ | otherwise = do+ put (Set.insert (NI n cs i) s)+ return i++showVar :: Name -> Int -> Piece+showVar (N n cs) i+ = Piece True True+ $ showString $ "{" ++ identColor ++ "\\mathit{" ++ n ++ "}" ++ sub ++ "}"+ where+ cs' = showCS cs+ i' = showI i++ sub | null cs && null i' = ""+ | not (null cs) && not (null i') = "_{" ++ cs' ++ ";" ++ i' ++ "}"+ | otherwise = "_{" ++ cs' ++ i' ++ "}"++ showCS :: [Char] -> String+ showCS ds = "\\mathtt{" ++ stringColor ++ concatMap (latexChar' "") ds ++ "}"++ showI :: Int -> String+ showI 0 = ""+ showI j = show j++-------------------------------------------------------------------------------+-- Trace+-------------------------------------------------------------------------------++-- | Run 'match' variant, collect intermediate steps, and+-- pretty-print that trace.+--+putLatexTrace :: RE Void -> String -> IO ()+putLatexTrace re str = displayTrace (traced re str)++traced :: RE Void -> String -> (Bool, RE Void, [(String, RE Void)])+traced = go id where+ go acc re [] = (nullable re, re, acc [])+ go acc re str@(c:cs) = go (acc . ((str, re) :)) (derivative c re) cs++displayTrace :: (Bool, RE Void, [(String, RE Void)]) -> IO ()+displayTrace (matched, final, steps) = do+ putStrLn "\\begin{aligned}"+ for_ steps $ \(str, re) ->+ putStrLn $ "& \\mathtt{" ++ stringColor ++ concatMap (latexChar' "") str ++ "} &&\\vdash" ++ sub (nullable re) ++ " " ++ latexify re ++ " \\\\"+ putStrLn $ "&{" ++ symbolColor ++ " \\varepsilon} &&\\vdash" ++ sub matched ++ " " ++ latexify final ++ " \\\\"+ putStrLn "\\end{aligned}"++ print matched+ print final++ where+ -- sub True = "_\\varepsilon"+ -- sub False = "_\\kappa"+ sub _ = ""++-------------------------------------------------------------------------------+-- CFG+-------------------------------------------------------------------------------++#ifndef RERE_NO_CFG+-- | Pretty-print 'CFG' given the names.+putLatexCFG :: Vec n Name -> CFG n Void -> IO ()+putLatexCFG names cfg = putStrLn (latexifyCfg names cfg)++latexifyCfg :: forall n. Vec n Name -> CFG n Void -> String+latexifyCfg names cfg =+ unlines $ ["\\begin{aligned}"] ++ go names cfg ++ ["\\end{aligned}"]+ where+ initS :: State (Set NI) ()+ initS = for_ names newUnique++ go :: Vec m Name -> Vec m (CFGBase n Void) -> [String]+ go VNil VNil = []+ go (n ::: ns) (e ::: es) = eq' : go ns es where+ e' = fmap (either (\i -> showVar (names V.! i) 0) absurd) e+ n' = showVar n 0++ eq = do+ initS+ e'' <- latexify' e'+ return $ n' <> " &= " <> e'' <> " \\\\"++ eq' :: String+ eq' = unPiece (evalState eq Set.empty) ""+#if __GLASGOW_HASKELL__ <711+ go _ _ = error "silly GHC"+#endif+#endif
+ src/RERE/Ref.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Regular expression with explicit sharing.+--+-- 'RR' is an opaque type, to maintain the invariants.+module RERE.Ref (+ RR,+ matchR, matchDebugR,+ ) where++import Control.Monad.Fix (mfix)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State+ (State, StateT, evalState, evalStateT, get, modify, put, runState)+import Data.Void (Void, vacuous)++import qualified Data.Map as Map+import qualified Data.Set as Set++import RERE.CharClasses+import qualified RERE.CharSet as CS+import qualified RERE.Type as R+import RERE.Var++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$), (<$>), (<*>))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++import Control.Monad.ST+import Data.STRef++-------------------------------------------------------------------------------+-- Type+-------------------------------------------------------------------------------++-- | Knot-tied recursive regular expression.+data RR s+ = Eps+ | Ch CS.CharSet+ | App (RR s) (RR s)+ | Alt (RR s) (RR s)+#ifdef RERE_INTERSECTION+ | And (RR s) (RR s)+#endif+ | Star (RR s)+ | Ref !Int !(STRef s (Map.Map Char (RR s))) (RR s)++instance Show (RR s) where+ showsPrec = go Set.empty where+ go :: Set.Set Int -> Int -> RR s -> ShowS+ go _ _ Eps = showString "Eps"+ go _ d (Ch c) = showParen (d > 10) $ showString "Ch " . showsPrec 11 c+ go past d (App r s)+ = showParen (d > 10)+ $ showString "App"+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+ go past d (Alt r s)+ = showParen (d > 10)+ $ showString "Alt"+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+#ifdef RERE_INTERSECTION+ go past d (And r s)+ = showParen (d > 10)+ $ showString "And"+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+#endif+ go past d (Star r)+ = showParen (d > 10)+ $ showString "Star"+ . showChar ' ' . go past 11 r++ go past d (Ref i _ r)+ | Set.member i past = showParen (d > 10)+ $ showString "Ref " . showsPrec 11 i . showString " <<loop>>"+ | otherwise = showParen (d > 10)+ $ showString "Ref " . showsPrec 11 i . showChar ' ' . go (Set.insert i past) 11 r++-------------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------------++-- | Convert 'R.RE' to 'RR'.+fromRE :: R.RE Void -> M s (RR s)+fromRE re = go (vacuous re) where+ go R.Null = return nullRR+ go R.Full = return fullRR+ go R.Eps = return Eps+ go (R.Ch c) = return (Ch c)++ go (R.App r s) = do+ r' <- go r+ s' <- go s+ return (app_ r' s')++ go (R.Alt r s) = do+ r' <- go r+ s' <- go s+ return (alt_ r' s')++#ifdef RERE_INTERSECTION+ go (R.And r s) = do+ r' <- go r+ s' <- go s+ return (and_ r' s')+#endif++ go (R.Star r) = do+ r' <- go r+ return (star_ r')++ go (R.Var r) = return r++ go (R.Let _ r s) = do+ r' <- go r+ -- it looks like we shouldn't memoize here+ -- both simple and json benchmark are noticeably faster.+ go (fmap (unvar r' id) s)++ go (R.Fix _ r) = mfix $ \res -> do+ i <- newId+ ref <- lift (newSTRef Map.empty)+ r' <- go (fmap (unvar res id) r)+ return (Ref i ref r')++_size :: RR s -> Int+_size rr = evalState (go rr) Set.empty where+ go Eps = return 1+ go (Ch _) = return 1+ go (App r s) = plus1 <$> go r <*> go s+ go (Alt r s) = plus1 <$> go r <*> go s+#ifdef RERE_INTERSECTION+ go (And r s) = plus1 <$> go r <*> go s+#endif+ go (Star r) = succ <$> go r+ go (Ref i _ r) = do+ visited <- get+ if Set.member i visited+ then return 1+ else do+ put (Set.insert i visited)+ succ <$> go r++ plus1 x y = succ (x + y)++-------------------------------------------------------------------------------+-- Variable supply monad+-------------------------------------------------------------------------------++type M s = StateT Int (ST s)++newId :: M s Int+newId = do+ i <- get+ put $! i + 1+ return i++_returnI :: RR s -> M s (RR s)+_returnI r@Eps = return r+_returnI r@Ch {} = return r+_returnI r@Ref {} = return r+_returnI r = do+ i <- newId+ ref <- lift (newSTRef Map.empty)+ return (Ref i ref r)++-------------------------------------------------------------------------------+-- Smart constructors+-------------------------------------------------------------------------------++nullRR :: RR s+nullRR = Ch CS.empty++fullRR :: RR s+fullRR = Star (Ch CS.universe)++isNull :: RR s -> Bool+isNull (Ch c) = CS.null c+isNull _ = False++isFull :: RR s -> Bool+isFull (Star (Ch x)) = x == CS.universe+isFull _ = False++app_ :: RR s -> RR s -> RR s+app_ r _ | isNull r = r+app_ _ r | isNull r = r+app_ Eps r = r+app_ r Eps = r+app_ r s = App r s++alt_ :: RR s -> RR s -> RR s+alt_ r s | isNull r = s+alt_ r s | isNull s = r+alt_ r s | isFull r || isFull s = fullRR+alt_ (Ch a) (Ch b) = Ch (CS.union a b)+alt_ r s = Alt r s++#ifdef RERE_INTERSECTION+and_ :: RR s -> RR s -> RR s+and_ r s | isFull r = s+and_ r s | isFull s = r+and_ r s | isNull r || isNull s = nullRR+and_ (Ch a) (Ch b) = Ch (CS.intersection a b)+and_ r s = And r s+#endif++star_ :: RR s -> RR s+star_ r | isNull r+ = Eps+star_ Eps = Eps+star_ r@(Star _) = r+star_ r = Star r++-------------------------------------------------------------------------------+-- Match+-------------------------------------------------------------------------------++-- | Convert 'R.RE' to 'RR' and then match.+--+-- Significantly faster than 'RERE.Type.match'.+--+matchR :: R.RE Void -> String -> Bool+matchR re str = runST (evalStateT (fromRE re >>= go0) 0)+ where+ go0 :: RR s -> M s Bool+ go0 rr = do+ let cc = charClasses re+ go cc str rr++ go :: CharClasses -> String -> RR s -> M s Bool+ go _ [] rr = return $ nullableR rr+ go cc (c:cs) rr = do+ let c' = classOfChar cc c+ rr' <- derivative c' rr+ go cc cs rr'++-- | Match and print final 'RR' + stats.+matchDebugR :: R.RE Void -> String -> IO ()+matchDebugR re str = runST (evalStateT (fromRE re >>= go0) 0)+ where+ go0 :: RR s -> M s (IO ())+ go0 rr = do+ let cc = charClasses re+ go cc str rr++ go :: CharClasses -> String -> RR s -> M s (IO ())+ go _ [] rr = return $ putStr $ unlines+ [ "size: " ++ show (_size rr)+ , "show: " ++ show rr+ , "null: " ++ show (nullableR rr)+ ]++ go cc (c:cs) rr = do+ let c' = classOfChar cc c+ rr' <- derivative c' rr+ go cc cs rr'++-------------------------------------------------------------------------------+-- Derivative+-------------------------------------------------------------------------------++derivative :: Char -> RR s -> M s (RR s)+derivative c = go where+ go :: RR s -> M s (RR s)+ go Eps = return nullRR+ go (Ch x) | CS.member c x = return Eps+ | otherwise = return nullRR++ go (Alt r s) = do+ r' <- go r+ s' <- go s+ return (alt_ r' s')++#ifdef RERE_INTERSECTION+ go (And r s) = do+ r' <- go r+ s' <- go s+ return (and_ r' s')+#endif++ go (App r s)+ | nullableR r = do+ r' <- go r+ s' <- go s+ return $ alt_ s' (app_ r' s)+ | otherwise = do+ r' <- go r+ return $ app_ r' s++ go r0@(Star r) = do+ r' <- go r+ return (app_ r' r0)++ go (Ref _ ref r) = do+ m <- lift (readSTRef ref)+ case Map.lookup c m of+ Just r' -> return r'+ Nothing -> mfix $ \res -> do+ j <- newId+ ref' <- lift (newSTRef Map.empty)+ lift (writeSTRef ref (Map.insert c res m))+ r' <- go r+ return (Ref j ref' r')++-------------------------------------------------------------------------------+-- Nullable equations+-------------------------------------------------------------------------------++-- | Whether 'RR' is nullable.+--+-- @+-- 'R.nullable' re = 'nullableR' ('fromRE' re)+-- @+nullableR :: RR s -> Bool+nullableR r =+ let (bexpr, eqs) = equations r+ in lfp bexpr eqs++equations :: RR s -> (BoolExpr, Map.Map Int BoolExpr)+equations r =+ let (bexpr, next) = runState (collectEquation r) Map.empty+ in (bexpr, collectEquations next)++collectEquations :: Map.Map Int (RR s)-> Map.Map Int BoolExpr+collectEquations = go Map.empty where+ go acc queue = case Map.minViewWithKey queue of+ Nothing -> acc+ Just ((i, r), queue')+ | Map.member i acc -> go acc queue'+ | otherwise ->+ let (bexpr, next) = runState (collectEquation r) Map.empty+ in go (Map.insert i bexpr acc) (queue' <> next)++collectEquation :: RR s -> State (Map.Map Int (RR s)) BoolExpr+collectEquation Eps = return BTrue+collectEquation (Ch _) = return BFalse+collectEquation (App r s) = band <$> collectEquation r <*> collectEquation s+collectEquation (Alt r s) = bor <$> collectEquation r <*> collectEquation s+collectEquation (Star _) = return BTrue+collectEquation (Ref i _ r) = do+ modify (Map.insert i r)+ return (BVar i)+#ifdef RERE_INTERSECTION+collectEquation (And r s) = band <$> collectEquation r <*> collectEquation s+#endif++lfp :: BoolExpr -> Map.Map Int BoolExpr -> Bool+lfp b exprs = go (False <$ exprs) where+ go curr+ | curr == next = evaluate b+ | otherwise = go next+ where+ next = fmap evaluate exprs++ evaluate :: BoolExpr -> Bool+ evaluate BTrue = True+ evaluate BFalse = False+ evaluate (BOr x y) = evaluate x || evaluate y+ evaluate (BAnd x y) = evaluate x && evaluate y+ evaluate (BVar i) = Map.findWithDefault False i curr++-------------------------------------------------------------------------------+-- BoolExpr+-------------------------------------------------------------------------------++data BoolExpr+ = BVar Int+ | BTrue+ | BFalse+ | BOr BoolExpr BoolExpr+ | BAnd BoolExpr BoolExpr+ deriving (Show)++band :: BoolExpr -> BoolExpr -> BoolExpr+band BFalse _ = BFalse+band _ BFalse = BFalse+band BTrue r = r+band r BTrue = r+band r s = BAnd r s++bor :: BoolExpr -> BoolExpr -> BoolExpr+bor BFalse r = r+bor r BFalse = r+bor BTrue _ = BTrue+bor _ BTrue = BTrue+bor r s = BOr r s
+ src/RERE/ST.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE CPP #-}+-- #define RERE_DEBUG++{-# LANGUAGE ScopedTypeVariables #-}++#ifdef RERE_DEBUG+#if __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+#else+#if __GLASGOW_HASKELL__ >=710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+#endif++-- | Regular expression with explicit sharing.+--+-- 'RST' is an opaque type, to maintain the invariants.+module RERE.ST (+ RST,+ matchST,+ matchDebugST,+ ) where++#ifdef RERE_DEBUG+import Debug.Trace+#endif++import Control.Monad.Fix (mfix)+import Control.Monad.Trans.State (State, evalState, get, modify, put, runState)+import Data.Void (Void, vacuous)+import Data.Word (Word64)++import qualified Data.Map as Map+import qualified Data.Set as Set++import RERE.CharClasses+import qualified RERE.CharSet as CS+import qualified RERE.Type as R+import RERE.Var++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$), (<$>), (<*>))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++import Control.Monad.ST+import Data.STRef++-- Alt (Ch "b") (Alt (App (Alt (Star (Ch "c")) (Ch "c")) Full) (Ch "de"))+-- Alt Null (App Eps Full)++-------------------------------------------------------------------------------+-- Parameters+-------------------------------------------------------------------------------++matchIter :: Int+matchIter = 20++nullableIter :: Int+nullableIter = 10++-------------------------------------------------------------------------------+-- Type+-------------------------------------------------------------------------------++-- | Knot-tied recursive regular expression.+data RST s = RST+ { _rrDef :: Def s+ , _rrId :: !Word64+ , rrDerivative :: !(Char -> ST s (RST s))+ , rrCompact :: !(ST s (RST s))+ }++data Def s+ = Eps+ | Full+ | Ch CS.CharSet+ | App (RST s) (RST s)+ | Alt (RST s) (RST s)+#ifdef RERE_INTERSECTION+ | And (RST s) (RST s)+#endif+ | Star (RST s)++ | Del (RST s)++-------------------------------------------------------------------------------+-- Make+-------------------------------------------------------------------------------++data Ctx s = Ctx+ { ctxId :: STRef s Word64+ , ctxNull :: RST s+ , ctxFull :: RST s+ , ctxEps :: RST s+ }++newCtx :: ST s (Ctx s)+newCtx = do+ i <- newSTRef 3+ let n = RST (Ch CS.empty) 0 (\_ -> return n) (return n)+ let f = RST Full 1 (\_ -> return f) (return f)+ e = RST Eps 2 (\_ -> return n) (return e)++ return (Ctx i n f e)++makeRST :: Ctx s -> Def s -> ST s (RST s)+makeRST ctx def = do+ i <- readSTRef (ctxId ctx)+ writeSTRef (ctxId ctx) (i + 1)+ dref <- newSTRef Map.empty+ cref <- newSTRef Nothing++ let d ch = do+ m <- readSTRef dref+ case Map.lookup ch m of+ Just x -> return x+ Nothing -> mfix $ \deriv -> do+ writeSTRef dref (Map.insert ch deriv m)+ derivativeDef ctx ch def++ let c = do+ mcompacted <- readSTRef cref+ case mcompacted of+ Just compacted -> return compacted+ Nothing -> mfix $ \compacted -> do+ writeSTRef cref (Just compacted)+ compactDef ctx def++ return (RST def i d c)++-------------------------------------------------------------------------------+-- Show+-------------------------------------------------------------------------------++instance Show (RST s) where+ showsPrec = go Set.empty where+ go :: Set.Set Word64 -> Int -> RST s -> ShowS+ go past d (RST def i _ _) =+ if Set.member i past+ then showString "<<loop " . shows i . showString ">>"+ else go' (Set.insert i past) d i def++ go' :: Set.Set Word64 -> Int -> Word64 -> Def s -> ShowS+ go' _ _ _ Eps = showString "Eps"+ go' _ _ _ Full = showString "Full"+ go' _ d _ (Ch c) = showParen (d > 10) $ showString "Ch " . showsPrec 11 c+ go' past d i (App r s)+ = showParen (d > 10)+ $ showString "App"+ . showSub i+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+ go' past d i (Alt r s)+ = showParen (d > 10)+ $ showString "Alt"+ . showSub i+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+#ifdef RERE_INTERSECTION+ go' past d i (And r s)+ = showParen (d > 10)+ $ showString "And"+ . showSub i+ . showChar ' ' . go past 11 r+ . showChar ' ' . go past 11 s+#endif+ go' past d i (Star r)+ = showParen (d > 10)+ $ showString "Star"+ . showSub i+ . showChar ' ' . go past 11 r++ go' past d i (Del r)+ = showParen (d > 10)+ $ showString "Del"+ . showSub i+ . showChar ' ' . go past 11 r++ showSub i = showChar '_' . shows i++_size :: RST s -> Int+_size rr = evalState (go rr) Set.empty where+ go (RST def i _ _) = do+ visited <- get+ if Set.member i visited+ then return 1+ else do+ put (Set.insert i visited)+ succ <$> go' def++ go' Eps = return 0+ go' Full = return 0+ go' (Ch _) = return 0+ go' (App r s) = plus1 <$> go r <*> go s+ go' (Alt r s) = plus1 <$> go r <*> go s+#ifdef RERE_INTERSECTION+ go' (And r s) = plus1 <$> go r <*> go s+#endif+ go' (Star r) = succ <$> go r+ go' (Del r) = succ <$> go r++ plus1 x y = succ (x + y)++-------------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------------++-- | Convert 'R.RE' to 'RST'.+fromRE :: forall s. Ctx s -> R.RE Void -> ST s (RST s)+fromRE ctx re = go (vacuous re) where+ go :: R.RE (RST s) -> ST s (RST s)++ go R.Null = return (ctxNull ctx)+ go R.Full = return (ctxFull ctx)+ go R.Eps = return (ctxEps ctx)+ go (R.Ch c)+ | CS.null c = return (ctxNull ctx)+ | otherwise = makeRST ctx (Ch c)++ go (R.App r s) = do+ r' <- go r+ s' <- go s+ makeRST ctx (App r' s')++ go (R.Alt r s) = do+ r' <- go r+ s' <- go s+ makeRST ctx (Alt r' s')++#ifdef RERE_INTERSECTION+ go (R.And r s) = do+ r' <- go r+ s' <- go s+ makeRST ctx (And r' s')+#endif++ go (R.Star r) = do+ r' <- go r+ makeRST ctx (Star r')++ go (R.Var r) = return r++ go (R.Let _ r s) = do+ r' <- go r+ go (fmap (unvar r' id) s)++ go (R.Fix _ r) = mfix $ \res -> do+ go (fmap (unvar res id) r)++-------------------------------------------------------------------------------+-- Match+-------------------------------------------------------------------------------++-- | Convert 'R.RE' to 'RST' and then match.+--+-- Significantly faster than 'RERE.Type.match'.+matchST :: R.RE Void -> String -> Bool+matchST re str = runST go0+ where+ go0 :: ST s Bool+ go0 = do+ ctx <- newCtx+ rr <- fromRE ctx re+ let cc = charClasses re+ go ctx cc str rr++ go :: Ctx s -> CharClasses -> String -> RST s -> ST s Bool+ go ctx _ [] rr = nullableR' ctx rr+ go ctx cc (c:cs) rr = do+ let c' = classOfChar cc c+ rr' <- derivativeR c' rr+ rr'' <- compactRN matchIter rr'+#ifdef RERE_DEBUG+ let size1 = _size rr'+ size2 = _size rr''+ traceM ("size: " ++ show size1 ++ " ~> " ++ show size2)+ if size1 < size2+ then traceM (show rr')+ else pure ()+#endif+ go ctx cc cs rr''++-- | Match and print final 'RR' + stats.+matchDebugST :: R.RE Void -> String -> IO ()+matchDebugST re str = runST go0 where+ go0 :: ST s (IO ())+ go0 = do+ ctx <- newCtx+ rr <- fromRE ctx re+ go ctx str rr++ go :: Ctx s -> String -> RST s -> ST s (IO ())+ go ctx [] rr = do+ n <- nullableR' ctx rr++ -- rn <- makeRST ctx (Del rr)+ -- (rn', trace) <- compactRTrace nullableIter rn++ return $ putStr $ unlines $+ [ "size: " ++ show (_size rr)+ , "show: " ++ show rr+ , "null: " ++ show n+ ]+ {-+ , "nul2: " ++ show (nullableR rr)+ , "dels: " ++ show rn'+ ] +++ [ " - " ++ show t+ | t <- trace+ ]+ -}++ go ctx (c:cs) rr = do+ rr' <- derivativeR c rr+ rr'' <- compactRN matchIter rr'+ go ctx cs rr''+++-------------------------------------------------------------------------------+-- Compact+-------------------------------------------------------------------------------++compactR :: RST s -> ST s (RST s)+compactR = rrCompact++compactDef :: Ctx s -> Def s -> ST s (RST s)+compactDef ctx r0 = case r0 of+ Eps -> return (ctxEps ctx)+ Full -> return (ctxFull ctx)+ Ch cs | CS.null cs -> return (ctxNull ctx)+ | otherwise -> makeRST ctx r0++ Alt (RST (Ch x) _ _ _) (RST (Ch y) _ _ _) ->+ makeRST ctx (Ch (CS.union x y))+ Alt (RST (Ch x) _ _ _) s | CS.null x ->+ compactR s+ Alt r (RST (Ch x) _ _ _) | CS.null x ->+ compactR r+ Alt (RST Full _ _ _) _ ->+ return (ctxFull ctx)+ Alt _ (RST Full _ _ _) ->+ return (ctxFull ctx)+ Alt (RST Eps _ _ _) (RST Eps _ _ _) ->+ return (ctxEps ctx)+ Alt r s -> do+ r' <- compactR r+ s' <- compactR s+ makeRST ctx (Alt r' s')++ App (RST Eps _ _ _) s ->+ compactR s+ App r (RST Eps _ _ _) ->+ compactR r+ App (RST (Ch x) _ _ _) _ | CS.null x ->+ return (ctxNull ctx)+ App _ (RST (Ch x) _ _ _) | CS.null x ->+ return (ctxNull ctx)+ App r s -> do+ r' <- compactR r+ s' <- compactR s+ makeRST ctx (App r' s')++#ifdef RERE_INTERSECTION+ And r s -> do+ r' <- compactR r+ s' <- compactR s+ makeRST ctx (And r' s')+#endif++ Star (RST (Ch x) _ _ _) | CS.null x ->+ return (ctxEps ctx)+ Star (RST Eps _ _ _) ->+ return (ctxEps ctx)+ Star r@(RST Star {} _ _ _) ->+ compactR r+ Star r -> do+ r' <- compactR r+ makeRST ctx (Star r')++ Del (RST Full _ _ _ ) -> return (ctxEps ctx)+ Del (RST (Star _) _ _ _ ) -> return (ctxEps ctx)+ Del (RST Eps _ _ _ ) -> return (ctxEps ctx)+ Del (RST (Ch _) _ _ _) -> return (ctxNull ctx)+ Del r@(RST (Del _) _ _ _ ) -> return r++ Del (RST (App r s) _ _ _) -> do+ r' <- makeRST ctx (Del r)+ s' <- makeRST ctx (Del s)+ makeRST ctx (App r' s')+ Del (RST (Alt r s) _ _ _) -> do+ r' <- makeRST ctx (Del r)+ s' <- makeRST ctx (Del s)+ makeRST ctx (Alt r' s')+#ifdef RERE_INTERSECTION+ Del (RST (And r s) _ _ _) -> do+ r' <- makeRST ctx (Del r)+ s' <- makeRST ctx (Del s)+ makeRST ctx (And r' s')+#endif++compactRN :: Int -> RST s -> ST s (RST s)+compactRN n rr | n <= 0 = return rr+ | otherwise = compactR rr >>= compactRN (n - 1)++_compactRTrace :: Int -> RST s -> ST s (RST s, [RST s])+_compactRTrace n rr+ | n <= 0 = return (rr, [])+ | otherwise = do+ rr' <- compactR rr+ (rr'', tr) <- _compactRTrace (n - 1) rr'+ return (rr'', rr : tr)++-------------------------------------------------------------------------------+-- Derivative+-------------------------------------------------------------------------------++derivativeR :: Char -> RST s -> ST s (RST s)+derivativeR = flip rrDerivative++derivativeDef :: Ctx s -> Char -> Def s -> ST s (RST s)+derivativeDef ctx _ Eps =+ return (ctxNull ctx)+derivativeDef ctx _ Full =+ return (ctxFull ctx)+derivativeDef ctx _ (Del _) = do+ return (ctxNull ctx)+derivativeDef ctx c (Ch x)+ | CS.member c x = return (ctxEps ctx)+ | otherwise = return (ctxNull ctx)+derivativeDef ctx c (Alt r s) = do+ r' <- derivativeR c r+ s' <- derivativeR c s+ makeRST ctx (Alt r' s')+#ifdef RERE_INTERSECTION+derivativeDef ctx c (And r s) = do+ r' <- derivativeR c r+ s' <- derivativeR c s+ makeRST ctx (And r' s')+#endif+derivativeDef ctx c (Star r) = do+ r' <- derivativeR c r+ starR <- makeRST ctx (Star r)+ makeRST ctx (App r' starR)+derivativeDef ctx c (App r s) = do+ r' <- derivativeR c r+ s' <- derivativeR c s++ dr <- makeRST ctx (Del r)++ lft <- makeRST ctx (App dr s')+ rgt <- makeRST ctx (App r' s)++ makeRST ctx (Alt lft rgt)++-------------------------------------------------------------------------------+-- Nullable equations+-------------------------------------------------------------------------------++-- | Whether 'RST' is nullable.+--+-- @+-- 'R.nullable' re = 'nullableR' ('fromRE' re)+-- @+nullableR :: RST s -> Bool+nullableR r =+ let (bexpr, eqs) = equations r+ in lfp bexpr eqs++nullableR' :: Ctx s -> RST s -> ST s Bool+nullableR' ctx rr = makeRST ctx (Del rr) >>= go nullableIter where+ go _ (RST Eps _ _ _) = return True+ go _ (RST (Ch _) _ _ _) = return False++ go n rr' | n <= 0 = return (nullableR rr')+ | otherwise = compactR rr' >>= go (n - 1)++equations :: RST s -> (BoolExpr, Map.Map Word64 BoolExpr)+equations r =+ let (bexpr, next) = runState (collectEquation r) Map.empty+ in (bexpr, collectEquations next)++collectEquations :: Map.Map Word64 (Def s)-> Map.Map Word64 BoolExpr+collectEquations = go Map.empty where+ go acc queue = case Map.minViewWithKey queue of+ Nothing -> acc+ Just ((i, r), queue')+ | Map.member i acc -> go acc queue'+ | otherwise ->+ let (bexpr, next) = runState (collectEquation' r) Map.empty+ in go (Map.insert i bexpr acc) (queue' <> next)++collectEquation :: RST s -> State (Map.Map Word64 (Def s)) BoolExpr+collectEquation (RST def i _ _) = do+ modify (Map.insert i def)+ return (BVar i)++collectEquation' :: Def s -> State (Map.Map Word64 (Def s)) BoolExpr+collectEquation' Eps = return BTrue+collectEquation' Full = return BTrue+collectEquation' (Ch _) = return BFalse+collectEquation' (Del r) = collectEquation r+collectEquation' (App r s) = band <$> collectEquation r <*> collectEquation s+collectEquation' (Alt r s) = bor <$> collectEquation r <*> collectEquation s+collectEquation' (Star _) = return BTrue+#ifdef RERE_INTERSECTION+collectEquation' (And r s) = band <$> collectEquation r <*> collectEquation s+#endif++lfp :: BoolExpr -> Map.Map Word64 BoolExpr -> Bool+lfp b exprs = go (False <$ exprs) where+ go curr+ | curr == next = evaluate b+ | otherwise = go next+ where+ next = fmap evaluate exprs++ evaluate :: BoolExpr -> Bool+ evaluate BTrue = True+ evaluate BFalse = False+ evaluate (BOr x y) = evaluate x || evaluate y+ evaluate (BAnd x y) = evaluate x && evaluate y+ evaluate (BVar i) = Map.findWithDefault False i curr++-------------------------------------------------------------------------------+-- BoolExpr+-------------------------------------------------------------------------------++data BoolExpr+ = BVar Word64+ | BTrue+ | BFalse+ | BOr BoolExpr BoolExpr+ | BAnd BoolExpr BoolExpr+ deriving (Show)++band :: BoolExpr -> BoolExpr -> BoolExpr+band BFalse _ = BFalse+band _ BFalse = BFalse+band BTrue r = r+band r BTrue = r+band r s = BAnd r s++bor :: BoolExpr -> BoolExpr -> BoolExpr+bor BFalse r = r+bor r BFalse = r+bor BTrue _ = BTrue+bor _ BTrue = BTrue+bor r s = BOr r s
+ src/RERE/Tuples.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+module RERE.Tuples where++-------------------------------------------------------------------------------+-- 3-tuples+-------------------------------------------------------------------------------++data Triple a b c = T !a !b !c+ deriving (Eq, Ord)++bimap :: (b -> b') -> (c -> c') -> Triple a b c -> Triple a b' c'+bimap f g (T a b c) = T a (f b) (g c)++fstOf3 :: Triple a b c -> a+fstOf3 (T a _ _) = a++sndOf3 :: Triple a b c -> b+sndOf3 (T _ b _) = b++trdOf3 :: Triple a b c -> c+trdOf3 (T _ _ c) = c
+ src/RERE/Type.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedStrings #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Regular-expression with fixed points.+module RERE.Type (+ -- * Regular expression type+ RE (..),+ -- * Smart constructors+ ch_, (\/), star_, let_, fix_, (>>>=),+#ifdef RERE_INTERSECTION+ (/\),+#endif+ string_,+ -- * Operations+ nullable,+ derivative,+ match,+ compact,+ size,+ -- * Internals+ derivative1,+ derivative2,+ ) where++import Control.Monad (ap)+import Data.String (IsString (..))+import Data.Void (Void)++import qualified Data.Set as Set+import qualified RERE.CharSet as CS+import qualified Test.QuickCheck as QC++import RERE.Absurd+import RERE.Tuples+import RERE.Var++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+import Data.Foldable (Foldable)+import Data.Traversable (Traversable (..))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip fmap++-------------------------------------------------------------------------------+-- Type+-------------------------------------------------------------------------------++-- | Regular expression with fixed point.+data RE a+ = Null+ | Full+ | Eps+ | Ch CS.CharSet+ | App (RE a) (RE a)+ | Alt (RE a) (RE a)+ | Star (RE a)++#ifdef RERE_INTERSECTION+ | And (RE a) (RE a)+#endif++ | Var a+ | Let Name (RE a) (RE (Var a))+ | Fix Name (RE (Var a))+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Ord a => IsString (RE a) where+ fromString = string_++instance Applicative RE where+ pure = Var+ (<*>) = ap++instance Monad RE where+ return = Var++ Null >>= _ = Null+ Full >>= _ = Full+ Eps >>= _ = Eps+ Ch c >>= _ = Ch c+ App r s >>= k = App (r >>= k) (s >>= k)+ Alt r s >>= k = Alt (r >>= k) (s >>= k)+ Star r >>= k = Star (r >>= k)+ Var a >>= k = k a+ Let n s r >>= k = Let n (s >>= k) (r >>= unvar (Var B) (fmap F . k))+ Fix n r1 >>= k = Fix n (r1 >>= unvar (Var B) (fmap F . k))++#ifdef RERE_INTERSECTION+ And r s >>= k = And (r >>= k) (s >>= k)+#endif++++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++arb :: Ord a => Int -> [QC.Gen a] -> QC.Gen (RE a)+arb n vars = QC.frequency $+ [ (1, pure Null)+ , (1, pure Full)+ , (1, pure Eps)+ , (5, Ch . CS.singleton <$> QC.elements "abcdef")+ ] +++ [ (10, Var <$> g) | g <- vars ] +++ (if n > 1+ then [ (20, app), (20, alt), (10, st), (10, letG), (5, fixG)+#if RERE_INTERSECTION+ , (10, and_)+#endif+ ]+ else [])+ where+ alt = binary (\/)++#if RERE_INTERSECTION+ and_ = binary (/\)+#endif++ app = binary (<>)++ binary f = do+ m <- QC.choose (0, n)+ x <- arb m vars+ y <- arb (n - m) vars+ return (f x y)++ st = do+ m <- QC.choose (0, n - 1)+ x <- arb m vars+ return (star_ x)++ letG = do+ m <- QC.choose (0, n)+ name <- arbName+ x <- arb m vars+ y <- arb m (pure B : map (fmap F) vars)+ return $ let_ name x y++ fixG = do+ m <- QC.choose (0, n)+ name <- arbName+ y <- arb m (pure B : map (fmap F) vars)+ return $ fix_ name y++instance (Absurd a, Ord a) => QC.Arbitrary (RE a) where+ arbitrary = QC.sized $ \n -> arb n []+ shrink = shr++shr :: RE a -> [RE a]+shr Null = []+shr Eps = [Null]+shr Full = [Eps]+shr (Ch _) = [Null, Eps]++shr (App r s) = r : s : map (uncurry App) (QC.liftShrink2 shr shr (r, s))+shr (Alt r s) = r : s : map (uncurry Alt) (QC.liftShrink2 shr shr (r, s))+shr (Star r) = r : map Star (shr r)++#ifdef RERE_INTERSECTION+shr (And r s) = r : s : map (uncurry And) (QC.liftShrink2 shr shr (r, s))+#endif++shr (Var _) = []+shr (Let n r s) = r : map (uncurry (Let n)) (QC.liftShrink2 shr shr (r, s))+shr (Fix n r) = map (Fix n) (shr r)++arbName :: QC.Gen Name+arbName = QC.elements ["x","y","z"]++-------------------------------------------------------------------------------+-- Match+-------------------------------------------------------------------------------++-- | Match string by iteratively differentiating the regular expression.+--+-- This version is slow, consider using 'RERE.matchR'.+match :: RE Void -> String -> Bool+match !re [] = nullable re+match !re (c:cs) = match (derivative c re) cs++-------------------------------------------------------------------------------+-- nullability and derivative+-------------------------------------------------------------------------------++-- | Whether the regular expression accepts empty string,+-- or whether the formal language contains empty string.+--+-- >>> nullable Eps+-- True+--+-- >>> nullable (ch_ 'c')+-- False+--+nullable :: RE a -> Bool+nullable = nullable' . fmap (const False)++nullable' :: RE Bool -> Bool+nullable' Null = False+nullable' Full = True+nullable' Eps = True+nullable' (Ch _) = False+nullable' (App r s) = nullable' r && nullable' s+nullable' (Alt r s) = nullable' r || nullable' s+nullable' (Star _) = True++#ifdef RERE_INTERSECTION+nullable' (And r s) = nullable' r && nullable' s+#endif++nullable' (Var a) = a+nullable' (Let _ r s) = nullable' (fmap (unvar (nullable' r) id) s)+nullable' (Fix _ r1) = nullable' (fmap (unvar False id) r1)++-- | Derivative of regular exression to respect of character.+-- @'derivative' c r@ is \(D_c(r)\).+derivative :: Char -> RE Void -> RE Void+derivative = derivative1++-- | 'derivative1' and 'derivative2' are slightly different+-- implementations internally. We are interested in comparing+-- whether either one is noticeably faster (no).+derivative2 :: Char -> RE Void -> RE Void+derivative2 c = go . vacuous where+ go :: Ord b => RE (Triple Bool b b) -> RE b+ go Null = Null+ go Full = Full+ go Eps = Null+ go (Ch x)+ | CS.member c x = Eps+ | otherwise = Null+ go (App r s)+ | nullable' (fmap fstOf3 r) = go s \/ (go r <> fmap trdOf3 s)+ | otherwise = go r <> fmap trdOf3 s++ go (Alt r s) = go r \/ go s+ go r0@(Star r) = go r <> fmap trdOf3 r0++#ifdef RERE_INTERSECTION+ go (And r s) = go r /\ go s+#endif++ go (Var x) = Var (sndOf3 x)++ go (Let n r s)+ | Just s' <- unused s+ = let_ n+ (fmap trdOf3 r)+ (go (fmap (bimap F F) s'))++ | otherwise+ = let_ n (fmap trdOf3 r)+ $ let_ n' (fmap F r')+ $ go+ $ s <&> \var -> case var of+ B -> T (nullable' (fmap fstOf3 r)) B (F B)+ F x -> bimap (F . F) (F . F) x+ where+ r' = go r+ n' = derivativeName c n++ go r0@(Fix n r)+ = let_ n (fmap trdOf3 r0)+ $ fix_ n'+ $ go+ $ r <&> \var -> case var of+ B -> T (nullable' (fmap fstOf3 r0)) B (F B)+ F x -> bimap (F . F) (F . F) x+ where+ n' = derivativeName c n++-- | 'derivative1' and 'derivative2' are slightly different+-- implementations internally. We are interested in comparing+-- whether either one is noticeably faster (no).+derivative1 :: Char -> RE Void -> RE Void+derivative1 c = go absurd where+ -- function to calculate nullability and derivative of a variable+ go :: (Ord a, Ord b) => (a -> Triple Bool b b) -> RE a -> RE b+ go _ Null = Null+ go _ Full = Full+ go _ Eps = Null+ go _ (Ch x)+ | CS.member c x = Eps+ | otherwise = Null+ go f (App r s)+ | nullable' (fmap (fstOf3 . f) r) = go f s \/ (go f r <> fmap (trdOf3 . f) s)+ | otherwise = go f r <> fmap (trdOf3 . f) s+ go f (Alt r s) = go f r \/ go f s+ go f r0@(Star r) = go f r <> fmap (trdOf3 . f) r0++#ifdef RERE_INTERSECTION+ go f (And r s) = go f r /\ go f s+#endif++ go f (Var a) = Var (sndOf3 (f a))+ go f (Let n r s)+ | Just s' <- unused s+ -- spare the binding+ = let_ n+ (fmap (trdOf3 . f) r)+ (go (bimap F F . f) s')++ | otherwise+ = let_ n (fmap (trdOf3 . f) r)+ $ let_ n' (fmap F r')+ $ go (\var -> case var of+ B -> T (nullable' (fmap (fstOf3 . f) r)) B (F B)+ F x -> bimap (F . F) (F . F) (f x))+ $ s+ where+ r' = go f r+ n' = derivativeName c n+ go f r0@(Fix n r)+ = let_ n (fmap (trdOf3 . f) r0)+ $ fix_ n'+ $ go (\var -> case var of+ B -> T (nullable' (fmap (fstOf3 . f) r0)) B (F B)+ F x -> bimap (F . F) (F . F) (f x))+ $ r+ where+ n' = derivativeName c n++-------------------------------------------------------------------------------+-- unused+-------------------------------------------------------------------------------++unused :: RE (Var a) -> Maybe (RE a)+unused = traverse (unvar Nothing Just)++-------------------------------------------------------------------------------+-- size+-------------------------------------------------------------------------------++-- | Size of 'RE'. Counts constructors.+--+size :: RE a -> Int+size Null = 1+size Full = 1+size Eps = 1+size (Ch _) = 1+size (Var _) = 1+size (App r s) = succ (size r + size s)+size (Alt r s) = succ (size r + size s)+size (Star r) = succ (size r)+size (Let _ r s) = succ (size r + size s)+size (Fix _ r) = succ (size r)+#ifdef RERE_INTERSECTION+size (And r s) = succ (size r + size s)+#endif++-------------------------------------------------------------------------------+-- compact+-------------------------------------------------------------------------------++-- | Re-apply smart constructors on 'RE' structure,+-- thus potentially making it smaller.+--+-- This function is slow.+compact :: Ord a => RE a -> RE a+compact r@Null = r+compact r@Full = r+compact r@Eps = r+compact r@(Ch _) = r+compact r@(Var _) = r+compact (App r s) = compact r <> compact s+compact (Alt r s) = compact r \/ compact s+compact (Star r) = star_ (compact r)+compact (Let n r s) = let_ n (compact r) (compact s)+compact (Fix n r) = fix_ n (compact r)+#ifdef RERE_INTERSECTION+compact (And r s) = compact r /\ compact s+#endif++-------------------------------------------------------------------------------+-- smart constructors+-------------------------------------------------------------------------------++-- | Variable substitution.+(>>>=) :: Ord b => RE a -> (a -> RE b) -> RE b+Null >>>= _ = Null+Full >>>= _ = Full+Eps >>>= _ = Eps+Ch c >>>= _ = Ch c+App r s >>>= k = (r >>>= k) <> (s >>>= k)+Alt r s >>>= k = (r >>>= k) \/ (s >>>= k)+Star r >>>= k = star_ (r >>>= k)+Var a >>>= k = k a+Let n s r >>>= k = let_ n (s >>>= k) (r >>>= unvar (Var B) (fmap F . k))+Fix n r1 >>>= k = fix_ n (r1 >>>= unvar (Var B) (fmap F . k))++#ifdef RERE_INTERSECTION+And r s >>>= k = (r >>>= k) /\ (s >>>= k)+#endif++infixl 4 >>>=++-- | Smart 'Ch', as it takes 'Char' argument.+ch_ :: Char -> RE a+ch_ = Ch . CS.singleton++-- | Construct literal 'String' regex.+string_ :: Ord a => String -> RE a+string_ [] = Eps+string_ [c] = ch_ c+string_ xs = foldr (\c r -> ch_ c <> r) Eps xs++-- | Smart 'Star'.+star_ :: RE a -> RE a+star_ Null = Eps+star_ Eps = Eps+star_ Full = Full+star_ r@(Star _) = r+star_ r = Star r++-- | Smart 'Let'+let_ :: Ord a => Name -> RE a -> RE (Var a) -> RE a+let_ n (Let m x r) s+ = let_ m x+ $ let_ n r (fmap (unvar B (F . F)) s)+let_ _ r s+ | cheap r+ = s >>>= unvar r Var+-- let_ _ r s+-- | foldMap (unvar (Sum 1) (\_ -> Sum 0)) s <= Sum (1 :: Int)+-- = s >>>= unvar r Var+let_ n r s = postlet_ n r (go B (fmap F r) s) where+ go :: Ord a => a -> RE a -> RE a -> RE a+ go v x y | x == y = Var v+ go _ _ Eps = Eps+ go _ _ Null = Null+ go _ _ Full = Full+ go _ _ (Ch c) = Ch c+ go v x (App a b) = App (go v x a) (go v x b)+ go v x (Alt a b) = Alt (go v x a) (go v x b)+ go v x (Star a) = Star (go v x a)++#ifdef RERE_INTERSECTION+ go v x (And a b) = And (go v x a) (go v x b)+#endif++ go _ _ (Var v) = Var v+ go v x (Let m a b)+ | x == a = go v x (fmap (unvar v id) b)+ | otherwise = let_ m (go v x a) (go (F v) (fmap F x) b)+ go v x (Fix m a) = fix_ m (go (F v) (fmap F x) a)++postlet_ :: Name -> RE a -> RE (Var a) -> RE a+postlet_ _ r (Var B) = r+postlet_ _ _ s+ | Just s' <- unused s+ = s'+postlet_ n r s = Let n r s++-- | Smart 'Fix'.+fix_ :: Ord a => Name -> RE (Var a) -> RE a+fix_ n r+ | Just r' <- traverse (unvar Nothing Just) r+ = r'+ | (r >>>= unvar Null Var) == Null+ = Null+ | Just r' <- floatOut r (unvar Nothing Just) (fix_ n)+ = r'+ where+-- fix_ n (Let m r s)+-- | Just r' <- traverse (unvar Nothing Just) r+-- = let_ m r' (fix_ n (fmap swapVar s))+fix_ n r = Fix n r++floatOut+ :: (Ord a, Ord b)+ => RE (Var a) -- ^ expression+ -> (Var a -> Maybe b) -- ^ float out var+ -> (RE (Var (Var a)) -> RE (Var b)) -- ^ binder+ -> Maybe (RE b) -- ^ maybe an expression with let floaten out+floatOut (Let m r s) un mk+ | Just r' <- traverse un r+ = Just+ $ let_ m r' $ mk $ fmap swapVar s+ | otherwise+ = floatOut+ s+ (unvar Nothing un)+ (mk . let_ m (fmap (fmap F) r) . fmap (fmap swapVar))+floatOut _ _ _ = Nothing++cheap :: RE a -> Bool+cheap Eps = True+cheap Null = True+cheap (Ch _) = True+cheap (Var _) = True+cheap _ = False++instance Ord a => Semigroup (RE a) where+ Null <> _ = Null+ _ <> Null = Null+ Full <> Full = Full+ Eps <> r = r+ r <> Eps = r+ Let n x r <> s = let_ n x (r <> fmap F s)+ r <> Let n x s = let_ n x (fmap F r <> s)+ r <> s = App r s++infixl 5 \/+-- | Smart 'Alt'.+(\/) :: Ord a => RE a -> RE a -> RE a+r \/ s | r == s = r+Null \/ r = r+r \/ Null = r+Full \/ _ = Full+_ \/ Full = Full+Ch a \/ Ch b = Ch (CS.union a b)+Eps \/ r | nullable r = r+r \/ Eps | nullable r = r+Let n x r \/ s = let_ n x (r \/ fmap F s)+r \/ Let n x s = let_ n x (fmap F r \/ s)+r \/ s = foldr alt' Null $ ordNub (unfoldAlt r . unfoldAlt s $ [])+ where+ alt' x Null = x+ alt' x y = Alt x y++#ifdef RERE_INTERSECTION+infixl 6 /\ -- silly CPP+-- | Smart 'Alt'.+(/\) :: Ord a => RE a -> RE a -> RE a+r /\ s | r == s = r+Null /\ _ = Null+_ /\ Null = Null+Full /\ r = r+r /\ Full = r+Ch a /\ Ch b = Ch (CS.intersection a b)+-- nullable is not precise here, so we cannot return Null when non nullable.+Eps /\ r | nullable r = Eps+r /\ Eps | nullable r = Eps+Let n x r /\ s = let_ n x (r /\ fmap F s)+r /\ Let n x s = let_ n x (fmap F r /\ s)+r /\ s = foldr and' Full $ ordNub (unfoldAnd r . unfoldAnd s $ [])+ where+ and' x Full = x+ and' x y = And x y+#endif++-------------------------------------------------------------------------------+-- Tools+-------------------------------------------------------------------------------++unfoldAlt :: RE a -> [RE a] -> [RE a]+unfoldAlt (Alt a b) = unfoldAlt a . unfoldAlt b+unfoldAlt r = (r :)++#ifdef RERE_INTERSECTION+unfoldAnd :: RE a -> [RE a] -> [RE a]+unfoldAnd (And a b) = unfoldAnd a . unfoldAnd b+unfoldAnd r = (r :)+#endif++ordNub :: (Ord a) => [a] -> [a]+ordNub = go Set.empty where+ go !_ [] = []+ go !s (x:xs)+ | Set.member x s = go s xs+ | otherwise = x : go (Set.insert x s) xs
+ src/RERE/Var.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >=704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >=702+{-# LANGUAGE Trustworthy #-}+#endif+-- | Variables, de Bruijn indices and names.+module RERE.Var where++import Data.String (IsString (..))++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+#endif++-- | 'Var' is essentially 'Maybe'.+data Var a+ = B -- ^ bound+ | F a -- ^ free variable.+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | Analogue of 'maybe' for 'Var'.+unvar :: r -> (a -> r) -> Var a -> r+unvar n _ B = n+unvar _ j (F x) = j x++-- | Swap variables.+swapVar :: Var (Var a) -> Var (Var a)+swapVar (F (F a)) = F (F a)+swapVar (F B) = B+swapVar B = F B++instance IsString a => IsString (Var a) where fromString = F . fromString++-- | Names carry information used in pretty-printing,+-- but otherwise they all 'compare' 'EQ'ual.+data Name = N String [Char]++instance Show Name where+ showsPrec d (N n sfx)+ | null sfx = showsPrec d n+ | otherwise+ = showParen (d > 10)+ $ showString "N "+ . showsPrec 11 n+ . showChar ' '+ . showsPrec 11 sfx++instance Eq Name where _ == _ = True+instance Ord Name where compare _ _ = EQ+instance IsString Name where fromString n = N n []++-- | Make a name for derivative binding (adds subindex).+derivativeName :: Char -> Name -> Name+derivativeName c (N n cs) = N n (cs ++ [c])
+ test/Tests.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Test.QuickCheck (label, (===), property)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import RERE+import RERE.Type (derivative1, derivative2)++import qualified Data.Set as Set+import qualified RERE.CharSet as CS++import Control.Monad.ST (runST)++topCon :: RE a -> String+topCon Null = "Null"+topCon Full = "Full"+topCon Eps = "Eps"+topCon Ch {} = "Ch"+topCon Alt {} = "Alt"+topCon App {} = "App"+topCon Star {} = "Star"+topCon Var {} = "Var"+topCon Let {} = "Let"+topCon Fix {} = "Fix"+#ifdef RERE_INTERSECTION+topCon And {} = "And"+#endif++main :: IO ()+main = defaultMain $ testGroup "RERE"+ [ testProperty "derivatives" $ \c re ->+ label (topCon re) $+ derivative1 c re === derivative2 c re+ , testProperty "RR nullable" $ \re ->+ label (topCon re) $+ match re "" === matchR re ""+ , testProperty "RR nullable . derivative^2" $ \c d re ->+ label (topCon re) $+ label (topCon (derivative d (derivative c re))) $+ match re [c,d] === matchR re [c,d]+ , testProperty "RR nullable . derivative^3" $ \c d e re ->+ label (topCon re) $+ label (topCon (derivative c (derivative d (derivative c re)))) $+ match re [c,d,e] === matchR re [c,d,e]++ , testGroup "CharSet"+ [ testProperty "fromList . toList" $ \cs ->+ Set.fromList (CS.toList (CS.fromList (Set.toList cs))) === cs+ , testProperty "member" $ \c cs ->+ Set.member c cs === CS.member c (CS.fromList (Set.toList cs))++ , testProperty "union" $ \xs ys ->+ let xs' = CS.fromList (Set.toList xs)+ ys' = CS.fromList (Set.toList ys)+ in Set.toList (Set.union xs ys) === CS.toList (CS.union xs' ys')+ , testProperty "intersection" $ \xs ys ->+ let xs' = CS.fromList (Set.toList xs)+ ys' = CS.fromList (Set.toList ys)+ in Set.toList (Set.intersection xs ys) === CS.toList (CS.intersection xs' ys')+ , testProperty "difference" $ \xs ys ->+ let xs' = CS.fromList (Set.toList xs)+ ys' = CS.fromList (Set.toList ys)+ in Set.toList (Set.difference xs ys) === CS.toList (CS.difference xs' ys')++ , testProperty "union: left identity" $ \xs ->+ let xs' = CS.fromList xs+ in xs' === CS.union CS.empty xs'+ , testProperty "union: right identity" $ \xs ->+ let xs' = CS.fromList xs+ in xs' === CS.union xs' CS.empty+ , testProperty "union: commutativity" $ \xs ys ->+ let xs' = CS.fromList xs+ ys' = CS.fromList ys+ in CS.union xs' ys' === CS.union ys' xs'+ , testProperty "union: associativity" $ \xs ys zs ->+ let xs' = CS.fromList xs+ ys' = CS.fromList ys+ zs' = CS.fromList zs+ in CS.union xs' (CS.union ys' zs') === CS.union (CS.union xs' ys') zs'++ , testProperty "intersection: left identity" $ \xs ->+ let xs' = CS.fromList xs+ in xs' === CS.intersection CS.universe xs'+ , testProperty "intersection: right identity" $ \xs ->+ let xs' = CS.fromList xs+ in xs' === CS.intersection xs' CS.universe+ , testProperty "intersection: commutativity" $ \xs ys ->+ let xs' = CS.fromList xs+ ys' = CS.fromList ys+ in CS.intersection xs' ys' === CS.intersection ys' xs'+ , testProperty "intersection: associativity" $ \xs ys zs ->+ let xs' = CS.fromList xs+ ys' = CS.fromList ys+ zs' = CS.fromList zs+ in CS.intersection xs' (CS.intersection ys' zs') === CS.intersection (CS.intersection xs' ys') zs'++ , testProperty "complement intersection is empty" $ \xs ->+ let xs' = CS.fromList xs+ in CS.null $ CS.intersection xs' (CS.complement xs')++ , testProperty "complement union is universe" $ \xs ->+ let xs' = CS.fromList xs+ in CS.universe == CS.union xs' (CS.complement xs')+ ]+ ]