diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/MultiGenerics.hs b/src/Data/MultiGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Data/MultiGenerics.hs @@ -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 diff --git a/src/Data/Regex/Example/FPDag2015.hs b/src/Data/Regex/Example/FPDag2015.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/Example/FPDag2015.hs @@ -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 diff --git a/src/Data/Regex/Example/Mono.hs b/src/Data/Regex/Example/Mono.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/Example/Mono.hs @@ -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 + ] diff --git a/src/Data/Regex/Example/Multi.hs b/src/Data/Regex/Example/Multi.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/Example/Multi.hs @@ -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 + ] diff --git a/src/Data/Regex/Generics.hs b/src/Data/Regex/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/Generics.hs @@ -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 . + + -- ** 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 diff --git a/src/Data/Regex/MultiGenerics.hs b/src/Data/Regex/MultiGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/MultiGenerics.hs @@ -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 . + + -- ** 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 diff --git a/src/Data/Regex/MultiRules.hs b/src/Data/Regex/MultiRules.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/MultiRules.hs @@ -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))))) diff --git a/src/Data/Regex/Rules.hs b/src/Data/Regex/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/Rules.hs @@ -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] diff --git a/src/Data/Regex/TH.hs b/src/Data/Regex/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Regex/TH.hs @@ -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" + } diff --git a/src/Test/QuickCheck/Arbitrary1.hs b/src/Test/QuickCheck/Arbitrary1.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Arbitrary1.hs @@ -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)] diff --git a/t-regex.cabal b/t-regex.cabal new file mode 100644 --- /dev/null +++ b/t-regex.cabal @@ -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