mini-egison 0.1.6 → 1.0.0
raw patch · 8 files changed
+345/−250 lines, 8 filesdep +egison-pattern-srcdep +egison-pattern-src-th-modedep +haskell-src-extsdep −containersdep −regex-compatdep −splitPVP ok
version bump matches the API change (PVP)
Dependencies added: egison-pattern-src, egison-pattern-src-th-mode, haskell-src-exts, mtl, recursion-schemes
Dependencies removed: containers, regex-compat, split
API changes (from Hackage documentation)
Files
- README.md +79/−75
- mini-egison.cabal +10/−4
- sample/cdcl.hs +22/−22
- src/Control/Egison/Core.hs +7/−0
- src/Control/Egison/Match.hs +26/−25
- src/Control/Egison/Matcher.hs +8/−8
- src/Control/Egison/QQ.hs +171/−94
- test/Spec.hs +22/−22
README.md view
@@ -13,21 +13,25 @@ This library provides two syntax constructs, `matchAll`, `match`, `matchAllDFS`, and `matchDFS` for advanced pattern matching for non-free data types. ```-e = hs-expr -- arbitrary Haskell expression- | matchAll e e [C, ...] -- match-all expression- | match e e [C, ...] -- match expression- | matchAllDFS e e [C, ...] -- match-all expression- | matchDFS e e [C, ...] -- match expression- | Something -- Something built-in matcher+e ::= hs-expr -- arbitrary Haskell expression+ | matchAll e e [C, ...] -- match-all expression+ | match e e [C, ...] -- match expression+ | matchAllDFS e e [C, ...] -- match-all expression+ | matchDFS e e [C, ...] -- match expression+ | Something -- Something built-in matcher -C = [mc| p => e |] -- match clause+C ::= [mc| p -> e |] -- match clause -p = _ -- wildcard- | $x -- pattern variable- | #e -- value pattern- | (& p ...) -- and-pattern- | (| p ...) -- or-pattern- | (not p) -- not-pattern+p ::= _ -- wildcard pattern+ | $v -- pattern variable+ | #e -- value pattern+ | ?e -- predicate pattern+ | (p_1, p_2, ..., p_n) -- tuple pattern+ | [p_1, p_2, ..., p_n] -- collection pattern+ | p & p -- and-pattern+ | p | p -- or-pattern+ | !p -- not-pattern+ | c p_1 p_2 ... p_n -- constructor pattern ``` ## Usage@@ -39,7 +43,7 @@ This expression returns a list of a single element because there is only one decomposition. ```-matchAll [1,2,3] (List Integer) [[mc| cons $x $xs => (x, xs)|]]+matchAll [1,2,3] (List Integer) [[mc| $x : $xs -> (x, xs)|]] -- [(1,[2,3])] ``` @@ -51,11 +55,11 @@ For example, by changing the matcher of the above `matchAll` from `List Integer` to `Multiset Integer`, the evaluation result changes as follows: ```-matchAll [1,2,3] (Multiset Integer) [[mc| cons $x $xs => (x, xs)|]]+matchAll [1,2,3] (Multiset Integer) [[mc| $x : $xs -> (x, xs)|]] -- [(1,[2,3]),(2,[1,3]),(3,[1,2])] ``` -When the `Multiset` matcher is used, the `cons` pattern decomposes a target list into an element and the rest elements.+When the `Multiset` matcher is used, `:` (the cons pattern) decomposes a target list into an element and the rest elements. The pattern-matching algorithms for each matcher can be defined by users. For example, the matchers such as `List` and `Multiset` can be defined by users.@@ -72,7 +76,7 @@ A non-linear pattern is effectively used for expressing the pattern. ```-matchAll [1,2,5,9,4] (Multiset Integer) [[mc| cons $x (cons #(x+1) _) => x|]]+matchAll [1,2,5,9,4] (Multiset Integer) [[mc| $x : #(x+1) : _ -> x|]] -- [1,4] ``` @@ -82,7 +86,7 @@ The `match` expression returns only the evaluation result of the first pattern-matching result. ```-match [1,2,5,9,4] (Multiset Integer) [[mc| cons $x (cons #(x+1) _) => x|]]+match [1,2,5,9,4] (Multiset Integer) [[mc| $x : #(x+1) : _ -> x|]] -- 1 ``` @@ -100,7 +104,7 @@ ``` take 10 (matchAll [1..] (Set Integer)- [[mc| cons $x (cons $y _) => (x, y) |]])+ [[mc| $x : $y : _ -> (x, y) |]]) -- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] ``` @@ -108,7 +112,7 @@ ``` take 10 (matchAllDFS [1..] (Set Integer)- [[mc| cons $x (cons $y _) => (x, y) |]])+ [[mc| $x : $y : _ -> (x, y) |]]) -- [(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)] ``` @@ -123,10 +127,10 @@ preparing... ```-matchAll (1,2) UnorderedEqlPair [[mc| uepair $x $y => (x,y) |]]+matchAll (1,2) UnorderedEqlPair [[mc| uepair $x $y -> (x,y) |]] -- [(1,2),(2,1)] -matchAll (1,2) UnorderedEqlPair [[mc| uepair #2 $x => x |]]+matchAll (1,2) UnorderedEqlPair [[mc| uepair #2 $x -> x |]] -- [1] ``` @@ -136,7 +140,7 @@ ``` data UnorderedEqlPair = UnorderedEqlPair-instance (Eq a) => Matcher UnorderedEqlPair (a, a)+instance (Eq a) -> Matcher UnorderedEqlPair (a, a) uepair :: (Eq a) => Pattern a Eql ctx xs@@ -176,7 +180,7 @@ ``` take 10 (matchAll primes (List Integer)- [[mc| join _ (cons $p (cons #(p+2) _)) => (p, p+2) |]])+ [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]) -- [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)] ``` @@ -184,7 +188,7 @@ ``` take 10 (matchAll primes (List Integer)- [[mc| join _ (cons $p (join _ (cons #(p+6) _))) => (p, p+6) |]])+ [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]]) -- [(5,11),(7,13),(11,17),(13,19),(17,23),(23,29),(31,37),(37,43),(41,47),(47,53)] ``` @@ -193,55 +197,55 @@ ``` poker cs = match cs (Multiset CardM)- [[mc| cons (card $s $n)- (cons (card #s #(n-1))- (cons (card #s #(n-2))- (cons (card #s #(n-3))- (cons (card #s #(n-4))- _)))) => "Straight flush" |],- [mc| cons (card _ $n)- (cons (card _ #n)- (cons (card _ #n)- (cons (card _ #n)- (cons _- _)))) => "Four of a kind" |],- [mc| cons (card _ $m)- (cons (card _ #m)- (cons (card _ #m)- (cons (card _ $n)- (cons (card _ #n)- _)))) => "Full house" |],- [mc| cons (card $s _)- (cons (card #s _)- (cons (card #s _)- (cons (card #s _)- (cons (card #s _)- _)))) => "Flush" |],- [mc| cons (card _ $n)- (cons (card _ #(n-1))- (cons (card _ #(n-2))- (cons (card _ #(n-3))- (cons (card _ #(n-4))- _)))) => "Straight" |],- [mc| cons (card _ $n)- (cons (card _ #n)- (cons (card _ #n)- (cons _- (cons _- _)))) => "Three of a kind" |],- [mc| cons (card _ $m)- (cons (card _ #m)- (cons (card _ $n)- (cons (card _ #n)- (cons _- _)))) => "Two pair" |],- [mc| cons (card _ $n)- (cons (card _ #n)- (cons _- (cons _- (cons _- _)))) => "One pair" |],- [mc| _ => "Nothing" |]]+ [[mc| card $s $n :+ card #s #(n-1) :+ card #s #(n-2) :+ card #s #(n-3) :+ card #s #(n-4) :+ [] -> "Straight flush" |],+ [mc| card _ $n :+ card _ #n :+ card _ #n :+ card _ #n :+ _ :+ [] -> "Four of a kind" |],+ [mc| card _ $m :+ card _ #m :+ card _ #m :+ card _ $n :+ card _ #n :+ [] -> "Full house" |],+ [mc| card $s _ :+ card #s _ :+ card #s _ :+ card #s _ :+ card #s _ :+ [] -> "Flush" |],+ [mc| card _ $n :+ card _ #(n-1) :+ card _ #(n-2) :+ card _ #(n-3) :+ card _ #(n-4) :+ [] -> "Straight" |],+ [mc| card _ $n :+ card _ #n :+ card _ #n :+ _ :+ _ :+ [] -> "Three of a kind" |],+ [mc| card _ $m :+ card _ #m :+ card _ $n :+ card _ #n :+ _ :+ [] -> "Two pair" |],+ [mc| card _ $n :+ card _ #n :+ _ :+ _ :+ _ :+ [] -> "One pair" |],+ [mc| _ -> "Nothing" |]] ``` ## Benchmark@@ -261,7 +265,7 @@ main = do let n = 100 let ans = take n (matchAll primes (List Integer)- [[mc| join _ (cons $p (cons #(p+2) _)) => (p, p+2) |]])+ [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]) putStrLn $ show ans $ stack ghc -- benchmark/prime-pairs-2.hs $ time ./benchmark/prime-pairs-2
mini-egison.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: mini-egison-version: 0.1.6+version: 1.0.0 synopsis: Template Haskell Implementation of Egison Pattern Matching description: This package provides the pattern-matching facility that fulfills the following three criteria for practical pattern matching for non-free data types\: (i) non-linear pattern matching with backtracking; (ii) extensibility of pattern-matching algorithms; (iii) ad-hoc polymorphism of patterns. Non-free data types are data types whose data have no standard forms.@@ -38,11 +38,13 @@ src build-depends: base >=4.7 && <5- , containers- , split+ , mtl+ , recursion-schemes+ , haskell-src-exts , haskell-src-meta- , regex-compat , template-haskell+ , egison-pattern-src >= 0.2.1 && < 0.3+ , egison-pattern-src-th-mode >= 0.2.1 && < 0.3 default-language: Haskell2010 default-extensions: TemplateHaskell@@ -54,7 +56,11 @@ , TypeFamilies , TypeOperators , FlexibleInstances+ , FlexibleContexts , TupleSections+ , Strict+ , StrictData+ , NamedFieldPuns ghc-options: -O3 test-suite mini-egison-test
sample/cdcl.hs view
@@ -71,8 +71,8 @@ addVars :: [Integer] -> [(Integer, Integer)] -> [(Integer, Integer)] addVars vs vars = matchDFS (vs, vars) (Pair (List Literal) (List (Pair Literal M.Integer)))- [[mc| pair nil _ => sortBy (\(_, c1) (_, c2) -> opposite (compare c1 c2)) vars |],- [mc| pair (cons $v $vs2) (join $hs (cons (pair #v $c) $ts)) =>+ [[mc| ([], _) -> sortBy (\(_, c1) (_, c2) -> opposite (compare c1 c2)) vars |],+ [mc| ($v : $vs2, $hs ++ (#v, $c) : $ts) -> addVars vs2 (hs ++ (v, c + 1) : ts) |]] where opposite LT = GT@@ -82,7 +82,7 @@ deleteVar :: Integer -> [(Integer, Integer)] -> [(Integer, Integer)] deleteVar v vars = matchDFS vars (Multiset (Pair Literal M.Integer))- [[mc| cons (pair #v _) (cons (pair #(negate v) _) $vars2) => vars2 |]]+ [[mc| (#v, _) : (#(negate v), _) : $vars2 -> vars2 |]] -- -- Utility functions for literals and cnfs@@ -90,19 +90,19 @@ getStage :: Integer -> [Assign] -> Integer getStage l trail = matchDFS trail (List Assignment)- [[mc| join _ (cons (whichever (pair #(negate l) $s)) _) => s |]]+ [[mc| _ ++ whichever (#(negate l), $s) : _ -> s |]] deleteLiteral :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] deleteLiteral l cnf = map (\(c1, c2) -> (matchAll c1 (Multiset Literal)- [[mc| cons (& (not #l) $m) _ => m |]],+ [[mc| (!#l & $m) : _ -> m |]], c2)) cnf deleteClausesWith :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] deleteClausesWith l cnf = matchAll cnf (Multiset (Pair (Multiset Literal) (Multiset Literal)))- [[mc| cons (& (pair (not (cons #l _)) _) $c) _ => c |]]+ [[mc| ((!(#l : _), _) & $c) : _ -> c |]] assignTrue :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] assignTrue l cnf =@@ -117,17 +117,17 @@ unitPropagate' :: Integer -> [([Integer], [Integer])] -> [Assign] -> [Assign] -> ([([Integer], [Integer])], [Assign]) unitPropagate' stage cnf trail otrail = matchDFS trail (List Assignment)- [[mc| cons (whichever (pair $l _)) $trail2 => unitPropagate' stage (assignTrue l cnf) trail2 otrail |],- [mc| _ => unitPropagate'' stage cnf otrail |]]+ [[mc| whichever ($l, _) : $trail2 -> unitPropagate' stage (assignTrue l cnf) trail2 otrail |],+ [mc| _ -> unitPropagate'' stage cnf otrail |]] unitPropagate'' :: Integer -> [([Integer], [Integer])] -> [Assign] -> ([([Integer], [Integer])], [Assign]) unitPropagate'' stage cnf trail = matchDFS cnf (Multiset (Pair (Multiset Literal) (Multiset Literal)))- [[mc| cons (pair nil _) _ => (cnf, trail) |],- [mc| cons (pair (cons $l nil) (cons #l $rs)) _ =>+ [[mc| ([], _) : _ -> (cnf, trail) |],+ [mc| ($l : [], #l : $rs) : _ -> unitPropagate'' stage (assignTrue l cnf) ([(Deduced (l, stage) (map (\r -> (r, (getStage r trail))) rs))] ++ trail) |],- [mc| _ => (cnf, trail) |]]+ [mc| _ -> (cnf, trail) |]] -- -- Learning@@ -136,10 +136,10 @@ learn :: Integer -> [(Integer, Integer)] -> [Assign] -> (Integer, [Integer]) learn stage cl trail = matchDFS (trail, cl) (Pair (List Assignment) (Multiset (Pair Literal M.Integer))) -- must be matchDFS- [[mc| pair _ (not (cons (pair _ #stage) (cons (pair _ #stage) _))) =>+ [[mc| (_, !((_, #stage) : (_, #stage) : _)) -> (minimum (map (\(_, c) -> c) cl), map (\(l, _) -> l) cl) |],- [mc| pair (join _ (cons (deduced (pair $l #stage) $ds) $trail2))- (cons (pair #(negate l) #stage) $rs) =>+ [mc| (_ ++ deduced ($l, #stage) $ds : $trail2,+ (#(negate l), #stage) : $rs) -> learn stage (union rs ds) trail2 |]] --@@ -149,8 +149,8 @@ backjump :: Integer -> [Assign] -> [Assign] backjump stage trail = matchDFS trail (List Assignment)- [[mc| join _ (& (cons (guessed (pair _ #stage)) _) $trail2) => trail2 |],- [mc| _ => [] |]]+ [[mc| _ ++ ((guessed (_, #stage) : _) & $trail2) -> trail2 |],+ [mc| _ -> [] |]] -- -- Guess@@ -158,8 +158,8 @@ guess vars trail = matchDFS (vars, trail) (Pair (List (Pair Literal M.Integer)) (List Assignment)) -- must be matchDFS- [[mc| pair (join _ (cons (pair $l _) _))- (not (join _ (cons (whichever (pair (| #l #(negate l)) _)) _))) =>+ [[mc| (_ ++ ($l, _) : _,+ (!(_ ++ whichever ((#l | #(negate l)), _) : _))) -> negate l |]] --@@ -174,13 +174,13 @@ let (cnf2, trail2) = unitPropagate stage cnf trail in -- let (cnf2, trail2) = unitPropagate stage cnf (trace (show trail) trail) in -- debug matchDFS (cnf2, trail2) (Pair (Multiset (Pair (Multiset Literal) (Multiset Literal))) (List Assignment))- [[mc| pair nil _ => True |],- [mc| pair (cons (pair nil $cc) _) (join _ (cons (guessed (pair $l #stage)) $trail3)) =>+ [[mc| ([], _) -> True |],+ [mc| (([], $cc) : _, _ ++ guessed ($l, #stage) : $trail3) -> let (s, lc) = learn stage (map (\l -> (l, (getStage l trail2))) cc) trail2 in let trail4 = backjump s trail3 in cdcl' (count + 1) s (addVars lc vars) ((lc, lc):cnf) trail4 |],- [mc| pair (cons (pair nil $cc) _) _ => False |],- [mc| _ =>+ [mc| (([], $cc) : _, _) -> False |],+ [mc| _ -> let g = guess vars trail2 in cdcl' (count + 1) (stage + 1) vars cnf (Guessed (g, stage + 1):trail2) |]]
src/Control/Egison/Core.hs view
@@ -93,14 +93,17 @@ Refl -> MCons atom (mappend atoms1 atoms2) -- | Create a list of a single matching atom.+{-# INLINE oneMAtom #-} oneMAtom :: MAtom ctx xs -> MList ctx xs oneMAtom atom1 = MCons atom1 MNil -- | Create a list of two matching atoms.+{-# INLINE twoMAtoms #-} twoMAtoms :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MList ctx (xs :++: ys) twoMAtoms atom1 atom2 = MCons atom1 (MCons atom2 MNil) -- | Create a list of three matching atoms.+{-# INLINE threeMAtoms #-} threeMAtoms :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MAtom (ctx :++: xs :++: ys) zs -> MList ctx (xs :++: ys :++: zs) threeMAtoms atom1 atom2 atom3 = case threeMConsAssocProof atom1 atom2 atom3 of@@ -123,15 +126,19 @@ happend xs@(HCons x xs') ys = case hconsAssocProof x xs' ys of Refl -> HCons x $ happend xs' ys +{-# INLINE hconsAssocProof #-} hconsAssocProof :: a -> HList as -> HList bs -> ((a ': as) :++: bs) :~: (a ': (as :++: bs)) hconsAssocProof _ _ HNil = Refl hconsAssocProof x xs (HCons y ys) = Refl +{-# INLINE mconsAssocProof #-} mconsAssocProof :: MAtom ctx vs -> MList (ctx :++: vs) vs' -> (ctx :++: (vs :++: vs')) :~: ((ctx :++: vs) :++: vs') mconsAssocProof _ _ = unsafeCoerce Refl -- Todo: Write proof. +{-# INLINE mappendAssocProof #-} mappendAssocProof :: MAtom ctx xs -> MList (ctx :++: xs) ys -> MList (ctx :++: xs :++: ys) zs -> (xs :++: (ys :++: zs)) :~: ((xs :++: ys) :++: zs) mappendAssocProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof. +{-# INLINE threeMConsAssocProof #-} threeMConsAssocProof :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MAtom (ctx :++: xs :++: ys) zs -> (xs :++: ys :++: zs) :~: (xs :++: (ys :++: zs)) threeMConsAssocProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof.
src/Control/Egison/Match.hs view
@@ -15,26 +15,32 @@ -- | @matchAll@ takes a target, a matcher, and a list of match clauses. -- @matchAll@ collects all the pattern-matching results and returns a list of the results evaluating the body expression for each pattern-matching result. -- @matchAll@ traverses a search tree for pattern matching in breadth-first order.+{-# INLINE matchAll #-} matchAll :: (Matcher m a) => a -> m -> [MatchClause a m b] -> [b]-matchAll tgt m [] = []-matchAll tgt m ((MatchClause pat f):cs) =- let results = processMStatesAll [[MState HNil (MCons (MAtom pat m tgt) MNil)]] in- map f results ++ matchAll tgt m cs+matchAll tgt m = foldr go []+ where+ go (MatchClause pat f) acc =+ let results = processMStatesAll [[MState HNil (MCons (MAtom pat m tgt) MNil)]] in+ map f results ++ acc -- | @match@ takes a target, a matcher, and a list of match clauses. -- @match@ calculates only the first pattern-matching result and returns the results evaluating the body expression for the first pattern-matching result. -- @match@ traverses a search tree for pattern matching in breadth-first order.+{-# INLINE match #-} match :: (Matcher m a) => a -> m -> [MatchClause a m b] -> b match tgt m cs = head $ matchAll tgt m cs -- | @matchAllDFS@ is much similar to @matchAll@ but traverses a search tree for pattern matching in depth-first order.+{-# INLINE matchAllDFS #-} matchAllDFS :: (Matcher m a) => a -> m -> [MatchClause a m b] -> [b]-matchAllDFS tgt m [] = []-matchAllDFS tgt m ((MatchClause pat f):cs) =- let results = processMStatesAllDFS [MState HNil (MCons (MAtom pat m tgt) MNil)] in- map f results ++ matchAllDFS tgt m cs+matchAllDFS tgt m = foldr go []+ where+ go (MatchClause pat f) acc =+ let results = processMStatesAllDFS [MState HNil (MCons (MAtom pat m tgt) MNil)] in+ map f results ++ acc -- | @matchDFS@ is much similar to @match@ but traverses a search tree for pattern matching in depth-first order.+{-# INLINE matchDFS #-} matchDFS :: (Matcher m a) => a -> m -> [MatchClause a m b] -> b matchDFS tgt m cs = head $ matchAllDFS tgt m cs @@ -49,23 +55,15 @@ processMStatesAll :: [[MState vs]] -> [HList vs] processMStatesAll [] = []-processMStatesAll streams =- case extractMatches $ concatMap processMStates streams of- ([], streams') -> processMStatesAll streams'- (results, streams') -> results ++ processMStatesAll streams'--extractMatches :: [[MState vs]] -> ([HList vs], [[MState vs]])-extractMatches = extractMatches' ([], [])- where- extractMatches' :: ([HList vs], [[MState vs]]) -> [[MState vs]] -> ([HList vs], [[MState vs]])- extractMatches' (xs, ys) [] = (reverse xs, reverse ys) -- These calls of the reverse function are very important for performance.- extractMatches' (xs, ys) ((MState rs MNil:[]):rest) = extractMatches' (rs:xs, ys) rest- extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, stream:ys) rest--processMStates :: [MState vs] -> [[MState vs]]-processMStates [] = []-processMStates (mstate:ms) = [processMState mstate, ms]+processMStatesAll streams = results ++ processMStatesAll streams'+ where+ (results, streams') = foldr processMStates ([], []) streams+ processMStates :: [MState vs] -> ([HList vs], [[MState vs]]) -> ([HList vs], [[MState vs]])+ processMStates [] (results, acc) = (results, acc)+ processMStates (MState rs MNil:ms) (results, acc) = processMStates ms (rs:results, acc)+ processMStates (mstate:ms) (results, acc) = (results, processMState mstate:ms:acc) +{-# INLINE processMState #-} processMState :: MState vs -> [MState vs] processMState (MState rs (MCons (MAtom pat m tgt) atoms)) = case pat of@@ -82,16 +80,19 @@ OrPat p1 p2 -> [MState rs (MCons (MAtom p1 m tgt) atoms), MState rs (MCons (MAtom p2 m tgt) atoms)] NotPat p ->- [MState rs atoms | null $ processMStatesAll [[MState rs $ MCons (MAtom p m tgt) MNil]]]+ [MState rs atoms | null $ processMStatesAllDFS [MState rs $ MCons (MAtom p m tgt) MNil]] PredicatePat f -> [MState rs atoms | f rs tgt] processMState (MState rs MNil) = undefined -- or [MState rs MNil] -- TODO: shold not reach here but reaches here. +{-# INLINE patVarProof #-} patVarProof :: HList xs -> HList '[a] -> MList (xs :++: '[a]) ys -> ((xs :++: '[a]) :++: ys) :~: (xs :++: ('[a] :++: ys)) patVarProof HNil _ _ = Refl patVarProof (HCons _ xs) ys zs = unsafeCoerce Refl -- Todo: Write proof. +{-# INLINE andPatProof #-} andPatProof :: MAtom ctx vs -> MAtom (ctx :++: vs) vs' -> MList (ctx :++: vs :++: vs') ys -> (ctx :++: ((vs :++: vs') :++: ys)) :~: (ctx :++: (vs :++: (vs' :++: ys))) andPatProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof. +{-# INLINE assocProof #-} assocProof :: MAtom ctx vs -> MAtom (ctx :++: vs) vs' -> (ctx :++: (vs :++: vs')) :~: ((ctx :++: vs) :++: vs') assocProof _ _ = unsafeCoerce Refl -- Todo: Write proof.
src/Control/Egison/Matcher.hs view
@@ -93,9 +93,9 @@ instance (Matcher m a, Eq a, ValuePat m a) => ValuePat (List m) [a] where valuePat f = Pattern (\ctx (List m) tgt -> match (f ctx, tgt) (Pair (List m) (List m)) $- [[mc| pair nil nil => [MNil] |],- [mc| pair (cons $x $xs) (cons #x #xs) => [MNil] |],- [mc| Wildcard => [] |]])+ [[mc| ([], []) -> [MNil] |],+ [mc| (($x : $xs), (#x : #xs)) -> [MNil] |],+ [mc| _ -> [] |]]) instance Matcher m a => CollectionPat (List m) [a] where nil = Pattern (\_ _ t -> [MNil | null t])@@ -118,16 +118,16 @@ instance (Matcher m a, Eq a, ValuePat m a) => ValuePat (Multiset m) [a] where valuePat f = Pattern (\ctx (Multiset m) tgt -> match (f ctx, tgt) (Pair (List m) (Multiset m)) $- [[mc| pair nil nil => [MNil] |],- [mc| pair (cons $x $xs) (cons #x #xs) => [MNil] |],- [mc| Wildcard => [] |]])+ [[mc| ([], []) -> [MNil] |],+ [mc| (($x : $xs), (#x : #xs)) -> [MNil] |],+ [mc| _ -> [] |]]) instance (Matcher m a) => CollectionPat (Multiset m) [a] where nil = Pattern (\_ _ tgt -> [MNil | null tgt]) -- | The @cons@ pattern for a multiset decomposes a collection into an arbitrary element and the rest elements. cons p Wildcard = Pattern (\_ (Multiset m) tgt -> map (\x -> oneMAtom (MAtom p m x)) tgt) cons p1 p2 = Pattern (\_ (Multiset m) tgt -> map (\(x, xs) -> twoMAtoms (MAtom p1 m x) (MAtom p2 (Multiset m) xs))- (matchAll tgt (List m) [[mc| join $hs (cons $x $ts) => (x, hs ++ ts) |]]))+ (matchAll tgt (List m) [[mc| $hs ++ $x : $ts -> (x, hs ++ ts) |]])) join p1 p2 = undefined -- | A matcher for a set. Both the order and the repetition of elements are ignored.@@ -141,5 +141,5 @@ nil = Pattern (\_ _ tgt -> [MNil | null tgt]) cons p1 p2 = Pattern (\_ (Set m) tgt -> map (\x -> twoMAtoms (MAtom p1 m x) (MAtom p2 (Set m) tgt))- (matchAll tgt (List m) [[mc| join Wildcard (cons $x Wildcard) => x |]]))+ (matchAll tgt (List m) [[mc| _ ++ $x : _ -> x |]])) join p1 p2 = undefined
src/Control/Egison/QQ.hs view
@@ -1,19 +1,66 @@ -- | Quasiquotation for rewriting a match clause. -module Control.Egison.QQ (- mc,- ) where+module Control.Egison.QQ+ ( mc+ )+where import Control.Egison.Core-import Data.List-import Data.List.Split-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Language.Haskell.Meta-import Language.Haskell.TH hiding (match)-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Text.Regex+import Control.Monad ( (<=<) )+import Control.Monad.State ( runStateT+ , MonadState(..)+ , modify+ , lift+ )+import Text.Read ( readMaybe )+import Data.Maybe ( mapMaybe )+import Data.List ( foldl' )+import Data.Functor.Foldable ( Recursive+ , Base+ , cata+ )+import Language.Haskell.TH ( Q+ , Loc(..)+ , Exp(..)+ , Pat(..)+ , Lit(..)+ , Name+ , location+ , extsEnabled+ , mkName+ , pprint+ )+import Language.Haskell.TH.Quote ( QuasiQuoter(..) )+import qualified Language.Haskell.TH as TH+ ( Extension(..) )+import Language.Haskell.Exts.Extension+ ( Extension(EnableExtension) )+import Language.Haskell.Exts.Parser ( ParseResult(..)+ , defaultParseMode+ , parseExpWithMode+ )+import qualified Language.Haskell.Exts.Extension+ as Exts+ ( KnownExtension(..) )+import qualified Language.Haskell.Exts.Parser as Exts+ ( ParseMode(..) )+import Language.Haskell.Meta.Syntax.Translate+ ( toExp )+import qualified Language.Egison.Syntax.Pattern+ as Pat+ ( Expr+ , ExprF(..)+ )+import qualified Language.Egison.Parser.Pattern+ as Pat+ ( parseNonGreedy )+import Language.Egison.Parser.Pattern ( Fixity(..)+ , ParseFixity(..)+ , Associativity(..)+ , Precedence(..)+ )+import Language.Egison.Parser.Pattern.Mode.Haskell.TH+ ( ParseMode(..) ) -- | A quasiquoter for rewriting a match clause. -- This quasiquoter is useful for generating a 'MatchClause' in user-friendly syntax.@@ -55,7 +102,7 @@ -- -- A match clause that contains an and-pattern -- --- > [mc| (& (cons _ _) $x) => x |]+-- > [mc| (cons _ _) & $x => x |] -- -- is rewritten to -- @@ -66,100 +113,130 @@ -- -- A match clause that contains an or-pattern -- --- > [mc| (| nil (cons _ _)) => "Matched" |]+-- > [mc| nil | (cons _ _) => "Matched" |] -- -- is rewritten to -- -- > MatchClause (OrPat nil (cons Wildcard Wildcard)) -- > (\HNil -> "Matched")+--+-- === Collection patterns+--+-- A collection pattern+--+-- > [p1, p2, ..., pn]+--+-- is desugared into+--+-- > p1 : p2 : ... : pn : nil+--+-- === Cons patterns+--+-- A pattern with special collection pattern operator @:@+--+-- > p1 : p2+--+-- is parsed as+--+-- > p1 `cons` p2+--+-- === Join patterns+--+-- A pattern with special collection pattern operator @++@+--+-- > p1 ++ p2+--+-- is parsed as+--+-- > p1 `join` p2 mc :: QuasiQuoter-mc = QuasiQuoter { quoteExp = \s -> do- let [pat, exp] = splitOn "=>" s- e1 <- case parseExp (changeNotPat (changeOrPat (changeAndPat (changeValuePat (changePatVar (changeWildcard pat)))))) of- Left _ -> fail "Could not parse pattern expression."- Right exp -> return exp- e2 <- case parseExp exp of- Left _ -> fail "Could not parse expression."- Right exp -> return exp- mcChange e1 e2- , quotePat = undefined- , quoteType = undefined- , quoteDec = undefined }+mc = QuasiQuoter { quoteExp = compile+ , quotePat = undefined+ , quoteType = undefined+ , quoteDec = undefined+ } -changeWildcard :: String -> String-changeWildcard pat = subRegex (mkRegex " _") pat " Wildcard" -changePatVar :: String -> String-changePatVar pat = subRegex (mkRegex "\\$([a-zA-Z0-9]+)") pat "(PatVar \"\\1\")"--changeValuePat :: String -> String-changeValuePat pat = subRegex (mkRegex "\\#(\\([^)]+\\)|\\[[^)]+\\]|[a-zA-Z0-9]+)") pat "(valuePat \\1)"+listFixities :: [ParseFixity Name String]+listFixities =+ [ ParseFixity (Fixity AssocRight (Precedence 5) (mkName "join")) $ parser "++"+ , ParseFixity (Fixity AssocRight (Precedence 5) (mkName "cons")) $ parser ":"+ ]+ where+ parser symbol content | symbol == content = Right ()+ | otherwise = Left $ show symbol ++ "is expected" -changeAndPat :: String -> String-changeAndPat pat = subRegex (mkRegex "\\(\\&") pat "(AndPat"+parseMode :: Q Exts.ParseMode+parseMode = do+ Loc { loc_filename } <- location+ extensions <- mapMaybe (fmap EnableExtension . convertExt) <$> extsEnabled+ pure defaultParseMode { Exts.parseFilename = loc_filename, Exts.extensions }+ where+ convertExt :: TH.Extension -> Maybe Exts.KnownExtension+ convertExt TH.TemplateHaskellQuotes = Just Exts.TemplateHaskell -- haskell-suite/haskell-src-exts#357+ convertExt ext = readMaybe $ show ext -changeOrPat :: String -> String-changeOrPat pat = subRegex (mkRegex "\\(\\|") pat "(OrPat"+parseExp :: Exts.ParseMode -> String -> Q Exp+parseExp mode content = case parseExpWithMode mode content of+ ParseOk x -> pure $ toExp x+ ParseFailed _ e -> fail e -changeNotPat :: String -> String-changeNotPat pat = subRegex (mkRegex "\\(not ") pat "(NotPat "+compile :: String -> Q Exp+compile content = do+ mode <- parseMode+ (pat, rest) <- parsePatternExpr mode content+ bodySource <- takeBody rest+ body <- parseExp mode bodySource+ compilePattern pat body+ where+ takeBody ('-' : '>' : xs) = pure xs+ takeBody xs = fail $ "\"->\" is expected, but found " ++ show xs -mcChange :: Exp -> Exp -> Q Exp-mcChange pat expr = do- let (vars, xs) = extractPatVars [pat] []- [| (MatchClause $(fst <$> changePat pat (map (`take` vars) xs)) $(changeExp vars expr)) |]+parsePatternExpr+ :: Exts.ParseMode -> String -> Q (Pat.Expr Name Name Exp, String)+parsePatternExpr haskellMode content = case Pat.parseNonGreedy mode content of+ Left e -> fail $ show e+ Right x -> pure x+ where mode = ParseMode { haskellMode, fixities = Just listFixities } --- extract patvars from pattern-extractPatVars :: [Exp] -> [String] -> ([String], [Int])-extractPatVars [] vars = (vars, [])-extractPatVars (ParensE x:xs) vars = extractPatVars (x:xs) vars-extractPatVars (AppE (ConE name) p:xs) vars- | nameBase name == "PatVar" = case p of (LitE (StringL s)) -> extractPatVars xs (vars ++ [s])- | nameBase name == "PredicatePat" = let (vs, ns) = extractPatVars xs vars in (vs, length vars:ns)- | nameBase name == "LaterPat" =- let (vs1, ns1) = extractPatVars xs vars in- let (vs2, ns2) = extractPatVars [p] vs1 in (vs2, ns2 ++ ns1)- | otherwise = extractPatVars (p:xs) vars-extractPatVars (AppE (VarE name) p:xs) vars- | nameBase name == "valuePat" = let (vs, ns) = extractPatVars xs vars in (vs, length vars:ns)- | otherwise = extractPatVars (p:xs) vars-extractPatVars (AppE a b:xs) vars = extractPatVars (a:b:xs) vars-extractPatVars (SigE x typ:xs) vs = extractPatVars (x:xs) vs-extractPatVars (_:xs) vars = extractPatVars xs vars+compilePattern :: Pat.Expr Name Name Exp -> Exp -> Q Exp+compilePattern pat body = do+ (clauseExp, bindings) <- runStateT (cataM go pat) []+ let bodyExp = bsFun bindings body+ pure $ AppE (AppE (ConE 'Control.Egison.Core.MatchClause) clauseExp) bodyExp+ where+ bsFun bs = LamE [toHListPat bs]+ go Pat.WildcardF = pure $ ConE 'Control.Egison.Core.Wildcard+ go (Pat.VariableF v) = do+ modify (<> [v])+ pure . AppE (ConE 'Control.Egison.Core.PatVar) . LitE . StringL $ pprint v+ go (Pat.ValueF e) = do+ bs <- get+ pure . AppE (VarE $ mkName "valuePat") $ bsFun bs e+ go (Pat.PredicateF e) = do+ bs <- get+ pure . AppE (ConE 'Control.Egison.Core.PredicatePat) $ bsFun bs e+ go (Pat.AndF e1 e2) =+ pure $ AppE (AppE (ConE 'Control.Egison.Core.AndPat) e1) e2+ go (Pat.OrF e1 e2) =+ pure $ AppE (AppE (ConE 'Control.Egison.Core.OrPat) e1) e2+ go (Pat.NotF e1) = pure $ AppE (ConE 'Control.Egison.Core.NotPat) e1+ go (Pat.TupleF [e1, e2]) = pure $ AppE (AppE (VarE $ mkName "pair") e1) e2+ go (Pat.TupleF _) = lift $ fail "tuples other than pairs are not supported"+ go (Pat.CollectionF es) = pure $ toNilCons es+ go (Pat.InfixF n e1 e2) = pure . ParensE $ UInfixE e1 (VarE n) e2+ go (Pat.PatternF n es) = pure $ foldl' AppE (VarE n) es --- change ValuePat e to \(HCons x HNil) -> e--- change PredicatePat (\x -> e) to \(HCons x HNil) -> (\x -> e)-changePat :: Exp -> [[String]] -> Q (Exp, [[String]])-changePat e@(AppE (ConE name) p) vs- | nameBase name == "PredicatePat" = do- let (vars:varss) = vs- (, varss) <$> appE (conE 'PredicatePat) (changeExp vars p)- | otherwise = do- (e', vs') <- changePat p vs- (, vs') <$> appE (conE name) (return e')-changePat e@(AppE (VarE name) p) vs- | nameBase name == "valuePat" = do- let (vars:varss) = vs- (, varss) <$> appE (varE name) (changeExp vars p)- | otherwise = do- (e', vs') <- changePat p vs- (, vs') <$> appE (varE name) (return e')-changePat (AppE e1 e2) vs = do- (e1', vs') <- changePat e1 vs- (e2', vs'') <- changePat e2 vs'- (, vs'') <$> appE (return e1') (return e2')-changePat (ParensE x) vs = changePat x vs-changePat (SigE x typ) vs = changePat x vs-changePat e vs = return (e, vs)+toHListPat :: [Name] -> Pat+toHListPat = foldr go $ ConP 'HNil [] where go x a = ConP 'HCons [VarP x, a] --- change e to \(HCons x HNil) -> e-changeExp :: [String] -> Exp -> Q Exp-changeExp vars expr = do- vars' <- mapM newName vars- vars'' <- mapM (\s -> newName $ s ++ "'") vars- return $ LamE [f vars'] expr+toNilCons :: [Exp] -> Exp+toNilCons = foldr go . VarE $ mkName "nil"+ where go e = AppE (AppE (VarE $ mkName "cons") e) --- \[x, y] -> HCons x (HCons y HNil)-f :: [Name] -> Pat-f [] = ConP 'HNil []-f (x:xs) = InfixP (VarP x) 'HCons $ f xs+cataM+ :: (Recursive t, Traversable (Base t), Monad m)+ => (Base t a -> m a)+ -> t+ -> m a+cataM alg = cata (alg <=< sequence)
test/Spec.hs view
@@ -10,99 +10,99 @@ pmap :: (a -> b) -> [a] -> [b] pmap f xs = matchAll xs (List Something)- [[mc| join _ (cons $x _) => f x |]]+ [[mc| _ ++ $x : _ -> f x |]] pmConcat :: [[a]] -> [a] pmConcat xss = matchAll xss (Multiset (Multiset Something))- [[mc| cons (cons $x _) _ => x |]]+ [[mc| ($x : _) : _ -> x |]] pmUniq :: (Eq a) => [a] -> [a] pmUniq xs = matchAll xs (List Eql)- [[mc| join _ (cons $x (not (join _ (cons #x _)))) => x |]]+ [[mc| _ ++ $x : !(_ ++ #x : _) -> x |]] pmIntersect :: (Eq a) => [a] -> [a] -> [a] pmIntersect xs ys = matchAll (xs, ys) (Pair (Multiset Eql) (Multiset Eql))- [[mc| pair (cons $x _) (cons #x _) => x |]]+ [[mc| (($x : _), (#x : _)) -> x |]] pmDiff :: (Eq a) => [a] -> [a] -> [a] pmDiff xs ys = matchAll (xs, ys) (Pair (Multiset Eql) (Multiset Eql))- [[mc| pair (cons $x _) (not (cons #x _)) => x |]]+ [[mc| (($x : _), !(#x : _)) -> x |]] spec :: Spec spec = do describe "list and multiset matchers" $ do it "cons pattern for list" $- matchAll [1,2,3] (List Integer) [[mc| cons $x $xs => (x, xs) |]]+ matchAll [1,2,3] (List Integer) [[mc| $x : $xs -> (x, xs) |]] `shouldBe` [(1, [2,3])] it "multiset cons pattern" $- matchAll [1,2,3] (Multiset Integer) [[mc| cons $x $xs => (x, xs) |]]+ matchAll [1,2,3] (Multiset Integer) [[mc| $x : $xs -> (x, xs) |]] `shouldBe` [(1,[2,3]),(2,[1,3]),(3,[1,2])] it "join pattern for list matcher" $ length ( matchAll [1..5] (List Integer)- [[mc| join $xs $ys => (xs, ys) |]])+ [[mc| $xs ++ $ys -> (xs, ys) |]]) `shouldBe` 6 it "value pattern for list matcher (1)" $ match [1,2,3] (List Integer)- [[mc| #[1,2,3] => "Matched" |],- [mc| _ => "Not matched" |]]+ [[mc| #[1,2,3] -> "Matched" |],+ [mc| _ -> "Not matched" |]] `shouldBe` "Matched" it "value pattern for list matcher (2)" $ match [1,2,3] (List Integer)- [[mc| #[2,1,3] => "Matched" |],- [mc| _ => "Not matched" |]]+ [[mc| #[2,1,3] -> "Matched" |],+ [mc| _ -> "Not matched" |]] `shouldBe` "Not matched" it "value pattern for multiset matcher" $ match [1,2,3] (Multiset Integer)- [[mc| #[2,1,3] => "Matched" |],- [mc| _ => "Not matched" |]]+ [[mc| #[2,1,3] -> "Matched" |],+ [mc| _ -> "Not matched" |]] `shouldBe` "Matched" -- it "test" $ -- match 1 (List Integer)--- [[mc| $x => "Matched" |]]+-- [[mc| $x -> "Matched" |]] -- `shouldBe` "Matched" describe "match-all with infinitely many results" $ do it "Check the order of pattern-matching results (multiset bfs) " $ take 10 (matchAll [1..] (Multiset Integer)- [[mc| cons $x (cons $y _) => (x, y) |]])+ [[mc| $x : $y : _ -> (x, y) |]]) `shouldBe` [(1,2),(1,3),(2,1),(1,4),(2,3),(3,1),(1,5),(2,4),(3,2),(4,1)] it "Check the order of pattern-matching results (set bfs)" $ take 10 (matchAll [1..] (Set Integer)- [[mc| cons $x (cons $y _) => (x, y) |]])+ [[mc| $x : $y : _ -> (x, y) |]]) `shouldBe` [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] it "Check the order of pattern-matching results (set dfs)" $ take 10 (matchAllDFS [1..] (Set Integer)- [[mc| cons $x (cons $y _) => (x, y) |]])+ [[mc| $x : $y : _ -> (x, y) |]]) `shouldBe` [(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)] describe "built-in pattern constructs" $ do it "Predicate patterns" $ matchAll [1..10] (Multiset Integer)- [[mc| cons (& (PredicatePat (\x -> mod x 2 == 0)) $x) _ => x |]]+ [[mc| (?(\x -> mod x 2 == 0) & $x) : _ -> x |]] `shouldBe` [2,4,6,8,10] describe "patterns for prime numbers" $ do it "twin primes (p, p+2)" $ take 10 (matchAll primes (List Integer)- [[mc| join _ (cons $p (cons #(p+2) _)) => (p, p+2) |]])+ [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]) `shouldBe` [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)] it "prime pairs whose form is (p, p+6) -- pattern matching with infinitely many results" $ take 10 (matchAll primes (List Integer)- [[mc| join _ (cons $p (join _ (cons #(p+6) _))) => (p, p+6) |]])+ [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]]) `shouldBe` [(5,11),(7,13),(11,17),(13,19),(17,23),(23,29),(31,37),(37,43),(41,47),(47,53)] it "prime triplets -- and-patterns, or-patterns, and not-patterns" $ take 10 (matchAll primes (List Integer)- [[mc| join _ (cons $p (cons (& (| #(p+2) #(p+4)) $m) (cons #(p+6) _))) => (p, m, p+6) |]])+ [[mc| _ ++ $p : ($m & (#(p+2) | #(p+4))) : #(p+6) : _ -> (p, m, p+6) |]]) `shouldBe` [(5,7,11),(7,11,13),(11,13,17),(13,17,19),(17,19,23),(37,41,43),(41,43,47),(67,71,73),(97,101,103),(101,103,107)] describe "Basic list processing functions" $ do