sweet-egison (empty) → 0.1.0.1
raw patch · 15 files changed
+1027/−0 lines, 15 filesdep +backtrackingdep +basedep +criterionsetup-changed
Dependencies added: backtracking, base, criterion, egison-pattern-src, egison-pattern-src-th-mode, haskell-src-exts, haskell-src-meta, logict, primes, sweet-egison, tasty, tasty-hunit, template-haskell, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +11/−0
- README.md +156/−0
- Setup.hs +2/−0
- benchmark/comb2.hs +36/−0
- benchmark/perm2.hs +37/−0
- src/Control/Egison.hs +21/−0
- src/Control/Egison/Match.hs +54/−0
- src/Control/Egison/Matcher.hs +43/−0
- src/Control/Egison/Matcher/Collection.hs +134/−0
- src/Control/Egison/Matcher/Pair.hs +28/−0
- src/Control/Egison/QQ.hs +190/−0
- sweet-egison.cabal +135/−0
- test/Control/EgisonSpec.hs +176/−0
- test/test.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1.0.1++- Initial Release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2020 coord_e++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,156 @@+# Sweet Egison++[](https://github.com/egison/sweet-egison/actions?workflow=latest)+[](https://github.com/egison/sweet-egison/actions?workflow=release)+[](https://hackage.haskell.org/package/sweet-egison)+[](http://packdeps.haskellers.com/reverse/sweet-egison)++The [Sweet Egison](https://hackage.haskell.org/package/sweet-egison) is a shallow embedding implementation of non-linear pattern matching with extensible and polymorphic patterns [1].+This library desguars the [Egison](https:///www.egison.org) pattern-match expressions into Haskell programs that use non-deterministic monads.+This library provides a base of the pattern-match-oriented (PMO) programming style [2] for Haskell users at a practical level of efficiency.++## Getting started++We code the equivalent pattern match of `case [1, 2, 3] of x : xs -> (x, xs)` in this library as follows:++```haskell+> matchAll dfs [1, 2, 3] (List Something) [[mc| $x : $xs -> (x, xs) |]]+[(1,[2,3])]+```++Here, we can only observe the small syntactic difference in pattern expressions: the variable bindings are prefixed with `$`. (We'll come back to `List Something` later.)+You may notice that `matchAll` returns a list.+In our library, pattern matching can return many results.+See the following example that doubles all elements in a list:++```haskell+> take 10 $ matchAll dfs [1 ..] (List Something) [[mc| _ ++ $x : _ -> x * 2 |]]+[2,4,6,8,10,12,14,16,18,20]+```++`++` is the *join* operator that decomposes a list into an initial prefix and the remaining suffix.+We can implement `map` with pattern matching using this:++```haskell+> map f xs = matchAll dfs xs (List Something) [[mc| _ ++ $x : _ -> f x |]]+> map (*2) [1,2,3]+[2,4,6]+```++Note that we don't see any recursions or `fold`s in our `map` definition! An intuition of `map` function, that applies the function to all elements, are expressed directly in the pattern expression.++### Matchers++Because our pattern matching can return many results, we can use it to decompose *non-free data types* such as multisets and sets.+For example:++```haskell+> matchAll dfs [1, 2, 3] (Multiset Something) [[mc| $x : $xs -> (x, xs) |]]+[(1,[2,3]),(2,[1,3]),(3,[1,2])]+```++We use `Multiset Something` instead of `List Something` here to match the target `[1, 2, 3]` as a multiset.+These parameters such as `Multiset Something`, `List (List Something)`, and `Something` are called *matchers* and specify pattern-matching methods.+Given a matcher `m`, `Multiset m` is a matcher for multisets that matches its elements with `m`.+`Something` is a matcher that provides simple matching methods for an arbitrary value.++### Controlling matching strategy++Some pattern matching have infinitely many results and `matchAll` is designed to be able to enumerate all the results.+For this purpose, `matchAll` traverses a search tree for pattern matching in the breadth-first order.+The following example illustrates this:++```haskell+> take 10 $ matchAll dfs [1 ..] (Set Something) [[mc| $x : $y : _ -> (x, y) |]]+[(1,1),(2,1),(1,2),(3,1),(1,3),(2,2),(1,4),(4,1),(1,5),(2,3)]+```++We can use the depth-first search with `matchAllDFS`.++```haskell+> take 10 $ matchAll dfs [1 ..] (Set Something) [[mc| $x : $y : _ -> (x, y) |]]+[(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)]+```++In most cases, the depth-first search is faster than the default breadth-first search strategy.+It is recommended to always use `matchAllDFS` if it is OK to do so.++With `matchAllDFS`, we can define an intuitive pattern-matching version of `concat` function on lists.++```haskell+> concat xs = matchAll dfs xs (List (List Something)) [[mc| _ ++ (_ ++ $x : _) : _ -> x |]]+> concat [[1,2], [3,4,5]]+[1,2,3,4,5]+```++### Non-linear patterns++The non-linear pattern is another powerful pattern-matching feature.+It allows us to refer the value bound to variables appear in the left side of the pattern.+We provide a pattern syntax named value patterns in the form of `#e`.+The `Eql` matcher enables value patterns to match with targets that are equal to the corresponding expression.+For example, the following example enumerates (p, p+2) pairs of primes:++```haskell+> import Data.Numbers.Primes ( primes )+> take 10 $ matchAll bfs primes (List Eql) [[mc| _ ++ $p : #(p + 2) : _ -> (p, p+2) |]]+[(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)]+```++We can implement a pattern-matching version of set functions such as `member` and `intersect` in a declarative way using non-linear patterns.+Match clauses are monoids and can be concatenated using `<>`.++```haskell+> member x xs = matchDFS xs (Multiset Eql) [[mc| #x : _ -> True |], [mc| _ -> False |]]+> member 1 [3,4,1,4]+True+> intersect xs ys = matchAll dfs (xs, ys) (Pair (Set Eql) (Set Eql)) [[mc| ($x : _, #x : _) -> x |]]+> intersect [1,2,3] [4,5,3,2]+[2,3]+```++### Further readings++Some practical applications of PMO such as a [SAT solver](https://github.com/egison/sweet-egison/blob/master/example/cdcl.hs) are placed under [example/](https://github.com/egison/sweet-egison/blob/master/example/).+Detailed information of Egison, the original PMO language implementation, can be found on [https://www.egison.org/](https://www.egison.org/) or in [1].+You can learn more about pattern-match-oriented programming style in [2].++## Implementation / Difference from miniEgison++[miniEgison](https://github.com/egison/egison-haskell) is also a Haskell library that implements Egison pattern matching.+The main difference from [miniEgison](https://github.com/egison/egison-haskell) is that sweet-egison translates pattern matching into Haskell control expressions (shallow embedding), where [miniEgison](https://github.com/egison/egison-haskell) translates it into Haskell data expressions (deep embedding).++Our quasi-quoter `mc` translates match clauses into functions that take a target and return a non-deterministic computation as `MonadPlus`-like monadic expression.+As `MonadPlus` can express backtracking computation, we can perform efficient backtracking pattern matching that is essential to PMO programming on it.++For example, `[mc| $xs ++ $x : $ys -> (xs, x, ys) |]` is translated as follows:++```haskell+\tgt ->+ join tgt >-> \(xs, d0) ->+ cons d0 >-> \(x, ys) ->+ pure (xs, x, ys)+```++```haskell+\(mat, tgt) ->+ join mat tgt >>= \((m0, m1), (xs, d0)) ->+ cons m1 d0 >>= \((m2, m3), (x, ys)) ->+ pure (xs, x, ys)+```++```haskell+-- $hs ++ $ts -> (hs, ts)+\tgt ->+ join tgt >>= \(hs, ts) ->+ pure (hs, ts)+```+++`:` and `++` are synonyms of `cons` and `join` respectively, and desugared in that way during translation.+Here, pattern constructor names such as `join` and `cons` are overloaded over matchers of collections to archive the ad-hoc polymorphism of patterns.++## Bibliography++- [1] Satoshi Egi and Yuichi Nishiwaki: Functional Programming in Pattern-Match-Oriented Programming Style, The Art, Science, and Engineering of Programming, 2020, Vol. 4, Issue 3, Article 7, DOI: 10.22152/programming-journal.org/2020/4/7+- [2] Satoshi Egi and Yuichi Nishiwaki: Non-linear Pattern Matching with Backtracking for Non-free Data Types, APLAS 2018 - Asian Symposium on Programming Languages and Systems, DOI: 11.1007/978-3-030-02768-1_1
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/comb2.hs view
@@ -0,0 +1,36 @@+import Control.Egison++import Data.List ( tails )+import Criterion.Main+++comb2 :: Int -> [(Int, Int)]+comb2 n = matchAll dfs+ [1 .. n]+ (List Something)+ [[mc| _ ++ $x : _ ++ $y : _ -> (x, y) |]]++comb2Native :: Int -> [(Int, Int)]+comb2Native n = [ (y, z) | y : ts <- tails xs, z <- ts ] where xs = [1 .. n]++main :: IO ()+main = defaultMain+ [ bgroup+ "comb2"+ [ bgroup+ "1600"+ [ bench "native" $ nf comb2Native 1600+ , bench "sweet-egison" $ nf comb2 1600+ ]+ , bgroup+ "3200"+ [ bench "native" $ nf comb2Native 3200+ , bench "sweet-egison" $ nf comb2 3200+ ]+ , bgroup+ "6400"+ [ bench "native" $ nf comb2Native 6400+ , bench "sweet-egison" $ nf comb2 6400+ ]+ ]+ ]
+ benchmark/perm2.hs view
@@ -0,0 +1,37 @@+import Control.Egison++import Criterion.Main+++perm2 :: Int -> [(Int, Int)]+perm2 n =+ matchAll dfs [1 .. n] (Multiset Something) [[mc| $x : $y : _ -> (x, y) |]]++perm2Native :: Int -> [(Int, Int)]+perm2Native n = go [1 .. n] [] []+ where+ go [] _ acc = acc+ go (x : xs) rest acc =+ [ (x, y) | y <- rest ++ xs ] ++ go xs (rest ++ [x]) acc++main :: IO ()+main = defaultMain+ [ bgroup+ "perm2"+ [ bgroup+ "1600"+ [ bench "native" $ nf perm2Native 1600+ , bench "sweet-egison" $ nf perm2 1600+ ]+ , bgroup+ "3200"+ [ bench "native" $ nf perm2Native 3200+ , bench "sweet-egison" $ nf perm2 3200+ ]+ , bgroup+ "6400"+ [ bench "native" $ nf perm2Native 6400+ , bench "sweet-egison" $ nf perm2 6400+ ]+ ]+ ]
+ src/Control/Egison.hs view
@@ -0,0 +1,21 @@+-- |+--+-- Module: Control.Egsion+-- Description: Battery Included Re-exports+-- Stability: experimental+--+-- This module provides a "Battery Included" set of re-exports++module Control.Egison+ ( module X+ )+where++import Control.Monad.Search as X+import Control.Egison.Match as X+import Control.Egison.Matcher as X+import Control.Egison.Matcher.Pair as X+import Control.Egison.Matcher.Collection+ as X+import Control.Egison.QQ as X+
+ src/Control/Egison/Match.hs view
@@ -0,0 +1,54 @@+-- |+--+-- Module: Control.Egison.Match+-- Description: Pattern-matching expressions+-- Stability: experimental+--+-- This module exposes many combinators to perform pattern matching in [miniEgison](https://hackage.haskell.org/package/mini-egison)-like way.++module Control.Egison.Match+ ( matchAll+ , matchAllSingle+ , match+ )+where++import Language.Haskell.TH.Quote ( QuasiQuoter )+import Control.Egison.Matcher ( Matcher )+import Control.Monad.Search ( MonadSearch(..)+ , bfs+ , dfs+ )+++{-# INLINE matchAll #-}+matchAll+ :: (Matcher m t, MonadSearch s)+ => ((m, t) -> s (m, t))+ -> t+ -> m+ -> [(m, t) -> s r]+ -> [r]+matchAll strategy target matcher =+ concatMap (\b -> toList (strategy (matcher, target) >>= b))++{-# INLINE matchAllSingle #-}+matchAllSingle+ :: (Matcher m t, MonadSearch s)+ => ((m, t) -> s (m, t))+ -> t+ -> m+ -> ((m, t) -> s r)+ -> [r]+matchAllSingle strategy target matcher b =+ toList (strategy (matcher, target) >>= b)++{-# INLINE match #-}+match+ :: (Matcher m t, MonadSearch s)+ => ((m, t) -> s (m, t))+ -> t+ -> m+ -> [(m, t) -> s r]+ -> r+match strategy target matcher bs = head (matchAll strategy target matcher bs)
+ src/Control/Egison/Matcher.hs view
@@ -0,0 +1,43 @@+-- |+--+-- Module: Control.Egison.Matcher+-- Description: Matcher class and basic matchers+-- Stability: experimental+--+-- This module defines a class for matchers and some basic matchers.++module Control.Egison.Matcher+ ( Pattern+ , Matcher+ , Something(..)+ , ValuePattern(..)+ , Eql(..)+ )+where++import Control.Monad ( MonadPlus(..) )++-- | Type synonym for patterns.+type Pattern ps im it ot = ps -> im -> it -> [ot]++-- | Class for matchers. @'Matcher' m tgt@ denotes that @m@ is a matcher for @tgt@.+class Matcher m tgt++-- | Matcher that handles pattern variables and wildcards for arbitrary types.+data Something = Something++instance Matcher Something a++class Eq t => ValuePattern m t where+ value :: t -> Pattern () m t ()+ default value :: Eq t => t -> Pattern () m t ()+ value e () _ v = if e == v then pure () else mzero+ valueM :: m -> t -> ()+ default valueM :: m -> t -> ()+ valueM _ _ = ()++-- | Matcher that can handle value patterns of 'Eq' types.+data Eql = Eql++instance Eq a => Matcher Eql a+instance Eq a => ValuePattern Eql a
+ src/Control/Egison/Matcher/Collection.hs view
@@ -0,0 +1,134 @@+-- |+--+-- Module: Control.Egison.Matcher.Collection+-- Description: Matchers for collection data types+-- Stability: experimental++module Control.Egison.Matcher.Collection+ ( CollectionPattern(..)+ , List(..)+ , Multiset(..)+ , Set(..)+ )+where++import Data.List ( tails )+import Control.Monad ( MonadPlus(..) )+import Control.Monad.Search+import Control.Egison.Match+import Control.Egison.Matcher+import Control.Egison.Matcher.Pair+import Control.Egison.QQ+import Language.Egison.Syntax.Pattern+ as Pat+ ( Expr(..) )+import Language.Haskell.TH ( Exp(..)+ , Name+ )++-- | Class for collection pattern constructors.+class CollectionPattern m t where+ -- | Matcher for the elements.+ type ElemM m+ -- | Type of the target elements.+ type ElemT t+ -- | Pattern that matches with empty collections.+ -- @[]@ is desugared into 'nil' by the quasi-quoter.+ nil :: Pattern () m t ()+ nilM :: m -> t -> ()+ default nilM :: m -> t -> ()+ {-# INLINE nilM #-}+ nilM _ _ = ()+ -- | Pattern that destructs collections into its head and tail.+ -- @:@ is desugared into 'cons' by the quasi-quoter.+ cons :: Pattern (PP, PP) m t (ElemT t, t)+ consM :: m -> t -> (ElemM m, m)+ -- | Pattern that destructs collections into its initial prefix and remaining suffix.+ -- @++@ is desugared into 'join' by the quasi-quoter.+ join :: Pattern (PP, PP) m t (t, t)+ joinM :: m -> t -> (m, m)+ default joinM :: m -> t -> (m, m)+ {-# INLINE joinM #-}+ joinM m _ = (m, m)++-- | 'List' matcher is a matcher for collections that matches as if they're normal lists.+newtype List m = List m++instance Matcher m t => Matcher (List m) [t]++instance Matcher m t => CollectionPattern (List m) [t] where+ type ElemM (List m) = m+ type ElemT [t] = t+ {-# INLINE nil #-}+ nil _ _ [] = pure ()+ nil _ _ _ = mzero+ {-# INLINE cons #-}+ cons _ _ [] = mzero+ cons _ (List m) (x : xs) = pure (x, xs)+ {-# INLINE consM #-}+ consM (List m) _ = (m, List m)+ {-# INLINABLE join #-}+ join (WC, _) m xs = map (\ts -> (undefined, ts)) (tails xs)+ join _ m [] = pure ([], [])+ join ps m (x : xs) = pure ([], x : xs) `mplus` do+ (ys, zs) <- join ps m xs+ pure (x : ys, zs)++instance (Eq a, Matcher m a, ValuePattern m a) => ValuePattern (List m) [a] where+ value e () (List m) v = if eqAs (List m) (List m) e v then pure () else mzero++newtype Multiset m = Multiset m++instance Matcher m t => Matcher (Multiset m) [t]++instance Matcher m t => CollectionPattern (Multiset m) [t] where+ type ElemM (Multiset m) = m+ type ElemT [t] = t+ {-# INLINE nil #-}+ nil _ _ [] = pure ()+ nil _ _ _ = mzero+ {-# INLINE cons #-}+ cons (_, WC) (Multiset m) xs = map (\x -> (x, undefined)) xs+ cons _ (Multiset m) xs = matchAll+ dfs+ xs+ (List Something)+ [[mc| $hs ++ $x : $ts -> (x, hs ++ ts) |]]+ {-# INLINE consM #-}+ consM (Multiset m) _ = (m, Multiset m)+ {-# INLINABLE join #-}+ join = undefined++instance (Eq a, Matcher m a, ValuePattern m a) => ValuePattern (Multiset m) [a] where+ value e () (Multiset m) v =+ if eqAs (List m) (Multiset m) e v then pure () else mzero++newtype Set m = Set m++instance Matcher m t => Matcher (Set m) [t]++instance Matcher m t => CollectionPattern (Set m) [t] where+ type ElemM (Set m) = m+ type ElemT [t] = t+ {-# INLINE nil #-}+ nil _ _ [] = pure ()+ nil _ _ _ = mzero+ {-# INLINE cons #-}+ cons (_, WC) (Set m) xs = map (\x -> (x, undefined)) xs+ cons _ (Set m) xs = map (\x -> (x, xs)) xs+ {-# INLINE consM #-}+ consM (Set m) _ = (m, Set m)+ {-# INLINABLE join #-}+ join = undefined++instance (Eq a, Matcher m a, ValuePattern m a) => ValuePattern (Set m) [a] where+ value e () (Set m) v = if eqAs (List m) (Set m) e v then pure () else mzero++eqAs m1 m2 xs ys = match+ dfs+ (xs, ys)+ (Pair m1 m2)+ [ [mc| ([], []) -> True |]+ , [mc| ($x : $xs, #x : $ys) -> eqAs m1 m2 xs ys |]+ , [mc| _ -> False |]+ ]
+ src/Control/Egison/Matcher/Pair.hs view
@@ -0,0 +1,28 @@+-- |+--+-- Module: Control.Egison.Matcher.Pair+-- Description: Matchers for pairs+-- Stability: experimental++module Control.Egison.Matcher.Pair+ ( Pair(..)+ , tuple2+ , tuple2M+ )+where++import Control.Monad ( MonadPlus(..) )+import Control.Monad.Search+import Control.Egison.Match+import Control.Egison.Matcher+import Control.Egison.QQ++data Pair m1 m2 = Pair m1 m2++instance (Matcher m1 t1, Matcher m2 t2) => Matcher (Pair m1 m2) (t1, t2)++tuple2 :: Pattern (PP, PP) (Pair m1 m2) (t1, t2) (t1, t2)+tuple2 _ (Pair m1 m2) (t1, t2) = pure (t1, t2)++tuple2M :: Pair m1 m2 -> (t1, t2) -> (m1, m2)+tuple2M (Pair m1 m2) _ = (m1, m2)
+ src/Control/Egison/QQ.hs view
@@ -0,0 +1,190 @@+-- |+--+-- Module: Control.Egison.QQ+-- Description: Quasi-quoter to construct queries+-- Stability: experimental+--+-- This module provides 'QuasiQuoter' that builds 'Query' from nice pattern expressions.++{-# LANGUAGE TemplateHaskell #-}++module Control.Egison.QQ+ ( mc+ , PP(..)+ )+where++-- imports to create 'Name' in compilation+import Data.Functor ( void )+import Control.Monad ( MonadPlus(..) )+import Control.Monad.Search ( MonadSearch(..) )++-- main+import Data.Maybe ( mapMaybe )+import Text.Read ( readMaybe )+import Data.Foldable ( foldrM )++import Language.Haskell.TH ( Q+ , Loc(..)+ , Exp(..)+ , Pat(..)+ , Dec(..)+ , Body(..)+ , Name+ , location+ , extsEnabled+ , newName+ , mkName+ , nameBase+ )+import Language.Haskell.TH.Quote ( QuasiQuoter(..) )+import Language.Haskell.TH as TH+ ( Extension )+import Language.Haskell.Meta.Syntax.Translate+ ( toExp )+import Language.Haskell.Exts.Extension+ ( Extension(EnableExtension) )+import Language.Haskell.Exts.Extension+ as Exts+ ( KnownExtension )+import Language.Haskell.Exts.Parser ( ParseResult(..)+ , defaultParseMode+ , parseExpWithMode+ )+import qualified Language.Haskell.Exts.Parser as Exts+ ( ParseMode(..) )+import Language.Egison.Syntax.Pattern+ as Pat+ ( Expr(..) )+import qualified Language.Egison.Parser.Pattern+ as Pat+ ( parseNonGreedy )+import Language.Egison.Parser.Pattern ( Fixity(..)+ , ParseFixity(..)+ , Associativity(..)+ , Precedence(..)+ )+import Language.Egison.Parser.Pattern.Mode.Haskell.TH+ ( ParseMode(..) )++-- | Quasi-quoter for pattern expressions.+mc :: QuasiQuoter+mc = QuasiQuoter { quoteExp = compile+ , quotePat = undefined+ , quoteType = undefined+ , quoteDec = undefined+ }++listFixities :: [ParseFixity Name String]+listFixities =+ [ ParseFixity (Fixity AssocRight (Precedence 5) (mkName "join")) $ parser "++"+ , ParseFixity (Fixity AssocRight (Precedence 5) (mkName "cons")) $ parser ":"+ ]+ where+ parser symbol content | symbol == content = Right ()+ | otherwise = Left $ show symbol ++ "is expected"++parseMode :: Q Exts.ParseMode+parseMode = do+ Loc { loc_filename } <- location+ extensions <- mapMaybe (fmap EnableExtension . convertExt) <$> extsEnabled+ pure defaultParseMode { Exts.parseFilename = loc_filename, Exts.extensions }+ where+ convertExt :: TH.Extension -> Maybe Exts.KnownExtension+ convertExt = readMaybe . show++parseExp :: Exts.ParseMode -> String -> Q Exp+parseExp mode content = case parseExpWithMode mode content of+ ParseOk x -> pure $ toExp x+ ParseFailed _ e -> fail e++compile :: String -> Q Exp+compile content = do+ mode <- parseMode+ (pat, rest) <- parsePatternExpr mode content+ bodySource <- takeBody rest+ body <- parseExp mode bodySource+ compilePattern pat body+ where+ takeBody ('-' : '>' : xs) = pure xs+ takeBody xs = fail $ "\"->\" is expected, but found " ++ show xs++parsePatternExpr+ :: Exts.ParseMode -> String -> Q (Pat.Expr Name Name Exp, String)+parsePatternExpr haskellMode content = case Pat.parseNonGreedy mode content of+ Left e -> fail $ show e+ Right x -> pure x+ where mode = ParseMode { haskellMode, fixities = Just listFixities }++compilePattern :: Pat.Expr Name Name Exp -> Exp -> Q Exp+compilePattern pat body = do+ mName <- newName "mat"+ tName <- newName "tgt"+ body' <- go pat mName tName (AppE (VarE 'pure) body)+ pure $ LamE [TupP [VarP mName, VarP tName]] body'+ where+ let_ p e1 = LetE [ValD p (NormalB e1) []]+ sbind_ x f = ParensE (UInfixE (ParensE x) (VarE sbindOp) (ParensE f))+ compose_ f g = ParensE (UInfixE (ParensE f) (VarE '(.)) (ParensE g))+ plusName = 'Control.Monad.mplus+ sbindOp = '(>>=)+ lnotName = 'Control.Monad.Search.lnot+ go :: Pat.Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp+ go Pat.Wildcard _ _ body = pure body+ go (Pat.Variable x) _ tName body = pure $ let_ (VarP x) (VarE tName) body+ go (Pat.Value e) mName tName body =+ pure+ $ AppE+ (VarE 'fromList)+ (AppE+ (AppE (AppE (AppE (VarE (mkName "value")) e) (TupE [])) (VarE mName)+ )+ (VarE tName)+ )+ `sbind_` LamE [TupP []] body+ go (Pat.And p1 p2) mName tName body =+ go p2 mName tName body >>= go p1 mName tName+ go (Pat.Or p1 p2) mName tName body = do+ r1 <- go p1 mName tName (AppE (VarE 'pure) (TupE []))+ r2 <- go p2 mName tName (AppE (VarE 'pure) (TupE []))+ pure $ AppE (AppE (VarE plusName) r1) r2 `sbind_` LamE [TupP []] body+ go (Pat.Not p) mName tName body = do+ r <- go p mName tName (AppE (VarE 'pure) (TupE []))+ pure $ AppE (VarE lnotName) r `sbind_` LamE [TupP []] body+ go (Pat.Infix n p1 p2) mName tName body =+ go (Pattern n [p1, p2]) mName tName body+ go (Pat.Collection ps) mName tName body =+ go (desugarCollection ps) mName tName body+ go (Pat.Tuple ps) mName tName body = go (desugarTuple ps) mName tName body+ go (Pat.Pattern cName ps) mName tName body = do+ mNames <- mapM (\_ -> newName "tmpM") ps+ tNames <- mapM (\_ -> newName "tmpT") ps+ let pps = map toPP ps+ body' <- foldrM go' body (zip3 ps mNames tNames)+ pure+ $ let_+ (TupP (map VarP mNames))+ (AppE (AppE (VarE (mkName (show cName ++ "M"))) (VarE mName))+ (VarE tName)+ )+ $ AppE+ (VarE 'fromList)+ (AppE (AppE (AppE (VarE cName) (TupE pps)) (VarE mName)) (VarE tName))+ `sbind_` LamE [TupP (map VarP tNames)] body'+ where+ go' :: (Pat.Expr Name Name Exp, Name, Name) -> Exp -> Q Exp+ go' (p, m, t) = go p m t++desugarCollection :: [Pat.Expr Name Name Exp] -> Pat.Expr Name Name Exp+desugarCollection = foldr go $ Pat.Pattern (mkName "nil") []+ where go x acc = Pat.Pattern (mkName "cons") [x, acc]++desugarTuple :: [Pat.Expr Name Name Exp] -> Pat.Expr Name Name Exp+desugarTuple ps = Pat.Pattern (mkName name) ps+ where name = "tuple" ++ show (length ps)++data PP = WC | GP++toPP :: Pat.Expr Name Name Exp -> Exp+toPP Pat.Wildcard = ConE 'WC+toPP _ = ConE 'GP
+ sweet-egison.cabal view
@@ -0,0 +1,135 @@+cabal-version: 2.0+name: sweet-egison+version: 0.1.0.1+synopsis:+ Shallow embedding implementation of non-linear pattern matching++description:+ The [sweet-egison](https://hackage.haskell.org/package/sweet-egison) is a shallow embedding implementation of non-linear pattern matching with extensible and polymorphic patterns.+ In other words, this implements [Egison](https:///www.egison.org) pattern matching in Haskell by desugaring pattern expressions.+ This library provides a base of the Pattern-Match-Oriented (PMO) programming style for Haskell users at a practical level of efficiency.++bug-reports: https://github.com/egison/sweet-egison/issues+homepage: https://github.com/egison/sweet-egison#readme+license: BSD3+license-file: LICENSE+author: coord_e+maintainer: coord_e <me@coord-e.com>, Satoshi Egi <egi@egison.org>+copyright: Copyright 2020 coord_e+category: Control, Pattern+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md++-- see .github/workflows+tested-with: GHC ==8.6.2 || ==8.6.5 || ==8.8.1++source-repository head+ type: git+ location: https://github.com/egison/sweet-egison++library+ hs-source-dirs: src+ exposed-modules:+ Control.Egison+ Control.Egison.Match+ Control.Egison.Matcher+ Control.Egison.Matcher.Collection+ Control.Egison.Matcher.Pair+ Control.Egison.QQ++ build-depends:+ backtracking ^>=0.1+ , base >=4.8 && <5+ , egison-pattern-src ^>=0.2.1+ , egison-pattern-src-th-mode ^>=0.2.1+ , haskell-src-exts+ , haskell-src-meta+ , logict ^>=0.7.0+ , template-haskell+ , transformers++ ghc-options:+ -O3 -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns++ default-language: Haskell2010+ default-extensions:+ AllowAmbiguousTypes+ DataKinds+ DefaultSignatures+ DerivingStrategies+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ PolyKinds+ QuasiQuotes+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeFamilies+ TypeOperators++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs+ ghc-options:+ -Wall -threaded -rtsopts -with-rtsopts=-N -Wno-type-defaults++ default-language: Haskell2010+ build-depends:+ base+ , primes+ , sweet-egison+ , tasty+ , tasty-hunit++ default-extensions:+ GADTs+ QuasiQuotes+ TemplateHaskell+ TypeApplications++ -- cabal-fmt: expand test+ other-modules: Control.EgisonSpec+ build-tool-depends: tasty-discover:tasty-discover -any++benchmark comb2+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ main-is: comb2.hs+ ghc-options: -O3 -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ build-depends:+ base+ , criterion+ , sweet-egison++ default-extensions:+ QuasiQuotes+ TemplateHaskell+ TypeApplications++benchmark perm2+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ main-is: perm2.hs+ ghc-options: -O3 -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ build-depends:+ base+ , criterion+ , sweet-egison++ default-extensions:+ QuasiQuotes+ TemplateHaskell+ TypeApplications
+ test/Control/EgisonSpec.hs view
@@ -0,0 +1,176 @@+module Control.EgisonSpec+ ( test_something+ , test_pair+ , test_list+ , test_multiset+ , test_set+ , test_prime+ )+where++import Control.Egison++import Test.Tasty+import Test.Tasty.HUnit+import Data.Numbers.Primes ( primes )++pmap :: (a -> b) -> [a] -> [b]+pmap f xs = matchAll dfs xs (List Something) [[mc| _ ++ $x : _ -> f x |]]++pmember :: Eq a => a -> [a] -> Bool+pmember x xs =+ match dfs xs (Multiset Eql) [[mc| #x : _ -> True |], [mc| _ -> False |]]++punique :: Eq a => [a] -> [a]+punique xs = matchAll dfs xs (List Eql) [[mc| _ ++ $x : !(_ ++ #x : _) -> x |]]+++test_something :: [TestTree]+test_something =+ [ testCase "Something and wildcard" $ assertEqual "simple" [1] $ matchAll+ dfs+ 2+ Something+ [[mc| _ -> 1 |]]+ , testCase "Something and pattern variable"+ $ assertEqual "simple" [2]+ $ matchAll dfs 2 Something [[mc| $x -> x |]]+ ]++test_pair :: [TestTree]+test_pair =+ [ testCase "pair" $ assertEqual "simple" (1, 2) $ match+ dfs+ (1, 2)+ (Pair Something Something)+ [[mc| ($x, $y) -> (x, y) |]]+ ]++test_list :: [TestTree]+test_list =+ [ testCase "The cons pattern for lists"+ $ assertEqual "simple" [(1, [2, 3])]+ $ matchAll dfs [1, 2, 3] (List Something) [[mc| cons $x $xs -> (x, xs) |]]+ , testCase "The infix cons pattern for lists"+ $ assertEqual "simple" [(1, [2, 3])]+ $ matchAll dfs [1, 2, 3] (List Something) [[mc| $x : $xs -> (x, xs) |]]+ , testCase "The infix join pattern for lists"+ $ assertEqual+ "simple"+ [([], [1, 2, 3]), ([1], [2, 3]), ([1, 2], [3]), ([1, 2, 3], [])]+ $ matchAll dfs [1, 2, 3] (List Something) [[mc| $hs ++ $ts -> (hs, ts) |]]+ , testCase "The join-cons pattern"+ $ assertEqual "simple" [([], 1, [2, 3]), ([1], 2, [3]), ([1, 2], 3, [])]+ $ matchAll dfs+ ([1, 2, 3] :: [Integer])+ (List Something)+ [[mc| $hs ++ $x : $ts -> (hs, x, ts) |]]+ , testCase "The join-cons value pattern"+ $ assertEqual "simple" [([1], [3])]+ $ matchAll dfs+ ([1, 2, 3] :: [Integer])+ (List Eql)+ [[mc| $hs ++ #2 : $ts -> (hs, ts) |]]+ , testCase "cons pattern for list (infinite)"+ $ assertEqual "simple" [1]+ $ matchAll dfs [1 ..] (List Something) [[mc| $x : _ -> x |]]+ , testCase "'map' defined using matchAllDFS"+ $ assertEqual "simple" [2, 4, 6]+ $ take 3+ $ pmap (* 2) [1 ..]+ , testCase "'unique' defined using matchAllDFS"+ $ assertEqual "simple" [1, 3, 5, 2, 4]+ $ punique [1, 2, 3, 4, 5, 2, 4]+ ]++test_multiset :: [TestTree]+test_multiset =+ [ testCase "cons pattern for multiset"+ $ assertEqual "simple" [(1, [2, 3]), (2, [1, 3]), (3, [1, 2])]+ $ matchAll dfs [1, 2, 3] (Multiset Something) [[mc| $x : $xs -> (x, xs) |]]+ , testCase "'member' defined using matchAllDFS"+ $ assertEqual "simple" False+ $ pmember 2 [1, 3, 4]+ ]++test_set :: [TestTree]+test_set =+ [ testCase "double cons pattern for set (dfs)"+ $ assertEqual+ "simple"+ [ (1, 1)+ , (1, 2)+ , (1, 3)+ , (1, 4)+ , (1, 5)+ , (1, 6)+ , (1, 7)+ , (1, 8)+ , (1, 9)+ , (1, 10)+ ]+ $ take 10+ $ matchAll dfs [1 ..] (Set Something) [[mc| $x : $y : _ -> (x, y) |]]+ , testCase "double cons pattern for set (bfs)"+ $ assertEqual+ "simple"+ [ (1, 1)+ , (1, 2)+ , (2, 1)+ , (1, 3)+ , (2, 2)+ , (3, 1)+ , (1, 4)+ , (2, 3)+ , (3, 2)+ , (4, 1)+ ]+ $ take 10+ $ matchAll bfs [1 ..] (Set Something) [[mc| $x : $y : _ -> (x, y) |]]+ ]++test_prime :: [TestTree]+test_prime =+ [ testCase "prime twins"+ $ assertEqual+ "simple"+ [ (3 , 5)+ , (5 , 7)+ , (11 , 13)+ , (17 , 19)+ , (29 , 31)+ , (41 , 43)+ , (59 , 61)+ , (71 , 73)+ , (101, 103)+ , (107, 109)+ ]+ $ take 10+ $ matchAll bfs primes (List Eql) [[mc| _ ++ $p : #(p+2) : _ -> (p, p+2) |]]+ , testCase "(p, p+6)"+ $ assertEqual "simple" [(5, 11), (7, 13), (11, 17), (13, 19), (17, 23)]+ $ take 5+ $ matchAll bfs+ primes+ (List Eql)+ [[mc| _ ++ $p : _ ++ #(p+6) : _ -> (p, p+6) |]]+-- , testCase "prime triplets"+-- $ assertEqual+-- "simple"+-- [ (5 , 7 , 11)+-- , (11 , 13 , 17)+-- , (7 , 11 , 13)+-- , (17 , 19 , 23)+-- , (13 , 17 , 19)+-- , (41 , 43 , 47)+-- , (37 , 41 , 43)+-- , (67 , 71 , 73)+-- , (101, 103, 107)+-- , (97 , 101, 103)+-- ]+-- $ take 10+-- $ matchAll bfs+-- primes+-- (List Eql)+-- [[mc| _ ++ $p : $m : #(p+6) : _ -> (p, m, p+6) |]]+ ]
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}