├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── benchmark ├── BenchImport.hs ├── comb2.hs ├── perm2.hs └── primePairs.hs ├── mini-egison.cabal ├── sample ├── cdcl.hs ├── deleteAs.hs ├── dp.hs ├── error.hs ├── mapWithBothSides.hs ├── poker.hs ├── tree.hs └── unordered-pair.hs ├── src └── Control │ ├── Egison.hs │ └── Egison │ ├── Core.hs │ ├── Match.hs │ ├── Matcher.hs │ └── QQ.hs ├── stack.yaml └── test ├── Spec.hs └── Test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | ### https://raw.github.com/github/gitignore/3818fecaa8f9d213b3b1b9dfc11ebcc8e8caeb45/Haskell.gitignore 2 | 3 | dist 4 | dist-* 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | 26 | sample/** 27 | !sample/*.hs 28 | 29 | benchmark/** 30 | !benchmark/*.hs 31 | !benchmark/*.md 32 | 33 | stack.yaml.lock 34 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | 3 | sudo: false 4 | 5 | # Caching so the next build will be fast too. 6 | cache: 7 | directories: 8 | - $HOME/.cabal/packages 9 | - $HOME/.cabal/store 10 | - $HOME/.stack 11 | - $TRAVIS_BUILD_DIR/.stack-work 12 | 13 | before_install: 14 | # Download and unpack the stack executable 15 | - mkdir -p ~/.local/bin 16 | - export PATH=$HOME/.local/bin:$PATH 17 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 18 | 19 | script: 20 | - stack --no-terminal --skip-ghc-check test 21 | 22 | branches: 23 | only: 24 | - master 25 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for egison-haskell 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Mayuko Kori, Satoshi Egi 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the "Software"), 5 | to deal in the Software without restriction, including without limitation 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 7 | and/or sell copies of the Software, and to permit persons to whom the Software 8 | is furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included 11 | in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 14 | INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR 15 | A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 16 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 17 | CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE 18 | OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # miniEgison: Template Haskell Implementation of Egison Pattern Matching 2 | [![Build Status](https://travis-ci.org/egison/egison-haskell.svg?branch=master)](https://travis-ci.org/egison/egison-haskell) 3 | 4 | This Haskell library provides the users with the pattern-matching facility against non-free data types. 5 | Non-free data types are data types whose data have no standard forms. 6 | 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}. 7 | 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. 8 | 9 | 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/). 10 | 11 | ## Grammar 12 | 13 | This library provides two syntax constructs, `matchAll`, `match`, `matchAllDFS`, and `matchDFS` for advanced pattern matching for non-free data types. 14 | 15 | ``` 16 | e ::= hs-expr -- arbitrary Haskell expression 17 | | matchAll e e [C, ...] -- match-all expression 18 | | match e e [C, ...] -- match expression 19 | | matchAllDFS e e [C, ...] -- match-all expression 20 | | matchDFS e e [C, ...] -- match expression 21 | | Something -- Something built-in matcher 22 | 23 | C ::= [mc| p -> e |] -- match clause 24 | 25 | p ::= _ -- wildcard pattern 26 | | $v -- pattern variable 27 | | #e -- value pattern 28 | | ?e -- predicate pattern 29 | | (p_1, p_2, ..., p_n) -- tuple pattern 30 | | [p_1, p_2, ..., p_n] -- collection pattern 31 | | p & p -- and-pattern 32 | | p | p -- or-pattern 33 | | !p -- not-pattern 34 | | c p_1 p_2 ... p_n -- constructor pattern 35 | ``` 36 | 37 | ## Usage 38 | 39 | ### The `matchAll` expression and matchers 40 | 41 | The `matchAll` expression evaluates the body of the match clause for all the pattern-matching results. 42 | The expression below pattern-matches a target `[1,2,3]` as a list of integers with a pattern `cons $x $xs`. 43 | This expression returns a list of a single element because there is only one decomposition. 44 | 45 | ```hs 46 | matchAll [1,2,3] (List Integer) [[mc| $x : $xs -> (x, xs)|]] 47 | -- [(1,[2,3])] 48 | ``` 49 | 50 | The other characteristic of `matchAll` is its additional argument matcher. 51 | A matcher is a special object that retains the pattern-matching algorithms for each data type. 52 | `matchAll` takes a matcher as its second argument. 53 | We can change a way to interpret a pattern by changing a matcher. 54 | 55 | For example, by changing the matcher of the above `matchAll` from `List Integer` to `Multiset Integer`, the evaluation result changes as follows: 56 | 57 | ```hs 58 | matchAll [1,2,3] (Multiset Integer) [[mc| $x : $xs -> (x, xs)|]] 59 | -- [(1,[2,3]),(2,[1,3]),(3,[1,2])] 60 | ``` 61 | 62 | When the `Multiset` matcher is used, `:` (the cons pattern) decomposes a target list into an element and the rest elements. 63 | 64 | The pattern-matching algorithms for each matcher can be defined by users. 65 | For example, the matchers such as `List` and `Multiset` can be defined by users. 66 | The `Something` matcher is the only built-in matcher. 67 | `something` can be used for pattern-matching arbitrary objects but can handle only pattern variables and wildcards. 68 | The definitions of `List` and `Multiset` are found [here](https://github.com/egison/egison-haskell/blob/master/src/Control/Egison/Matcher.hs). 69 | We will write an explanation of this definition in future. 70 | 71 | ### Non-linear pattern 72 | 73 | Non-linear pattern matching is another important feature of Egison pattern matching. 74 | Non-linear patterns are patterns that allow multiple occurrences of the same pattern variables in a pattern. 75 | For example, the program below pattern-matches a list `[1,2,5,9,4]` as a multiset and extracts pairs of sequential elements. 76 | A non-linear pattern is effectively used for expressing the pattern. 77 | 78 | ```hs 79 | matchAll [1,2,5,9,4] (Multiset Integer) [[mc| $x : #(x+1) : _ -> x|]] 80 | -- [1,4] 81 | ``` 82 | 83 | ### The `match` expression 84 | 85 | The `match` expression takes a target, a matcher, and match-clauses as the `matchAll` expression. 86 | The `match` expression returns only the evaluation result of the first pattern-matching result. 87 | 88 | ```hs 89 | match [1,2,5,9,4] (Multiset Integer) [[mc| $x : #(x+1) : _ -> x|]] 90 | -- 1 91 | ``` 92 | 93 | The `match` expression is simply implemented using `matchAll` as follows: 94 | 95 | ```hs 96 | match tgt m cs = head $ matchAll tgt m cs 97 | ``` 98 | 99 | ### `matchAllDFS` and `matchDFS` 100 | 101 | The `matchAll` and `match` expressions traverse a search tree for pattern matching in breadth-first order. 102 | The reason of the default breadth-first traversal is because to enumerate all the successful pattern-matching results even when they are infinitely many. 103 | For example, all the pairs of natural numbers can be enumerated by the following `matchAll` expression: 104 | 105 | ```hs 106 | take 10 (matchAll [1..] (Set Integer) 107 | [[mc| $x : $y : _ -> (x, y) |]]) 108 | -- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] 109 | ``` 110 | 111 | If we change the above `matchAll` to `matchAllDFS`, the order of the pattern-matching results changes as follows: 112 | 113 | ```hs 114 | take 10 (matchAllDFS [1..] (Set Integer) 115 | [[mc| $x : $y : _ -> (x, y) |]]) 116 | -- [(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)] 117 | ``` 118 | 119 | There are cases where depth-first traversal is suitable because the depth-first order of pattern-matching results is preferable. 120 | Furthermore, `matchAllDFS` is more efficient than `matchAll`. 121 | It would be better to use `matchAllDFS` instead of `matchAll` when the both expressions can be used. 122 | 123 | ### Matcher definitions 124 | 125 | The users can define pattern-matching algorithms for each pattern by themselves. 126 | 127 | preparing... 128 | 129 | ```hs 130 | matchAll (1,2) UnorderedEqlPair [[mc| uepair $x $y -> (x,y) |]] 131 | -- [(1,2),(2,1)] 132 | 133 | matchAll (1,2) UnorderedEqlPair [[mc| uepair #2 $x -> x |]] 134 | -- [1] 135 | ``` 136 | 137 | A matcher is represented as a data type whose name and constructor's name is identical. 138 | 139 | preparing... 140 | 141 | ```hs 142 | data UnorderedEqlPair = UnorderedEqlPair 143 | instance (Eq a) -> Matcher UnorderedEqlPair (a, a) 144 | 145 | uepair :: (Eq a) 146 | => Pattern a Eql ctx xs 147 | -> Pattern a Eql (ctx :++: xs) ys 148 | -> Pattern (a, a) UnorderedEqlPair ctx (xs :++: ys) 149 | uepair p1 p2 = Pattern (\_ UnorderedEqlPair (t1, t2) -> 150 | [twoMAtoms (MAtom p1 Eql t1) (MAtom p2 Eql t2) 151 | ,twoMAtoms (MAtom p1 Eql t2) (MAtom p2 Eql t1)]) 152 | ``` 153 | 154 | ```hs 155 | matchAll (1,2) (UnorderedPair Eql) [[mc| uepair $x $y -> (x,y) |]] 156 | -- [(1,2),(2,1)] 157 | 158 | matchAll (1,2) (UnorderedPair Eql) [[mc| upair #2 $x -> x |]] 159 | -- [1] 160 | ``` 161 | 162 | ```hs 163 | data UnorderedPair m = UnorderedPair m 164 | instance Matcher m a => Matcher (UnorderedPair m) (a, a) 165 | 166 | upair :: (Matcher m a , a ~ (b, b), m ~ (UnorderedPair m'), Matcher m' b) 167 | => Pattern b m' ctx xs 168 | -> Pattern b m' (ctx :++: xs) ys 169 | -> Pattern a m ctx (xs :++: ys) 170 | upair p1 p2 = Pattern (\_ (UnorderedPair m') (t1, t2) -> 171 | [twoMAtoms (MAtom p1 m' t1) (MAtom p2 m' t2) 172 | ,twoMAtoms (MAtom p1 m' t2) (MAtom p2 m' t1)]) 173 | ``` 174 | 175 | ## Samples 176 | 177 | ### Twin primes 178 | 179 | We can extract all twin primes from the list of prime numbers by pattern matching: 180 | 181 | ```hs 182 | take 10 (matchAll primes (List Integer) 183 | [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]) 184 | -- [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)] 185 | ``` 186 | 187 | It is also possible to enumerate all the pairs of prime numbers whose form is (p, p+6): 188 | 189 | ```hs 190 | take 10 (matchAll primes (List Integer) 191 | [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]]) 192 | -- [(5,11),(7,13),(11,17),(13,19),(17,23),(23,29),(31,37),(37,43),(41,47),(47,53)] 193 | ``` 194 | 195 | ### Poker hand 196 | 197 | ```hs 198 | poker cs = 199 | match cs (Multiset CardM) 200 | [[mc| card $s $n : 201 | card #s #(n-1) : 202 | card #s #(n-2) : 203 | card #s #(n-3) : 204 | card #s #(n-4) : 205 | [] -> "Straight flush" |], 206 | [mc| card _ $n : 207 | card _ #n : 208 | card _ #n : 209 | card _ #n : 210 | _ : 211 | [] -> "Four of a kind" |], 212 | [mc| card _ $m : 213 | card _ #m : 214 | card _ #m : 215 | card _ $n : 216 | card _ #n : 217 | [] -> "Full house" |], 218 | [mc| card $s _ : 219 | card #s _ : 220 | card #s _ : 221 | card #s _ : 222 | card #s _ : 223 | [] -> "Flush" |], 224 | [mc| card _ $n : 225 | card _ #(n-1) : 226 | card _ #(n-2) : 227 | card _ #(n-3) : 228 | card _ #(n-4) : 229 | [] -> "Straight" |], 230 | [mc| card _ $n : 231 | card _ #n : 232 | card _ #n : 233 | _ : 234 | _ : 235 | [] -> "Three of a kind" |], 236 | [mc| card _ $m : 237 | card _ #m : 238 | card _ $n : 239 | card _ #n : 240 | _ : 241 | [] -> "Two pair" |], 242 | [mc| card _ $n : 243 | card _ #n : 244 | _ : 245 | _ : 246 | _ : 247 | [] -> "One pair" |], 248 | [mc| _ -> "Nothing" |]] 249 | ``` 250 | 251 | ## Benchmark 252 | 253 | We benchmarked this library using the program that enumerates the first 50 (p, p+6) primes. 254 | This Haskell library is much faster than the original Egison interpreter! 255 | 256 | ``` 257 | $ cabal new-bench prime-pairs 258 | ... 259 | benchmarking (p, p+6) pairs/50/egison 260 | time 5.066 s (4.610 s .. 5.608 s) 261 | 0.999 R² (0.995 R² .. 1.000 R²) 262 | mean 4.932 s (4.807 s .. 5.017 s) 263 | std dev 120.2 ms (34.72 ms .. 161.7 ms) 264 | variance introduced by outliers: 19% (moderately inflated) 265 | 266 | benchmarking (p, p+6) pairs/50/miniEgison 267 | time 2.415 ms (2.264 ms .. 2.527 ms) 268 | 0.984 R² (0.975 R² .. 0.991 R²) 269 | mean 2.196 ms (2.106 ms .. 2.266 ms) 270 | std dev 252.3 μs (219.0 μs .. 296.6 μs) 271 | variance introduced by outliers: 73% (severely inflated) 272 | ... 273 | ``` 274 | 275 | ## Sponsors 276 | 277 | Egison is sponsored by [Rakuten, Inc.](http://global.rakuten.com/corp/) and [Rakuten Institute of Technology](http://rit.rakuten.co.jp/). 278 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmark/BenchImport.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module BenchImport 4 | ( parseEgison 5 | , evalEgison 6 | , EgisonExpr 7 | ) 8 | where 9 | 10 | import Language.Egison ( initialEnv 11 | , evalEgisonExpr 12 | , EgisonValue(..) 13 | ) 14 | import Language.Egison.Data ( fromEgisonM ) 15 | import Language.Egison.AST 16 | import Language.Egison.ParserNonS ( readExpr ) 17 | import Language.Egison.CmdOptions ( defaultOption ) 18 | 19 | import GHC.Generics ( Generic ) 20 | import Control.DeepSeq ( NFData ) 21 | 22 | deriving instance Generic BinOpAssoc 23 | instance NFData BinOpAssoc 24 | 25 | deriving instance Generic Infix 26 | instance NFData Infix 27 | 28 | deriving instance Generic LoopRange 29 | instance NFData LoopRange 30 | 31 | deriving instance Generic Arg 32 | instance NFData Arg 33 | 34 | deriving instance Generic PMMode 35 | instance NFData PMMode 36 | 37 | deriving instance Generic PrimitivePatPattern 38 | instance NFData PrimitivePatPattern 39 | 40 | deriving instance Generic InnerExpr 41 | instance NFData InnerExpr 42 | 43 | deriving instance Generic PrimitiveDataPattern 44 | instance NFData PrimitiveDataPattern 45 | 46 | deriving instance Generic EgisonPattern 47 | instance NFData EgisonPattern 48 | 49 | instance NFData Var 50 | instance NFData (Index ()) 51 | instance NFData (Index EgisonExpr) 52 | 53 | deriving instance Generic EgisonExpr 54 | instance NFData EgisonExpr 55 | 56 | evalEgison :: EgisonExpr -> IO EgisonValue 57 | evalEgison expr = do 58 | egisonEnv <- initialEnv defaultOption 59 | Right value <- evalEgisonExpr egisonEnv expr 60 | pure value 61 | 62 | parseEgison :: String -> IO EgisonExpr 63 | parseEgison exprString = leftToFail =<< fromEgisonM (readExpr exprString) 64 | where 65 | leftToFail (Left e) = fail $ show e 66 | leftToFail (Right x) = pure x 67 | -------------------------------------------------------------------------------- /benchmark/comb2.hs: -------------------------------------------------------------------------------- 1 | import Control.Egison 2 | 3 | import Data.List ( tails ) 4 | import Criterion.Main 5 | 6 | 7 | comb2 :: Int -> [(Int, Int)] 8 | comb2 n = matchAllDFS [1 .. n] 9 | (List Something) 10 | [[mc| _ ++ $x : _ ++ $y : _ -> (x, y) |]] 11 | 12 | comb2Native :: Int -> [(Int, Int)] 13 | comb2Native n = [ (y, z) | y : ts <- tails xs, z <- ts ] where xs = [1 .. n] 14 | 15 | main :: IO () 16 | main = defaultMain 17 | [ bgroup 18 | "comb2" 19 | [ bgroup 20 | "1600" 21 | [ bench "native" $ nf comb2Native 1600 22 | , bench "miniEgison" $ nf comb2 1600 23 | ] 24 | , bgroup 25 | "3200" 26 | [ bench "native" $ nf comb2Native 3200 27 | , bench "miniEgison" $ nf comb2 3200 28 | ] 29 | , bgroup 30 | "6400" 31 | [ bench "native" $ nf comb2Native 6400 32 | , bench "miniEgison" $ nf comb2 6400 33 | ] 34 | ] 35 | ] 36 | -------------------------------------------------------------------------------- /benchmark/perm2.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | import Control.Egison 4 | 5 | import BenchImport 6 | import Criterion.Main 7 | 8 | perm2 :: Int -> [(Int, Int)] 9 | perm2 n = 10 | matchAllDFS [1 .. n] (Multiset Something) [[mc| $x : $y : _ -> (x, y) |]] 11 | 12 | perm2Native :: Int -> [(Int, Int)] 13 | perm2Native n = go [1 .. n] [] 14 | where 15 | go [] _ = [] 16 | go (x : xs) rest = 17 | [ (x, y) | y <- rest ++ xs ] ++ go xs (rest ++ [x]) 18 | 19 | perm2Egison :: Int -> IO EgisonExpr 20 | perm2Egison n = parseEgison expr 21 | where 22 | expr = 23 | "matchAllDFS [1 .. " 24 | ++ show n 25 | ++ "] as multiset something with $x :: $y :: _ -> (x, y)" 26 | 27 | main :: IO () 28 | main = defaultMain 29 | [ bgroup 30 | "perm2" 31 | [ bgroup 32 | "50" 33 | [ bench "native" $ nf perm2Native 50 34 | , env (perm2Egison 50) $ bench "egison" . whnfIO . evalEgison 35 | , bench "miniEgison" $ nf perm2 50 36 | ] 37 | , bgroup 38 | "100" 39 | [ bench "native" $ nf perm2Native 100 40 | , env (perm2Egison 100) $ bench "egison" . whnfIO . evalEgison 41 | , bench "miniEgison" $ nf perm2 100 42 | ] 43 | , bgroup 44 | "200" 45 | [ bench "native" $ nf perm2Native 200 46 | , env (perm2Egison 200) $ bench "egison" . whnfIO . evalEgison 47 | , bench "miniEgison" $ nf perm2 200 48 | ] 49 | , bgroup 50 | "400" 51 | [ bench "native" $ nf perm2Native 400 52 | , env (perm2Egison 400) $ bench "egison" . whnfIO . evalEgison 53 | , bench "miniEgison" $ nf perm2 400 54 | ] 55 | , bgroup 56 | "800" 57 | [ bench "native" $ nf perm2Native 800 58 | , env (perm2Egison 800) $ bench "egison" . whnfIO . evalEgison 59 | , bench "miniEgison" $ nf perm2 800 60 | ] 61 | , bgroup 62 | "1600" 63 | [ bench "native" $ nf perm2Native 1600 64 | , bench "miniEgison" $ nf perm2 1600 65 | ] 66 | , bgroup 67 | "3200" 68 | [ bench "native" $ nf perm2Native 3200 69 | , bench "miniEgison" $ nf perm2 3200 70 | ] 71 | , bgroup 72 | "6400" 73 | [ bench "native" $ nf perm2Native 6400 74 | , bench "miniEgison" $ nf perm2 6400 75 | ] 76 | ] 77 | ] 78 | -------------------------------------------------------------------------------- /benchmark/primePairs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-full-laziness #-} 2 | 3 | import Control.Egison 4 | 5 | import Data.Numbers.Primes ( primes ) 6 | 7 | import BenchImport 8 | import Criterion.Main 9 | 10 | 11 | primePairs2 :: Int -> [(Int, Int)] 12 | primePairs2 n = take n 13 | $ matchAll primes (List Integer) [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]] 14 | 15 | primePairs2Egison :: Int -> IO EgisonExpr 16 | primePairs2Egison n = parseEgison expr 17 | where 18 | expr = 19 | "take " 20 | ++ show n 21 | ++ " (matchAll primes as list integer with _ ++ $p :: #(p+2) :: _ -> (p, p+2))" 22 | 23 | primePairs6 :: Int -> [(Int, Int)] 24 | primePairs6 n = take n $ matchAll 25 | primes 26 | (List Integer) 27 | [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]] 28 | 29 | primePairs6Egison :: Int -> IO EgisonExpr 30 | primePairs6Egison n = parseEgison expr 31 | where 32 | expr = 33 | "take " 34 | ++ show n 35 | ++ " (matchAll primes as list integer with _ ++ $p :: _ ++ #(p+6) :: _ -> (p, p+6))" 36 | 37 | main :: IO () 38 | main = defaultMain 39 | [ bgroup 40 | "(p, p+2) pairs" 41 | [ bgroup 42 | "50" 43 | [ env (primePairs2Egison 50) $ bench "egison" . whnfIO . evalEgison 44 | , bench "miniEgison" $ nf primePairs2 50 45 | ] 46 | , bench "12800" $ nf primePairs2 12800 47 | , bench "25600" $ nf primePairs2 25600 48 | , bench "51200" $ nf primePairs2 51200 49 | ] 50 | , bgroup 51 | "(p, p+6) pairs" 52 | [ bgroup 53 | "50" 54 | [ env (primePairs6Egison 50) $ bench "egison" . whnfIO . evalEgison 55 | , bench "miniEgison" $ nf primePairs6 50 56 | ] 57 | , bench "128" $ nf primePairs6 128 58 | , bench "256" $ nf primePairs6 256 59 | , bench "512" $ nf primePairs6 512 60 | ] 61 | ] 62 | -------------------------------------------------------------------------------- /mini-egison.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | name: mini-egison 4 | version: 1.0.0 5 | synopsis: Template Haskell Implementation of Egison Pattern Matching 6 | 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. 7 | Non-free data types are data types whose data have no standard forms. 8 | 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]'. 9 | . 10 | The design of the pattern-matching facility is originally proposed in and implemented in . 11 | 12 | homepage: https://github.com/egison/egison-haskell#readme 13 | bug-reports: https://github.com/egison/egison-haskell/issues 14 | author: Mayuko Kori, Satoshi Egi 15 | maintainer: Satoshi Egi 16 | license: MIT 17 | license-file: LICENSE 18 | category: Data, Pattern 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/egison/egison-haskell 27 | 28 | library 29 | exposed-modules: 30 | Control.Egison 31 | Control.Egison.Core 32 | Control.Egison.Match 33 | Control.Egison.Matcher 34 | Control.Egison.QQ 35 | other-modules: 36 | Paths_mini_egison 37 | hs-source-dirs: 38 | src 39 | build-depends: 40 | base >=4.7 && <5 41 | , mtl 42 | , recursion-schemes 43 | , haskell-src-exts 44 | , haskell-src-meta 45 | , template-haskell 46 | , egison-pattern-src >= 0.2.1 && < 0.3 47 | , egison-pattern-src-th-mode >= 0.2.1 && < 0.3 48 | default-language: Haskell2010 49 | default-extensions: 50 | TemplateHaskell 51 | , QuasiQuotes 52 | , GADTs 53 | , ExistentialQuantification 54 | , DataKinds 55 | , MultiParamTypeClasses 56 | , TypeFamilies 57 | , TypeOperators 58 | , FlexibleInstances 59 | , FlexibleContexts 60 | , TupleSections 61 | , Strict 62 | , StrictData 63 | , NamedFieldPuns 64 | ghc-options: -O3 65 | 66 | test-suite mini-egison-test 67 | type: exitcode-stdio-1.0 68 | main-is: Test.hs 69 | other-modules: 70 | Spec 71 | Paths_mini_egison 72 | hs-source-dirs: 73 | test 74 | build-depends: 75 | base >=4.7 && <5 76 | , mini-egison 77 | , hspec 78 | , primes 79 | default-language: Haskell2010 80 | default-extensions: 81 | QuasiQuotes 82 | , GADTs 83 | ghc-options: -O3 84 | 85 | Executable cdcl 86 | Main-is: cdcl.hs 87 | Build-depends: 88 | base >=4.7 && <5 89 | , mini-egison 90 | , sort 91 | Hs-Source-Dirs: sample 92 | default-language: Haskell2010 93 | ghc-options: -O3 94 | 95 | benchmark comb2 96 | type: exitcode-stdio-1.0 97 | main-is: comb2.hs 98 | hs-source-dirs: benchmark 99 | ghc-options: -O3 -Wall -threaded -rtsopts -with-rtsopts=-N 100 | default-language: Haskell2010 101 | default-extensions: 102 | TemplateHaskell 103 | , QuasiQuotes 104 | , GADTs 105 | build-depends: 106 | base 107 | , mini-egison 108 | , criterion >= 1 109 | 110 | benchmark perm2 111 | type: exitcode-stdio-1.0 112 | main-is: perm2.hs 113 | hs-source-dirs: benchmark 114 | ghc-options: -O3 -Wall -threaded -rtsopts -with-rtsopts=-N 115 | default-language: Haskell2010 116 | default-extensions: 117 | TemplateHaskell 118 | , QuasiQuotes 119 | , GADTs 120 | , DeriveGeneric 121 | , StandaloneDeriving 122 | , FlexibleInstances 123 | other-modules: BenchImport 124 | build-depends: 125 | base 126 | , mini-egison 127 | , criterion >= 1 128 | , egison >= 3.10.0 && < 3.11 129 | , deepseq 130 | 131 | benchmark prime-pairs 132 | type: exitcode-stdio-1.0 133 | main-is: primePairs.hs 134 | hs-source-dirs: benchmark 135 | ghc-options: -O3 -Wall -threaded -rtsopts -with-rtsopts=-N 136 | default-language: Haskell2010 137 | default-extensions: 138 | TemplateHaskell 139 | , QuasiQuotes 140 | , GADTs 141 | , DeriveGeneric 142 | , StandaloneDeriving 143 | , FlexibleInstances 144 | other-modules: BenchImport 145 | build-depends: 146 | base 147 | , mini-egison 148 | , criterion >= 1 149 | , primes 150 | , egison >= 3.10.0 && < 3.11 151 | , deepseq 152 | -------------------------------------------------------------------------------- /sample/cdcl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | import Data.List 8 | import Data.Sort 9 | import Control.Egison hiding (Integer) 10 | import qualified Control.Egison as M 11 | import Debug.Trace 12 | 13 | 14 | 15 | -- Literal matcher = Integer matcher 16 | data Literal = Literal 17 | instance Integral a => Matcher Literal a 18 | 19 | instance Integral a => ValuePat Literal a where 20 | valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt]) 21 | 22 | -- Stage matcher = Integer matcher 23 | data Stage = Stage 24 | instance Integral a => Matcher Stage a 25 | 26 | instance Integral a => ValuePat Stage a where 27 | valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt]) 28 | 29 | -- Matchers for assignments 30 | type TaggedLiteral = (Integer, Integer) -- a tuple of a variable and a stage 31 | 32 | data Assign = Deduced TaggedLiteral [TaggedLiteral] 33 | | Guessed TaggedLiteral 34 | deriving (Show) 35 | 36 | data Assignment = Assignment 37 | instance Matcher Assignment Assign 38 | 39 | deduced :: Pattern TaggedLiteral (Pair Literal Stage) ctx xs 40 | -> Pattern [TaggedLiteral] (Multiset (Pair Literal Stage)) (ctx :++: xs) ys 41 | -> Pattern Assign Assignment ctx (xs :++: ys) 42 | deduced p1 p2 = Pattern (\_ _ tgt -> case tgt of 43 | Deduced l ls -> [twoMAtoms (MAtom p1 (Pair Literal Stage) l) 44 | (MAtom p2 (Multiset (Pair Literal Stage)) ls)] 45 | _ -> []) 46 | 47 | guessed :: Pattern TaggedLiteral (Pair Literal Stage) ctx xs 48 | -> Pattern Assign Assignment ctx xs 49 | guessed p1 = Pattern (\_ _ tgt -> case tgt of 50 | Guessed l -> [oneMAtom (MAtom p1 (Pair Literal Stage) l)] 51 | _ -> []) 52 | 53 | whichever :: Pattern TaggedLiteral (Pair Literal Stage) ctx xs 54 | -> Pattern Assign Assignment ctx xs 55 | whichever p1 = Pattern (\_ _ tgt -> case tgt of 56 | Deduced l _ -> [oneMAtom (MAtom p1 (Pair Literal Stage) l)] 57 | Guessed l -> [oneMAtom (MAtom p1 (Pair Literal Stage) l)]) 58 | 59 | -- 60 | -- VSIDS 61 | -- 62 | toCNF :: [[Integer]] -> [([Integer], [Integer])] 63 | toCNF cs = map (\c -> (c, c)) cs 64 | 65 | fromCNF :: [([Integer], [Integer])] -> [[Integer]] 66 | fromCNF cnf = map (\(c1, _) -> c1) cnf 67 | 68 | initVars :: [Integer] -> [(Integer, Integer)] 69 | initVars vs = map (\v -> (negate v, 0)) vs ++ map (\v -> (v, 0)) vs 70 | 71 | addVars :: [Integer] -> [(Integer, Integer)] -> [(Integer, Integer)] 72 | addVars vs vars = 73 | matchDFS (vs, vars) (Pair (List Literal) (List (Pair Literal M.Integer))) 74 | [[mc| ([], _) -> sortBy (\(_, c1) (_, c2) -> opposite (compare c1 c2)) vars |], 75 | [mc| ($v : $vs2, $hs ++ (#v, $c) : $ts) -> 76 | addVars vs2 (hs ++ (v, c + 1) : ts) |]] 77 | where 78 | opposite LT = GT 79 | opposite GT = LT 80 | opposite EQ = EQ 81 | 82 | deleteVar :: Integer -> [(Integer, Integer)] -> [(Integer, Integer)] 83 | deleteVar v vars = 84 | matchDFS vars (Multiset (Pair Literal M.Integer)) 85 | [[mc| (#v, _) : (#(negate v), _) : $vars2 -> vars2 |]] 86 | 87 | -- 88 | -- Utility functions for literals and cnfs 89 | -- 90 | getStage :: Integer -> [Assign] -> Integer 91 | getStage l trail = 92 | matchDFS trail (List Assignment) 93 | [[mc| _ ++ whichever (#(negate l), $s) : _ -> s |]] 94 | 95 | deleteLiteral :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] 96 | deleteLiteral l cnf = 97 | map (\(c1, c2) -> (matchAllDFS c1 (Multiset Literal) 98 | [[mc| (!#l & $m) : _ -> m |]], 99 | c2)) 100 | cnf 101 | 102 | deleteClausesWith :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] 103 | deleteClausesWith l cnf = 104 | matchAllDFS cnf (Multiset (Pair (Multiset Literal) (Multiset Literal))) 105 | [[mc| ((!(#l : _), _) & $c) : _ -> c |]] 106 | 107 | assignTrue :: Integer -> [([Integer], [Integer])] -> [([Integer], [Integer])] 108 | assignTrue l cnf = 109 | deleteLiteral (negate l) (deleteClausesWith l cnf) 110 | 111 | -- 112 | -- Unit propagation 113 | -- 114 | unitPropagate :: Integer -> [([Integer], [Integer])] -> [Assign] -> ([([Integer], [Integer])], [Assign]) 115 | unitPropagate stage cnf trail = unitPropagate' stage cnf trail trail 116 | 117 | unitPropagate' :: Integer -> [([Integer], [Integer])] -> [Assign] -> [Assign] -> ([([Integer], [Integer])], [Assign]) 118 | unitPropagate' stage cnf trail otrail = 119 | matchDFS trail (List Assignment) 120 | [[mc| whichever ($l, _) : $trail2 -> unitPropagate' stage (assignTrue l cnf) trail2 otrail |], 121 | [mc| _ -> unitPropagate'' stage cnf otrail |]] 122 | 123 | unitPropagate'' :: Integer -> [([Integer], [Integer])] -> [Assign] -> ([([Integer], [Integer])], [Assign]) 124 | unitPropagate'' stage cnf trail = 125 | matchDFS cnf (Multiset (Pair (Multiset Literal) (Multiset Literal))) 126 | [[mc| ([], _) : _ -> (cnf, trail) |], 127 | [mc| ($l : [], #l : $rs) : _ -> 128 | unitPropagate'' stage (assignTrue l cnf) 129 | ([(Deduced (l, stage) (map (\r -> (r, (getStage r trail))) rs))] ++ trail) |], 130 | [mc| _ -> (cnf, trail) |]] 131 | 132 | -- 133 | -- Learning 134 | -- 135 | 136 | learn :: Integer -> [(Integer, Integer)] -> [Assign] -> (Integer, [Integer]) 137 | learn stage cl trail = 138 | matchDFS (trail, cl) (Pair (List Assignment) (Multiset (Pair Literal M.Integer))) -- must be matchDFS 139 | [[mc| (_, !((_, #stage) : (_, #stage) : _)) -> 140 | (minimum (map (\(_, c) -> c) cl), map (\(l, _) -> l) cl) |], 141 | [mc| (_ ++ deduced ($l, #stage) $ds : $trail2, 142 | (#(negate l), #stage) : $rs) -> 143 | learn stage (union rs ds) trail2 |]] 144 | 145 | -- 146 | -- Backjumping 147 | -- 148 | 149 | backjump :: Integer -> [Assign] -> [Assign] 150 | backjump stage trail = 151 | matchDFS trail (List Assignment) 152 | [[mc| _ ++ ((guessed (_, #stage) : _) & $trail2) -> trail2 |], 153 | [mc| _ -> [] |]] 154 | 155 | -- 156 | -- Guess 157 | -- 158 | 159 | guess vars trail = 160 | matchDFS (vars, trail) (Pair (List (Pair Literal M.Integer)) (List Assignment)) -- must be matchDFS 161 | [[mc| (_ ++ ($l, _) : _, 162 | (!(_ ++ whichever ((#l | #(negate l)), _) : _))) -> 163 | negate l |]] 164 | 165 | -- 166 | -- CDCL main 167 | -- 168 | 169 | cdcl :: [Integer] -> [[Integer]] -> Bool 170 | cdcl vars cnf = cdcl' 0 0 (initVars vars) (toCNF cnf) [] 171 | 172 | cdcl' :: Integer -> Integer -> [(Integer, Integer)] -> [([Integer], [Integer])] -> [Assign] -> Bool 173 | cdcl' count stage vars cnf trail = 174 | let (cnf2, trail2) = unitPropagate stage cnf trail in 175 | -- let (cnf2, trail2) = unitPropagate stage cnf (trace (show trail) trail) in -- debug 176 | matchDFS (cnf2, trail2) (Pair (Multiset (Pair (Multiset Literal) (Multiset Literal))) (List Assignment)) 177 | [[mc| ([], _) -> True |], 178 | [mc| (([], $cc) : _, _ ++ guessed ($l, #stage) : $trail3) -> 179 | let (s, lc) = learn stage (map (\l -> (l, (getStage l trail2))) cc) trail2 in 180 | let trail4 = backjump s trail3 in 181 | cdcl' (count + 1) s (addVars lc vars) ((lc, lc):cnf) trail4 |], 182 | [mc| (([], $cc) : _, _) -> False |], 183 | [mc| _ -> 184 | let g = guess vars trail2 in 185 | cdcl' (count + 1) (stage + 1) vars cnf (Guessed (g, stage + 1):trail2) |]] 186 | 187 | main = do 188 | -- putStrLn $ show $ cdcl [] [] 189 | -- putStrLn $ show $ cdcl [] [[]] 190 | -- putStrLn $ show $ cdcl [1] [[1]] 191 | -- putStrLn $ show $ cdcl [1,2] [[1],[1,2]] 192 | -- putStrLn $ "Problem 20" 193 | -- putStrLn $ show $ cdcl [1..20] problem20 -- 0.293 sec 194 | putStrLn $ "Problem 50" 195 | putStrLn $ show $ cdcl [1..50] problem50 -- 2.570 sec 196 | 197 | problem20 = 198 | [[4,-18,19],[3,18,-5],[-5,-8,-15],[-20,7,-16],[10,-13,-7],[-12,-9,17],[17,19,5],[-16,9,15],[11,-5,-14],[18,-10,13],[-3,11,12],[-6,-17,-8],[-18,14,1],[-19,-15,10],[12,18,-19],[-8,4,7],[-8,-9,4],[7,17,-15],[12,-7,-14],[-10,-11,8],[2,-15,-11],[9,6,1],[-11,20,-17],[9,-15,13],[12,-7,-17],[-18,-2,20],[20,12,4],[19,11,14],[-16,18,-4],[-1,-17,-19],[-13,15,10],[-12,-14,-13],[12,-14,-7],[-7,16,10],[6,10,7],[20,14,-16],[-19,17,11],[-7,1,-20],[-5,12,15],[-4,-9,-13],[12,-11,-7],[-5,19,-8],[1,16,17],[20,-14,-15],[13,-4,10],[14,7,10],[-5,9,20],[10,1,-19],[-16,-15,-1],[16,3,-11],[-15,-10,4],[4,-15,-3],[-10,-16,11],[-8,12,-5],[14,-6,12],[1,6,11],[-13,-5,-1],[-7,-2,12],[1,-20,19],[-2,-13,-8],[15,18,4],[-11,14,9],[-6,-15,-2],[5,-12,-15],[-6,17,5],[-13,5,-19],[20,-1,14],[9,-17,15],[-5,19,-18],[-12,8,-10],[-18,14,-4],[15,-9,13],[9,-5,-1],[10,-19,-14],[20,9,4],[-9,-2,19],[-5,13,-17],[2,-10,-18],[-18,3,11],[7,-9,17],[-15,-6,-3],[-2,3,-13],[12,3,-2],[-2,-3,17],[20,-15,-16],[-5,-17,-19],[-20,-18,11],[-9,1,-5],[-19,9,17],[12,-2,17],[4,-16,-5]] 199 | 200 | problem50 = 201 | [[18,-8,29],[-16,3,18],[-36,-11,-30],[-50,20,32],[-6,9,35],[42,-38,29],[43,-15,10],[-48,-47,1],[-45,-16,33],[38,42,22],[-49,41,-34],[12,17,35],[22,-49,7],[-10,-11,-39],[-28,-36,-37],[-13,-46,-41],[21,-4,9],[12,48,10],[24,23,15],[-8,-41,-43],[-44,-2,-35],[-27,18,31],[47,35,6],[-11,-27,41],[-33,-47,-45],[-16,36,-37],[27,-46,2],[15,-28,10],[-38,46,-39],[-33,-4,24],[-12,-45,50],[-32,-21,-15],[8,42,24],[30,-49,4],[45,-9,28],[-33,-47,-1],[1,27,-16],[-11,-17,-35],[-42,-15,45],[-19,-27,30],[3,28,12],[48,-11,-33],[-6,37,-9],[-37,13,-7],[-2,26,16],[46,-24,-38],[-13,-24,-8],[-36,-42,-21],[-37,-19,3],[-31,-50,35],[-7,-26,29],[-42,-45,29],[33,25,-6],[-45,-5,7],[-7,28,-6],[-48,31,-11],[32,16,-37],[-24,48,1],[18,-46,23],[-30,-50,48],[-21,39,-2],[24,47,42],[-36,30,4],[-5,28,-1],[-47,32,-42],[16,37,-22],[-43,42,-34],[-40,39,-20],[-49,29,6],[-41,-3,39],[-16,-12,43],[24,22,3],[47,-45,43],[45,-37,46],[-9,26,5],[-3,23,-13],[5,-34,13],[12,39,13],[22,50,37],[19,9,46],[-24,8,-27],[-28,7,21],[8,-25,50],[20,50,4],[27,36,13],[26,31,-25],[39,-44,-32],[-20,41,-10],[49,-28,35],[1,44,34],[39,35,-11],[-50,-42,-7],[-24,7,47],[-13,5,-48],[-9,-20,-23],[2,17,-19],[11,23,21],[-45,30,15],[11,26,-24],[38,33,-13],[44,-27,-7],[41,49,2],[-18,12,-37],[-2,12,-26],[-19,7,32],[-22,11,33],[8,12,-20],[16,40,-48],[-2,-24,-11],[26,-17,37],[-14,-19,46],[5,47,36],[-29,-9,19],[32,4,28],[-34,20,-46],[-4,-36,-13],[-15,-37,45],[-21,29,23],[-6,-40,7],[-42,31,-29],[-36,24,31],[-45,-37,-1],[3,-6,-29],[-28,-50,27],[44,26,5],[-17,-48,49],[12,-40,-7],[-12,31,-48],[27,32,-42],[-27,-10,1],[6,-49,10],[-24,8,43],[23,31,1],[11,-47,38],[-28,26,-13],[-40,12,-42],[-3,39,46],[17,41,46],[23,21,13],[-14,-1,-38],[20,18,6],[-50,20,-9],[10,-32,-18],[-21,49,-34],[44,23,-35],[40,-19,34],[-1,6,-12],[6,-2,-7],[32,-20,34],[-12,43,-29],[24,2,-49],[10,-4,40],[11,5,12],[-3,47,-31],[43,-23,21],[-41,-36,-50],[-8,-42,-24],[39,45,7],[7,37,-45],[41,40,8],[-50,-10,-8],[-5,-39,-14],[-22,-24,-43],[-36,40,35],[17,49,41],[-32,7,24],[-30,-8,-9],[-41,-13,-10],[31,26,-33],[17,-22,-39],[-21,28,3],[-14,46,23],[29,16,19],[42,-32,-44],[-24,10,23],[-1,-32,-21],[-8,-44,-39],[39,11,9],[19,14,-46],[46,44,-42],[37,23,-29],[32,25,20],[14,-43,-12],[-36,-18,46],[14,-26,-10],[-2,-30,5],[6,-18,46],[-26,2,-44],[20,-8,-11],[-31,3,16],[-22,-9,39],[-49,44,-42],[-45,-44,31],[-31,50,-11],[-32,-46,2],[-6,-7,17],[19,-32,48],[39,20,-10],[-22,-37,38],[-31,9,-48],[40,12,7],[-24,-4,9],[-22,49,33],[-12,43,10],[25,-30,-10],[46,47,31],[13,27,-7],[-45,32,-35],[-50,34,9],[2,34,30],[3,16,2],[-18,45,-12],[33,37,10],[43,7,-18],[-22,44,-19],[-31,-27,-42],[-3,-40,8],[-23,-31,38]] 202 | -------------------------------------------------------------------------------- /sample/deleteAs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | import Control.Egison 5 | 6 | deleteWith m x xs = 7 | match xs (List m) 8 | [[mc| $hs ++ #x : $ts -> hs ++ ts |], 9 | [mc| _ -> xs |]] 10 | 11 | main = do 12 | putStrLn $ show $ deleteWith (List Eql) [1, 2] [[2, 3], [2, 1], [2, 4]] -- [[2, 3], [2, 1], [2, 4]] 13 | putStrLn $ show $ deleteWith (Multiset Eql) [1, 2] [[2, 3], [2, 1], [2, 4]] -- [[2, 3], [2, 4]] 14 | -------------------------------------------------------------------------------- /sample/dp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | import Prelude 9 | import Data.List 10 | import Control.Egison hiding (Integer) 11 | import qualified Control.Egison as M 12 | 13 | -- Integer matcher 14 | data Literal = Literal 15 | instance Integral a => Matcher Literal a 16 | 17 | instance Integral a => ValuePat Literal a where 18 | valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt]) 19 | 20 | deleteLiteral l cnf = 21 | map (\c -> matchAll c (Multiset Literal) 22 | [[mc| (!#l & $m) : _ -> m |]]) 23 | cnf 24 | 25 | deleteClausesWith l cnf = 26 | matchAll cnf (Multiset (Multiset Literal)) 27 | [[mc| (!(#l : _) & $c) : _ -> c |]] 28 | 29 | assignTrue l cnf = 30 | deleteLiteral (negate l) (deleteClausesWith l cnf) 31 | 32 | tautology c = 33 | match c (Multiset Literal) 34 | [[mc| $l : #(negate l) : _ -> True |], 35 | [mc| _ -> False |]] 36 | 37 | resolveOn v cnf = 38 | filter (\c -> not (tautology c)) 39 | (matchAll cnf (Multiset (Multiset Literal)) 40 | [[mc| (#v : $xs) : 41 | (#(negate v) : $ys) : 42 | _ -> 43 | nub (xs ++ ys) |]]) 44 | 45 | dp :: [Integer] -> [[Integer]] -> Bool 46 | dp vars cnf = 47 | match (vars, cnf) (Pair (Multiset Literal) (Multiset (Multiset Literal))) 48 | [-- satisfiable 49 | [mc| (_, []) -> True |], 50 | -- unsatisfiable 51 | [mc| (_, [] : _) -> False |], 52 | -- 1-literal rule 53 | [mc| (_, ($l : []) : _) -> 54 | dp (delete (abs l) vars) (assignTrue l cnf) |], 55 | -- pure literal rule (positive) 56 | [mc| ($v : $vs, !((#v : _) : _)) -> 57 | dp vs (assignTrue v cnf) |], 58 | -- pure literal rule (negative) 59 | [mc| ($v : $vs, !((#(negate v) : _) : _)) -> 60 | dp vs (assignTrue (negate v) cnf) |], 61 | -- otherwise 62 | [mc| ($v : $vs, _) -> 63 | dp vs (resolveOn v cnf ++ 64 | deleteClausesWith v (deleteClausesWith (negate v) cnf)) |]] 65 | 66 | main = do 67 | putStrLn $ show $ dp [] [] 68 | putStrLn $ show $ dp [] [[]] 69 | putStrLn $ show $ dp [1] [[1]] 70 | putStrLn $ show $ dp [1,2] [[1],[1,2]] 71 | putStrLn $ show $ dp [1..50] problem 72 | 73 | problem = 74 | [[18,-8,29] 75 | ,[-16,3,18] 76 | ,[-36,-11,-30] 77 | ,[-50,20,32] 78 | ,[-6,9,35] 79 | ,[42,-38,29] 80 | ,[43,-15,10] 81 | ,[-48,-47,1] 82 | ,[-45,-16,33] 83 | ,[38,42,22] 84 | ,[-49,41,-34] 85 | ,[12,17,35] 86 | ,[22,-49,7] 87 | ,[-10,-11,-39] 88 | ,[-28,-36,-37] 89 | ,[-13,-46,-41] 90 | ,[21,-4,9] 91 | ,[12,48,10] 92 | ,[24,23,15] 93 | ,[-8,-41,-43] 94 | ,[-44,-2,-35] 95 | ,[-27,18,31] 96 | ,[47,35,6] 97 | ,[-11,-27,41] 98 | ,[-33,-47,-45] 99 | ,[-16,36,-37] 100 | ,[27,-46,2] 101 | ,[15,-28,10] 102 | ,[-38,46,-39] 103 | ,[-33,-4,24] 104 | ,[-12,-45,50] 105 | ,[-32,-21,-15] 106 | ,[8,42,24] 107 | ,[30,-49,4] 108 | ,[45,-9,28] 109 | ,[-33,-47,-1] 110 | ,[1,27,-16] 111 | ,[-11,-17,-35] 112 | ,[-42,-15,45] 113 | ,[-19,-27,30] 114 | ,[3,28,12] 115 | ,[48,-11,-33] 116 | ,[-6,37,-9] 117 | ,[-37,13,-7] 118 | ,[-2,26,16] 119 | ,[46,-24,-38] 120 | ,[-13,-24,-8] 121 | ,[-36,-42,-21] 122 | ,[-37,-19,3] 123 | ,[-31,-50,35] 124 | ,[-7,-26,29] 125 | ,[-42,-45,29] 126 | ,[33,25,-6] 127 | ,[-45,-5,7] 128 | ,[-7,28,-6] 129 | ,[-48,31,-11] 130 | ,[32,16,-37] 131 | ,[-24,48,1] 132 | ,[18,-46,23] 133 | ,[-30,-50,48] 134 | ,[-21,39,-2] 135 | ,[24,47,42] 136 | ,[-36,30,4] 137 | ,[-5,28,-1] 138 | ,[-47,32,-42] 139 | ,[16,37,-22] 140 | ,[-43,42,-34] 141 | ,[-40,39,-20] 142 | ,[-49,29,6] 143 | ,[-41,-3,39] 144 | ,[-16,-12,43] 145 | ,[24,22,3] 146 | ,[47,-45,43] 147 | ,[45,-37,46] 148 | ,[-9,26,5] 149 | ,[-3,23,-13] 150 | ,[5,-34,13] 151 | ,[12,39,13] 152 | ,[22,50,37] 153 | ,[19,9,46] 154 | ,[-24,8,-27] 155 | ,[-28,7,21] 156 | ,[8,-25,50] 157 | ,[20,50,4] 158 | ,[27,36,13] 159 | ,[26,31,-25] 160 | ,[39,-44,-32] 161 | ,[-20,41,-10] 162 | ,[49,-28,35] 163 | ,[1,44,34] 164 | ,[39,35,-11] 165 | ,[-50,-42,-7] 166 | ,[-24,7,47] 167 | ,[-13,5,-48] 168 | ,[-9,-20,-23] 169 | ,[2,17,-19] 170 | ,[11,23,21] 171 | ,[-45,30,15] 172 | ,[11,26,-24] 173 | ,[38,33,-13] 174 | ,[44,-27,-7] 175 | ,[41,49,2] 176 | ,[-18,12,-37] 177 | ,[-2,12,-26] 178 | ,[-19,7,32] 179 | ,[-22,11,33] 180 | ,[8,12,-20] 181 | ,[16,40,-48] 182 | ,[-2,-24,-11] 183 | ,[26,-17,37] 184 | ,[-14,-19,46] 185 | ,[5,47,36] 186 | ,[-29,-9,19] 187 | ,[32,4,28] 188 | ,[-34,20,-46] 189 | ,[-4,-36,-13] 190 | ,[-15,-37,45] 191 | ,[-21,29,23] 192 | ,[-6,-40,7] 193 | ,[-42,31,-29] 194 | ,[-36,24,31] 195 | ,[-45,-37,-1] 196 | ,[3,-6,-29] 197 | ,[-28,-50,27] 198 | ,[44,26,5] 199 | ,[-17,-48,49] 200 | ,[12,-40,-7] 201 | ,[-12,31,-48] 202 | ,[27,32,-42] 203 | ,[-27,-10,1] 204 | ,[6,-49,10] 205 | ,[-24,8,43] 206 | ,[23,31,1] 207 | ,[11,-47,38] 208 | ,[-28,26,-13] 209 | ,[-40,12,-42] 210 | ,[-3,39,46] 211 | ,[17,41,46] 212 | ,[23,21,13] 213 | ,[-14,-1,-38] 214 | ,[20,18,6] 215 | ,[-50,20,-9] 216 | ,[10,-32,-18] 217 | ,[-21,49,-34] 218 | ,[44,23,-35] 219 | ,[40,-19,34] 220 | ,[-1,6,-12] 221 | ,[6,-2,-7] 222 | ,[32,-20,34] 223 | ,[-12,43,-29] 224 | ,[24,2,-49] 225 | ,[10,-4,40] 226 | ,[11,5,12] 227 | ,[-3,47,-31] 228 | ,[43,-23,21] 229 | ,[-41,-36,-50] 230 | ,[-8,-42,-24] 231 | ,[39,45,7] 232 | ,[7,37,-45] 233 | ,[41,40,8] 234 | ,[-50,-10,-8] 235 | ,[-5,-39,-14] 236 | ,[-22,-24,-43] 237 | ,[-36,40,35] 238 | ,[17,49,41] 239 | ,[-32,7,24] 240 | ,[-30,-8,-9] 241 | ,[-41,-13,-10] 242 | ,[31,26,-33] 243 | ,[17,-22,-39] 244 | ,[-21,28,3] 245 | ,[-14,46,23] 246 | ,[29,16,19] 247 | ,[42,-32,-44] 248 | ,[-24,10,23] 249 | ,[-1,-32,-21] 250 | ,[-8,-44,-39] 251 | ,[39,11,9] 252 | ,[19,14,-46] 253 | ,[46,44,-42] 254 | ,[37,23,-29] 255 | ,[32,25,20] 256 | ,[14,-43,-12] 257 | ,[-36,-18,46] 258 | ,[14,-26,-10] 259 | ,[-2,-30,5] 260 | ,[6,-18,46] 261 | ,[-26,2,-44] 262 | ,[20,-8,-11] 263 | ,[-31,3,16] 264 | ,[-22,-9,39] 265 | ,[-49,44,-42] 266 | ,[-45,-44,31] 267 | ,[-31,50,-11] 268 | ,[-32,-46,2] 269 | ,[-6,-7,17] 270 | ,[19,-32,48] 271 | ,[39,20,-10] 272 | ,[-22,-37,38] 273 | ,[-31,9,-48] 274 | ,[40,12,7] 275 | ,[-24,-4,9] 276 | ,[-22,49,33] 277 | ,[-12,43,10] 278 | ,[25,-30,-10] 279 | ,[46,47,31] 280 | ,[13,27,-7] 281 | ,[-45,32,-35] 282 | ,[-50,34,9] 283 | ,[2,34,30] 284 | ,[3,16,2] 285 | ,[-18,45,-12] 286 | ,[33,37,10] 287 | ,[43,7,-18] 288 | ,[-22,44,-19] 289 | ,[-31,-27,-42] 290 | ,[-3,-40,8] 291 | ,[-23,-31,38]] 292 | -------------------------------------------------------------------------------- /sample/error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | import Control.Egison hiding (Integer) 7 | import qualified Control.Egison as M 8 | 9 | main = do 10 | putStrLn $ show $ matchAll [1,2,3,5] (Multiset Eql) 11 | [[mc| [$x, $y, #(x + 1), $z] -> (x, y, z) |]] 12 | -- [(1,3,5),(2,1,5),(1,5,3),(2,5,1)] 13 | putStrLn $ show $ matchAll [1,2,3,5] (Multiset Eql) 14 | [[mc| [$x, $y, #(x + 1), #(not x)] -> (x, y) |]] 15 | -------------------------------------------------------------------------------- /sample/mapWithBothSides.hs: -------------------------------------------------------------------------------- 1 | splits [] = [] 2 | splits (x:xs) = ([],x:xs) : [ (x:ys,zs) | (ys,zs) <- splits xs ] 3 | 4 | mapWithBothSides :: ([Integer] -> Integer -> [Integer] -> a) -> [Integer] -> [a] 5 | mapWithBothSides f xs = [ f hs (head ts) (tail ts) | (hs,ts) <- splits xs, not (null ts) ] 6 | 7 | main = do 8 | putStrLn $ show $ mapWithBothSides (\hs x ts -> (hs,x,ts)) [1..3] 9 | -------------------------------------------------------------------------------- /sample/poker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | import Control.Egison hiding (Integer) 7 | import qualified Control.Egison as M 8 | 9 | data Card = Card Suit Integer 10 | data Suit = Spade | Heart | Club | Diamond deriving (Eq) 11 | 12 | data CardM = CardM 13 | instance Matcher CardM Card 14 | 15 | card :: Pattern Suit Eql ctx xs 16 | -> Pattern Integer M.Integer (ctx :++: xs) ys 17 | -> Pattern Card CardM ctx (xs :++: ys) 18 | card p1 p2 = Pattern (\_ _ (Card s n) -> [twoMAtoms (MAtom p1 Eql s) (MAtom p2 M.Integer n)]) 19 | 20 | poker :: [Card] -> String 21 | poker cs = 22 | match cs (Multiset CardM) 23 | [[mc| [card $s $n, card #s #(n-1), card #s #(n-2), card #s #(n-3), card #s #(n-4)] -> 24 | "Straight flush" |], 25 | [mc| [card _ $n, card _ #n, card _ #n, card _ #n, _] -> 26 | "Four of a kind" |], 27 | [mc| [card _ $m, card _ #m, card _ #m, card _ $n, card _ #n] -> 28 | "Full house" |], 29 | [mc| [card $s _, card #s _, card #s _, card #s _, card #s _] -> 30 | "Flush" |], 31 | [mc| [card _ $n, card _ #(n-1), card _ #(n-2), card _ #(n-3), card _ #(n-4)] -> 32 | "Straight" |], 33 | [mc| [card _ $n, card _ #n, card _ #n, _, _] -> 34 | "Three of a kind" |], 35 | [mc| [card _ $m, card _ #m, card _ $n, card _ #n, _] -> 36 | "Two pair" |], 37 | [mc| [card _ $n, card _ #n, _, _, _] -> 38 | "One pair" |], 39 | [mc| _ -> "Nothing" |]] 40 | 41 | main :: IO () 42 | main = do 43 | putStrLn $ poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9] -- "Straight flush 44 | putStrLn $ poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5] -- "Four of a kind" 45 | putStrLn $ poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7] -- "Full house" 46 | putStrLn $ poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9] -- "Flush" 47 | putStrLn $ poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9] -- "Straight" 48 | putStrLn $ poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8] -- "Three of a kind" 49 | putStrLn $ poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10] -- "Two pair" 50 | putStrLn $ poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8] -- "One pair" 51 | putStrLn $ poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11] -- "Nothing" 52 | -------------------------------------------------------------------------------- /sample/tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | import Control.Egison 9 | 10 | data Tree a = Leaf | Node a (Tree a) (Tree a) 11 | 12 | data TreeM m = TreeM m 13 | instance (Matcher m a) => Matcher (TreeM m) (Tree a) 14 | 15 | class TreePat m a where 16 | leafPat :: Pattern a m ctx '[] 17 | nodePat :: (a ~ (Tree a'), m ~ (f m')) 18 | => Pattern a' m' ctx xs 19 | -> Pattern a m (ctx :++: xs) ys 20 | -> Pattern a m (ctx :++: xs :++: ys) zs 21 | -> Pattern a m ctx (xs :++: ys :++: zs) 22 | 23 | instance (Matcher m a) => TreePat (TreeM m) (Tree a) where 24 | leafPat = 25 | Pattern (\ctx _ t -> case t of 26 | Leaf -> [MNil] 27 | _ -> []) 28 | nodePat p1 p2 p3 = 29 | Pattern (\ctx (TreeM m) t -> case t of 30 | Node v t1 t2 -> [threeMAtoms (MAtom p1 m v) (MAtom p2 (TreeM m) t1) (MAtom p3 (TreeM m) t2)] 31 | _ -> []) 32 | 33 | main :: IO () 34 | main = do 35 | let t1 = Node 3 (Node 1 Leaf Leaf) (Node 2 Leaf Leaf) 36 | let t2 = Leaf 37 | putStrLn $ show $ f t1 -- [3] 38 | putStrLn $ show $ f t2 -- [0] 39 | where 40 | f t = matchAll t (TreeM Eql) 41 | [[mc| nodePat $x _ _ -> x |], 42 | [mc| leafPat -> 0 |]] 43 | -------------------------------------------------------------------------------- /sample/unordered-pair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | import Control.Egison hiding (Integer) 10 | import qualified Control.Egison as M 11 | 12 | -- 13 | -- UnorderedEqlPair 14 | -- 15 | 16 | data UnorderedEqlPair = UnorderedEqlPair 17 | instance (Eq a) => Matcher UnorderedEqlPair (a, a) 18 | 19 | uepair :: (Eq a) 20 | => Pattern a Eql ctx xs 21 | -> Pattern a Eql (ctx :++: xs) ys 22 | -> Pattern (a, a) UnorderedEqlPair ctx (xs :++: ys) 23 | uepair p1 p2 = Pattern (\_ UnorderedEqlPair (t1, t2) -> 24 | [twoMAtoms (MAtom p1 Eql t1) (MAtom p2 Eql t2) 25 | ,twoMAtoms (MAtom p1 Eql t2) (MAtom p2 Eql t1)]) 26 | 27 | -- 28 | -- UnorderedPair (parameterized) 29 | -- 30 | 31 | data UnorderedPair m = UnorderedPair m 32 | instance Matcher m a => Matcher (UnorderedPair m) (a, a) 33 | 34 | upair :: (Matcher m (a, a), m ~ (UnorderedPair m'), Matcher m' a) 35 | => Pattern a m' ctx xs 36 | -> Pattern a m' (ctx :++: xs) ys 37 | -> Pattern (a, a) m ctx (xs :++: ys) 38 | upair p1 p2 = Pattern (\_ (UnorderedPair m') (t1, t2) -> 39 | [twoMAtoms (MAtom p1 m' t1) (MAtom p2 m' t2) 40 | ,twoMAtoms (MAtom p1 m' t2) (MAtom p2 m' t1)]) 41 | 42 | -- 43 | -- Main 44 | -- 45 | 46 | main :: IO () 47 | main = do 48 | let t1 = (1,2) 49 | putStrLn $ show $ matchAll t1 UnorderedEqlPair [[mc| uepair #2 $x -> x |]] 50 | putStrLn $ show $ matchAll t1 (UnorderedPair Eql) [[mc| upair #2 $x -> x |]] 51 | -------------------------------------------------------------------------------- /src/Control/Egison.hs: -------------------------------------------------------------------------------- 1 | -- | A library for user-extensible non-linear pattern matching with backtracking. 2 | 3 | module Control.Egison 4 | ( module Control.Egison.Core 5 | , module Control.Egison.Match 6 | , module Control.Egison.Matcher 7 | , module Control.Egison.QQ 8 | ) where 9 | 10 | import Control.Egison.Core 11 | import Control.Egison.Match 12 | import Control.Egison.Matcher 13 | import Control.Egison.QQ 14 | -------------------------------------------------------------------------------- /src/Control/Egison/Core.hs: -------------------------------------------------------------------------------- 1 | -- | Definitions of data types for patterns, matchers, match clauses, matching states, and matching atoms. 2 | 3 | module Control.Egison.Core ( 4 | -- * Patterns 5 | Pattern(..), 6 | Matcher(..), 7 | MatchClause(..), 8 | -- * Matching states and matching atoms 9 | MState(..), 10 | MAtom(..), 11 | MList(..), 12 | mappend, 13 | oneMAtom, 14 | twoMAtoms, 15 | threeMAtoms, 16 | -- * Heterogeneous lists 17 | HList(..), 18 | happend, 19 | (:++:), 20 | ) where 21 | 22 | import Prelude hiding (mappend) 23 | import Data.Maybe 24 | import Data.Type.Equality 25 | import Unsafe.Coerce 26 | 27 | --- 28 | --- Pattern 29 | --- 30 | 31 | -- | A pattern for data of a type @a@ for a matcher @m@. 32 | -- @ctx@ is an intermediate pattern-matching result that is a type of a list of data bound in the left-side of the pattern. 33 | -- @vs@ is a list of types bound to the pattern variables in this pattern. 34 | data Pattern a m ctx vs where 35 | Wildcard :: (Matcher m a) => Pattern a m ctx '[] 36 | PatVar :: (Matcher m a) => String -> Pattern a m ctx '[a] 37 | AndPat :: (Matcher m a) => Pattern a m ctx vs -> Pattern a m (ctx :++: vs) vs' -> Pattern a m ctx (vs :++: vs') 38 | OrPat :: (Matcher m a) => Pattern a m ctx vs -> Pattern a m ctx vs -> Pattern a m ctx vs 39 | NotPat :: (Matcher m a) => Pattern a m ctx '[] -> Pattern a m ctx '[] 40 | PredicatePat :: (Matcher m a) => (HList ctx -> a -> Bool) -> Pattern a m ctx '[] 41 | -- | 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. 42 | Pattern :: (Matcher m a) => (HList ctx -> m -> a -> [MList ctx vs]) -> Pattern a m ctx vs 43 | 44 | -- | The @Matcher@ class is used to declare that @m@ is a matcher for data of a type @a@. 45 | -- For example, 46 | -- 47 | -- > instance (Matcher m a) => Matcher (Multiset m) [a] 48 | -- 49 | -- declares that "let @m@ be a matcher for @a@, @(Multiset m)@ is a matcher for @[a]@". 50 | class Matcher m a 51 | 52 | -- | A match clause of a match expression whose target data is @a@ and matcher is @m@. 53 | -- The body of the match clause is evaluated to @b@. 54 | -- 55 | -- The first argument of @MatchClause@ is a pattern for @a@ with a matcher @m@. 56 | -- This pattern makes a binding whose type is @vs@. 57 | -- The second argument of @MatchClause@ is a function that takes a heterogeneous list containing @vs@ and returns @b@. 58 | -- 59 | -- @vs@ is existentially quantified because generally each pattern of the list of match clauses in a pattern-matching expression makes different bindings. 60 | -- 61 | -- Several samples of @MatchClause@s are found in "Control.Egison.QQ". 62 | -- The 'Control.Egison.QQ.mc' quasiquoter allows us to describe a match clause in user-friendly syntax. 63 | data MatchClause a m b = forall vs. (Matcher m a) => MatchClause (Pattern a m '[] vs) (HList vs -> b) 64 | 65 | --- 66 | --- Matching state 67 | --- 68 | 69 | -- | A matching state. 70 | -- A matching state consists of an intermediate pattern-matching result and a stack of matching atoms. 71 | -- @vs@ is a list of types bound to the pattern variables in the pattern after processing @MState@. 72 | data MState vs where 73 | MState :: vs ~ (xs :++: ys) => HList xs -> MList xs ys -> MState vs 74 | 75 | -- | A matching atom. 76 | -- @ctx@ is a intermediate pattern-matching result. 77 | -- @vs@ is a list of types bound to the pattern variables by processing this matching atom. 78 | -- The types of a target @a@ and a matcher @m@ are existentially quantified each matching atom in a stack of matching atoms contains a pattern, matcher, and target for a different type. 79 | data MAtom ctx vs = forall a m. (Matcher m a) => MAtom (Pattern a m ctx vs) m a 80 | 81 | -- | A list of matching atoms. 82 | -- It is used to represent a stack of matching atoms in a matching state. 83 | data MList ctx vs where 84 | MNil :: MList ctx '[] 85 | MCons :: MAtom ctx xs -> MList (ctx :++: xs) ys -> MList ctx (xs :++: ys) 86 | 87 | -- | Concatenate two lists of matching atoms. 88 | mappend :: MList ctx xs -> MList (ctx :++: xs) ys -> MList ctx (xs :++: ys) 89 | mappend MNil atoms = atoms 90 | mappend (MCons atom atoms1) atoms2 = 91 | case mconsAssocProof atom atoms1 of 92 | Refl -> case mappendAssocProof atom atoms1 atoms2 of 93 | Refl -> MCons atom (mappend atoms1 atoms2) 94 | 95 | -- | Create a list of a single matching atom. 96 | {-# INLINE oneMAtom #-} 97 | oneMAtom :: MAtom ctx xs -> MList ctx xs 98 | oneMAtom atom1 = MCons atom1 MNil 99 | 100 | -- | Create a list of two matching atoms. 101 | {-# INLINE twoMAtoms #-} 102 | twoMAtoms :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MList ctx (xs :++: ys) 103 | twoMAtoms atom1 atom2 = MCons atom1 (MCons atom2 MNil) 104 | 105 | -- | Create a list of three matching atoms. 106 | {-# INLINE threeMAtoms #-} 107 | threeMAtoms :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MAtom (ctx :++: xs :++: ys) zs -> MList ctx (xs :++: ys :++: zs) 108 | threeMAtoms atom1 atom2 atom3 = 109 | case threeMConsAssocProof atom1 atom2 atom3 of 110 | Refl -> MCons atom1 (MCons atom2 (MCons atom3 MNil)) 111 | 112 | -- | Heterogeneous lists. 113 | data HList xs where 114 | HNil :: HList '[] 115 | HCons :: a -> HList as -> HList (a ': as) 116 | 117 | -- | Axioms for heterogeneous lists. 118 | type family (as ::[*]) :++: (bs :: [*]) :: [*] where 119 | as :++: '[] = as 120 | '[] :++: bs = bs 121 | (a ': as) :++: bs = a ': (as :++: bs) 122 | 123 | -- | Concatenate two heterogeneous lists. 124 | happend :: HList as -> HList bs -> HList (as :++: bs) 125 | happend HNil ys = ys 126 | happend xs@(HCons x xs') ys = case hconsAssocProof x xs' ys of 127 | Refl -> HCons x $ happend xs' ys 128 | 129 | {-# INLINE hconsAssocProof #-} 130 | hconsAssocProof :: a -> HList as -> HList bs -> ((a ': as) :++: bs) :~: (a ': (as :++: bs)) 131 | hconsAssocProof _ _ HNil = Refl 132 | hconsAssocProof x xs (HCons y ys) = Refl 133 | 134 | {-# INLINE mconsAssocProof #-} 135 | mconsAssocProof :: MAtom ctx vs -> MList (ctx :++: vs) vs' -> (ctx :++: (vs :++: vs')) :~: ((ctx :++: vs) :++: vs') 136 | mconsAssocProof _ _ = unsafeCoerce Refl -- Todo: Write proof. 137 | 138 | {-# INLINE mappendAssocProof #-} 139 | mappendAssocProof :: MAtom ctx xs -> MList (ctx :++: xs) ys -> MList (ctx :++: xs :++: ys) zs -> (xs :++: (ys :++: zs)) :~: ((xs :++: ys) :++: zs) 140 | mappendAssocProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof. 141 | 142 | {-# INLINE threeMConsAssocProof #-} 143 | threeMConsAssocProof :: MAtom ctx xs -> MAtom (ctx :++: xs) ys -> MAtom (ctx :++: xs :++: ys) zs -> (xs :++: ys :++: zs) :~: (xs :++: (ys :++: zs)) 144 | threeMConsAssocProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof. 145 | -------------------------------------------------------------------------------- /src/Control/Egison/Match.hs: -------------------------------------------------------------------------------- 1 | -- | Pattern-matching expressions. 2 | 3 | module Control.Egison.Match ( 4 | matchAll, 5 | match, 6 | matchAllDFS, 7 | matchDFS, 8 | ) where 9 | 10 | import Prelude hiding (mappend) 11 | import Control.Egison.Core 12 | import Unsafe.Coerce 13 | import Data.Type.Equality 14 | 15 | -- | @matchAll@ takes a target, a matcher, and a list of match clauses. 16 | -- @matchAll@ collects all the pattern-matching results and returns a list of the results evaluating the body expression for each pattern-matching result. 17 | -- @matchAll@ traverses a search tree for pattern matching in breadth-first order. 18 | {-# INLINE matchAll #-} 19 | matchAll :: (Matcher m a) => a -> m -> [MatchClause a m b] -> [b] 20 | matchAll tgt m = foldr go [] 21 | where 22 | go (MatchClause pat f) acc = 23 | let results = processMStatesAll [[MState HNil (MCons (MAtom pat m tgt) MNil)]] in 24 | map f results ++ acc 25 | 26 | -- | @match@ takes a target, a matcher, and a list of match clauses. 27 | -- @match@ calculates only the first pattern-matching result and returns the results evaluating the body expression for the first pattern-matching result. 28 | -- @match@ traverses a search tree for pattern matching in breadth-first order. 29 | {-# INLINE match #-} 30 | match :: (Matcher m a) => a -> m -> [MatchClause a m b] -> b 31 | match tgt m cs = head $ matchAll tgt m cs 32 | 33 | -- | @matchAllDFS@ is much similar to @matchAll@ but traverses a search tree for pattern matching in depth-first order. 34 | {-# INLINE matchAllDFS #-} 35 | matchAllDFS :: (Matcher m a) => a -> m -> [MatchClause a m b] -> [b] 36 | matchAllDFS tgt m = foldr go [] 37 | where 38 | go (MatchClause pat f) acc = 39 | let results = processMStatesAllDFS [MState HNil (MCons (MAtom pat m tgt) MNil)] in 40 | map f results ++ acc 41 | 42 | -- | @matchDFS@ is much similar to @match@ but traverses a search tree for pattern matching in depth-first order. 43 | {-# INLINE matchDFS #-} 44 | matchDFS :: (Matcher m a) => a -> m -> [MatchClause a m b] -> b 45 | matchDFS tgt m cs = head $ matchAllDFS tgt m cs 46 | 47 | -- 48 | -- Pattern-matching algorithm 49 | -- 50 | 51 | processMStatesAllDFS :: [MState vs] -> [HList vs] 52 | processMStatesAllDFS [] = [] 53 | processMStatesAllDFS (MState rs MNil:ms) = rs:(processMStatesAllDFS ms) 54 | processMStatesAllDFS (mstate:ms) = processMStatesAllDFS $ (processMState mstate) ++ ms 55 | 56 | processMStatesAll :: [[MState vs]] -> [HList vs] 57 | processMStatesAll [] = [] 58 | processMStatesAll streams = results ++ processMStatesAll streams' 59 | where 60 | (results, streams') = foldr processMStates ([], []) streams 61 | processMStates :: [MState vs] -> ([HList vs], [[MState vs]]) -> ([HList vs], [[MState vs]]) 62 | processMStates [] (results, acc) = (results, acc) 63 | processMStates (MState rs MNil:ms) (results, acc) = processMStates ms (rs:results, acc) 64 | processMStates (mstate:ms) (results, acc) = (results, processMState mstate:ms:acc) 65 | 66 | {-# INLINE processMState #-} 67 | processMState :: MState vs -> [MState vs] 68 | processMState (MState rs (MCons (MAtom pat m tgt) atoms)) = 69 | case pat of 70 | Pattern f -> 71 | let matomss = f rs m tgt in 72 | map (\newAtoms -> MState rs (mappend newAtoms atoms)) matomss 73 | Wildcard -> [MState rs atoms] 74 | PatVar _ -> case patVarProof rs (HCons tgt HNil) atoms of 75 | Refl -> [MState (happend rs (HCons tgt HNil)) atoms] 76 | AndPat p1 p2 -> 77 | case (assocProof (MAtom p1 m tgt) (MAtom p2 m tgt)) of 78 | Refl -> case (andPatProof (MAtom p1 m tgt) (MAtom p2 m tgt) atoms) of 79 | Refl -> [MState rs (MCons (MAtom p1 m tgt) (MCons (MAtom p2 m tgt) $ atoms))] 80 | OrPat p1 p2 -> 81 | [MState rs (MCons (MAtom p1 m tgt) atoms), MState rs (MCons (MAtom p2 m tgt) atoms)] 82 | NotPat p -> 83 | [MState rs atoms | null $ processMStatesAllDFS [MState rs $ MCons (MAtom p m tgt) MNil]] 84 | PredicatePat f -> [MState rs atoms | f rs tgt] 85 | processMState (MState rs MNil) = undefined -- or [MState rs MNil] -- TODO: shold not reach here but reaches here. 86 | 87 | {-# INLINE patVarProof #-} 88 | patVarProof :: HList xs -> HList '[a] -> MList (xs :++: '[a]) ys -> ((xs :++: '[a]) :++: ys) :~: (xs :++: ('[a] :++: ys)) 89 | patVarProof HNil _ _ = Refl 90 | patVarProof (HCons _ xs) ys zs = unsafeCoerce Refl -- Todo: Write proof. 91 | 92 | {-# INLINE andPatProof #-} 93 | andPatProof :: MAtom ctx vs -> MAtom (ctx :++: vs) vs' -> MList (ctx :++: vs :++: vs') ys -> (ctx :++: ((vs :++: vs') :++: ys)) :~: (ctx :++: (vs :++: (vs' :++: ys))) 94 | andPatProof _ _ _ = unsafeCoerce Refl -- Todo: Write proof. 95 | 96 | {-# INLINE assocProof #-} 97 | assocProof :: MAtom ctx vs -> MAtom (ctx :++: vs) vs' -> (ctx :++: (vs :++: vs')) :~: ((ctx :++: vs) :++: vs') 98 | assocProof _ _ = unsafeCoerce Refl -- Todo: Write proof. 99 | -------------------------------------------------------------------------------- /src/Control/Egison/Matcher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | -- | Matcher definitions. 9 | 10 | module Control.Egison.Matcher ( 11 | -- * @Something@ matcher 12 | Something(..), 13 | -- * @Eql@ and @Integer@ matchers 14 | ValuePat(..), 15 | Eql(..), 16 | Integer(..), 17 | -- * @Pair@ matcher 18 | PairPat(..), 19 | Pair(..), 20 | -- * Matchers for collections 21 | CollectionPat(..), 22 | List(..), 23 | Multiset(..), 24 | Set(..), 25 | ) where 26 | 27 | import Prelude hiding (Integer) 28 | import Data.List (tails) 29 | import Control.Egison.Core 30 | import Control.Egison.Match 31 | import Control.Egison.QQ 32 | 33 | -- | Something built-in matcher. 34 | -- The @Something@ matcher can handle only a pattern variable and a wildcard. 35 | data Something = Something 36 | instance Matcher Something a 37 | 38 | -- | Value patterns. 39 | class ValuePat m a where 40 | valuePat :: (Matcher m a, Eq a) => (HList ctx -> a) -> Pattern a m ctx '[] 41 | 42 | -- | A matcher for data types that are instances of @Eq@. 43 | -- The @Eql@ matcher can handle a pattern variable, a wildcard, and a value pattern. 44 | data Eql = Eql 45 | instance (Eq a) => Matcher Eql a 46 | 47 | instance Eq a => ValuePat Eql a where 48 | valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt]) 49 | 50 | -- | A matcher for integers. 51 | -- The @Integer@ matcher can handle a pattern variable, a wildcard, and a value pattern. 52 | data Integer = Integer 53 | instance Integral a => Matcher Integer a 54 | 55 | instance Integral a => ValuePat Integer a where 56 | valuePat f = Pattern (\ctx _ tgt -> [MNil | f ctx == tgt]) 57 | 58 | 59 | -- | A pattern constructor for pairs. 60 | class PairPat m a where 61 | pair :: (Matcher m a , a ~ (b1, b2), m ~ (Pair m1 m2)) 62 | => Pattern b1 m1 ctx xs 63 | -> Pattern b2 m2 (ctx :++: xs) ys 64 | -> Pattern a m ctx (xs :++: ys) 65 | 66 | -- | A matcher for a pair of data. 67 | data Pair m1 m2 = Pair m1 m2 68 | instance (Matcher m1 a1, Matcher m2 a2) => Matcher (Pair m1 m2) (a1, a2) 69 | 70 | instance (Matcher m1 a1, Matcher m2 a2) => PairPat (Pair m1 m2) (a1, a2) where 71 | pair p1 p2 = Pattern (\_ (Pair m1 m2) (t1, t2) -> [twoMAtoms (MAtom p1 m1 t1) (MAtom p2 m2 t2)]) 72 | 73 | 74 | -- | Patterns for collections. 75 | class CollectionPat m a where 76 | -- | The @nil@ pattern matches an empty collection. 77 | nil :: (Matcher m a) => Pattern a m ctx '[] 78 | -- | The @cons@ pattern decomposes a collection into an element and the rest elements. 79 | cons :: (Matcher m a, a ~ [a'], m ~ (f m')) 80 | => Pattern a' m' ctx xs 81 | -> Pattern a m (ctx :++: xs) ys 82 | -> Pattern a m ctx (xs :++: ys) 83 | -- | The @join@ pattern decomposes a collection into two collections. 84 | join :: (Matcher m a) 85 | => Pattern a m ctx xs 86 | -> Pattern a m (ctx :++: xs) ys 87 | -> Pattern a m ctx (xs :++: ys) 88 | 89 | -- | A matcher for a list. 90 | newtype List m = List m 91 | instance (Matcher m a) => Matcher (List m) [a] 92 | 93 | instance (Matcher m a, Eq a, ValuePat m a) => ValuePat (List m) [a] where 94 | valuePat f = Pattern (\ctx (List m) tgt -> 95 | match (f ctx, tgt) (Pair (List m) (List m)) $ 96 | [[mc| ([], []) -> [MNil] |], 97 | [mc| (($x : $xs), (#x : #xs)) -> [MNil] |], 98 | [mc| _ -> [] |]]) 99 | 100 | instance Matcher m a => CollectionPat (List m) [a] where 101 | nil = Pattern (\_ _ t -> [MNil | null t]) 102 | cons p1 p2 = Pattern (\_ (List m) tgt -> 103 | case tgt of 104 | [] -> [] 105 | x:xs -> [twoMAtoms (MAtom p1 m x) (MAtom p2 (List m) xs)]) 106 | join Wildcard p2 = Pattern (\_ m tgt -> map (\ts -> oneMAtom (MAtom p2 m ts)) (tails tgt)) 107 | join p1 p2 = Pattern (\_ m tgt -> map (\(hs, ts) -> twoMAtoms (MAtom p1 m hs) (MAtom p2 m ts)) (splits tgt)) 108 | 109 | splits :: [a] -> [([a], [a])] 110 | splits [] = [([], [])] 111 | splits (x:xs) = ([], x:xs) : [(x:ys, zs) | (ys, zs) <- splits xs] 112 | 113 | -- | A matcher for a multiset. 114 | -- When we regard a collection as a multiset, the order of elements is ignored but the number of times an element appears in the collection is counted. 115 | newtype Multiset m = Multiset m 116 | instance (Matcher m a) => Matcher (Multiset m) [a] 117 | 118 | instance (Matcher m a, Eq a, ValuePat m a) => ValuePat (Multiset m) [a] where 119 | valuePat f = Pattern (\ctx (Multiset m) tgt -> 120 | match (f ctx, tgt) (Pair (List m) (Multiset m)) $ 121 | [[mc| ([], []) -> [MNil] |], 122 | [mc| (($x : $xs), (#x : #xs)) -> [MNil] |], 123 | [mc| _ -> [] |]]) 124 | 125 | instance (Matcher m a) => CollectionPat (Multiset m) [a] where 126 | nil = Pattern (\_ _ tgt -> [MNil | null tgt]) 127 | -- | The @cons@ pattern for a multiset decomposes a collection into an arbitrary element and the rest elements. 128 | cons p Wildcard = Pattern (\_ (Multiset m) tgt -> map (\x -> oneMAtom (MAtom p m x)) tgt) 129 | cons p1 p2 = Pattern (\_ (Multiset m) tgt -> map (\(x, xs) -> twoMAtoms (MAtom p1 m x) (MAtom p2 (Multiset m) xs)) 130 | (matchAll tgt (List m) [[mc| $hs ++ $x : $ts -> (x, hs ++ ts) |]])) 131 | join p1 p2 = undefined 132 | 133 | -- | A matcher for a set. Both the order and the repetition of elements are ignored. 134 | newtype Set m = Set m 135 | instance (Matcher m a) => Matcher (Set m) [a] 136 | 137 | instance (Matcher m a, Eq a, Ord a, ValuePat m a) => ValuePat (Set m) [a] where 138 | valuePat f = undefined 139 | 140 | instance Matcher m a => CollectionPat (Set m) [a] where 141 | nil = Pattern (\_ _ tgt -> [MNil | null tgt]) 142 | cons p1 p2 = Pattern (\_ (Set m) tgt -> 143 | map (\x -> twoMAtoms (MAtom p1 m x) (MAtom p2 (Set m) tgt)) 144 | (matchAll tgt (List m) [[mc| _ ++ $x : _ -> x |]])) 145 | join p1 p2 = undefined 146 | -------------------------------------------------------------------------------- /src/Control/Egison/QQ.hs: -------------------------------------------------------------------------------- 1 | -- | Quasiquotation for rewriting a match clause. 2 | 3 | module Control.Egison.QQ 4 | ( mc 5 | ) 6 | where 7 | 8 | import Control.Egison.Core 9 | import Control.Monad ( (<=<) ) 10 | import Control.Monad.State ( runStateT 11 | , MonadState(..) 12 | , modify 13 | , lift 14 | ) 15 | import Text.Read ( readMaybe ) 16 | import Data.Maybe ( mapMaybe ) 17 | import Data.List ( foldl' ) 18 | import Data.Functor.Foldable ( Recursive 19 | , Base 20 | , cata 21 | ) 22 | import Language.Haskell.TH ( Q 23 | , Loc(..) 24 | , Exp(..) 25 | , Pat(..) 26 | , Lit(..) 27 | , Name 28 | , location 29 | , extsEnabled 30 | , mkName 31 | , pprint 32 | ) 33 | import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) 34 | import qualified Language.Haskell.TH as TH 35 | ( Extension(..) ) 36 | import Language.Haskell.Exts.Extension 37 | ( Extension(EnableExtension) ) 38 | import Language.Haskell.Exts.Parser ( ParseResult(..) 39 | , defaultParseMode 40 | , parseExpWithMode 41 | ) 42 | import qualified Language.Haskell.Exts.Extension 43 | as Exts 44 | ( KnownExtension(..) ) 45 | import qualified Language.Haskell.Exts.Parser as Exts 46 | ( ParseMode(..) ) 47 | import Language.Haskell.Meta.Syntax.Translate 48 | ( toExp ) 49 | import qualified Language.Egison.Syntax.Pattern 50 | as Pat 51 | ( Expr 52 | , ExprF(..) 53 | ) 54 | import qualified Language.Egison.Parser.Pattern 55 | as Pat 56 | ( parseNonGreedy ) 57 | import Language.Egison.Parser.Pattern ( Fixity(..) 58 | , ParseFixity(..) 59 | , Associativity(..) 60 | , Precedence(..) 61 | ) 62 | import Language.Egison.Parser.Pattern.Mode.Haskell.TH 63 | ( ParseMode(..) ) 64 | 65 | -- | A quasiquoter for rewriting a match clause. 66 | -- This quasiquoter is useful for generating a 'MatchClause' in user-friendly syntax. 67 | -- 68 | -- === Wildcards 69 | -- 70 | -- A match clause that contains a wildcard 71 | -- 72 | -- > [mc| _ -> "Matched" |] 73 | -- 74 | -- is rewritten to 75 | -- 76 | -- > MatchClause Wildcard 77 | -- > (\HNil -> "Matched") 78 | -- 79 | -- === Pattern variables 80 | -- 81 | -- A match clause that contains a pattern variable 82 | -- 83 | -- > [mc| $x -> x |] 84 | -- 85 | -- is rewritten to 86 | -- 87 | -- > MatchClause (PatVar "x") 88 | -- > (\HCons x HNil -> x) 89 | -- 90 | -- === Value patterns 91 | -- 92 | -- A match clause that contains a value pattern 93 | -- 94 | -- > [mc| cons $x (cons $y (cons #(x + 1) (cons $z nil))) -> (x, y, z) |] 95 | -- 96 | -- is rewritten to 97 | -- 98 | -- > MatchClause (cons (PatVar "x") (cons (PatVar "y") (cons (valuePat (\HCons x (HCons (y HNil)) -> x + 1)) (cons (PatVar "z") nil)))) 99 | -- > (\HCons x (HCons (y (HCons z HNil))) -> (x, y, z)) 100 | -- 101 | -- === And-patterns 102 | -- 103 | -- A match clause that contains an and-pattern 104 | -- 105 | -- > [mc| (cons _ _) & $x -> x |] 106 | -- 107 | -- is rewritten to 108 | -- 109 | -- > MatchClause (AndPat (cons Wildcard Wildcard) (PatVar "x")) 110 | -- > (\HCons x HNil -> x) 111 | -- 112 | -- === Or-patterns 113 | -- 114 | -- A match clause that contains an or-pattern 115 | -- 116 | -- > [mc| nil | (cons _ _) -> "Matched" |] 117 | -- 118 | -- is rewritten to 119 | -- 120 | -- > MatchClause (OrPat nil (cons Wildcard Wildcard)) 121 | -- > (\HNil -> "Matched") 122 | -- 123 | -- === Collection patterns 124 | -- 125 | -- A collection pattern 126 | -- 127 | -- > [p1, p2, ..., pn] 128 | -- 129 | -- is desugared into 130 | -- 131 | -- > p1 : p2 : ... : pn : nil 132 | -- 133 | -- === Cons patterns 134 | -- 135 | -- A pattern with special collection pattern operator @:@ 136 | -- 137 | -- > p1 : p2 138 | -- 139 | -- is parsed as 140 | -- 141 | -- > p1 `cons` p2 142 | -- 143 | -- === Join patterns 144 | -- 145 | -- A pattern with special collection pattern operator @++@ 146 | -- 147 | -- > p1 ++ p2 148 | -- 149 | -- is parsed as 150 | -- 151 | -- > p1 `join` p2 152 | mc :: QuasiQuoter 153 | mc = QuasiQuoter { quoteExp = compile 154 | , quotePat = undefined 155 | , quoteType = undefined 156 | , quoteDec = undefined 157 | } 158 | 159 | 160 | listFixities :: [ParseFixity Name String] 161 | listFixities = 162 | [ ParseFixity (Fixity AssocRight (Precedence 5) (mkName "join")) $ parser "++" 163 | , ParseFixity (Fixity AssocRight (Precedence 5) (mkName "cons")) $ parser ":" 164 | ] 165 | where 166 | parser symbol content | symbol == content = Right () 167 | | otherwise = Left $ show symbol ++ "is expected" 168 | 169 | parseMode :: Q Exts.ParseMode 170 | parseMode = do 171 | Loc { loc_filename } <- location 172 | extensions <- mapMaybe (fmap EnableExtension . convertExt) <$> extsEnabled 173 | pure defaultParseMode { Exts.parseFilename = loc_filename, Exts.extensions } 174 | where 175 | convertExt :: TH.Extension -> Maybe Exts.KnownExtension 176 | convertExt TH.TemplateHaskellQuotes = Just Exts.TemplateHaskell -- haskell-suite/haskell-src-exts#357 177 | convertExt ext = readMaybe $ show ext 178 | 179 | parseExp :: Exts.ParseMode -> String -> Q Exp 180 | parseExp mode content = case parseExpWithMode mode content of 181 | ParseOk x -> pure $ toExp x 182 | ParseFailed _ e -> fail e 183 | 184 | compile :: String -> Q Exp 185 | compile content = do 186 | mode <- parseMode 187 | (pat, rest) <- parsePatternExpr mode content 188 | bodySource <- takeBody rest 189 | body <- parseExp mode bodySource 190 | compilePattern pat body 191 | where 192 | takeBody ('-' : '>' : xs) = pure xs 193 | takeBody xs = fail $ "\"->\" is expected, but found " ++ show xs 194 | 195 | parsePatternExpr 196 | :: Exts.ParseMode -> String -> Q (Pat.Expr Name Name Exp, String) 197 | parsePatternExpr haskellMode content = case Pat.parseNonGreedy mode content of 198 | Left e -> fail $ show e 199 | Right x -> pure x 200 | where mode = ParseMode { haskellMode, fixities = Just listFixities } 201 | 202 | compilePattern :: Pat.Expr Name Name Exp -> Exp -> Q Exp 203 | compilePattern pat body = do 204 | (clauseExp, bindings) <- runStateT (cataM go pat) [] 205 | let bodyExp = bsFun bindings body 206 | pure $ AppE (AppE (ConE 'Control.Egison.Core.MatchClause) clauseExp) bodyExp 207 | where 208 | bsFun bs = LamE [toHListPat bs] 209 | go Pat.WildcardF = pure $ ConE 'Control.Egison.Core.Wildcard 210 | go (Pat.VariableF v) = do 211 | modify (<> [v]) 212 | pure . AppE (ConE 'Control.Egison.Core.PatVar) . LitE . StringL $ pprint v 213 | go (Pat.ValueF e) = do 214 | bs <- get 215 | pure . AppE (VarE $ mkName "valuePat") $ bsFun bs e 216 | go (Pat.PredicateF e) = do 217 | bs <- get 218 | pure . AppE (ConE 'Control.Egison.Core.PredicatePat) $ bsFun bs e 219 | go (Pat.AndF e1 e2) = 220 | pure $ AppE (AppE (ConE 'Control.Egison.Core.AndPat) e1) e2 221 | go (Pat.OrF e1 e2) = 222 | pure $ AppE (AppE (ConE 'Control.Egison.Core.OrPat) e1) e2 223 | go (Pat.NotF e1) = pure $ AppE (ConE 'Control.Egison.Core.NotPat) e1 224 | go (Pat.TupleF [e1, e2]) = pure $ AppE (AppE (VarE $ mkName "pair") e1) e2 225 | go (Pat.TupleF _) = lift $ fail "tuples other than pairs are not supported" 226 | go (Pat.CollectionF es) = pure $ toNilCons es 227 | go (Pat.InfixF n e1 e2) = pure . ParensE $ UInfixE e1 (VarE n) e2 228 | go (Pat.PatternF n es) = pure $ foldl' AppE (VarE n) es 229 | 230 | toHListPat :: [Name] -> Pat 231 | toHListPat = foldr go $ ConP 'HNil [] where go x a = ConP 'HCons [VarP x, a] 232 | 233 | toNilCons :: [Exp] -> Exp 234 | toNilCons = foldr go . VarE $ mkName "nil" 235 | where go e = AppE (AppE (VarE $ mkName "cons") e) 236 | 237 | cataM 238 | :: (Recursive t, Traversable (Base t), Monad m) 239 | => (Base t a -> m a) 240 | -> t 241 | -> m a 242 | cataM alg = cata (alg <=< sequence) 243 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.1 2 | extra-deps: 3 | - egison-pattern-src-0.2.1.0@sha256:8f4e72f25abb4f6cf8f1283774ae0d5030c44dad32838de2423c8f9644529c78 4 | - egison-pattern-src-th-mode-0.2.1.0@sha256:89d98f2660f7afa3abf27cbe43242b80a7af45db6b8032dd1cf7f390458305d5 5 | 6 | packages: 7 | - . 8 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Spec (spec) where 2 | 3 | import Control.Egison 4 | import Data.Numbers.Primes 5 | import Test.Hspec 6 | 7 | -- 8 | -- Basic list processing functions in pattern-matching-oriented programming style 9 | -- 10 | 11 | pmap :: (a -> b) -> [a] -> [b] 12 | pmap f xs = matchAll xs (List Something) 13 | [[mc| _ ++ $x : _ -> f x |]] 14 | 15 | pmConcat :: [[a]] -> [a] 16 | pmConcat xss = matchAll xss (Multiset (Multiset Something)) 17 | [[mc| ($x : _) : _ -> x |]] 18 | 19 | pmUniq :: (Eq a) => [a] -> [a] 20 | pmUniq xs = matchAll xs (List Eql) 21 | [[mc| _ ++ $x : !(_ ++ #x : _) -> x |]] 22 | 23 | pmIntersect :: (Eq a) => [a] -> [a] -> [a] 24 | pmIntersect xs ys = matchAll (xs, ys) (Pair (Multiset Eql) (Multiset Eql)) 25 | [[mc| (($x : _), (#x : _)) -> x |]] 26 | 27 | pmDiff :: (Eq a) => [a] -> [a] -> [a] 28 | pmDiff xs ys = matchAll (xs, ys) (Pair (Multiset Eql) (Multiset Eql)) 29 | [[mc| (($x : _), !(#x : _)) -> x |]] 30 | 31 | spec :: Spec 32 | spec = do 33 | describe "list and multiset matchers" $ do 34 | it "cons pattern for list" $ 35 | matchAll [1,2,3] (List Integer) [[mc| $x : $xs -> (x, xs) |]] 36 | `shouldBe` [(1, [2,3])] 37 | 38 | it "multiset cons pattern" $ 39 | matchAll [1,2,3] (Multiset Integer) [[mc| $x : $xs -> (x, xs) |]] 40 | `shouldBe` [(1,[2,3]),(2,[1,3]),(3,[1,2])] 41 | 42 | it "join pattern for list matcher" $ length ( 43 | matchAll [1..5] (List Integer) 44 | [[mc| $xs ++ $ys -> (xs, ys) |]]) 45 | `shouldBe` 6 46 | 47 | it "value pattern for list matcher (1)" $ 48 | match [1,2,3] (List Integer) 49 | [[mc| #[1,2,3] -> "Matched" |], 50 | [mc| _ -> "Not matched" |]] 51 | `shouldBe` "Matched" 52 | 53 | it "value pattern for list matcher (2)" $ 54 | match [1,2,3] (List Integer) 55 | [[mc| #[2,1,3] -> "Matched" |], 56 | [mc| _ -> "Not matched" |]] 57 | `shouldBe` "Not matched" 58 | 59 | it "value pattern for multiset matcher" $ 60 | match [1,2,3] (Multiset Integer) 61 | [[mc| #[2,1,3] -> "Matched" |], 62 | [mc| _ -> "Not matched" |]] 63 | `shouldBe` "Matched" 64 | 65 | -- it "test" $ 66 | -- match 1 (List Integer) 67 | -- [[mc| $x -> "Matched" |]] 68 | -- `shouldBe` "Matched" 69 | 70 | describe "match-all with infinitely many results" $ do 71 | it "Check the order of pattern-matching results (multiset bfs) " $ 72 | take 10 (matchAll [1..] (Multiset Integer) 73 | [[mc| $x : $y : _ -> (x, y) |]]) 74 | `shouldBe` [(1,2),(1,3),(2,1),(1,4),(2,3),(3,1),(1,5),(2,4),(3,2),(4,1)] 75 | 76 | it "Check the order of pattern-matching results (set bfs)" $ 77 | take 10 (matchAll [1..] (Set Integer) 78 | [[mc| $x : $y : _ -> (x, y) |]]) 79 | `shouldBe` [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] 80 | 81 | it "Check the order of pattern-matching results (set dfs)" $ 82 | take 10 (matchAllDFS [1..] (Set Integer) 83 | [[mc| $x : $y : _ -> (x, y) |]]) 84 | `shouldBe` [(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)] 85 | 86 | describe "built-in pattern constructs" $ do 87 | it "Predicate patterns" $ 88 | matchAll [1..10] (Multiset Integer) 89 | [[mc| (?(\x -> mod x 2 == 0) & $x) : _ -> x |]] 90 | `shouldBe` [2,4,6,8,10] 91 | 92 | describe "patterns for prime numbers" $ do 93 | it "twin primes (p, p+2)" $ 94 | take 10 (matchAll primes (List Integer) 95 | [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]) 96 | `shouldBe` [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)] 97 | 98 | it "prime pairs whose form is (p, p+6) -- pattern matching with infinitely many results" $ 99 | take 10 (matchAll primes (List Integer) 100 | [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]]) 101 | `shouldBe` [(5,11),(7,13),(11,17),(13,19),(17,23),(23,29),(31,37),(37,43),(41,47),(47,53)] 102 | 103 | it "prime triplets -- and-patterns, or-patterns, and not-patterns" $ 104 | take 10 (matchAll primes (List Integer) 105 | [[mc| _ ++ $p : ($m & (#(p+2) | #(p+4))) : #(p+6) : _ -> (p, m, p+6) |]]) 106 | `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)] 107 | 108 | describe "Basic list processing functions" $ do 109 | it "map" $ 110 | pmap (+ 10) [1,2,3] `shouldBe` [11, 12, 13] 111 | it "concat" $ 112 | pmConcat [[1,2], [3], [4, 5]] `shouldBe` [1..5] 113 | it "uniq" $ 114 | pmUniq [1,1,2,3,2] `shouldBe` [1,3,2] 115 | it "intersect" $ 116 | pmIntersect [1,2,3,4] [2,4,5] `shouldBe` [2,4] 117 | it "diff" $ 118 | pmDiff [1,2,3,4] [2,4,5] `shouldBe` [1,3] 119 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Hspec 4 | import Spec 5 | 6 | main :: IO () 7 | main = hspec spec 8 | --------------------------------------------------------------------------------