t-regex (empty) → 0.1.0.0
raw patch · 13 files changed
+2290/−0 lines, 13 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, haskell-src-exts, haskell-src-meta, lens, mtl, recursion-schemes, template-haskell, transformers
Files
- README.md +332/−0
- Setup.hs +2/−0
- src/Data/MultiGenerics.hs +122/−0
- src/Data/Regex/Example/FPDag2015.hs +77/−0
- src/Data/Regex/Example/Mono.hs +201/−0
- src/Data/Regex/Example/Multi.hs +154/−0
- src/Data/Regex/Generics.hs +339/−0
- src/Data/Regex/MultiGenerics.hs +430/−0
- src/Data/Regex/MultiRules.hs +262/−0
- src/Data/Regex/Rules.hs +161/−0
- src/Data/Regex/TH.hs +154/−0
- src/Test/QuickCheck/Arbitrary1.hs +19/−0
- t-regex.cabal +37/−0
+ README.md view
@@ -0,0 +1,332 @@+`t-regex`: matchers and grammars using tree regular expressions+===============================================================++`t-regex` defines a series of combinators to express tree regular+expressions over any Haskell data type. In addition, with the use+of some combinators (and a bit of Template Haskell), it defines+nice syntax for using this tree regular expressions for matching+and computing attributes over a term.++## Defining your data type++In order to use `t-regex`, you need to define you data type in a+way amenable to inspection. In particular, it means that instead+of a closed data type, you need to define a *pattern functor* in+which recursion is described using the final argument, and which+should instantiate the `Generic1` type class (this can be done+automatically if you are using GHC).++For example, the following block of code defines a `Tree'` data+type in the required fashion:+```haskell+{-# LANGUAGE DeriveGeneric #-}+import GHC.Generics++data Tree' f = Leaf'+ | Branch' { elt :: Int, left :: f, right :: f }+ deriving (Generic1, Show)+```+Notice the `f` argument in the place where `Tree'` would usually be+found. In addition, we have declared the constructors using `'` at+the end, but we will get rid of them soon.++Now, if you want to create terms, you need to *close* the type, which+essentially makes the `f` argument refer back to `Tree'`. You do so+by using `Fix`:+```haskell+type Tree = Fix Tree'+```+However, this induces the need to add explicit `Fix` constructors at+each level. To alleviate this problem, let's define *pattern synonyms*,+available from GHC 7.8 on:+```haskell+pattern Leaf = Fix Leaf'+pattern Branch n l r = Fix (Branch' n l r)+```+From an outsider point of view, now your data type is a normal one,+with `Leaf` and `Branch` as its constructors:+```haskell+aTree = Branch 2 (Branch 2 Leaf Leaf) Leaf+```++## Tree regular expressions++Tree regular expressions are parametrized by a pattern functor: in this+way they are flexible enough to be used with different data types,+while keeping our loved Haskell type safety.++The available combinators to build regular expressions follow the syntax+of [Tree Automata Techniques and Applications](http://tata.gforge.inria.fr/),+Chapter 2.++#### Emptiness++The expressions `empty_` and `none` do not match any value. They can be+used to signal an error branch on an expressions.++#### Whole language++You can match any possible term using `any_`. It is commonly use in+combination with `capture` to extract information from a term.++#### Choice++A regular expression of the form `r1 <||> r2` tries to match `r1`, and if+it not possible, it tries to do so with `r2`. Note than when capturing,+the first regular expression is given priority.++#### Injection++Of course, at some point you would like to check whether some term has+a specific shape. In our case, this means that it has been constructed in+some specific way. In order to do so, you need to *inject* the+constructor as a tree regular expression. When doing so, you can use+the same syntax as usual, but where at the recursive positions you write+regular expressions again.++Let's make it clearer with an example. In our initial definition we had+a constructor `Branch'` with type:+```haskell+Branch' :: Int -> f -> f -> Tree' f+```+Once you inject it using `inj`, the resulting constructor becomes:+```haskell+inj . Branch' :: Int -> Regex' c f -> Regex c' f -> Tree' (Regex' c f)+```+Notice that fields with no `f` do not change their type. Now, here is how+you would represent a tree whose top node is a 2:+```haskell+topTwo = inj (Branch' 2 any_ any_)+```++In some cases, you don't want to check the value of a certain position+which is not recursive. In that case, you cannot use `any_`, since we+are not talking about the type being built upon. For that case, you+may use the special value `__`.++For example, here is how you would represent the shape of a tree which+has at least one branch point:+```haskell+someBranching = inj (Branch' __ any_ any_)+```++#### Iteration and concatenation++Iteration in tree regular expressions is not as easy as in word languages.+The reason is that iteration may occur several times, and in different+positions. For that reason, we need to introduce the notion of *hole*: a+hole is a placeholder where iteration takes place.++In `t-regex` hole names are represented as lambda-bound variables. Then,+you can use any of the functions `square`, `var` or `#` to indicate a+position where the placeholder should be put. Iteration is then indicated+by a call to `iter` or its post-fix version `^*`.++The following two are ways to indicate a `Tree` where all internal nodes+include the number `2`:+```haskell+{-# LANGUAGE PostfixOperators #-}++regex1 = Regex $+ iter $ \k ->+ inj (Branch' 2 (square k) (square k))+ <||> inj Leaf'++regex2 = Regex $ ( (\k -> inj (Branch' 2 (k#) (k#)) <||> inj Leaf')^* )+```+Notice that the use of `PostfixOperators` enables a much terse language.++Iteration is an instance of a more general construction called *concatenation*,+where a hole in an expression is filled by another given expression. The+general shape of those are:+```haskell+(\k -> ... (k#) ...) <.> r -- k is replaced by r in the first expression+```++## Matching and capturing++You can check whether a term `t` is matched by a regular expression `r`+by simply using:+```haskell+r `matches` t+```+However, the full power of tree regular expression come at the moment you+start *capturing* subterms of your tree. A capture group is introduced+in a expression by either `capture` or `<<-`, and all of them appearing+in a expression should be from the same type. For example, we can refine+the previous `regex2` to capture leaves:+```haskell+regex2 = Regex $ ( (\k -> inj (Branch' 2 (k#) (k#)) <||> "leaves" <<- inj Leaf')^* )+```++To check whether a term matches a expression and capture the subterms,+you need to call `match`. The result is of type `Maybe (Map c (m (Fix f)))`.+Let's see what it means:++ * The outermost `Maybe` indicates whether the match is successful+ or not. A value of `Nothing` indicates that the given term does+ not match the regular expression,+ * Capture groups are returned as a `Map`, whose keys are those+ given at `capture` or `<<-`. For that reason, you need capture+ identifiers to be instances of `Ord`,+ * Finally, you have a choice about how to save the found subterms,+ given by the `Alternative m`. Most of the time, you will make+ `m = []`, which means that all matches of the group will be+ returned as a list. Other option is using `m = Maybe`, where+ only the first match is returned.++#### Tree regular expression patterns++Capturing is quite simple, but comes with a problem: it becomes easy to+mistake the name of a capture group, so your code becomes quite brittle.+For that reason, `t-regex` includes matchers which you can use at the+same positions where pattern matching is usually done, and which take+care of linking capture groups to variable names, making it impossible+to mistake them.++To use them, you need to import `Data.Regex.TH`. Then, a quasi-quoter+named `rx` is available to you. Here is an example:+```haskell+{-# LANGUAGE QuasiQuotes #-}++example :: Tree -> [Tree]+example [rx| (\k -> inj (Branch' 2 (k#) (k#)) <||> leaves <<- inj Leaf')^* |]+ = leaves+example _ = []+```+The name of the capture group, `leaves`, is now available in the body+of the `example` function. There is no need to look inside maps, this+is all taken care for you.++Note that when using the `rx` quasi-quoter, you have no choice about+the `Alternative m` to use when matching. Instead, you always get as+value of each capture group a list of terms.++For those who don't like using quasi-quotation, `t-regex` provides a+less magical version called `with`. In this case, you need to introduce+the variables in a explicit manner, and then pattern match on a tuple+wrapped inside a `Maybe`. The previous example would be written as:+```haskell+{-# LANGUAGE ViewPatterns #-}++example :: Tree -> [Tree]+example with (\leaves -> Regex $ iter $ \k -> inj (Branch' 2 (k#) (k#))+ <||> leaves <<- inj Leaf' )+ -> Just leaves+ = leaves+example _ = []+```+Notice that the pattern is always similar `with (\v1 v2 ... ->+regular expression) -> Just (v1,v2,...)`.++## Random generation++You can use `t-regex` to generate random values of a type which satisfy a+certain tree regular expression. Of course, you might always generate+random values and then check that they match the given expression, but+this is usually very costly and maybe even statistically impossible.+Instead, you should use `arbitraryFromRegex`.++```haskell+instance Arbitrary Tree where+ arbitrary = frequency+ [ (1, return Leaf)+ , (5, Branch <$> arbitrary <*> arbitrary <*> arbitrary) ]++> arbitraryFromRegex regex2+```++Note that in the previous example we also gave an instance declaration+for `Arbitrary`. This class comes from the `QuickCheck` package, and+is needed to generate unconstrained random values for the case in+which `any_` is found.++Sometimes you may not be able or want to write such an instance. In that+case, you can use `arbitraryFromRegexAndGen`, which takes an additional+argument from which `any_` values are generated.++## Attribute grammars++[Attribute grammars](https://www.haskell.org/haskellwiki/The_Monad.Reader/Issue4/Why_Attribute_Grammars_Matter)+are a powerful way to perform computations over a term. The main+idea is that each node in your term (when seen as a tree) is+traversed, and two sets of information are recorded at each point:++ * *Inherited attributes* go from parent to children. When+ describing a grammar, each node needs to specify the value+ of inherited attributes of all their children,+ * *Synthesized attributes* flow in the other direction.+ At each node, you need to described how to get the value+ of each synthesized attribute based on your inherited+ attributes and the synthesized attributes of children.++The most performant attribute grammar compilers, such as+[UUAGC](http://foswiki.cs.uu.nl/foswiki/HUT/AttributeGrammarSystem)+only allow deciding which rule to apply on a node depending on+their topmost constructor. With `t-regex` you can look as+deep as you want to take this decision (but of course, performance+will suffer if you do this very often).++Here is an example of a grammar which computes a graphical+representation of a `Tree` plus its number of leaves:+```haskell+grammar = [+ rule $ \l r ->+ inj (Branch' 2 (l <<- any_) (r <<- any_)) ->> do+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ this.syn._1 .= "(" ++ lText ++ ")-SPECIAL-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ \l r ->+ inj (Branch' __ (l <<- any_) (r <<- any_)) ->>> \(Branch e _ _) -> do+ check $ e >= 0+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ this.syn._1 .= "(" ++ lText ++ ")-" ++ show e ++ "-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ inj Leaf' ->> do+ this.syn._1 .= "leaf"+ this.syn._2 .= Sum 1+ ]+```+Let's dissect it part by part.++First of all, a grammar is made of a series of *rules*. Each rule+follows the same schema:+```haskell+rule $ \v1 ... vn ->+ regular expression ->> do+ actions+```+`rule` is the constant part which prefixes every rule. Then, you+have the set of variables which will be used to capture information+from the term, in a similar way to previous section. After that you+have the tree regular expression the term needs to match. Finally,+and separated by `->>`, you find the actions to perform when this+rule is selected.++Two small extensions are shown in the second rule. By default,+`->>` does not give you access to the matched term. However, if you+need to access some of its information (for example, because you+used `__`, as in this case), you can use the alternative version+`->>>` which gives this as an argument. The second extension is the+use of `check` to pinpoint a logical condition which is not captured+by the regular expression itself.++The syntax for the actions relies heavily in lenses and operators+from the `lens` package. In particular, you have four lenses:++ * `this.inh` gives access to the inherited attributes of the node,+ * `at n . syn` gives access to the synthesized attributes of children,+ * `this.syn` is where you set the synthesized attributes of your node,+ * `at n . inh` is where you set the inherited attributes of children,++Furthermore, you can combine those with lenses over your inherited+and synthesized attribute data type to have more lightweight syntax.+In our case, the synthesized attributes are a tuple `(String, Sum Int)`,+so we access them with `_1` and `_2`, as shown in the example.++The general rule is that you read values using `use`, and set values+via `.=`. If some value is not set, it defaults to the empty element+of your synthesized type, or to the value of parent node in the case+of inherited attributes.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/MultiGenerics.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+-- | Multirec-style generics, indexed by data kind 'k'.+-- Pattern functors should have kind @(k -> *) -> k -> *@.+module Data.MultiGenerics where++import Test.QuickCheck.Gen++-- | Multirec-style fix-point, indexed by data kind.+newtype Fix (f :: (k -> *) -> k -> *) (ix :: k) = Fix { unFix :: f (Fix f) ix }++-- | The singleton kind-indexed data family. Taken from the @singletons@ package.+data family Sing (a :: k)++-- | A 'SingI' constraint is essentially an implicitly-passed singleton.+class SingI (a :: k) where+ -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@+ -- extension to use this method the way you want.+ sing :: Sing a++-- | Convert a pattern functor to a readable 'String'.+class ShowM (f :: k -> *) where+ -- | An index-independent way to show a value.+ showM :: f ix -> String++-- | We have equality for each instantiation of the pattern functor.+class EqM (f :: k -> *) where+ eqM :: f ix -> f xi -> Bool++-- | Generate a random element given a proxy.+type GenM f = forall ix. Sing ix -> Gen (f ix)++class ArbitraryM (f :: k -> *) where+ arbitraryM :: GenM f++-- | Representable types of kind * -> *.+-- This class is derivable in GHC with the DeriveGeneric flag on.+class Generic1m (f :: (k -> *) -> k -> *) where+ -- | Generic representation type.+ type Rep1m f :: (k -> *) -> k -> *+ -- | Convert from the datatype to its representation.+ from1k :: f a ix -> Rep1m f a ix+ -- | Convert from the representation to the datatype.+ to1k :: Rep1m f a ix -> f a ix++-- | Void: used for datatypes without constructors.+data V1m p ix++instance Generic1m V1m where+ type Rep1m V1m = V1m+ from1k = undefined+ to1k = undefined++-- | Unit: used for constructors without arguments.+data U1m p ix = U1m+ deriving (Eq, Ord, Read, Show)++instance Generic1m U1m where+ type Rep1m U1m = U1m+ from1k = id+ to1k = id++-- | Used for marking occurrences of the parameter.+newtype Par1m (xi :: k) (p :: k -> *) (ix :: k)+ = Par1m { unPar1m :: p xi }++instance Generic1m (Par1m xi) where+ type Rep1m (Par1m xi) = Par1m xi+ from1k = id+ to1k = id++-- | Recursive calls of kind '* -> *'.+newtype Rec1m (f :: * -> *) (xi :: k) (p :: k -> *) (ix :: k)+ = Rec1m { unRec1m :: f (p xi) }++instance Generic1m (Rec1m f xi) where+ type Rep1m (Rec1m f xi) = Rec1m f xi+ from1k (Rec1m x) = Rec1m x+ to1k (Rec1m x) = Rec1m x++-- | Constants, additional parameters and recursion of kind '*'.+newtype K1m i c p ix = K1m { unK1m :: c }+ deriving (Eq, Ord, Read, Show)++instance Generic1m (K1m i c) where+ type Rep1m (K1m i c) = K1m i c+ from1k = id+ to1k = id++-- | Sums: encode choice between constructors.+infixr 5 :++:+data (:++:) (f :: (k -> *) -> k -> *) (g :: (k -> *) -> k -> *) p ix+ = L1m (f p ix) | R1m (g p ix)+ deriving (Eq, Ord, Read, Show)++instance (Generic1m f, Generic1m g) => Generic1m (f :++: g) where+ type Rep1m (f :++: g) = (f :++: g)+ from1k = id+ to1k = id++-- | Products: encode multiple arguments to constructors.+infixr 6 :**:+data (:**:) f g p ix = f p ix :**: g p ix+ deriving (Eq, Ord, Read, Show)++instance (Generic1m f, Generic1m g) => Generic1m (f :**: g) where+ type Rep1m (f :**: g) = (f :**: g)+ from1k = id+ to1k = id++-- | Tags: encode return type of a GADT constructor.+data Tag1m (f :: (k -> *) -> k -> *) (xi :: k) (p :: k -> *) (ix :: k) where+ Tag1m :: f p ix -> Tag1m f ix p ix++instance Generic1m f => Generic1m (Tag1m f xi) where+ type Rep1m (Tag1m f xi) = Tag1m f xi+ from1k = id+ to1k = id
+ src/Data/Regex/Example/FPDag2015.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.Regex.Example.FPDag2015 where++import Control.Applicative+import Data.Regex.Generics+import Data.Regex.TH+import GHC.Generics+import Test.QuickCheck++data List_ a l = Cons_ a l | Nil_ deriving (Show, Generic1)+type List a = Fix (List_ a)++pattern Cons x xs = Fix (Cons_ x xs)+pattern Nil = Fix Nil_++instance Arbitrary a => Arbitrary (List a) where+ arbitrary = frequency [ (1, return Nil)+ , (3, Cons <$> arbitrary <*> arbitrary) ]++oneTwoOrOneThree :: Regex c (List_ Int)+oneTwoOrOneThree = Regex $+ inj $ Cons_ 1 (inj (Cons_ 2 $ inj Nil_) <||> inj (Cons_ 3 $ inj Nil_))++oneTwoThree :: List Char -> Bool+oneTwoThree [rx| iter (\k -> inj (Cons_ 'a' (inj $ Cons_ 'b' (inj $ Cons_ 'c' (k#)))) <||> _last <<- inj Nil_) |] = True+oneTwoThree _ = False++data Tree_ t = Node_ Int t t | Leaf_ Int deriving (Show, Generic1)+type Tree = Fix Tree_++pattern Node x l r = Fix (Node_ x l r)+pattern Leaf x = Fix (Leaf_ x)++matchAny :: Regex c Tree_+matchAny = Regex $ any_++topTwo :: Regex c Tree_+topTwo = Regex $ inj (Node_ 2 any_ any_)++shape1 :: Regex c Tree_+shape1 = Regex $+ inj $ Node_ 2 (inj $ Node_ 3 any_ any_)+ (inj $ Node_ 4 any_ any_)++shape2 :: Regex c Tree_+shape2 = Regex $+ inj $ Node_ __ (inj $ Node_ 3 any_ any_)+ (inj $ Node_ 4 any_ any_)++allTwos :: Regex c Tree_+allTwos = Regex $ iter (\k -> inj (Node_ 2 (var k) (var k)) <||> inj (Leaf_ 2))++allTwosPostfix :: Regex c Tree_+allTwosPostfix = Regex ((\k -> inj (Node_ 2 (k#) (k#)) <||> inj (Leaf_ 2))^*)++allLeaves :: Tree -> [Int]+allLeaves [rx| iter (\k -> inj (Node_ __ (k#) (k#)) <||> leaves <<- inj (Leaf_ __)) |] =+ map (\(Leaf i) -> i) leaves -- Note this is a Fix-ed element++data Expr_ e = Plus_ e e | Times_ e e | Var_ Int deriving (Show, Generic1)+type Expr = Fix Expr_++iPlus a b = inj (Plus_ a b)+iTimes a b = inj (Times_ a b)+iVar v = inj (Var_ v)++simplify :: Expr -> Expr+simplify [rx| iPlus (iVar 0) (x <<- any_) <||> iPlus (x <<- any_) (iVar 0)+ <||> iTimes (iVar 1) (x <<- any_) <||> iTimes (x <<- any_) (iVar 1) |] = simplify (head x)+simplify x = x
+ src/Data/Regex/Example/Mono.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Example of tree regular expressions over a regular data type.+-- Click on @Source@ to view the code.+module Data.Regex.Example.Mono (+ -- * Data type definitions+ Tree'(..), Tree,+ Rose'(..), Rose,+ -- ** Useful pattern synonyms+ pattern Leaf, pattern Branch,+ pattern Rose,+ -- ** Some 'Tree' values+ aTree1, aTree2, aTree3,+ -- ** Some 'Rose' values+ aRose1, aRose2,+ -- * Tree regular expressions+ -- ** Useful pattern synonyms+ pattern Leaf_, pattern Branch_,+ -- ** Some stand-alone expressions+ rTree1, rTree2, rTree3, rRose1,+ -- ** Using 'with' views+ eWith1, eWith2,+ -- ** Using the 'rx' quasi-quoter+ eWith2Bis, eWith3, eWith4,+ -- * Grammar and rules+ grammar1, grammar2, grammar3+) where++import Control.Applicative ((<$>), (<*>))+import Control.Lens hiding (at, (#), children)+import Data.Map ((!))+import qualified Data.Map as M+import Data.Monoid (Sum(..))+import Data.Regex.Generics+import Data.Regex.Rules+import Data.Regex.TH+import GHC.Generics+import Test.QuickCheck++-- | The pattern functor, which should be kept open.+-- Recursion is done by using the argument.+data Tree' f = Leaf' | Branch' { elt :: Int, left :: f, right :: f }+ deriving (Generic1, Show)+-- | Closes the data type by creating its fix-point.+type Tree = Fix Tree'++instance Arbitrary Tree where+ arbitrary = frequency+ [ (1, return Leaf)+ , (5, Branch <$> arbitrary <*> arbitrary <*> arbitrary) ]++-- | The pattern functor for rose trees.+data Rose' f = Rose' { value :: Int, child :: [f] }+ deriving (Generic1, Show)+-- | Closes the data type by creating its fix-point.+type Rose = Fix Rose'++-- | Pattern synonym for the 'Leaf' constructor inside 'Fix'.+pattern Leaf = Fix Leaf'+-- | Pattern synonym for the 'Branch' constructor inside 'Fix'.+pattern Branch n l r = Fix (Branch' n l r)+-- | Pattern synonym for the 'Rose' constructor inside 'Fix'.+pattern Rose v c = Fix (Rose' v c)++instance Show Tree where+ show (Fix Leaf') = "Leaf"+ show (Fix (Branch' n t1 t2)) = "(Branch " ++ show n ++ " " ++ show t1 ++ " " ++ show t2 ++ ")"++instance Show Rose where+ show (Fix (Rose' n c)) = show n ++ show c++aTree1 :: Tree+aTree1 = Branch 2 (Branch 3 (Branch 2 (Branch 4 Leaf Leaf) Leaf) Leaf) Leaf++aTree2 :: Tree+aTree2 = Branch 2 (Branch 2 Leaf Leaf) Leaf++aTree3 :: Tree+aTree3 = Branch 2 Leaf Leaf++aRose1 :: Rose+aRose1 = Rose 2 [Rose 2 [], Rose 2 []]++aRose2 :: Rose+aRose2 = Rose 2 [Rose 2 [], Rose 2 [Rose 3 []]]++rTree1 :: Regex String Tree'+rTree1 = Regex $+ iter $ \k ->+ capture "x" $+ inj (Branch' 2 (square k) (square k))+ <||> inj Leaf'++rTree2 :: Integer -> Regex Integer Tree'+rTree2 c = Regex $+ iter $ \k ->+ capture c $+ inj (Branch' 2 (square k) (square k))+ <||> inj Leaf'++pattern Branch_ n l r = Inject (Branch' n l r)+pattern Leaf_ = Inject Leaf'++rTree3 :: Integer -> Integer -> Regex Integer Tree'+rTree3 c1 c2 = Regex ( (\k -> c1 <<- Branch_ 2 (k#) (k#) <||> c2 <<- Leaf_)^* )++rRose1 :: Regex String Rose'+rRose1 = Regex $ iter $ \k -> capture "x" $ inj (Rose' 2 [square k])++eWith1 :: Tree -> [Tree]+eWith1 (with rTree2 -> Just e) = e+eWith1 _ = error "What?"++eWith2 :: Tree -> [Tree]+eWith2 (with rTree3 -> Just (_,e)) = e+eWith2 _ = error "What?"++eWith2Bis :: Tree -> [Tree]+eWith2Bis [rx| (\k -> branches <<- Branch_ 2 (k#) (k#) <||> leaves <<- Leaf_)^* |] = leaves+eWith2Bis _ = []++eWith3 :: Tree -> [Tree]+eWith3 [rx| x <<- Leaf_ |] = x+eWith3 _ = error "What?"++eWith4 :: Tree -> [Int]+eWith4 [rx| (\k -> x <<- inj (Branch' __ (k#) (k#)) <||> e <<- Leaf_)^* |] = map (elt . unFix) x+eWith4 _ = error "What?"++unFix :: Fix f -> f (Fix f)+unFix (Fix x) = x++grammar1 :: Grammar String Tree' () String+grammar1 = [ ( Regex $ inj (Branch' 2 ("l" <<- any_) ("r" <<- any_))+ , \_ _ children ->+ ( True+ , M.fromList [("l",()),("r",())]+ , "(" ++ children ! "l"+ ++ ")-SPECIAL-("+ ++ children ! "r" ++ ")" ) )+ , ( Regex $ inj (Branch' __ ("l" <<- any_) ("r" <<- any_))+ , \(Branch e _ _) _ children ->+ ( True+ , M.fromList [("l",()),("r",())]+ , "(" ++ children ! "l"+ ++ ")-" ++ show e ++ "-("+ ++ children ! "r" ++ ")" ) )+ , ( Regex $ Leaf_, \_ _ _ -> (True, M.empty, "leaf") )+ ]++grammar2 :: Grammar Integer Tree' () (String, Sum Integer)+grammar2 = [+ rule $ \l r ->+ inj (Branch' 2 (l <<- any_) (r <<- any_)) ->> do+ -- check False+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ this.syn._1 .= "(" ++ lText ++ ")-SPECIAL-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ \l r ->+ inj (Branch' __ (l <<- any_) (r <<- any_)) ->>> \(Branch e _ _) -> do+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ this.syn._1 .= "(" ++ lText ++ ")-" ++ show e ++ "-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ Leaf_ ->> do+ this.syn._1 .= "leaf"+ this.syn._2 .= Sum 1+ ]++grammar3 :: Grammar Integer Tree' Char (String, Sum Integer)+grammar3 = [+ rule $ \l r ->+ inj (Branch' 2 (l <<- any_) (r <<- any_)) ->> do+ special <- use (this.inh)+ at l . inh .= succ special+ at r . inh .= succ special+ -- check False+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ if lText == "leaf" && rText == "leaf"+ then this.syn._1 .= "leaves"+ else this.syn._1 .= "(" ++ lText ++ ")-" ++ [special] ++ "-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ \l r ->+ inj (Branch' __ (l <<- any_) (r <<- any_)) ->>> \(Branch e _ _) -> do+ (lText,lN) <- use (at l . syn)+ (rText,rN) <- use (at r . syn)+ this.syn._1 .= "(" ++ lText ++ ")-" ++ show e ++ "-(" ++ rText ++ ")"+ this.syn._2 .= lN + rN+ , rule $ Leaf_ ->> do+ this.syn._1 .= "leaf"+ this.syn._2 .= Sum 1+ ]
+ src/Data/Regex/Example/Multi.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Example of tree regular expressions over+-- a family of regular data types.+-- Click on @Source@ to view the code.+module Data.Regex.Example.Multi (+ -- * Data type definition+ Ty(..), Bis(..), FixOne, FixTwo,+ -- ** Useful pattern synonyms+ pattern NilOne, pattern ConsOne,+ pattern NilTwo, pattern ConsTwo,+ -- ** Some 'Bis' values+ aBis1, aBis2,+ -- * Tree regular expressions+ -- ** Some stand-alone expressions+ rBis1, rBis2, rBis3, rBis4, rBis5,+ -- ** Using 'with' views+ cBis1, eBis1,+ -- ** Using the 'mrx' quasi-quoter+ eBis2,+ -- * Grammars+ grammar1+) where++import Control.Applicative ((<$>), (<*>))+import Control.Lens hiding (at, (#), children)+import Data.MultiGenerics+import Data.Regex.MultiGenerics+import Data.Regex.MultiRules+import Data.Regex.TH+import Test.QuickCheck++data Ty = One | Two++data instance Sing (a :: Ty) where+ SOne :: Sing One+ STwo :: Sing Two+deriving instance Eq (Sing (a :: Ty))++instance SingI One where+ sing = SOne+instance SingI Two where+ sing = STwo++data Bis f ix where+ NilOne' :: Bis f One+ ConsOne' :: Int -> f Two -> Bis f One+ NilTwo' :: Bis f Two+ ConsTwo' :: Char -> f One -> Bis f Two++type FixOne = Fix Bis One+type FixTwo = Fix Bis Two++instance ArbitraryM (Fix Bis) where+ arbitraryM SOne = frequency [ (1, return NilOne)+ , (3, ConsOne <$> arbitrary <*> arbitraryM STwo) ]+ arbitraryM STwo = frequency [ (1, return NilTwo)+ , (3, ConsTwo <$> arbitrary <*> arbitraryM SOne) ]++instance ShowM (Fix Bis) where+ showM (Fix NilOne') = "NilOne"+ showM (Fix (ConsOne' n r)) = "(ConsOne " ++ show n ++ " " ++ showM r ++ ")"+ showM (Fix NilTwo') = "NilTwo"+ showM (Fix (ConsTwo' c r)) = "(ConsTwo " ++ show c ++ " " ++ showM r ++ ")"+instance Show (Fix Bis One) where+ show = showM+instance Show (Fix Bis Two) where+ show = showM++pattern NilOne = Fix NilOne'+pattern ConsOne x xs = Fix (ConsOne' x xs)+pattern NilTwo = Fix NilTwo'+pattern ConsTwo x xs = Fix (ConsTwo' x xs)++-- | Implementation of 'Generic1m' for 'Bis'.+-- This is required to use tree regular expressions.+instance Generic1m Bis where+ type Rep1m Bis = Tag1m U1m One+ :++: Tag1m (K1m () Int :**: Par1m Two) One+ :++: Tag1m U1m Two+ :++: Tag1m (K1m () Char :**: Par1m One) Two++ from1k NilOne' = L1m $ Tag1m U1m+ from1k (ConsOne' x xs) = R1m $ L1m $ Tag1m (K1m x :**: Par1m xs)+ from1k NilTwo' = R1m $ R1m $ L1m $ Tag1m U1m+ from1k (ConsTwo' x xs) = R1m $ R1m $ R1m $ Tag1m (K1m x :**: Par1m xs)++ to1k (L1m (Tag1m U1m)) = NilOne'+ to1k (R1m (L1m (Tag1m (K1m x :**: Par1m xs)))) = ConsOne' x xs+ to1k (R1m (R1m (L1m (Tag1m U1m)))) = NilTwo'+ to1k (R1m (R1m (R1m (Tag1m (K1m x :**: Par1m xs))))) = ConsTwo' x xs++aBis1 :: FixOne+aBis1 = NilOne++aBis2 :: FixOne+aBis2 = ConsOne 1 (ConsTwo 'a' NilOne)++rBis1 :: Regex (Wrap Char) Bis One+rBis1 = Regex $ capture ('a'?) $ inj NilOne'++rBis2 :: Regex c Bis One+rBis2 = Regex $ inj (ConsOne' 2 (inj NilTwo'))++rBis3 :: Regex c Bis One+rBis3 = Regex $ inj (ConsOne' 2 (inj (ConsTwo' 'a' (inj NilOne'))))++rBis4 :: Regex c Bis One+rBis4 = Regex $ inj NilOne' <||> inj NilOne'++rBis5 :: Regex c Bis One+rBis5 = Regex $ inj (ConsOne' 2 (inj (ConsTwo' 'a' any_)))++cBis1 :: Wrap Integer One -> Regex (Wrap Integer) Bis One+cBis1 x = Regex $ x <<- inj NilOne'+++eBis1 :: FixOne -> [FixOne]+eBis1 (with cBis1 -> Just x) = x+eBis1 _ = error "What?"++eBis2 :: FixOne -> [FixOne]+eBis2 [mrx| (x :: One) <<- inj NilOne' |] = x++grammar1 :: IndexIndependentGrammar (Wrap Integer) Bis () String+grammar1 = [+ rule0 $ + inj NilOne' ->> do+ this.syn_ .= "NilOne"+ , rule $ \x ->+ inj (ConsOne' 1 (x <<- any_)) ->> do+ s <- use (at x . syn_)+ this.syn_ .= "Special - " ++ s+ , rule $ \x ->+ inj (ConsOne' __ (x <<- any_)) ->>> \(ConsOne n _) -> do+ s <- use (at x . syn_)+ this.syn_ .= show n ++ " - " ++ s+ , rule0 $ + inj NilTwo' ->> do+ this.syn_ .= "NilTwo"+ , rule $ \x ->+ inj (ConsTwo' __ (x <<- any_)) ->>> \(ConsTwo n _) -> do+ s <- use (at x . syn_)+ this.syn_ .= show n ++ " - " ++ s+ ]
+ src/Data/Regex/Generics.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | Tree regular expressions over regular data types.+module Data.Regex.Generics (+ -- * Base types+ Regex(Regex),+ Regex'(Inject),+ Fix(..),+ + -- * Constructors+ -- | For a description and study of tree regular expressions, you are invited to read+ -- Chapter 2 of <http://tata.gforge.inria.fr/ Tree Automata Techniques and Applications>.+ + -- ** Emptiness+ empty_, none,+ -- ** Whole language+ any_,+ -- ** Injection+ inj, __,+ -- ** Holes/squares+ square, var, (#),+ -- ** Alternation+ choice, (<||>),+ -- ** Concatenation+ concat_, (<.>),+ -- ** Iteration+ iter, (^*),+ -- ** Capture+ capture, (<<-),+ + -- * Matching+ Matchable,+ matches, match,+ + -- * Views+ with,++ -- * Random generation+ arbitraryFromRegex,+ arbitraryFromRegexAndGen+) where++import Control.Applicative+import Control.Exception+import Control.Monad (guard)+import Data.Foldable as F+import Data.Functor.Foldable (Fix(..))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (isJust)+import Data.Typeable+import GHC.Generics+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary1++-- | The basic data type for tree regular expressions.+--+-- * 'k' is used as phantom type to point to concatenation and iteration positions.+-- * 'c' is the type of capture identifiers.+-- * 'f' is the pattern functor over which regular expressions match.+-- In tree regular expression jargon, expresses the set of constructors for nodes.+data Regex' k c (f :: * -> *)+ = Empty+ | Any+ | Inject (f (Regex' k c f)) -- ^ Useful for defining pattern synonyms for injected constructors.+ | Square k+ | Choice (Regex' k c f) (Regex' k c f)+ | Concat (k -> Regex' k c f) (Regex' k c f)+ | Capture c (Regex' k c f)+-- | Tree regular expressions over pattern functor 'f' with capture identifiers of type 'c'.+newtype Regex c (f :: * -> *) = Regex { unRegex :: forall k. Regex' k c f }++-- | Matches no value.+empty_, none :: Regex' k c f+empty_ = Empty+none = empty_++-- | Matches any value of the data type.+any_ :: Regex' k c f+any_ = Any++-- | Injects a constructor as a regular expression.+-- That is, specifies a tree regular expression whose root is given by a constructor+-- of the corresponding pattern functor, and whose nodes are other tree regular expressions.+-- When matching, fields of types other than 'f' are checked for equality,+-- except when using '__' as the value.+inj :: f (Regex' k c f) -> Regex' k c f+inj = Inject++-- | Serves as a placeholder for any value in a non-'f'-typed position.+__ :: a+__ = throw DoNotCheckThisException++data DoNotCheckThisException = DoNotCheckThisException deriving (Show, Typeable)+instance Exception DoNotCheckThisException++-- | Indicates the position of a hole in a regular expression.+square, var :: k -> Regex' k c f+square = Square+var = square++-- | Indicates the position of a hole in a regular expression.+-- This function is meant to be used with the @PostfixOperators@ pragma.+(#) :: k -> Regex' k c f+(#) = square++-- | Expresses alternation between two tree regular expressions:+-- Data types may match one or the other.+-- When capturing, the first one is given priority.+infixl 3 <||>+choice, (<||>) :: Regex' k c f -> Regex' k c f -> Regex' k c f+choice = Choice+(<||>) = choice++-- | Concatenation: a whole in the first tree regular expression+-- is replaced by the second one.+concat_, (<.>) :: (k -> Regex' k c f) -> Regex' k c f -> Regex' k c f+concat_ = Concat+(<.>) = concat_++-- | Repeated replacement of a hole in a tree regular expression.+-- Iteration fulfills the law: @iter r = r \<.\> iter r@.+iter :: (k -> Regex' k c f) -> Regex' k c f+iter r = Concat r (iter r)++-- | Repeated replacement of a hole in a tree regular expression.+-- This function is meant to be used with the @PostfixOperators@ pragma.+(^*) :: (k -> Regex' k c f) -> Regex' k c f+(^*) = iter++-- | Indicates a part of a value that, when matched, should be+-- given a name of type 'c' and saved for querying.+infixl 4 <<-+capture, (<<-) :: c -> Regex' k c f -> Regex' k c f+capture = Capture+(<<-) = capture+++-- | Types which can be matched.+type Matchable f = (Generic1 f, MatchG (Rep1 f))++-- | Checks whether a term 't' matches the tree regular expression 'r'.+matches :: forall c f. (Ord c, Matchable f)+ => Regex c f -> Fix f -> Bool+r `matches` t = isJust $ (match r t :: Maybe (Map c [Fix f]))++-- | Checks whether a term 't' matches the tree regular expression 'r'.+-- When successful, it returns in addition a map of captured subterms.+--+-- The behaviour of several matches over the same capture identifier+-- is governed by the 'Alternative' functor 'm'. For example, if+-- @m = []@, all matches are returned in prefix-order. If @m = Maybe@,+-- only the first result is returned.+match :: (Ord c, Matchable f, Alternative m)+ => Regex c f -> Fix f -> Maybe (Map c (m (Fix f)))+match r t = match' (unRegex r) t 0 []++match' :: (Ord c, Matchable f, Alternative m)+ => Regex' Integer c f+ -> Fix f+ -> Integer -- Fresh variable generator+ -> [(Integer, Regex' Integer c f)] -- Ongoing substitution+ -> Maybe (Map c (m (Fix f)))+match' Empty _ _ _ = Nothing+match' Any _ _ _ = Just M.empty+match' (Inject r) (Fix t) i s = injG (from1 r) (from1 t) i s+match' (Square n) t i s = let Just r = lookup n s in match' r t i s+match' (Choice r1 r2) t i s = match' r1 t i s <|> match' r2 t i s+match' (Concat r1 r2) t i s = match' (r1 i) t (i+1) ((i,r2):s)+match' (Capture c r) t i s = M.insertWith (<|>) c (pure t) <$> match' r t i s++class MatchG f where+ injG :: (Ord c, Matchable g, Alternative m)+ => f (Regex' Integer c g) -> f (Fix g)+ -> Integer -> [(Integer, Regex' Integer c g)]+ -> Maybe (Map c (m (Fix g)))++instance MatchG U1 where+ injG _ _ _ _ = Just M.empty++instance MatchG Par1 where+ injG (Par1 r) (Par1 t) = match' r t++instance Eq c => MatchG (K1 i c) where+ injG (K1 r) (K1 t) _ _ = unsafePerformIO $+ catch (evaluate $ do guard (r == t) -- Maybe monad+ return M.empty)+ (\(_ :: DoNotCheckThisException) -> return $ Just M.empty)++instance (Functor f, Foldable f) => MatchG (Rec1 f) where+ injG (Rec1 rs) (Rec1 ts) i s =+ F.foldr (<|>) Nothing -- Get only the first option+ $ fmap (\r -> F.foldr (\x1 x2 -> case (x1, x2) of+ (Just m1, Just m2) -> Just (M.unionWith (<|>) m1 m2)+ _ -> Nothing)+ (Just M.empty)+ $ fmap (\t -> match' r t i s) ts) rs++instance MatchG a => MatchG (M1 i c a) where+ injG (M1 r) (M1 t) = injG r t++instance (MatchG a, MatchG b) => MatchG (a :+: b) where+ injG (L1 r) (L1 t) i s = injG r t i s+ injG (R1 r) (R1 t) i s = injG r t i s+ injG _ _ _ _ = Nothing++instance (MatchG a, MatchG b) => MatchG (a :*: b) where+ injG (r1 :*: r2) (t1 :*: t2) i s = M.unionWith (<|>) <$> injG r1 t1 i s <*> injG r2 t2 i s++instance (Functor f, Foldable f, MatchG g) => MatchG (f :.: g) where+ injG (Comp1 rs) (Comp1 ts) i s =+ F.foldr (<|>) Nothing -- Get only the first option+ $ fmap (\r -> F.foldr (\x1 x2 -> case (x1, x2) of+ (Just m1, Just m2) -> Just (M.unionWith (<|>) m1 m2)+ _ -> Nothing)+ (Just M.empty)+ $ fmap (\t -> injG r t i s) ts) rs+++class With f fn r | fn -> r where+ -- | Useful function to be used as view pattern.+ -- The first argument should be a function, which indicates those places where captured are found+ -- Those captured are automatically put in a tuple, giving a simpler and type-safer+ -- access to captured subterms that looking inside a map.+ --+ -- As an example, here is how one would use it for capturing two subterms:+ --+ -- > f (with (\x y -> iter $ \k -> x <<- inj One <||> y <<- inj (Two (var k))) -> Just (x, y)) = ... x and y available here ...+ --+ -- For more concise syntax which uses quasi-quotation, check "Data.Regex.TH".+ with :: fn -> Fix f -> Maybe r++instance (Generic1 f, MatchG (Rep1 f), Ord c)+ => With f (Regex c f) () where+ with r t = (const ()) <$> (match r t :: Maybe (Map c [Fix f]))+ +instance (Generic1 f, MatchG (Rep1 f))+ => With f (Integer -> Regex Integer f) [Fix f] where+ with r t = M.findWithDefault [] 1 <$> match (r 1) t++instance (Generic1 f, MatchG (Rep1 f))+ => With f (Integer -> Integer -> Regex Integer f)+ ([Fix f], [Fix f]) where+ with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m))+ <$> match (r 1 2) t++instance (Generic1 f, MatchG (Rep1 f))+ => With f (Integer -> Integer -> Integer -> Regex Integer f)+ ([Fix f],[Fix f],[Fix f]) where+ with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m, M.findWithDefault [] 3 m))+ <$> match (r 1 2 3) t++instance (Generic1 f, MatchG (Rep1 f))+ => With f (Integer -> Integer -> Integer -> Integer -> Regex Integer f)+ ([Fix f],[Fix f],[Fix f],[Fix f]) where+ with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m,+ M.findWithDefault [] 3 m, M.findWithDefault [] 4 m))+ <$> match (r 1 2 3 4) t++instance (Generic1 f, MatchG (Rep1 f))+ => With f (Integer -> Integer -> Integer -> Integer -> Integer -> Regex Integer f)+ ([Fix f],[Fix f],[Fix f],[Fix f],[Fix f]) where+ with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m, M.findWithDefault [] 3 m,+ M.findWithDefault [] 4 m, M.findWithDefault [] 5 m))+ <$> match (r 1 2 3 4 5) t+++-- Generation of arbitrary elements following a pattern++-- | Return a random value which matches the given regular expression.+arbitraryFromRegex :: (Generic1 f, ArbitraryRegexG (Rep1 f), Arbitrary (Fix f))+ => Regex c f -> Gen (Fix f)+arbitraryFromRegex = arbitraryFromRegexAndGen arbitrary++-- | Return a random value which matches the given regular expression,+-- and which uses a supplied generator for 'any_'.+arbitraryFromRegexAndGen :: (Generic1 f, ArbitraryRegexG (Rep1 f))+ => Gen (Fix f) -> Regex c f -> Gen (Fix f)+arbitraryFromRegexAndGen g r = arbitraryFromRegex_ g (unRegex r) 0 []++arbitraryFromRegex_ :: (Generic1 f, ArbitraryRegexG (Rep1 f))+ => Gen (Fix f)+ -> Regex' Integer c f+ -> Integer -> [(Integer, Regex' Integer c f)]+ -> Gen (Fix f)+arbitraryFromRegex_ _ Empty _ _ = error "Cannot generate empty tree"+arbitraryFromRegex_ g Any _ _ = g+arbitraryFromRegex_ g (Capture _ r) i s = arbitraryFromRegex_ g r i s+arbitraryFromRegex_ g (Inject r) i s = Fix . to1 <$> arbG g (from1 r) i s+arbitraryFromRegex_ g (Square n) i s = let Just r = lookup n s in arbitraryFromRegex_ g r i s+arbitraryFromRegex_ g (Concat r1 r2) i s = arbitraryFromRegex_ g (r1 i) (i+1) ((i,r2):s)+arbitraryFromRegex_ g r@(Choice _ _) i s = oneof [arbitraryFromRegex_ g rx i s | rx <- toListOfChoices r]++toListOfChoices :: Regex' k c f -> [Regex' k c f]+toListOfChoices Empty = []+toListOfChoices Any = [Any]+toListOfChoices (Capture _ r) = toListOfChoices r+toListOfChoices (Choice r1 r2) = toListOfChoices r1 ++ toListOfChoices r2+toListOfChoices r = [r]++class ArbitraryRegexG f where+ arbG :: (Generic1 g, ArbitraryRegexG (Rep1 g))+ => Gen (Fix g)+ -> f (Regex' Integer c g)+ -> Integer -> [(Integer, Regex' Integer c g)]+ -> Gen (f (Fix g))++instance ArbitraryRegexG U1 where+ arbG _ U1 _ _ = return U1++instance ArbitraryRegexG Par1 where+ arbG g (Par1 r) i s = Par1 <$> arbitraryFromRegex_ g r i s++instance Arbitrary c => ArbitraryRegexG (K1 i c) where+ arbG _ (K1 r) _ _ = unsafePerformIO $+ catch (r `seq` return (return (K1 r))) -- try to return a constant value+ (\(_ :: DoNotCheckThisException) -> return (K1 <$> arbitrary))++instance (Foldable f, Arbitrary1 f) => ArbitraryRegexG (Rec1 f) where+ arbG g (Rec1 rs) i s = let r:_ = toList rs in Rec1 <$> arbitrary1 (arbitraryFromRegex_ g r i s)++instance ArbitraryRegexG a => ArbitraryRegexG (M1 i c a) where+ arbG g (M1 r) i s = M1 <$> arbG g r i s++instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :+: b) where+ arbG g (L1 r) i s = L1 <$> arbG g r i s+ arbG g (R1 r) i s = R1 <$> arbG g r i s++instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :*: b) where+ arbG g (r1 :*: r2) i s = (:*:) <$> arbG g r1 i s <*> arbG g r2 i s
+ src/Data/Regex/MultiGenerics.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ConstraintKinds #-}+-- | Tree regular expressions over mutually recursive regular data types.+module Data.Regex.MultiGenerics (+ -- * Base types+ Regex(Regex),+ Regex',+ Fix(..),++ -- * Constructors+ -- | For a description and study of tree regular expressions, you are invited to read+ -- Chapter 2 of <http://tata.gforge.inria.fr/ Tree Automata Techniques and Applications>.+ + -- ** Emptiness+ empty_, none,+ -- ** Whole language+ any_,+ -- ** Injection+ inj, __,+ -- ** Holes/squares+ square, var, (!),+ -- ** Alternation+ choice, (<||>),+ -- ** Concatenation+ concat_, (<.>),+ -- ** Iteration+ iter, (^*),+ -- ** Capture+ capture, (<<-),++ -- * Matching+ Matchable,+ matches,+ Capturable,+ match,+ -- ** Querying capture groups+ CaptureGroup(..),+ lookupGroup,++ -- * Views+ with,+ Wrap(..),+ (?),++ -- * Random generation+ arbitraryFromRegex,+ arbitraryFromRegexAndGen+) where++import Control.Applicative+import Control.Exception+import Control.Monad (guard)+import qualified Data.Foldable as F+import Data.Foldable (Foldable, toList)+import Data.List (intercalate)+import Data.MultiGenerics+import Data.Typeable+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary1++import Unsafe.Coerce -- :(++-- | The basic data type for tree regular expressions.+--+-- * 'k' is used as phantom type to point to concatenation and iteration positions.+-- * 'c' is the type of capture identifiers.+-- * 'f' is the family of pattern functors over which regular expressions match. In tree regular expression jargon, expresses the set of constructors for nodes.+-- * 'ix' is the index of the data type over which the regular expression matches.+data Regex' (s :: k -> *) (c :: k -> *) (f :: (k -> *) -> k -> *) (ix :: k) where+ Empty :: Regex' s c f ix+ Any :: Regex' s c f ix+ Inject :: f (Regex' s c f) ix -> Regex' s c f ix+ Square :: s ix -> Regex' s c f ix+ Choice :: Regex' s c f ix -> Regex' s c f ix -> Regex' s c f ix+ Concat :: (s xi -> Regex' s c f ix) -> Regex' s c f xi -> Regex' s c f ix+ Capture :: c ix -> Regex' s c f ix -> Regex' s c f ix+-- | Tree regular expressions over mutually recursive data types given by the pattern+-- functor 'f', where the top node is at index 'ix', and with capture identifiers of type 'c'.+newtype Regex c f ix = Regex { unRegex :: forall s. Regex' s c f ix }++-- | Matches no value.+empty_, none :: Regex' k c f ix+empty_ = Empty+none = empty_++-- | Matches any value of the data type.+any_ :: Regex' k c f ix+any_ = Any++-- | Injects a constructor as a regular expression.+-- That is, specifies a tree regular expression whose root is given by a constructor+-- of the corresponding pattern functor, and whose nodes are other tree regular expressions.+-- When matching, fields of types other than 'f' are checked for equality,+-- except when using '__' as the value.+inj :: f (Regex' k c f) ix -> Regex' k c f ix+inj = Inject++-- | Serves as a placeholder for any value in a non-'f'-typed position.+__ :: a+__ = throw DoNotCheckThisException++data DoNotCheckThisException = DoNotCheckThisException deriving (Show, Typeable)+instance Exception DoNotCheckThisException++-- | Indicates the position of a hole in a regular expression.+square, var :: k ix -> Regex' k c f ix+square = Square+var = square++-- | Indicates the position of a hole in a regular expression.+-- This function is meant to be used with the @PostfixOperators@ pragma.+(!) :: k ix -> Regex' k c f ix+(!) = square++-- | Expresses alternation between two tree regular expressions:+-- Data types may match one or the other.+-- When capturing, the first one is given priority.+infixl 3 <||>+choice, (<||>) :: Regex' k c f ix -> Regex' k c f ix -> Regex' k c f ix+choice = Choice+(<||>) = choice++-- | Concatenation: a whole in the first tree regular expression+-- is replaced by the second one.+concat_, (<.>) :: (k xi -> Regex' k c f ix) -> Regex' k c f xi -> Regex' k c f ix+concat_ = Concat+(<.>) = concat_++-- | Repeated replacement of a hole in a tree regular expression.+-- Iteration fulfills the law: @iter r = r \<.\> iter r@.+iter :: (k ix -> Regex' k c f ix) -> Regex' k c f ix+iter r = Concat r (iter r)++-- | Repeated replacement of a hole in a tree regular expression.+-- This function is meant to be used with the @PostfixOperators@ pragma.+(^*) :: (k ix -> Regex' k c f ix) -> Regex' k c f ix+(^*) = iter++-- | Indicates a part of a value that, when matched, should be+-- given a name of type 'c' and saved for querying.+infixl 4 <<-+capture, (<<-) :: c ix -> Regex' k c f ix -> Regex' k c f ix+capture = Capture+(<<-) = capture++-- | Types which can be matched.+type Matchable f = (Generic1m f, MatchG (Rep1m f))++-- | Checks whether a term 't' matches the tree regular expression 'r'.+matches :: Matchable f => Regex c f ix -> Fix f ix -> Bool+r `matches` t = matches' (unRegex r) t 0 []++data CaptureGroup c f m where+ CaptureGroup :: c ix -> m (Fix f ix) -> CaptureGroup c f m++instance (ShowM c, Foldable m, ShowM (Fix f)) => Show (CaptureGroup c f m) where+ show (CaptureGroup ix e) = showM ix ++ " -> { " ++ intercalate ", " (map showM $ toList e) ++ " }"++lookupGroup :: EqM c => c ix -> [CaptureGroup c f m] -> Maybe (m (Fix f ix))+lookupGroup _ [] = Nothing+lookupGroup c (CaptureGroup ix info : rest) | c `eqM` ix = Just (unsafeCoerce info)+ | otherwise = lookupGroup c rest++lookupGroupDef :: (Alternative m, EqM c) => c ix -> [CaptureGroup c f m] -> m (Fix f ix)+lookupGroupDef _ [] = empty+lookupGroupDef c (CaptureGroup ix info : rest) | c `eqM` ix = unsafeCoerce info+ | otherwise = lookupGroupDef c rest++unionGroups :: (EqM c, Alternative m)+ => [CaptureGroup c f m] -> [CaptureGroup c f m]+ -> [CaptureGroup c f m]+unionGroups [] g2 = g2+unionGroups (ge1@(CaptureGroup ix1 info1) : grest1) g2 =+ newG1 ++ unionGroups grest1 newG2+ where (newG1, newG2) = unionGroups' g2 []+ unionGroups' [] accG2 = ([ge1], reverse accG2)+ unionGroups' (ge2@(CaptureGroup ix2 info2) : grest2) accG2+ | ix1 `eqM` ix2 = ([CaptureGroup ix1 (info1 <|> unsafeCoerce info2)], reverse accG2 ++ grest2)+ | otherwise = unionGroups' grest2 (ge2 : accG2)++-- | Types which can be matched and captured.+type Capturable c f = (Generic1m f, MatchG (Rep1m f), EqM c)++-- | Checks whether a term 't' matches the tree regular expression 'r'.+-- When successful, it returns in addition a map of captured subterms.+--+-- The behaviour of several matches over the same capture identifier+-- is governed by the 'Alternative' functor 'm'. For example, if+-- @m = []@, all matches are returned in prefix-order. If @m = Maybe@,+-- only the first result is returned.+match :: (Capturable c f, Alternative m)+ => Regex c f ix -> Fix f ix -> Maybe [CaptureGroup c f m]+match r t = match' (unRegex r) t 0 []++newtype WrappedInteger a = W Integer++matches' :: Matchable f+ => Regex' WrappedInteger c f ix+ -> Fix f ix+ -> Integer -- Fresh variable generator+ -> [(Integer, forall xi. Regex' WrappedInteger c f xi)] -- Ongoing substitution+ -> Bool+matches' Empty _ _ _ = False+matches' Any _ _ _ = True+matches' (Inject r) (Fix t) i s = injesG (from1k r) (from1k t) i s+matches' (Square (W n)) t i s = let Just r = unsafeCoerce (lookup n s) in matches' r t i s+matches' (Choice r1 r2) t i s = matches' r1 t i s || matches' r2 t i s+matches' (Concat r1 r2) t i s = matches' (r1 (W i)) t (i+1) ((i, unsafeCoerce r2):s)+matches' (Capture _ r) t i s = matches' r t i s++match' :: (Capturable c f, Alternative m)+ => Regex' WrappedInteger c f ix+ -> Fix f ix+ -> Integer -- Fresh variable generator+ -> [(Integer, forall xi. Regex' WrappedInteger c f xi)] -- Ongoing substitution+ -> Maybe [CaptureGroup c f m]+match' Empty _ _ _ = Nothing+match' Any _ _ _ = Just []+match' (Inject r) (Fix t) i s = injG (from1k r) (from1k t) i s+match' (Square (W n)) t i s = let Just r = unsafeCoerce (lookup n s) in match' r t i s+match' (Choice r1 r2) t i s = match' r1 t i s <|> match' r2 t i s+match' (Concat r1 r2) t i s = match' (r1 (W i)) t (i+1) ((i, unsafeCoerce r2):s)+match' (Capture c r) t i s = unionGroups [CaptureGroup c (pure t)] <$> match' r t i s++class MatchG (f :: (k -> *) -> k -> *) where+ injesG :: Matchable g+ => f (Regex' WrappedInteger c g) ix+ -> f (Fix g) ix+ -> Integer+ -> [(Integer, forall xi. Regex' WrappedInteger c g xi)]+ -> Bool+ injG :: (Capturable c g, Alternative m)+ => f (Regex' WrappedInteger c g) ix+ -> f (Fix g) ix+ -> Integer+ -> [(Integer, forall xi. Regex' WrappedInteger c g xi)]+ -> Maybe [CaptureGroup c g m]++instance MatchG U1m where+ injesG _ _ _ _ = True+ injG _ _ _ _ = Just []++instance MatchG (Par1m xi) where+ injesG (Par1m r) (Par1m t) = matches' r t+ injG (Par1m r) (Par1m t) = match' r t++instance (Functor f, Foldable f) => MatchG (Rec1m f xi) where+ injesG (Rec1m rs) (Rec1m ts) i s =+ F.foldr (||) False $ fmap (\r -> F.foldr (&&) True $ fmap (\t -> matches' r t i s) ts) rs+ injG (Rec1m rs) (Rec1m ts) i s =+ F.foldr (<|>) Nothing -- Get only the first option+ $ fmap (\r -> F.foldr (\x1 x2 -> case (x1, x2) of+ (Just m1, Just m2) -> Just (unionGroups m1 m2)+ _ -> Nothing)+ (Just [])+ $ fmap (\t -> match' r t i s) ts) rs++instance Eq c => MatchG (K1m i c) where+ injesG (K1m r) (K1m t) _ _ =+ unsafePerformIO $+ catch (evaluate $ r == t)+ (\(_ :: DoNotCheckThisException) -> return True)+ injG (K1m r) (K1m t) _ _ =+ unsafePerformIO $+ catch (evaluate $ do guard (r == t) -- Maybe monad+ return [])+ (\(_ :: DoNotCheckThisException) -> return $ Just [])++instance (MatchG a, MatchG b) => MatchG (a :++: b) where+ injesG (L1m r) (L1m t) i s = injesG r t i s+ injesG (R1m r) (R1m t) i s = injesG r t i s+ injesG _ _ _ _ = False+ injG (L1m r) (L1m t) i s = injG r t i s+ injG (R1m r) (R1m t) i s = injG r t i s+ injG _ _ _ _ = Nothing++instance (MatchG a, MatchG b) => MatchG (a :**: b) where+ injesG (r1 :**: r2) (t1 :**: t2) i s = injesG r1 t1 i s && injesG r2 t2 i s+ injG (r1 :**: r2) (t1 :**: t2) i s = unionGroups <$> injG r1 t1 i s <*> injG r2 t2 i s++instance MatchG f => MatchG (Tag1m f xi) where+ injesG (Tag1m r) (Tag1m t) = injesG r t+ injG (Tag1m r) (Tag1m t) = injG r t++-- | Data type used to tag capture identifiers with their expected type.+newtype Wrap c ix = Wrap c deriving (Eq, Ord)++instance Eq c => EqM (Wrap c) where+ eqM (Wrap n1) (Wrap n2) = n1 == n2++instance Show c => ShowM (Wrap c) where+ showM (Wrap n) = show n++-- | Wraps an already existing type to recall extra index information.+(?) :: c -> Wrap c ix+(?) = Wrap++type WI = Wrap Integer++class With f ix fn r | fn -> r where+ -- | Useful function to be used as view pattern.+ -- The first argument should be a function, which indicates those places where captured are found+ -- Those captured are automatically put in a tuple, giving a simpler and type-safer+ -- access to captured subterms that looking inside a map.+ --+ -- As an example, here is how one would use it for capturing two subterms:+ --+ -- > f (with (\x y -> iter $ \k -> x <<- inj One <||> y <<- inj (Two (var k))) -> Just (x, y)) = ... x and y available here ...+ --+ -- For more concise syntax which uses quasi-quotation, check "Data.Regex.TH".+ with :: fn -> Fix f ix -> Maybe r++instance Capturable c f+ => With f ix (Regex c f ix) () where+ with r t = (const ()) <$> (match r t :: Maybe [CaptureGroup c f []])++instance Matchable f+ => With f ix (WI xi -> Regex WI f ix) [Fix f xi] where+ with r t = lookupGroupDef (Wrap 1) <$> match (r (Wrap 1)) t++instance Matchable f+ => With f ix (WI xi1 -> WI xi2 -> Regex WI f ix)+ ([Fix f xi1], [Fix f xi2]) where+ with r t = (\m -> ( lookupGroupDef (Wrap 1) m+ , lookupGroupDef (Wrap 2) m) )+ <$> match (r (Wrap 1) (Wrap 2)) t++instance Matchable f+ => With f ix (WI xi1 -> WI xi2 -> WI xi3 -> Regex WI f ix)+ ([Fix f xi1], [Fix f xi2], [Fix f xi3]) where+ with r t = (\m -> ( lookupGroupDef (Wrap 1) m+ , lookupGroupDef (Wrap 2) m+ , lookupGroupDef (Wrap 3) m) )+ <$> match (r (Wrap 1) (Wrap 2) (Wrap 3)) t++instance Matchable f+ => With f ix (WI xi1 -> WI xi2 -> WI xi3 -> WI xi4 -> Regex WI f ix)+ ([Fix f xi1], [Fix f xi2], [Fix f xi3], [Fix f xi4]) where+ with r t = (\m -> ( lookupGroupDef (Wrap 1) m+ , lookupGroupDef (Wrap 2) m+ , lookupGroupDef (Wrap 3) m+ , lookupGroupDef (Wrap 4) m) )+ <$> match (r (Wrap 1) (Wrap 2) (Wrap 3) (Wrap 4)) t++instance Matchable f+ => With f ix (WI xi1 -> WI xi2 -> WI xi3 -> WI xi4 -> WI xi5 -> Regex WI f ix)+ ([Fix f xi1], [Fix f xi2], [Fix f xi3], [Fix f xi4], [Fix f xi5]) where+ with r t = (\m -> ( lookupGroupDef (Wrap 1) m+ , lookupGroupDef (Wrap 2) m+ , lookupGroupDef (Wrap 3) m+ , lookupGroupDef (Wrap 4) m+ , lookupGroupDef (Wrap 5) m))+ <$> match (r (Wrap 1) (Wrap 2) (Wrap 3) (Wrap 4) (Wrap 5)) t++-- | Return a random value which matches the given regular expression.+arbitraryFromRegex :: (Generic1m f, ArbitraryRegexG (Rep1m f)+ , ArbitraryM (Fix f), SingI ix)+ => Regex c f ix -> Gen (Fix f ix)+arbitraryFromRegex = arbitraryFromRegexAndGen arbitraryM++-- | Return a random value which matches the given regular expression,+-- and which uses a supplied generator for 'any_'.+arbitraryFromRegexAndGen :: (Generic1m f, ArbitraryRegexG (Rep1m f), SingI ix)+ => GenM (Fix f) -> Regex c f ix -> Gen (Fix f ix)+arbitraryFromRegexAndGen g r = arbitraryFromRegex_ g (unRegex r) 0 []++arbitraryFromRegex_ :: (Generic1m f, ArbitraryRegexG (Rep1m f), SingI ix)+ => GenM (Fix f)+ -> Regex' WrappedInteger c f ix+ -> Integer+ -> [(Integer, forall xi. Regex' WrappedInteger c f xi)]+ -> Gen (Fix f ix)+arbitraryFromRegex_ _ Empty _ _ = error "Cannot generate empty tree"+arbitraryFromRegex_ g Any _ _ = g sing+arbitraryFromRegex_ g (Capture _ r) i s = arbitraryFromRegex_ g r i s+arbitraryFromRegex_ g (Inject r) i s = Fix . to1k <$> arbG g (from1k r) i s+arbitraryFromRegex_ g (Square (W n)) i s = let Just r = lookup n s in arbitraryFromRegex_ g r i s+arbitraryFromRegex_ g (Concat r1 r2) i s = arbitraryFromRegex_ g (r1 (W i)) (i+1) ((i, unsafeCoerce r2):s)+arbitraryFromRegex_ g r@(Choice _ _) i s = oneof [arbitraryFromRegex_ g rx i s | rx <- toListOfChoices r]++toListOfChoices :: Regex' k c f ix -> [Regex' k c f ix]+toListOfChoices Empty = []+toListOfChoices Any = [Any]+toListOfChoices (Capture _ r) = toListOfChoices r+toListOfChoices (Choice r1 r2) = toListOfChoices r1 ++ toListOfChoices r2+toListOfChoices r = [r]++class ArbitraryRegexG f where+ arbG :: (Generic1m g, ArbitraryRegexG (Rep1m g))+ => GenM (Fix g)+ -> f (Regex' WrappedInteger c g) ix+ -> Integer+ -> [(Integer, forall xi. Regex' WrappedInteger c g xi)]+ -> Gen (f (Fix g) ix)++instance ArbitraryRegexG U1m where+ arbG _ U1m _ _ = return U1m++instance SingI xi => ArbitraryRegexG (Par1m xi) where+ arbG g (Par1m r) i s = Par1m <$> arbitraryFromRegex_ g r i s++instance Arbitrary c => ArbitraryRegexG (K1m i c) where+ arbG _ (K1m r) _ _ = unsafePerformIO $+ catch (r `seq` return (return (K1m r))) -- try to return a constant value+ (\(_ :: DoNotCheckThisException) -> return (K1m <$> arbitrary))++instance (Foldable f, Arbitrary1 f, SingI xi) => ArbitraryRegexG (Rec1m f xi) where+ arbG g (Rec1m rs) i s = let r:_ = toList rs in Rec1m <$> arbitrary1 (arbitraryFromRegex_ g r i s)++instance ArbitraryRegexG f => ArbitraryRegexG (Tag1m f xi) where+ arbG g (Tag1m r) i s = Tag1m <$> arbG g r i s++instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :++: b) where+ arbG g (L1m r) i s = L1m <$> arbG g r i s+ arbG g (R1m r) i s = R1m <$> arbG g r i s++instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :**: b) where+ arbG g (r1 :**: r2) i s = (:**:) <$> arbG g r1 i s <*> arbG g r2 i s
+ src/Data/Regex/MultiRules.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Attribute grammars with regular expression matching.+module Data.Regex.MultiRules (+ -- * Children maps+ Child(..),+ Children,+ lookupChild,+ -- * Basic blocks+ Action, Rule(..), Grammar,+ eval,+ -- * Nice syntax for defining rules+ rule, rule0,+ -- ** Combinators+ check,+ (->>>), (->>),+ -- ** Special lenses+ this, at,+ inh, syn,+ -- * Index-independent attributes+ IndexIndependent(..),+ IndexIndependentGrammar,+ iieval,+ inh_, syn_, copy+) where++import Control.Applicative+import Control.Lens (use, (.=))+import Control.Monad.State+import Data.Foldable (fold)+import Data.Maybe (fromJust)+import Data.Monoid+import Data.MultiGenerics+import Data.Regex.MultiGenerics+import GHC.Exts (Constraint)++import Unsafe.Coerce++-- | A child records both an actual values and the index it corresponds to.+data Child (c :: k -> *) (attrib :: k -> *) where+ Child :: c ix -> [attrib ix] -> Child c attrib+-- | Children are just a list of 'Child's.+type Children c attrib = [Child c attrib]++lookupChild :: EqM c => c ix -> Children c attrib -> [attrib ix]+lookupChild _ [] = []+lookupChild c (Child ix info : rest) | c `eqM` ix = unsafeCoerce info+ | otherwise = lookupChild c rest++insertChild :: EqM c => c ix -> [attrib ix] -> Children c attrib -> Children c attrib+insertChild k e [] = [Child k e]+insertChild k e (c@(Child ix _) : rest) | k `eqM` ix = Child k e : rest+ | otherwise = c : insertChild k e rest++-- | Actions create new inherited attributes for their children,+-- and synthesized attribute for its own node, from the synthesized+-- attributes of children and the inheritance from its parent.+-- Additionally, actions may include an explicit backtrack.+type Action (c :: k -> *) (f :: (k -> *) -> k -> *) (inh :: k -> *) (syn :: k -> *) (ix :: k) =+ Fix f ix -> inh ix -> Children c syn -> (Bool, Children c inh, syn ix)+-- | A rule comprises the regular expression to match+-- and the action to execute if successful.+data Rule (c :: k -> *) (f :: (k -> *) -> k -> *) (inh :: k -> *) (syn :: k -> *) where+ Rule :: Regex c f ix -> Action c f inh syn ix -> Rule c f inh syn+-- | A grammar is simply a list of rules.+type Grammar (c :: k -> *) (f :: (k -> *) -> k -> *) (inh :: k -> *) (syn :: k -> *) =+ [Rule c f inh syn]++-- | Evaluate an attribute grammar over a certain term.+eval :: forall c f inh syn ix. Capturable c f+ => Grammar c f inh syn -> inh ix -> Fix f ix -> syn ix+eval grammar down term = fromJust $ foldr (<|>) empty $ map evalRule grammar+ where evalRule :: Rule c f inh syn -> Maybe (syn ix)+ evalRule (Rule regex action) = do -- Maybe monad+ let regex' = unsafeCoerce regex+ action' = unsafeCoerce action+ (captures :: [CaptureGroup c f []]) <- match regex' term+ let (ok, children, up) = action' term down $ map evalList captures+ evalList (CaptureGroup k subterms) = let [kInh] = lookupChild k children+ in Child k $ map (eval grammar kInh) subterms+ guard ok+ return up+++data InhAndSyn inh syn ix = InhAndSyn (inh ix) (syn ix)+data ActionState c inh syn ix = ActionState { _apply :: Bool+ , _this :: InhAndSyn inh syn ix+ , _rest :: Children c (InhAndSyn inh syn)+ }++-- | Lens for the attributes of the current node. To be used in composition with 'inh' or 'syn'.+this :: Functor f+ => (InhAndSyn inh syn ix -> f (InhAndSyn inh syn ix))+ -> ActionState c inh syn ix -> f (ActionState c inh syn ix)+this go (ActionState ok th rs) = (\x -> ActionState ok x rs) <$> go th+{-# INLINE this #-}++-- | Lens the attributes of a child node. To be used in composition with 'inh' or 'syn'.+at :: (EqM c, Functor f)+ => c xi -> (InhAndSyn inh syn xi -> f (InhAndSyn inh syn xi))+ -> ActionState c inh syn ix -> f (ActionState c inh syn ix)+at k go (ActionState ok th rs) = (\x -> ActionState ok th (insertChild k [x] rs)) <$> go (head $ lookupChild k rs)+{-# INLINE at #-}++-- | Lens for the inherited attributes of a node.+-- Use only as getter with 'this' and as setter with 'at'.+inh :: (Functor f) => (inh ix -> f (inh ix))+ -> InhAndSyn inh syn ix -> f (InhAndSyn inh syn ix)+inh go (InhAndSyn i s) = (\x -> InhAndSyn x s) <$> go i+{-# INLINE inh #-}++-- | Lens the inherited synthesized attributes of a node.+-- Use only as setter with 'this' and as getter with 'at'.+syn :: (Functor f) => (syn ix -> f (syn ix))+ -> InhAndSyn inh syn ix -> f (InhAndSyn inh syn ix)+syn go (InhAndSyn i s) = (\x -> InhAndSyn i x) <$> go s+{-# INLINE syn #-}++data IxList (c :: k -> *) :: [k] -> * where+ IxNil :: IxList c '[]+ IxCons :: c ix -> IxList c rest -> IxList c (ix ': rest)++type family IxListMonoid (c :: k -> *) (ixs :: [k]) :: Constraint where+ IxListMonoid c '[] = ()+ IxListMonoid c (ix ': rest) = (Monoid (c ix), IxListMonoid c rest)++stateToAction :: (EqM c, IxListMonoid inh ixs, Monoid (syn ix), IxListMonoid syn ixs)+ => IxList c ixs+ -> (Fix f ix -> State (ActionState c inh syn ix) ())+ -> Action c f inh syn ix -- Fix f ix -> inh ix -> Children c syn -> (Bool, Children c inh, syn ix)+stateToAction nodes st term down up = + let initialSyn = initialRest nodes up+ initial = ActionState True (InhAndSyn down mempty) initialSyn+ ActionState ok (InhAndSyn _ thisUp) rs = execState (st term) initial+ in (ok, finalDown nodes rs, thisUp)++initialRest :: (EqM c, IxListMonoid inh ixs, IxListMonoid syn ixs)+ => IxList c ixs -> Children c syn -> Children c (InhAndSyn inh syn)+initialRest IxNil _ = []+initialRest (IxCons c rest) children =+ Child c [InhAndSyn mempty (fold $ lookupChild c children)] : initialRest rest children++finalDown :: EqM c => IxList c ixs -> Children c (InhAndSyn inh syn) -> Children c inh+finalDown IxNil _ = []+finalDown (IxCons c rest) children =+ Child c [ firstInh $ lookupChild c children ] : finalDown rest children+ where firstInh [InhAndSyn s _] = s+ firstInh _ = error "This should never happen"++-- | Separates matching and attribute calculation on a rule.+-- The action should take as extra parameter the node which was matched.+(->>>) :: forall f (ix :: k) inh syn (ixs :: [k])+ . (IxListMonoid inh ixs, Monoid (syn ix), IxListMonoid syn ixs)+ => (forall c. Regex' c (Wrap Integer) f ix)+ -> (Fix f ix -> State (ActionState (Wrap Integer) inh syn ix) ())+ -> IxList (Wrap Integer) ixs -> Rule (Wrap Integer) f inh syn+(rx ->>> st) nodes = Rule (Regex rx) (stateToAction nodes st)++-- | Separates matching and attribute calculation on a rule.+(->>) :: forall f (ix :: k) inh syn (ixs :: [k])+ . (IxListMonoid inh ixs, Monoid (syn ix), IxListMonoid syn ixs)+ => (forall c. Regex' c (Wrap Integer) f ix)+ -> State (ActionState (Wrap Integer) inh syn ix) ()+ -> IxList (Wrap Integer) ixs -> Rule (Wrap Integer) f inh syn+(rx ->> st) nodes = (rx ->>> const st) nodes++-- | Makes the attribute calculation fail if the condition is false.+-- This function can be used to add extra conditions over whether+-- a certain rule should be applied (a bit like guards).+check :: Bool -> State (ActionState (Wrap Integer) inh syn ix) ()+check ok = modify (\(ActionState _ th rs) -> ActionState ok th rs)+++-- | Utility type which does not distinguish between indices.+newtype IndexIndependent t ix = IndexIndependent t deriving (Show, Eq, Ord, Monoid)++-- | A grammar whose attributes are equal throughout all indices.+type IndexIndependentGrammar c f inh syn = Grammar c f (IndexIndependent inh) (IndexIndependent syn)++-- | Evaluate an index-indendepent grammar.+iieval :: forall c f inh syn ix. Capturable c f+ => IndexIndependentGrammar c f inh syn -> inh -> Fix f ix -> syn+iieval g down t = up where IndexIndependent up = eval g (IndexIndependent down) t++-- | Lens for 'Indexed' inherited attributes of a node.+-- Use only as getter with 'this' and as setter with 'at'.+inh_ :: (Functor f) => (inh -> f inh)+ -> InhAndSyn (IndexIndependent inh) syn ix -> f (InhAndSyn (IndexIndependent inh) syn ix)+inh_ go (InhAndSyn (IndexIndependent i) s) = (\x -> InhAndSyn (IndexIndependent x) s) <$> go i+{-# INLINE inh_ #-}++-- | Lens the 'Indexed' synthesized attributes of a node.+-- Use only as setter with 'this' and as getter with 'at'.+syn_ :: (Functor f) => (syn -> f syn)+ -> InhAndSyn inh (IndexIndependent syn) ix -> f (InhAndSyn inh (IndexIndependent syn) ix)+syn_ go (InhAndSyn i (IndexIndependent s)) = (\x -> InhAndSyn i (IndexIndependent x)) <$> go s+{-# INLINE syn_ #-}++-- | Apply copy rule for inherited attributes.+copy :: EqM c => [c xi] -> State (ActionState c (IndexIndependent inh) syn ix) ()+copy nodes = do+ down <- use (this . inh_)+ mapM_ (\node -> at node . inh_ .= down) nodes+++class RuleBuilder (f :: (k -> *) -> k -> *) (inh :: k -> *) (syn :: k -> *) (ixs :: [k]) fn | fn -> ixs where+ -- | Converts a rule description into an actual 'Rule'.+ -- Its use must follow this pattern:+ --+ -- * A block of lambda-bound variables will introduce the capture names,+ -- * A tree regular expression to match should capture using the previous names,+ -- * After '->>>' or '->>', the state calculation should proceed.+ --+ -- > rule $ \c1 c2 ->+ -- > regex ... c1 <<- ... c2 <<- ... ->> do+ -- > at c2 . inh .= ... -- Set inherited for children+ -- > c1Syn <- use (at c1 . syn) -- Get synthesized from children+ -- > this . syn .= ... -- Set upwards synthesized attributes+ rule :: (fn -> IxList (Wrap Integer) ixs -> Rule (Wrap Integer) f inh syn) -> Rule (Wrap Integer) f inh syn++{- Does not fulfill coverage condition+instance RuleBuilder f inh syn '[] () where+ rule r = r () IxNil+-}++-- | Special case for rules without capture.+rule0 :: (IxList (Wrap Integer) '[] -> Rule (Wrap Integer) f inh syn) -> Rule (Wrap Integer) f inh syn+rule0 r = r IxNil++instance RuleBuilder f inh syn '[ix1] (Wrap Integer ix1) where+ rule r = r (Wrap 1) (IxCons (Wrap 1) IxNil)++instance RuleBuilder f inh syn '[ix1, ix2] (Wrap Integer ix1, Wrap Integer ix2) where+ rule r = r (Wrap 1, Wrap 2) (IxCons (Wrap 1) ((IxCons (Wrap 2)) IxNil))++instance RuleBuilder f inh syn '[ix1, ix2, ix3]+ (Wrap Integer ix1, Wrap Integer ix2, Wrap Integer ix3) where+ rule r = r (Wrap 1, Wrap 2, Wrap 3) (IxCons (Wrap 1) (IxCons (Wrap 2) (IxCons (Wrap 3) IxNil)))++instance RuleBuilder f inh syn '[ix1, ix2, ix3, ix4]+ (Wrap Integer ix1, Wrap Integer ix2, Wrap Integer ix3, Wrap Integer ix4) where+ rule r = r (Wrap 1, Wrap 2, Wrap 3, Wrap 4)+ (IxCons (Wrap 1) (IxCons (Wrap 2) (IxCons (Wrap 3) (IxCons (Wrap 4) IxNil))))++instance RuleBuilder f inh syn '[ix1, ix2, ix3, ix4, ix5]+ (Wrap Integer ix1, Wrap Integer ix2, Wrap Integer ix3, Wrap Integer ix4, Wrap Integer ix5) where+ rule r = r (Wrap 1, Wrap 2, Wrap 3, Wrap 4, Wrap 5)+ (IxCons (Wrap 1) (IxCons (Wrap 2) (IxCons (Wrap 3) (IxCons (Wrap 4) (IxCons (Wrap 5) IxNil)))))
+ src/Data/Regex/Rules.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+-- | Attribute grammars with regular expression matching.+module Data.Regex.Rules (+ -- * Basic blocks+ Action, Rule, Grammar,+ eval,+ -- * Nice syntax for defining rules+ rule,+ -- ** Combinators+ check,+ (->>>), (->>),+ -- ** Special lenses+ this, at,+ inh, syn+) where++import Control.Applicative+import Control.Monad.State+import Data.Foldable (foldMap)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromJust)+import Data.Monoid+import Data.Regex.Generics++-- | Actions create new inherited attributes for their children,+-- and synthesized attribute for its own node, from the synthesized+-- attributes of children and the inheritance from its parent.+-- Additionally, actions may include an explicit backtrack.+type Action c (f :: * -> *) inh syn = Fix f -> inh -> Map c syn -> (Bool, Map c inh, syn)+-- | A rule comprises the regular expression to match+-- and the action to execute if successful.+type Rule c (f :: * -> *) inh syn = (Regex c f, Action c f inh syn)+-- | A grammar is simply a list of rules.+type Grammar c (f :: * -> *) inh syn = [Rule c f inh syn]++-- | Evaluate an attribute grammar over a certain term.+eval :: (Ord c, Matchable f, Monoid syn)+ => Grammar c f inh syn -> inh -> Fix f -> syn+eval grammar down term = fromJust $ foldr (<|>) empty $ map evalRule grammar+ where evalRule (regex, action) = do -- Maybe monad+ (captures :: Map c [Fix f]) <- match regex term+ let (ok, children, up) = action term down $ M.mapWithKey evalList captures+ evalList k = foldMap $ eval grammar (children M.! k)+ guard ok+ return up++data ActionState c inh syn = ActionState { _apply :: Bool, _this :: (inh, syn), _rest :: Map c (inh, syn) }++-- | Lens for the attributes of the current node. To be used in composition with 'inh' or 'syn'.+this :: Functor f => ((inh,syn) -> f (inh,syn))+ -> ActionState c inh syn -> f (ActionState c inh syn)+this go (ActionState ok th rs) = (\x -> ActionState ok x rs) <$> go th+{-# INLINE this #-}++-- | Lens the attributes of a child node. To be used in composition with 'inh' or 'syn'.+at :: (Ord c, Functor f) => c -> ((inh,syn) -> f (inh,syn))+ -> ActionState c inh syn -> f (ActionState c inh syn)+at k go (ActionState ok th rs) = (\x -> ActionState ok th (M.insert k x rs)) <$> go (rs M.! k)+{-# INLINE at #-}++-- | Lens for the inherited attributes of a node.+-- Use only as getter with 'this' and as setter with 'at'.+inh :: Functor f => (inh -> f inh) -> (inh, syn) -> f (inh, syn)+inh go (i,s) = (\x -> (x,s)) <$> go i+{-# INLINE inh #-}++-- | Lens the inherited synthesized attributes of a node.+-- Use only as setter with 'this' and as getter with 'at'.+syn :: Functor f => (syn -> f syn) -> (inh, syn) -> f (inh, syn)+syn go (i,s) = (\x -> (i,x)) <$> go s+{-# INLINE syn #-}+++stateToAction :: (Ord c, Monoid syn)+ => [c] -> (Fix f -> State (ActionState c inh syn) ())+ -> Action c f inh syn+stateToAction nodes st term down up =+ let initialRest = M.fromList $ map (\c -> (c, (down, up M.! c))) nodes -- down copy rule+ initial = ActionState True (down, mempty) initialRest -- start with empty+ ActionState ok th rs = execState (st term) initial+ in (ok, M.map fst rs, snd th)++-- | Separates matching and attribute calculation on a rule.+-- The action should take as extra parameter the node which was matched.+(->>>) :: Monoid syn+ => (forall k. Regex' k Integer f) -> (Fix f -> State (ActionState Integer inh syn) ())+ -> [Integer] -> Rule Integer f inh syn+(rx ->>> st) nodes = (Regex rx, stateToAction nodes st)++-- | Separates matching and attribute calculation on a rule.+(->>) :: Monoid syn+ => (forall k. Regex' k Integer f) -> State (ActionState Integer inh syn) ()+ -> [Integer] -> Rule Integer f inh syn+rx ->> st = rx ->>> const st++-- | Makes the attribute calculation fail if the condition is false.+-- This function can be used to add extra conditions over whether+-- a certain rule should be applied (a bit like guards).+check :: Bool -> State (ActionState Integer inh syn) ()+check ok = modify (\(ActionState _ th rs) -> ActionState ok th rs)+++class RuleBuilder (f :: * -> *) inh syn fn r | fn -> r, r -> f inh syn where+ -- | Converts a rule description into an actual 'Rule'.+ -- Its use must follow this pattern:+ --+ -- * A block of lambda-bound variables will introduce the capture names,+ -- * A tree regular expression to match should capture using the previous names,+ -- * After '->>>' or '->>', the state calculation should proceed.+ --+ -- > rule $ \c1 c2 ->+ -- > regex ... c1 <<- ... c2 <<- ... ->> do+ -- > at c2 . inh .= ... -- Set inherited for children+ -- > c1Syn <- use (at c1 . syn) -- Get synthesized from children+ -- > this . syn .= ... -- Set upwards synthesized attributes+ rule :: fn -> r++instance Monoid syn =>+ RuleBuilder f inh syn+ ([Integer] -> Rule Integer f inh syn)+ (Rule Integer f inh syn) where+ rule r = r []++instance Monoid syn =>+ RuleBuilder f inh syn+ (Integer -> [Integer] -> Rule Integer f inh syn)+ (Rule Integer f inh syn) where+ rule r = r 1 [1]++instance Monoid syn =>+ RuleBuilder f inh syn+ (Integer -> Integer -> [Integer] -> Rule Integer f inh syn)+ (Rule Integer f inh syn) where+ rule r = r 1 2 [1,2]++instance Monoid syn =>+ RuleBuilder f inh syn+ (Integer -> Integer -> Integer -> [Integer] -> Rule Integer f inh syn) + (Rule Integer f inh syn) where+ rule r = r 1 2 3 [1,2,3]++instance Monoid syn =>+ RuleBuilder f inh syn+ (Integer -> Integer -> Integer -> Integer -> [Integer] -> Rule Integer f inh syn) + (Rule Integer f inh syn) where+ rule r = r 1 2 3 4 [1,2,3,4]++instance Monoid syn =>+ RuleBuilder f inh syn+ (Integer -> Integer -> Integer -> Integer -> Integer -> [Integer] -> Rule Integer f inh syn) + (Rule Integer f inh syn) where+ rule r = r 1 2 3 4 5 [1,2,3,4,5]
+ src/Data/Regex/TH.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Quasi-quoters for doing pattern matching using tree regular expressions.+module Data.Regex.TH (rx, mrx) where++import Control.Applicative ((<$>))+import Data.List (nub)+import Data.Regex.Generics+import qualified Data.Regex.MultiGenerics as M+import qualified Language.Haskell.Exts as E+import Language.Haskell.Exts.Parser+import Language.Haskell.Meta.Syntax.Translate+import Language.Haskell.TH+import Language.Haskell.TH.Quote++rPat :: String -> Q Pat+rPat s = case parseExp ("(" ++ s ++ ")") of+ ParseFailed _ msg -> fail msg+ ParseOk expr -> do eName <- nub <$> getFreeVars (getUnboundVarsE expr)+ let nullSrc = E.SrcLoc "" 0 0+ fullExpr = E.App (E.Con (E.Qual (E.ModuleName "Data.Regex.Generics") (E.Ident "Regex"))) expr+ case eName of+ [] -> return $ ViewP (AppE (VarE 'with)+ (toExp fullExpr))+ (ConP 'Just [ConP '() []])+ [v] -> return $ ViewP (AppE (VarE 'with)+ (toExp $ E.Lambda nullSrc [toIntegerVar v] fullExpr))+ (ConP 'Just [toPat (E.PVar v)])+ vs -> return $ ViewP (AppE (VarE 'with)+ (toExp $ E.Lambda nullSrc (map toIntegerVar vs) fullExpr))+ (ConP 'Just [TupP $ map (toPat . E.PVar) vs])++getUnboundVarsE :: E.Exp -> [E.Name]+getUnboundVarsE (E.Var (E.UnQual n)) = [n]+getUnboundVarsE (E.Var _) = []+getUnboundVarsE (E.App e1 e2) = getUnboundVarsE e1 ++ getUnboundVarsE e2+getUnboundVarsE (E.InfixApp e1 _ e2) = getUnboundVarsE e1 ++ getUnboundVarsE e2+getUnboundVarsE (E.LeftSection e _) = getUnboundVarsE e+getUnboundVarsE (E.RightSection _ e) = getUnboundVarsE e+getUnboundVarsE (E.Paren e) = getUnboundVarsE e+getUnboundVarsE (E.Lambda _ p e) = let pvars = map (\(E.PVar n) -> n) p+ in filter (not . flip elem pvars) (getUnboundVarsE e)+getUnboundVarsE _ = []++getFreeVars :: [E.Name] -> Q [E.Name]+getFreeVars [] = return []+getFreeVars (n@(E.Ident i):ns) = do nRest <- getFreeVars ns+ l <- lookupValueName i+ case l of+ Nothing -> return (n:nRest)+ Just _ -> return nRest+getFreeVars (_:ns) = getFreeVars ns++toIntegerVar :: E.Name -> E.Pat+toIntegerVar e = E.PatTypeSig (E.SrcLoc "" 0 0)+ (E.PVar e)+ (E.TyCon (E.Qual (E.ModuleName "Prelude") (E.Ident "Integer")))++-- | Builds a pattern for a matching a tree regular expression over+-- a regular data type. Those variables not bound are taken to be+-- capture identifiers. Note that the value of capture identifiers+-- is always a list, even if it matches only one subterm in the+-- given tree regular expression.+--+-- One example of use is:+--+-- > f [rx| iter $ \k -> x <<- inj One <||> y <<- inj (Two (k#)) |] =+-- > ... x and y available here with type [Fix f] ...+--+-- In many cases, it is useful to define pattern synonyms for+-- injecting constructors, as shown below:+--+-- > pattern One_ = Inject One+-- > pattern Two_ x = Inject (Two_ x)+-- > +-- > f [rx| (\k -> x <<- One_ <||> y <<- Two_ (k#))^* |] = ...+rx :: QuasiQuoter+rx = QuasiQuoter { quotePat = rPat+ , quoteExp = fail "Quasi-quoter only supports patterns"+ , quoteType = fail "Quasi-quoter only supports patterns"+ , quoteDec = fail "Quasi-quoter only supports patterns"+ }++mrPat :: String -> Q Pat+mrPat s = case parseExp ("(" ++ s ++ ")") of+ ParseFailed _ msg -> fail msg+ ParseOk expr -> do let (newExpr, unbound) = getUnboundVarsM expr+ eName <- getFreeVarsM unbound+ let nullSrc = E.SrcLoc "" 0 0+ fullExpr = E.App (E.Con (E.Qual (E.ModuleName "Data.Regex.MultiGenerics") (E.Ident "Regex"))) newExpr+ case eName of+ [] -> return $ ViewP (AppE (VarE 'M.with)+ (toExp fullExpr))+ (ConP 'Just [ConP '() []])+ [(v,ty)] -> return $ ViewP (AppE (VarE 'M.with)+ (toExp $ E.Lambda nullSrc [toVarM (v,ty)] fullExpr))+ (ConP 'Just [toPat (E.PVar v)])+ vs -> return $ ViewP (AppE (VarE 'M.with)+ (toExp $ E.Lambda nullSrc (map toVarM vs) fullExpr))+ (ConP 'Just [TupP $ map (toPat . E.PVar . fst) vs])++getUnboundVarsM :: E.Exp -> (E.Exp, [(E.Name, E.Type)])+getUnboundVarsM (E.ExpTypeSig _ v@(E.Var (E.UnQual n)) ty) = (v, [(n,ty)])+getUnboundVarsM v@(E.Var _) = (v, [])+getUnboundVarsM (E.App e1 e2) = let (r1, m1) = getUnboundVarsM e1+ (r2, m2) = getUnboundVarsM e2+ in (E.App r1 r2, m1 ++ m2)+getUnboundVarsM (E.InfixApp e1 o e2) = let (r1, m1) = getUnboundVarsM e1+ (r2, m2) = getUnboundVarsM e2+ in (E.InfixApp r1 o r2, m1 ++ m2)+getUnboundVarsM (E.LeftSection e o) = let (r,m) = getUnboundVarsM e+ in (E.LeftSection r o, m)+getUnboundVarsM (E.RightSection o e) = let (r,m) = getUnboundVarsM e+ in (E.RightSection o r, m)+getUnboundVarsM (E.Paren e) = let (r,m) = getUnboundVarsM e+ in (E.Paren r, m)+getUnboundVarsM (E.Lambda l p e) = let pvars = map (\(E.PVar n) -> n) p+ (r,m) = getUnboundVarsM e+ in (E.Lambda l p r, filter (not . flip elem pvars . fst) m)+getUnboundVarsM x = (x, [])++getFreeVarsM :: [(E.Name, E.Type)] -> Q [(E.Name, E.Type)]+getFreeVarsM [] = return []+getFreeVarsM ((n@(E.Ident i),t):ns) = do nRest <- getFreeVarsM ns+ l <- lookupValueName i+ case l of+ Nothing -> return ((n,t):nRest)+ Just _ -> return nRest+getFreeVarsM (_:ns) = getFreeVarsM ns++toVarM :: (E.Name, E.Type) -> E.Pat+toVarM (e,ty) = E.PatTypeSig (E.SrcLoc "" 0 0)+ (E.PVar e)+ (E.TyApp (E.TyApp (E.TyCon (E.Qual (E.ModuleName "Data.Regex.MultiGenerics") (E.Symbol "Wrap")))+ (E.TyCon (E.Qual (E.ModuleName "Prelude") (E.Ident "Integer"))))+ ty)++-- | Builds a pattern for a matching a tree regular expression over+-- a family of regular data type. Those variables not bound are+-- taken to be capture identifiers, and their index should be explicitly+-- given in the expression. Note that the value of capture identifiers+-- is always a list, even if it matches only one subterm in the+-- given tree regular expression.+--+-- One example of use is:+--+-- > f [mrx| iter $ \k -> (x :: A) <<- inj One <||> (y :: B) <<- inj (Two (k#)) |] =+-- > ... x is available with type [Fix f A]+-- > ... and y with type [Fix f B]+mrx :: QuasiQuoter+mrx = QuasiQuoter { quotePat = mrPat+ , quoteExp = fail "Quasi-quoter only supports patterns"+ , quoteType = fail "Quasi-quoter only supports patterns"+ , quoteDec = fail "Quasi-quoter only supports patterns"+ }
+ src/Test/QuickCheck/Arbitrary1.hs view
@@ -0,0 +1,19 @@+module Test.QuickCheck.Arbitrary1 (+ Arbitrary1(..)+) where++import Control.Applicative+import Test.QuickCheck++-- | Version of 'Arbitrary' for functors.+class Arbitrary1 f where+ arbitrary1 :: Gen a -> Gen (f a)++-- From QuickCheck source+instance Arbitrary1 [] where+ arbitrary1 g = sized $ \n ->+ do k <- choose (0,n)+ sequence [ g | _ <- [1..k] ]++instance Arbitrary1 Maybe where+ arbitrary1 g = frequency [(1, return Nothing), (3, Just <$> g)]
+ t-regex.cabal view
@@ -0,0 +1,37 @@+name: t-regex+version: 0.1.0.0+synopsis: Matchers and grammars using tree regular expressions+license: BSD3+author: Alejandro Serrano+maintainer: A.SerranoMena@uu.nl+category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Data.MultiGenerics,+ Test.QuickCheck.Arbitrary1,+ Data.Regex.Generics,+ Data.Regex.MultiGenerics,+ Data.Regex.Example.Mono,+ Data.Regex.Example.Multi,+ Data.Regex.Example.FPDag2015,+ Data.Regex.TH,+ Data.Regex.Rules,+ Data.Regex.MultiRules+ -- other-modules: + -- other-extensions: + build-depends: base >= 4 && < 5,+ containers,+ recursion-schemes >= 4 && < 5,+ template-haskell,+ haskell-src-exts,+ haskell-src-meta,+ mtl >= 2,+ transformers,+ lens >= 4,+ QuickCheck > 2+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall