sweet-egison 0.1.0.3 → 0.1.1.0
raw patch · 6 files changed
+122/−50 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- src/Control/Egison/Match.hs +1/−6
- src/Control/Egison/Matcher/Collection.hs +21/−15
- src/Control/Egison/Matcher/Pair.hs +4/−7
- src/Control/Egison/QQ.hs +55/−15
- sweet-egison.cabal +4/−3
- test/Control/EgisonSpec.hs +37/−4
src/Control/Egison/Match.hs view
@@ -13,13 +13,8 @@ ) where -import Language.Haskell.TH.Quote ( QuasiQuoter ) import Control.Egison.Matcher ( Matcher )-import Control.Monad.Search ( MonadSearch(..)- , bfs- , dfs- )-+import Control.Monad.Search ( MonadSearch(..) ) {-# INLINE matchAll #-} matchAll
src/Control/Egison/Matcher/Collection.hs view
@@ -19,12 +19,6 @@ 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@@ -69,21 +63,21 @@ nil _ _ _ = mzero {-# INLINE cons #-} cons _ _ [] = mzero- cons _ (List m) (x : xs) = pure (x, xs)+ cons _ (List _) (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 (WC, _) _ xs = map (\ts -> (undefined, ts)) (tails xs)+ join _ _ [] = pure ([], []) join ps m (x : xs) = pure ([], x : xs) `mplus` do (ys, zs) <- join ps m xs pure (x : ys, zs) {-# INLINE elm #-}- elm _ (List m) xs = xs+ elm _ (List _) xs = xs {-# INLINE elmM #-} elmM (List m) _ = m {-# INLINE joinCons #-}- joinCons (_, _, _) (List m) = f []+ joinCons (_, _, _) (List _) = f [] where f _ [] = [] f rhs (x : ts) = (reverse rhs, x, ts) : f (x : rhs) ts@@ -105,8 +99,8 @@ nil _ _ [] = pure () nil _ _ _ = mzero {-# INLINE cons #-}- cons (_, WC) (Multiset m) xs = map (\x -> (x, undefined)) xs- cons _ (Multiset m) xs = matchAll+ cons (_, WC) (Multiset _) xs = map (\x -> (x, undefined)) xs+ cons _ (Multiset _) xs = matchAll dfs xs (List Something)@@ -115,6 +109,10 @@ consM (Multiset m) _ = (m, Multiset m) {-# INLINABLE join #-} join = undefined+ elm = undefined+ elmM = undefined+ joinCons = undefined+ joinConsM = undefined instance (Eq a, Matcher m a, ValuePattern m a) => ValuePattern (Multiset m) [a] where value e () (Multiset m) v =@@ -132,16 +130,24 @@ 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+ cons (_, WC) (Set _) xs = map (\x -> (x, undefined)) xs+ cons _ (Set _) xs = map (\x -> (x, xs)) xs {-# INLINE consM #-} consM (Set m) _ = (m, Set m) {-# INLINABLE join #-} join = undefined+ elm = undefined+ elmM = undefined+ joinCons = undefined+ joinConsM = 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 :: (Matcher m1 t1, Matcher m2 t2,+ ValuePattern (ElemM m2) (ElemT t2), ElemT t1 ~ ElemT t2,+ CollectionPattern m1 t1, CollectionPattern m2 t2) =>+ m1 -> m2 -> t1 -> t2 -> Bool eqAs m1 m2 xs ys = match dfs (xs, ys)
src/Control/Egison/Matcher/Pair.hs view
@@ -22,17 +22,14 @@ instance (Matcher m1 t1, Matcher m2 t2) => Matcher (Pair m1 m2) (t1, t2) tuple2 :: Pattern (PP t1, PP t2) (Pair m1 m2) (t1, t2) (t1, t2)-tuple2 _ (Pair m1 m2) (t1, t2) = pure (t1, t2)+tuple2 _ (Pair _ _) (t1, t2) = pure (t1, t2) tuple2M :: Pair m1 m2 -> (t1, t2) -> (m1, m2) tuple2M (Pair m1 m2) _ = (m1, m2) instance (Eq a1, Matcher m1 a1, ValuePattern m1 a1, Eq a2, Matcher m2 a2, ValuePattern m2 a2) => ValuePattern (Pair m1 m2) (a1, a2) where- value (e1, e2) () (Pair m1 m2) (v1, v2) = if eqAs m1 e1 v1 && eqAs m2 e2 v2 then pure () else mzero+ value (e1, e2) () (Pair m1 m2) (v1, v2) =+ if eqAs m1 e1 v1 && eqAs m2 e2 v2 then pure () else mzero eqAs :: (Matcher m t, ValuePattern m t) => m -> t -> t -> Bool-eqAs m x y =- match dfs y m- [ [mc| #x -> True |]- , [mc| _ -> False |]- ]+eqAs m x y = match dfs y m [[mc| #x -> True |], [mc| _ -> False |]]
src/Control/Egison/QQ.hs view
@@ -15,7 +15,6 @@ where -- imports to create 'Name' in compilation-import Data.Functor ( void ) import Control.Monad ( MonadPlus(..) ) import Control.Monad.Search ( MonadSearch(..) ) @@ -121,11 +120,13 @@ mName <- newName "mat" tName <- newName "tgt" body' <- go pat mName tName (AppE (VarE 'pure) body)- pure $ LamE [TupP [VarP mName, VarP tName]] body'+ case pat of+ Pat.Wildcard -> pure $ LamE [TupP [WildP, WildP]] body'+ Pat.Variable _ -> pure $ LamE [TupP [WildP, VarP tName]] 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@@ -142,7 +143,10 @@ (VarE tName) ) `sbind_` LamE [TupP []] body- go (Pat.Predicate e) _ tName body = pure $ AppE (VarE 'Control.Monad.Search.guard) (AppE e (VarE tName)) `sbind_` LamE [TupP []] body+ go (Pat.Predicate e) _ tName body =+ pure+ $ AppE (VarE 'Control.Monad.Search.guard) (AppE e (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@@ -156,13 +160,37 @@ go (desugarCollection ps) mName tName body go (Pat.Tuple ps) mName tName body = go (desugarTuple ps) mName tName body -- PROBLEM: Ad-hoc optimization- go (Pat.Infix c1 Pat.Wildcard (Pat.Infix c2 p Pat.Wildcard)) mName tName body | nameBase c1 == "join", nameBase c2 == "cons" =- go (Pattern (mkName "elm") [p]) mName tName body+ go (Pat.Infix c1 Pat.Wildcard (Pat.Infix c2 p Pat.Wildcard)) mName tName body+ | nameBase c1 == "join", nameBase c2 == "cons" = go+ (Pattern (mkName "elm") [p])+ mName+ tName+ body -- PROBLEM: Ad-hoc optimization- go (Pat.Infix c1 p1 (Pat.Infix c2 p2 p3)) mName tName body | nameBase c1 == "join", nameBase c2 == "cons" =- go (Pattern (mkName "joinCons") [p1, p2, p3]) mName tName body+ go (Pat.Infix c1 p1 (Pat.Infix c2 p2 p3)) mName tName body+ | nameBase c1 == "join", nameBase c2 == "cons" = go+ (Pattern (mkName "joinCons") [p1, p2, p3])+ mName+ tName+ body go (Pat.Infix n p1 p2) mName tName body = go (Pattern n [p1, p2]) mName tName body+ go (Pat.Pattern cName []) mName tName body =+ pure+ $ AppE+ (VarE 'fromList)+ (AppE (AppE (AppE (VarE cName) (TupE [])) (VarE mName)) (VarE tName))+ `sbind_` LamE [TupP []] body+ go (Pat.Pattern cName ps) mName tName body | all isPatVar ps = 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+ $ AppE+ (VarE 'fromList)+ (AppE (AppE (AppE (VarE cName) (TupE pps)) (VarE mName)) (VarE tName))+ `sbind_` LamE [TupP (zipWith tNameToVar ps tNames)] body' go (Pat.Pattern cName ps) mName tName body = do mNames <- mapM (\_ -> newName "tmpM") ps tNames <- mapM (\_ -> newName "tmpT") ps@@ -170,17 +198,29 @@ body' <- foldrM go' body (zip3 ps mNames tNames) pure $ let_- (TupP (map VarP mNames))+ (TupP (zipWith mNameToVar ps 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+ `sbind_` LamE [TupP (zipWith tNameToVar ps tNames)] body'+ go' :: (Pat.Expr Name Name Exp, Name, Name) -> Exp -> Q Exp+ go' (p, m, t) = go p m t+ isPatVar :: Pat.Expr Name Name Exp -> Bool+ isPatVar Pat.Wildcard = True+ isPatVar (Pat.Variable _) = True+ isPatVar (Pat.Predicate _) = True+ isPatVar _ = False+ mNameToVar :: Pat.Expr Name Name Exp -> Name -> Pat+ mNameToVar Pat.Wildcard _ = WildP+ mNameToVar (Pat.Variable _) _ = WildP+ mNameToVar (Pat.Predicate _) _ = WildP+ mNameToVar _ mName = VarP mName+ tNameToVar :: Pat.Expr Name Name Exp -> Name -> Pat+ tNameToVar Pat.Wildcard _ = WildP+ tNameToVar _ tName = VarP tName desugarCollection :: [Pat.Expr Name Name Exp] -> Pat.Expr Name Name Exp desugarCollection = foldr go $ Pat.Pattern (mkName "nil") []@@ -193,6 +233,6 @@ data PP a = WC | VP a | GP toPP :: Pat.Expr Name Name Exp -> Exp-toPP Pat.Wildcard = ConE 'WC+toPP Pat.Wildcard = ConE 'WC toPP (Pat.Value e) = AppE (ConE 'VP) e-toPP _ = ConE 'GP+toPP _ = ConE 'GP
sweet-egison.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: sweet-egison-version: 0.1.0.3+version: 0.1.1.0 synopsis: Shallow embedding implementation of non-linear pattern matching @@ -51,8 +51,9 @@ , transformers ghc-options:- -O3 -Wall -Wcompat -Widentities -Wincomplete-record-updates- -Wincomplete-uni-patterns+ -O3 -Wunused-local-binds -Wunused-imports -Wunused-matches -Wcompat+ -Widentities -Wincomplete-record-updates -Wunused-pattern-binds+ -Wincomplete-uni-patterns -Wmissing-methods -Wmissing-signatures default-language: Haskell2010 default-extensions:
test/Control/EgisonSpec.hs view
@@ -134,15 +134,38 @@ [ testCase "prime twins (value pattern)" $ assertEqual "simple"- [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)]+ [ (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 "prime twins (predicate pattern)" $ assertEqual "simple"- [(3,5),(5,7),(11,13),(17,19),(29,31),(41,43),(59,61),(71,73),(101,103),(107,109)]+ [ (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 : ?(\x -> x == p + 2) : _ -> (p, p+2) |]]+ $ matchAll bfs+ primes+ (List Eql)+ [[mc| _ ++ $p : ?(\x -> x == p + 2) : _ -> (p, p+2) |]] , testCase "(p, p+6)" $ assertEqual "simple" [(5, 11), (7, 13), (11, 17), (13, 19), (17, 23)] $ take 5@@ -153,7 +176,17 @@ , testCase "prime triplets" $ assertEqual "simple"- [(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)]+ [ (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)+ ] $ take 10 $ matchAll bfs primes