mini-egison (empty) → 0.1.0
raw patch · 12 files changed
+876/−0 lines, 12 filesdep +basedep +containersdep +haskell-src-metasetup-changed
Dependencies added: base, containers, haskell-src-meta, hspec, mini-egison, primes, regex-compat, split, template-haskell
Files
- ChangeLog.md +5/−0
- LICENSE +18/−0
- README.md +205/−0
- Setup.hs +2/−0
- mini-egison.cabal +126/−0
- src/Control/Egison.hs +11/−0
- src/Control/Egison/Core.hs +88/−0
- src/Control/Egison/Match.hs +80/−0
- src/Control/Egison/Matcher.hs +133/−0
- src/Control/Egison/QQ.hs +111/−0
- test/Spec.hs +90/−0
- test/Test.hs +7/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for egison-haskell++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,18 @@+Copyright (c) 2019, Mayuko Kori, Satoshi Egi++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the Software+is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,+INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR+A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE+OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,205 @@+# miniEgison: Template Haskell Implementation of Egison Pattern Matching++This Haskell library provides the users with the pattern-matching facility against non-free data types.+Non-free data types are data types whose data have no standard forms.+For example, multisets are non-free data types because the multiset {a,b,b} has two other equivalent but literally different forms {b,a,b} and {b,b,a}.+This library 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.++The design of the pattern-matching facility is originally proposed in [this paper](https://arxiv.org/abs/1808.10603) and implemented in [the Egison programming language](http://github.com/egison/egison/).++## Grammar++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++C = [mc| p => e] -- match clause++p = _ -- wildcard+ | $x -- pattern variable+ | #e -- value pattern+ | (& p ...) -- and-pattern+ | (| p ...) -- or-pattern+ | (not p) -- not-pattern+```++## Usage++### The `matchAll` expression and matchers++The `matchAll` expression evaluates the body of the match clause for all the pattern-matching results.+The expression below pattern-matches a target `[1,2,3]` as a list of integers with a pattern `cons $x $xs`.+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)]]+-- [(1,[2,3])]+```++The other characteristic of `matchAll` is its additional argument matcher.+A matcher is a special object that retains the pattern-matching algorithms for each data type.+`matchAll` takes a matcher as its second argument.+We can change a way to interpret a pattern by changing a matcher.++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)]]+-- [(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.++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.+The `Something` matcher is the only built-in matcher.+`something` can be used for pattern-matching arbitrary objects but can handle only pattern variables and wildcards.+The definitions of `List` and `Multiset` are found [here](https://github.com/egison/egison-haskell/blob/master/src/Control/Egison/Matcher.hs).+We will write an explanation of this definition in future.++### Non-linear pattern++Non-linear pattern matching is another important feature of Egison pattern matching.+Non-linear patterns are patterns that allow multiple occurrences of the same pattern variables in a pattern.+For example, the program below pattern-matches a list `[1,2,5,9,4]` as a multiset and extracts pairs of sequential elements.+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]]+-- [1,4]+```++### The `match` expression++preparing...++### `matchAllDFS` and `matchDFS`++preparing...++## Samples++### Twin primes++We can extract all twin primes from the list of prime numbers by pattern matching:++```+take 10 (matchAll primes (List Integer)+ [[mc| join _ (cons $p (cons #(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)]+```++It is also possible to enumerate all the pairs of prime numbers whose form is (p, p+6):++```+take 10 (matchAll primes (List Integer)+ [[mc| join _ (cons $p (join _ (cons #(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)]+```++### Poker hand++```+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" |]]+```++## Benchmark++We benchmarked this library using the program that enumerates the first 100 twin primes.+This Haskell library is faster (more than 20 times in this case) than the original Egison interpreter!++```+$ cat benchmark/prime-pairs-2.hs+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}++import Control.Egison+import Data.Numbers.Primes++main :: IO ()+main = do+ let n = 100+ let ans = take n (matchAll primes (List Integer)+ [[mc| join _ (cons $p (cons #(p+2) _)) => (p, p+2) |]])+ putStrLn $ show ans+$ stack ghc -- benchmark/prime-pairs-2.hs+$ time ./benchmark/prime-pairs-2+[(3,5),(5,7),(11,13), ..., (3671,3673),(3767,3769),(3821,3823)]+./benchmark/prime-pairs-2 0.01s user 0.01s system 64% cpu 0.024 total+```++```+$ cat benchmark/prime-pairs-2.egi+(define $n 100)+(define $primes {2 3 5 7 11 13 17 ... 4391 4397 4409})++(define $twin-primes+ (match-all primes (list integer)+ [<join _ <cons $p <cons ,(+ p 2) _>>>+ [p (+ p 2)]]))++(take n twin-primes)+$ time stack exec egison -- -t benchmark/prime-pairs-2.egi+{[3 5] [5 7] [11 13] ... [3671 3673] [3767 3769] [3821 3823]}+stack exec egison -- -t benchmark/prime-pairs-2.egi 0.54s user 0.04s system 97% cpu 0.593 total+```++## Sponsors++Egison is sponsored by [Rakuten, Inc.](http://global.rakuten.com/corp/) and [Rakuten Institute of Technology](http://rit.rakuten.co.jp/).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mini-egison.cabal view
@@ -0,0 +1,126 @@+cabal-version: 1.12++name: mini-egison+version: 0.1.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.+ For example, multisets are non-free data types because the multiset '[a,b,b]' has two other equivalent but literally different forms '[b,a,b]' and '[b,b,a]'.+ .+ The design of the pattern-matching facility is originally proposed in <https://arxiv.org/abs/1808.10603 this paper> and implemented in <http://github.com/egison/egison/ the Egison programming language>.+ .+ /Samples/+ .+ We can extract all twin primes from the list of prime numbers by pattern matching:+ .+ > take 10 (matchAll primes (List Integer)+ > [[mc| join _ (cons $p (cons #(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)]+ .+ We can describe patterns for each poker hand utilizing pattern matching for a multiset:+ .+ > 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" |]]+ .+ The pattern-matching algorithms for 'List' and 'Multiset' can be defined by users.++homepage: https://github.com/egison/egison-haskell#readme+bug-reports: https://github.com/egison/egison-haskell/issues+author: Mayuko Kori, Satoshi Egi+maintainer: Satoshi Egi <egi@egison.org>+license: MIT+license-file: LICENSE+category: Data, Pattern+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/egison/egison-haskell++library+ exposed-modules:+ Control.Egison+ Control.Egison.Core+ Control.Egison.Match+ Control.Egison.Matcher+ Control.Egison.QQ+ other-modules:+ Paths_mini_egison+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , containers+ , split+ , haskell-src-meta+ , regex-compat+ , template-haskell+ default-language: Haskell2010++test-suite mini-egison-test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ other-modules:+ Spec+ Paths_mini_egison+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , mini-egison+ , hspec+ , primes+ default-language: Haskell2010
+ src/Control/Egison.hs view
@@ -0,0 +1,11 @@+module Control.Egison+ ( module Control.Egison.Core+ , module Control.Egison.Match+ , module Control.Egison.Matcher+ , module Control.Egison.QQ+ ) where++import Control.Egison.Core+import Control.Egison.Match+import Control.Egison.Matcher+import Control.Egison.QQ
+ src/Control/Egison/Core.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Control.Egison.Core (+ -- Pattern+ Pattern(..),+ Matcher(..),+ MatchClause(..),+ -- Matching state+ MState(..),+ MAtom(..),+ MList(..),+ -- Heterogeneous list+ HList(..),+ happend,+ (:++:),+ ) where++import Data.Maybe++---+--- Pattern+---++-- a: the type of the target+-- m: a matcher passed to the pattern+-- ctx: the intermediate pattern-matching result+-- vs: the list of types bound to the pattern variables in the pattern.+data Pattern a m ctx vs where+ Wildcard :: Pattern a m ctx '[]+ PatVar :: String -> Pattern a m ctx '[a]+ AndPat :: Pattern a m ctx vs -> Pattern a m (ctx :++: vs) vs' -> Pattern a m ctx (vs :++: vs')+ OrPat :: Pattern a m ctx vs -> Pattern a m ctx vs -> Pattern a m ctx vs+ NotPat :: Pattern a m ctx '[] -> Pattern a m ctx '[]+ PredicatePat :: (HList ctx -> a -> Bool) -> Pattern a m ctx '[]+ -- User-defined pattern; pattern is a function that takes a target, an intermediate pattern-matching result, and a matcher and returns a list of lists of matching atoms.+ Pattern :: Matcher m => (HList ctx -> m -> a -> [MList ctx vs]) -> Pattern a m ctx vs++class Matcher a++data MatchClause a m b = forall vs. (Matcher m) => MatchClause (Pattern a m '[] vs) (HList vs -> b)++---+--- Matching state+---++data MState vs where+ MState :: vs ~ (xs :++: ys) => HList xs -> MList xs ys -> MState vs++-- matching atom+-- ctx: intermediate pattern-matching results+-- vs: list of types bound to the pattern variables in the pattern.+data MAtom ctx vs = forall a m. (Matcher m) => MAtom (Pattern a m ctx vs) m a++-- stack of matching atoms+data MList ctx vs where+ MNil :: MList ctx '[]+ MCons :: MAtom ctx xs -> MList (ctx :++: xs) ys -> MList ctx (xs :++: ys)+ MJoin :: MList ctx xs -> MList (ctx :++: xs) ys -> MList ctx (xs :++: ys)++---+--- Heterogeneous list+---++data HList xs where+ HNil :: HList '[]+ HCons :: a -> HList as -> HList (a ': as)++happend :: HList as -> HList bs -> HList (as :++: bs)+happend (HCons x xs) ys = case proof x xs ys of Refl -> HCons x $ happend xs ys+happend HNil ys = ys++type family as :++: bs :: [*] where+ bs :++: '[] = bs+ '[] :++: bs = bs+ (a ': as) :++: bs = a ': (as :++: bs)++data (a :: [*]) :~: (b :: [*]) where+ Refl :: a :~: a++proof :: a -> HList as -> HList bs -> ((a ': as) :++: bs) :~: (a ': (as :++: bs))+proof _ _ HNil = Refl+proof x xs (HCons y ys) = Refl+
+ src/Control/Egison/Match.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Control.Egison.Match (+ matchAll,+ match,+ matchAllDFS,+ matchDFS,+ ) where++import Control.Egison.Core+import Unsafe.Coerce++matchAll :: (Matcher m) => 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++match :: (Matcher m) => a -> m -> [MatchClause a m b] -> b+match tgt m cs = head $ matchAll tgt m cs++matchAllDFS :: (Matcher m) => 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++matchDFS :: (Matcher m) => a -> m -> [MatchClause a m b] -> b+matchDFS tgt m cs = head $ matchAllDFS tgt m cs++--+-- Pattern-matching algorithm+--++processMStatesAllDFS :: [MState vs] -> [HList vs]+processMStatesAllDFS [] = []+processMStatesAllDFS (MState rs MNil:ms) = rs:(processMStatesAllDFS ms)+processMStatesAllDFS (mstate:ms) = processMStatesAllDFS $ (processMState mstate) ++ ms++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]++processMState :: MState vs -> [MState vs]+processMState (MState rs (MCons (MAtom pat m tgt) atoms)) =+ case pat of+ Pattern f ->+ let matomss = f rs m tgt in+ map (\newAtoms -> MState rs (MJoin newAtoms atoms)) matomss+ Wildcard -> [MState rs atoms]+ PatVar _ -> [unsafeCoerce $ MState (happend rs (HCons tgt HNil)) atoms]+ AndPat p1 p2 ->+ [unsafeCoerce $ MState rs (MCons (MAtom p1 m tgt) (MCons (MAtom p2 m tgt) $ unsafeCoerce atoms))]+ 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]]]+ PredicatePat f -> [MState rs atoms | f rs tgt]+processMState (MState rs (MJoin MNil matoms2)) = processMState (MState rs matoms2)+processMState (MState rs (MJoin matoms1 matoms2)) =+ let mstates = processMState (MState rs matoms1) in+ map (\(MState rs' ms) -> unsafeCoerce $ MState rs' $ MJoin ms matoms2) mstates+processMState (MState rs MNil) = [MState rs MNil] -- TODO: shold not reach here but reaches here.+
+ src/Control/Egison/Matcher.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Control.Egison.Matcher (+ -- Something matcher+ Something(..),+ -- Eql and Integer matchers+ ValuePat(..),+ Eql(..),+ Integer(..),+ -- Pair matcher+ PairPat(..),+ Pair(..),+ -- Matchers for collections+ CollectionPat(..),+ List(..),+ Multiset(..),+ Set(..),+ ) where++import Prelude hiding (Integer)+import Control.Egison.Core+import Control.Egison.Match+import Control.Egison.QQ++--+-- Something matcher+--++data Something = Something+instance Matcher Something++--+-- Eql and Integer matchers+--++class ValuePat m a where+ valuePat :: (Matcher m, Eq a) => (HList ctx -> a) -> Pattern a m ctx '[]++-- Eql matcher+data Eql = Eql+instance Matcher Eql++instance Eq a => ValuePat Eql a where+ valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt])++-- Integer matcher+data Integer = Integer+instance Matcher Integer++instance Integral a => ValuePat Integer a where+ valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt])++---+--- Pair matcher+---++data Pair a b = Pair a b+instance (Matcher a, Matcher b) => Matcher (Pair a b)++class PairPat m a where+ pair :: (Matcher m, a ~ (b1, b2), m ~ (Pair m1 m2)) => Pattern b1 m1 ctx xs -> Pattern b2 m2 (ctx :++: xs) ys -> Pattern a m ctx (xs :++: ys)++instance (Matcher m1, Matcher m2) => PairPat (Pair m1 m2) (a1, a2) where+ pair p1 p2 = Pattern (\_ (Pair m1 m2) (t1, t2) -> [MCons (MAtom p1 m1 t1) $ MCons (MAtom p2 m2 t2) MNil])++---+--- Matchers for collections+---++class CollectionPat m a where+ nil :: (Matcher m, a ~ [a']) => Pattern a m ctx '[]+ cons :: (Matcher m, a ~ [a'], m ~ (f m')) => Pattern a' m' ctx xs -> Pattern a m (ctx :++: xs) ys -> Pattern a m ctx (xs :++: ys)+ join :: (Matcher m, a ~ [a']) => Pattern a m ctx xs -> Pattern a m (ctx :++: xs) ys -> Pattern a m ctx (xs :++: ys)++-- List matcher+newtype List a = List a+instance (Matcher a) => Matcher (List a)++instance (Matcher m, 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 => [] |]])++instance Matcher m => CollectionPat (List m) [a] where+ nil = Pattern (\_ _ t -> [MNil | null t])+ cons p1 p2 = Pattern (\_ (List m) tgt ->+ case tgt of+ [] -> []+ x:xs -> [MCons (MAtom p1 m x) $ MCons (MAtom p2 (List m) xs) MNil])+ join p1 p2 = Pattern (\_ m tgt -> map (\(hs, ts) -> MCons (MAtom p1 m hs) $ MCons (MAtom p2 m ts) MNil) (splits tgt))++splits :: [a] -> [([a], [a])]+splits [] = [([], [])]+splits (x:xs) = ([], x:xs) : [(x:ys, zs) | (ys, zs) <- splits xs]++-- Multiset matcher+newtype Multiset a = Multiset a+instance (Matcher a) => Matcher (Multiset a)++instance (Matcher m, 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 => [] |]])++instance (Matcher m) => CollectionPat (Multiset m) [a] where+ nil = Pattern (\_ _ tgt -> [MNil | null tgt])+ cons p Wildcard = Pattern (\_ (Multiset m) tgt -> map (\x -> MCons (MAtom p m x) MNil) tgt)+ cons p1 p2 = Pattern (\_ (Multiset m) tgt -> map (\(x, xs) -> MCons (MAtom p1 m x) $ MCons (MAtom p2 (Multiset m) xs) MNil)+ (matchAll tgt (List m) [[mc| join $hs (cons $x $ts) => (x, hs ++ ts) |]]))+ join p1 p2 = undefined++-- Set matcher+newtype Set a = Set a+instance (Matcher a) => Matcher (Set a)++instance (Matcher m, Eq a, Ord a, ValuePat m a) => ValuePat (Set m) [a] where+ valuePat f = undefined++instance Matcher m => CollectionPat (Set m) [a] where+ nil = Pattern (\_ _ tgt -> [MNil | null tgt])+ cons p1 p2 = Pattern (\_ (Set m) tgt ->+ map (\x -> MCons (MAtom p1 m x) $ MCons (MAtom p2 (Set m) tgt) MNil)+ (matchAll tgt (List m) [[mc| join Wildcard (cons $x Wildcard) => x |]]))+ join p1 p2 = undefined
+ src/Control/Egison/QQ.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++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++++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 }++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)"++changeAndPat :: String -> String+changeAndPat pat = subRegex (mkRegex "\\(\\&") pat "(AndPat"++changeOrPat :: String -> String+changeOrPat pat = subRegex (mkRegex "\\(\\|") pat "(OrPat"++changeNotPat :: String -> String+changeNotPat pat = subRegex (mkRegex "\\(not ") pat "(NotPat "++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)) |]++-- 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++-- 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)++-- 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++-- \[x, y] -> HCons x (HCons y HNil)+f :: [Name] -> Pat+f [] = ConP 'HNil []+f (x:xs) = InfixP (VarP x) 'HCons $ f xs
+ test/Spec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuasiQuotes #-}++module Spec (spec) where++import Control.Egison+import Data.Numbers.Primes+import Test.Hspec++--+-- Basic list processing functions in pattern-matching-oriented programming style+--++pmap :: (a -> b) -> [a] -> [b]+pmap f xs = matchAll xs (List Something)+ [[mc| join _ (cons $x _) => f x |]]++pmConcat :: [[a]] -> [a]+pmConcat xss = matchAll xss (Multiset (Multiset Something))+ [[mc| cons (cons $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) |]]+ `shouldBe` [(1, [2,3])]++ it "multiset cons pattern" $+ matchAll [1,2,3] (Multiset Integer) [[mc| cons $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) |]])+ `shouldBe` 6++ it "value pattern for list matcher (1)" $+ match [1,2,3] (List Integer)+ [[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" |]]+ `shouldBe` "Not matched"++ it "value pattern for multiset matcher" $+ match [1,2,3] (Multiset Integer)+ [[mc| #[2,1,3] => "Matched" |],+ [mc| _ => "Not matched" |]]+ `shouldBe` "Matched"++ describe "match-all with infinitely many results" $ do+ it "Check the order of pattern-matching results" $+ take 10 (matchAll [1..] (Multiset Integer)+ [[mc| cons $x (cons $y _) => (x, y) |]])+ `shouldBe` [(1,2),(1,3),(2,1),(1,4),(2,3),(3,1),(1,5),(2,4),(3,2),(4,1)]++ describe "built-in pattern constructs" $ do+ it "Predicate patterns" $+ matchAll [1..10] (Multiset Integer)+ [[mc| cons (& (PredicatePat (\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) |]])+ `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) |]])+ `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) |]])+ `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+ it "map" $+ pmap (+ 10) [1,2,3] `shouldBe` [11, 12, 13]+ it "concat" $+ pmConcat [[1,2], [3], [4, 5]] `shouldBe` [1..5]+ -- it "uniq" $+ -- pmUniq [1,1,2,3,2] `shouldBe` [1,2,3]
+ test/Test.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Test.Hspec+import Spec++main :: IO ()+main = hspec spec