├── stack.yaml ├── Setup.lhs ├── README.md ├── .gitignore ├── Data ├── Pattern │ ├── Base │ │ ├── TypeList.hs │ │ ├── Tuple.hs │ │ └── Difference.hs │ ├── Base.hs │ └── Common.hs └── Pattern.hs ├── .travis.yml ├── CHANGELOG.md ├── .stylish-haskell.yaml ├── LICENSE ├── examples └── Examples.hs └── first-class-patterns.cabal /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2019-09-30 2 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # first-class-patterns 2 | 3 | [![Build status](https://secure.travis-ci.org/kowainik/first-class-patterns.svg)](http://travis-ci.org/kowainik/first-class-patterns) 4 | [![Hackage](https://img.shields.io/hackage/v/first-class-patterns.svg)](https://hackage.haskell.org/package/first-class-patterns) 5 | 6 | Implements patterns in Haskell as first class objects. 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .HTF/ 23 | .ghc.environment* 24 | 25 | # Stack 26 | .stack-work/ 27 | stack.yaml.lock 28 | 29 | ### IDE/support 30 | # Vim 31 | [._]*.s[a-v][a-z] 32 | [._]*.sw[a-p] 33 | [._]s[a-v][a-z] 34 | [._]sw[a-p] 35 | *~ 36 | tags 37 | 38 | # IntellijIDEA 39 | .idea/ 40 | .ideaHaskellLib/ 41 | *.iml 42 | 43 | # Atom 44 | .haskell-ghc-mod.json 45 | 46 | # VS 47 | .vscode/ 48 | 49 | # Emacs 50 | *# 51 | .dir-locals.el 52 | TAGS 53 | 54 | # other 55 | .DS_Store 56 | -------------------------------------------------------------------------------- /Data/Pattern/Base/TypeList.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module: Data.Pattern.Base.TypeList 4 | -- License: BSD3 5 | -- Maintainer: Brent Yorgey 6 | -- Stability: experimental 7 | -- Portability: non-portable (see .cabal) 8 | -- 9 | -- Type-level lists. These lists only describe the types, but contain 10 | -- no data. That is, they are phantom types. 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE PolyKinds, DataKinds #-} 14 | module Data.Pattern.Base.TypeList where 15 | 16 | import Data.Kind (Type) 17 | 18 | 19 | -- | Concatenation of lists. Instances: 20 | -- 21 | -- > type instance Nil :++: xs = xs 22 | -- > type instance (h:*:t) :++: xs = h :*: (t :++: xs) 23 | infixr :++: 24 | type family (:++:) (a :: [Type]) (b :: [Type]) :: [Type] 25 | type instance '[] :++: xs = xs 26 | type instance (h ': t) :++: xs = h ': (t :++: xs) 27 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: true 2 | language: haskell 3 | 4 | git: 5 | depth: 5 6 | 7 | cabal: "3.0" 8 | 9 | cache: 10 | directories: 11 | - "$HOME/.cabal/store" 12 | - "$HOME/.stack" 13 | - "$TRAVIS_BUILD_DIR/.stack-work" 14 | 15 | matrix: 16 | include: 17 | 18 | # cabal 19 | - ghc: 8.2.2 20 | - ghc: 8.4.4 21 | - ghc: 8.6.5 22 | - ghc: 8.8.1 23 | 24 | # stack 25 | - ghc: 8.8.1 26 | env: STACK_YAML="$TRAVIS_BUILD_DIR/stack.yaml" 27 | 28 | install: 29 | - | 30 | if [ -z "$STACK_YAML" ]; then 31 | ghc --version 32 | cabal --version 33 | cabal update 34 | cabal build --enable-tests --enable-benchmarks 35 | else 36 | # install stack 37 | curl -sSL https://get.haskellstack.org/ | sh 38 | 39 | # build project with stack 40 | stack --version 41 | stack build --system-ghc --test --no-run-tests 42 | fi 43 | 44 | script: 45 | - | 46 | if [ -z "$STACK_YAML" ]; then 47 | cabal test --enable-tests 48 | else 49 | stack test --no-terminal --system-ghc 50 | fi 51 | 52 | notifications: 53 | email: false 54 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | `first-class-patterns` uses [PVP Versioning][1]. 4 | The changelog is available [on GitHub][2]. 5 | 6 | ## 0.3.2.5 — Oct 1, 2019 7 | 8 | * [#8](https://github.com/kowainik/first-class-patterns/issues/8): 9 | Support GHC-8.8.1. 10 | (by [@SanchayanMaity](https://github.com/SanchayanMaity)) 11 | * [#10](https://github.com/kowainik/first-class-patterns/issues/10): 12 | Improve package metadata. 13 | (by [@chshersh](https://github.com/chshersh)) 14 | 15 | ## 0.3.2.4 16 | 17 | * Update maintainer information. 18 | * [#1](https://github.com/kowainik/first-class-patterns/issues/1): 19 | Add `stack` support. 20 | * [#3](https://github.com/kowainik/first-class-patterns/issues/3): 21 | Add Travis CI support. Build with GHC-8.2.2 and GHC-8.4.3. 22 | 23 | ## 0.3.2.3 (9 May 2016) 24 | 25 | * Allow transformers-0.5 26 | 27 | ## 0.3.2.2 (28 May 2015) 28 | 29 | * Bug fix: [#3](https://github.com/reinerp/first-class-patterns/issues/3) 30 | 31 | ## 0.3.2.1: 12 May, 2014 32 | 33 | * Allow transformers-0.4 34 | 35 | ## 0.3.2: 30 July, 2013 36 | 37 | * Updates to compile with GHC 7.6 38 | * fix examples 39 | * reinstate tup2 as a synonym for pair 40 | 41 | [1]: https://pvp.haskell.org 42 | [2]: https://github.com/kowainik/first-class-patterns/releases 43 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | # Import cleanup 8 | - imports: 9 | align: none 10 | list_align: after_alias 11 | pad_module_names: false 12 | long_list_align: inline 13 | empty_list_align: inherit 14 | list_padding: 4 15 | separate_lists: true 16 | space_surround: false 17 | 18 | - language_pragmas: 19 | style: vertical 20 | remove_redundant: true 21 | 22 | # Remove trailing whitespace 23 | - trailing_whitespace: {} 24 | 25 | columns: 100 26 | 27 | newline: native 28 | 29 | language_extensions: 30 | - BangPatterns 31 | - ConstraintKinds 32 | - DataKinds 33 | - DefaultSignatures 34 | - DeriveAnyClass 35 | - DeriveDataTypeable 36 | - DeriveGeneric 37 | - DerivingStrategies 38 | - DerivingVia 39 | - ExplicitNamespaces 40 | - FlexibleContexts 41 | - FlexibleInstances 42 | - FunctionalDependencies 43 | - GADTs 44 | - GeneralizedNewtypeDeriving 45 | - InstanceSigs 46 | - KindSignatures 47 | - LambdaCase 48 | - MultiParamTypeClasses 49 | - MultiWayIf 50 | - NamedFieldPuns 51 | - NoImplicitPrelude 52 | - OverloadedStrings 53 | - QuasiQuotes 54 | - RecordWildCards 55 | - ScopedTypeVariables 56 | - StandaloneDeriving 57 | - TemplateHaskell 58 | - TupleSections 59 | - TypeApplications 60 | - TypeFamilies 61 | - ViewPatterns 62 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Reiner Pope 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Reiner Pope nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Data/Pattern.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module: Data.Pattern 4 | -- License: BSD3 5 | -- Maintainer: Brent Yorgey 6 | -- Stability: experimental 7 | -- Portability: non-portable (see .cabal) 8 | -- 9 | -- The main module for first-class-patterns; to use the library it 10 | -- should suffice to import this module. For a quick start using the 11 | -- library, see the examples below. 12 | -- 13 | -- If you want to read further, start with "Data.Pattern.Base", which 14 | -- defines the basic pattern type and some basic combinators. Then 15 | -- read "Data.Pattern.Common", which defines a number of convenient 16 | -- combinators for constructing various sorts of patterns. 17 | -- 18 | -- As an example, the following functions, @ex1@ and @ex2@, are 19 | -- semantically equivalent: 20 | -- 21 | -- @ 22 | -- ex1, ex2 :: Num a => Either a (a, a) -> a 23 | -- ex1 a = 'match' a $ 24 | -- 'left' ('cst' 4) '->>' 0 25 | -- '<|>' 'left' 'var' '->>' id 26 | -- '<|>' 'right' ('tup2' 'var' 'var') '->>' (+) 27 | -- ex2 a = case a of 28 | -- Left 4 -> 0 29 | -- Left x -> x 30 | -- Right (x,y) -> x+y 31 | -- @ 32 | -- 33 | -- Also, when optimisation is turned on, GHC will compile them to the 34 | -- same code. 35 | -- 36 | -- XXX add more examples here. 37 | ----------------------------------------------------------------------------- 38 | 39 | 40 | module Data.Pattern ( 41 | module Data.Pattern.Base, 42 | module Data.Pattern.Common 43 | ) where 44 | 45 | import Data.Pattern.Base 46 | import Data.Pattern.Common 47 | -------------------------------------------------------------------------------- /examples/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module Examples where 3 | 4 | import Control.Applicative 5 | 6 | import Data.Pattern 7 | 8 | --- Basic pattern matching syntax 9 | ex1, ex2 :: Either Int (Int, Int) -> Int 10 | ex1 a = match a $ 11 | left (cst 4) ->> 0 12 | <|> left var ->> id 13 | <|> right (pair var var) ->> (+) 14 | 15 | ex2 a = case a of 16 | Left 4 -> 0 17 | Left x -> x 18 | Right (x,y) -> x+y 19 | 20 | -- Defining your own pattern matchers. 21 | data Foo = Foo1 Int Int Int Int Int | Foo2 Int 22 | type PInt as = Pattern as Int 23 | 24 | foo1 :: PInt as -> PInt bs -> PInt cs -> PInt ds -> PInt es 25 | -> Pattern (as :++: bs :++: cs :++: ds :++: es) Foo 26 | foo1 = mk5 (\x -> case x of 27 | Foo1 a b c d e -> Just (a,b,c,d,e) 28 | _ -> Nothing) 29 | 30 | foo2 :: PInt as -> Pattern as Foo 31 | foo2 = mk1 (\x -> case x of 32 | Foo2 a -> Just a 33 | _ -> Nothing) 34 | 35 | ex3 :: Foo -> Int 36 | ex3 a = match a $ 37 | foo1 var (cst 5) __ __ __ ->> id 38 | <|> foo1 __ var __ __ __ ->> id 39 | <|> foo2 var ->> id 40 | 41 | -- using Functor/Applicative/Monad instances on Clause. 42 | 43 | -- Functor: apply a function to multiple cases, using (<$>). 44 | ex4 :: Either (Int,Int) Int -> Int 45 | ex4 a = match a $ 46 | (1+) <$> (left (pair var (cst 4)) ->> id 47 | <|> right var ->> id) 48 | <|> left (pair __ var) ->> id 49 | 50 | --ex4' :: Either (Int,Int) Int -> Int 51 | --ex4' a = match a $ 52 | 53 | 54 | -- Applicative: do 2 pattern matches on the same data, and combine them with function application. (<*>). 55 | ex5 :: (Int,Int) -> Int 56 | ex5 a = match a $ 57 | (pair (cst 4) __ ->> (3*) <|> pair var __ ->> (*)) <*> (pair __ var ->> id) 58 | 59 | -- ex5 is semantically the same as ex5'. 60 | ex5' :: (Int,Int) -> Int 61 | ex5' a = case a of 62 | (4,_) -> case a of 63 | (_,y) -> 3 * y 64 | (x,_) -> case a of 65 | (_,y) -> x * y 66 | 67 | ---- "anonymous" matching 68 | ex6 :: Show a => Either a String -> IO () 69 | ex6 = elim $ 70 | left var ->> print 71 | <|> right var ->> putStrLn 72 | 73 | -- same as Prelude.either 74 | ex7 :: (a -> r) -> (b -> r) -> Either a b -> r 75 | ex7 withLeft withRight = elim $ 76 | left var ->> withLeft 77 | <|> right var ->> withRight 78 | 79 | 80 | -- "monadic" matching 81 | ex8 :: IO () 82 | ex8 = mmatch getLine $ 83 | cst "" ->> return () 84 | <|> var ->> putStrLn . ("You said " ++) 85 | 86 | ex9 :: String 87 | ex9 = match (3 :: Integer) $ zero ->> "z" <|> suc (suc var) ->> show 88 | -------------------------------------------------------------------------------- /Data/Pattern/Base.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module: Data.Pattern.Pattern 4 | -- License: BSD3 5 | -- Maintainer: Brent Yorgey 6 | -- Stability: experimental 7 | -- Portability: non-portable (see .cabal) 8 | -- 9 | -- The main types used in the implementation of first-class patterns: 10 | -- 'Pattern' and 'Clause'. 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE PolyKinds, DataKinds #-} 14 | module Data.Pattern.Base ( 15 | -- * Patterns 16 | Pattern(..), 17 | 18 | -- * Clauses 19 | Clause, runClause, 20 | (->>), (<|>), 21 | 22 | -- * Internals 23 | module Data.Pattern.Base.TypeList, 24 | module Data.Pattern.Base.Tuple, 25 | ) where 26 | 27 | import Data.Pattern.Base.TypeList 28 | import Data.Pattern.Base.Tuple 29 | 30 | import Data.Maybe 31 | 32 | import Control.Applicative 33 | import Control.Monad 34 | import Control.Monad.Trans.Reader 35 | 36 | -- | The pattern type. A value of type @Pattern vars a@ is a pattern 37 | -- which matches values of type @a@ and binds variables with types 38 | -- given by the type-list @vars@. For example, something of type 39 | -- 40 | -- > Pattern (a :*: c :*: Nil) (a,b,c) 41 | -- 42 | -- is a pattern which matches against a triple and binds values of 43 | -- types @a@ and @c@. (A pattern of this type can be constructed as 44 | -- @tup3 var __ var@.) 45 | -- 46 | -- Many \"normal\" patterns can be conveniently defined using 'mk0', 47 | -- 'mk1', 'mk2', and so on. 48 | newtype Pattern vars a = Pattern { runPattern :: a -> Maybe (Tuple vars) } 49 | 50 | -- | Pattern-match clauses. Typically something of the form 51 | -- 52 | -- @pattern '->>' function@ 53 | -- 54 | -- where the function takes one argument for each variable bound by 55 | -- the pattern. 56 | -- 57 | -- Clauses can be constructed with @('->>')@, run with 'tryMatch', 58 | -- and manipulated by the 'Monad' and 'MonadPlus' instances. In 59 | -- particular, the @('<|>')@ operator from the 'Alternative' class 60 | -- is the way to list multiple cases in a pattern. 61 | newtype Clause a r = Clause { runClause :: ReaderT a Maybe r 62 | -- ^ Extract the underlying computation 63 | -- constituting a 'Clause'. This 64 | -- function is not intended to be used 65 | -- directly; instead, see 'match', 66 | -- 'tryMatch', 'mmatch', and 'elim' from 67 | -- "Data.Pattern.Common". 68 | } 69 | deriving newtype (Functor,Applicative,Monad,Alternative,MonadPlus) 70 | 71 | -- (<|>) is infix 3, so we make (->>) infix 4. 72 | infix 4 ->> 73 | 74 | -- | Construct a 'Clause' from a pattern and a function which takes 75 | -- one argument for each variable bound by the pattern. For example, 76 | -- 77 | -- > pair __ nothing ->> 3 78 | -- > pair var nothing ->> \x -> x + 3 79 | -- > pair var (just var) ->> \x y -> x + y + 3 80 | (->>) :: Pattern vars a -> Fun vars r -> Clause a r 81 | (Pattern p) ->> k = Clause (ReaderT $ fmap (flip runTuple k) . p) 82 | -------------------------------------------------------------------------------- /Data/Pattern/Base/Tuple.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module: Data.Pattern.Base.Tuple 4 | -- License: BSD3 5 | -- Maintainer: Brent Yorgey 6 | -- Stability: experimental 7 | -- Portability: non-portable (see .cabal) 8 | -- 9 | -- Various types defined inductively as type families or data families 10 | -- on type-lists. 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | module Data.Pattern.Base.Tuple ( 16 | -- * Functions 17 | Fun, 18 | -- * Tuples 19 | Tuple, 20 | zeroT, 21 | oneT, 22 | (<+>), 23 | runTuple, 24 | -- * Mapping and distributing over tuples 25 | Map, Distribute(..) 26 | ) where 27 | 28 | import Data.Pattern.Base.Difference 29 | import Data.Pattern.Base.TypeList 30 | import Data.Kind (Type) 31 | 32 | -- | Curried functions. We have 33 | -- 34 | -- @Fun '[x1, ..., xn] r = x1 -> ... -> xn -> r@ 35 | type family Fun (xs :: [Type]) r 36 | type instance Fun '[] r = r 37 | type instance Fun (h ': t) r = h -> Fun t r 38 | 39 | data family Tup (xs :: [Type]) 40 | data instance Tup '[] = Unit 41 | data instance Tup (h ': t) = Pair h (Tup t) 42 | 43 | class Uncurriable xs where 44 | uncurryT :: (Tup xs -> r) -> Fun xs r 45 | 46 | instance Uncurriable '[] where 47 | uncurryT f = f Unit 48 | 49 | instance Uncurriable t => Uncurriable (h ': t) where 50 | uncurryT f = \h -> uncurryT (\tup -> f (Pair h tup)) 51 | 52 | newtype Tuple' xs = Tuple' { runTuple' :: forall r. Fun xs r -> r } 53 | 54 | -- | Tuples with types given by @xs@. 55 | newtype Tuple xs = Tuple (D Tuple' xs) 56 | 57 | -- | The empty tuple 58 | zeroT :: Tuple '[] 59 | zeroT = Tuple zeroD 60 | 61 | -- | The singleton tuple 62 | oneT :: a -> Tuple '[a] 63 | oneT a = Tuple (mkOneD (\(Tuple' t) -> Tuple' (\k -> t (k a)))) 64 | 65 | -- XXX somehow derive this from a general 'TypeList' class? and also Uncurriable? 66 | class Tupable xs where 67 | mkTuple :: Tup xs -> Tuple xs 68 | 69 | instance Tupable '[] where 70 | mkTuple Unit = zeroT 71 | 72 | instance Tupable t => Tupable (h ': t) where 73 | mkTuple (Pair h t) = oneT h <+> mkTuple t 74 | 75 | -- | Concatenation of tuples. 76 | (<+>) :: Tuple xs -> Tuple ys -> Tuple (xs :++: ys) 77 | Tuple xs <+> Tuple ys = Tuple (xs `plusD` ys) 78 | 79 | -- | Runs a tuple by applying it to a curried function. 80 | runTuple :: Tuple xs -> Fun xs r -> r 81 | runTuple (Tuple t) = runTuple' (evalD (Tuple' id) t) 82 | 83 | -- | Runs a tuple by applying it to an uncurried function expecting 84 | -- nested pairs. 85 | runTupleT :: Uncurriable xs => Tuple xs -> (Tup xs -> r) -> r 86 | runTupleT t f = runTuple t (uncurryT f) 87 | 88 | unconsTuple :: (Uncurriable t, Tupable t) => Tuple (h ': t) -> (h, Tuple t) 89 | unconsTuple t = runTupleT t (\(Pair h t) -> (h, mkTuple t)) 90 | 91 | tupleHead :: (Uncurriable t, Tupable t) => Tuple (h ': t) -> h 92 | tupleHead = fst . unconsTuple 93 | 94 | tupleTail :: (Uncurriable t, Tupable t) => Tuple (h ': t) -> Tuple t 95 | tupleTail = snd . unconsTuple 96 | 97 | type family Map (f :: Type -> Type) (xs :: [Type]) :: [Type] 98 | type instance Map f '[] = '[] 99 | type instance Map f (h ': t) = f h ': Map f t 100 | 101 | class Distribute xs where 102 | distribute :: Functor f => f (Tuple xs) -> Tuple (Map f xs) 103 | 104 | instance Distribute '[] where 105 | distribute _ = zeroT 106 | 107 | instance (Uncurriable t, Tupable t, Distribute t) => Distribute (h ': t) where 108 | -- distribute :: f (Tuple (h :*: t)) -> Tuple (f h :*: Map f t) 109 | distribute f = oneT (fmap tupleHead f) <+> distribute (fmap tupleTail f) 110 | -------------------------------------------------------------------------------- /first-class-patterns.cabal: -------------------------------------------------------------------------------- 1 | cabal-Version: 2.4 2 | name: first-class-patterns 3 | version: 0.3.2.5 4 | author: Reiner Pope, Brent Yorgey 5 | maintainer: Kowainik 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | synopsis: First class patterns and pattern matching, using type families 9 | description: 10 | 11 | This package implements a library of first class patterns. The 12 | initial basis for this library was Morten Rhiger's \"Type-safe 13 | pattern combinators\"; the patterns can be used in an almost 14 | identical way to those of Morten Rhiger. In a series of blog 15 | posts at 16 | 17 | the types of patterns were made more revealing using type 18 | families, and a simpler implementation was used which avoids 19 | some book-keeping. 20 | . 21 | The library reimplements most of Haskell's built-in 22 | pattern matching facilities, plus some more. The pattern 23 | matches of this library are lightweight: when GHC's 24 | optimisation is turned on, all overhead should be optimised 25 | away, leaving a standard Haskell pattern match. 26 | . 27 | If you're just reading the documentation for this library for 28 | the first time, start with "Data.Pattern". 29 | 30 | category: Data, Pattern 31 | build-Type: Simple 32 | stability: stable 33 | homepage: https://github.com/kowainik/first-class-patterns 34 | bug-reports: https://github.com/kowainik/first-class-patterns/issues 35 | extra-doc-files: README.md 36 | CHANGELOG.md 37 | tested-with: GHC == 8.2.2 38 | GHC == 8.4.4 39 | GHC == 8.6.5 40 | GHC == 8.8.8 41 | 42 | source-repository head 43 | type: git 44 | location: git://github.com/kowainik/first-class-patterns.git 45 | 46 | library 47 | build-Depends: base >= 4.10.1.0 && < 5 48 | , transformers >= 0.1.0 && < 0.6 49 | 50 | exposed-modules: Data.Pattern 51 | Data.Pattern.Base 52 | Data.Pattern.Base.TypeList 53 | Data.Pattern.Base.Tuple 54 | Data.Pattern.Common 55 | other-modules: Data.Pattern.Base.Difference 56 | 57 | default-language: Haskell2010 58 | default-extensions: DerivingStrategies 59 | EmptyDataDecls 60 | FlexibleInstances 61 | GeneralizedNewtypeDeriving 62 | GADTs 63 | Rank2Types 64 | ScopedTypeVariables 65 | TypeFamilies 66 | TypeOperators 67 | 68 | -- necessary to get all the patterns properly inlined. Note that putting 69 | -- {-# INLINE #-} pragmas every doesn't seem to work, due to some subtlety 70 | -- of the inliner. 71 | -- TODO: test with recent ghc versions and check this 72 | ghc-options: -Wmissing-deriving-strategies 73 | -funfolding-use-threshold=1000 74 | -funfolding-creation-threshold=1000 75 | 76 | -Wall 77 | -Wincomplete-uni-patterns 78 | -Wincomplete-record-updates 79 | -Wcompat 80 | -Widentities 81 | -Wredundant-constraints 82 | -Wpartial-fields 83 | -fhide-source-paths 84 | -freverse-errors 85 | 86 | if impl(ghc >= 8.8.1) 87 | ghc-options: -Wmissing-deriving-strategies 88 | -Werror=missing-deriving-strategies 89 | -------------------------------------------------------------------------------- /Data/Pattern/Base/Difference.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Pattern.TypeList.Difference 3 | -- License: BSD3 4 | -- Maintainer: Brent Yorgey 5 | -- Stability: experimental 6 | -- Portability: non-portable (see .cabal) 7 | -- 8 | -- \"Difference list converters\". Developed in 9 | ----------------------------------------------------------------------------- 10 | 11 | {-# LANGUAGE PolyKinds, DataKinds, FlexibleContexts, UndecidableInstances #-} 12 | module Data.Pattern.Base.Difference ( 13 | Difference(..), 14 | D, 15 | ) where 16 | 17 | import Data.Pattern.Base.TypeList 18 | import Data.Kind (Type) 19 | import Unsafe.Coerce 20 | 21 | 22 | -- | The API presented by @Data.Pattern.Base.Difference.GADT@ and 23 | -- @Data.Pattern.Base.Difference.Coerce@. An instance of 'Difference' is a 24 | -- type which converts an inductively-defined type to one with 25 | -- an efficient append operation. 26 | class Difference d where 27 | -- | constructs the empty @d t@. 28 | zeroD :: d t '[] 29 | -- | appends two @d t@s. 30 | plusD :: d t xs -> d t ys -> d t (xs :++: ys) 31 | -- | given a \"cons\" operation, constructs the singleton @d t@. 32 | mkOneD :: (forall ys. t ys -> t (a ': ys)) -> d t '[a] 33 | -- | given a \"nil\" value, \"runs\" the @d t@. 34 | evalD :: t '[] -> d t xs -> t xs 35 | 36 | newtype D t xs = D (CoerceD t xs) 37 | 38 | -- Make a Difference instance explicitly, instead of using GND, 39 | -- to work around some sort of bug (?) 40 | instance Difference CoerceD => Difference D where 41 | zeroD = D zeroD 42 | plusD (D xs) (D ys) = D (plusD xs ys) 43 | mkOneD f = D (mkOneD f) 44 | evalD t (D xs) = evalD t xs 45 | 46 | ----- GADT implementation (pure (no cheating), recursive) ------------- 47 | data Proxy a 48 | proxy :: forall (a :: [Type]). Proxy a 49 | proxy = undefined 50 | 51 | data GadtD t xs = List xs => GadtD (forall ys. t ys -> t (xs :++: ys)) 52 | 53 | instance Difference GadtD where 54 | {-# INLINE zeroD #-} 55 | zeroD = GadtD id 56 | {-# INLINE plusD #-} 57 | plusD (GadtD fx :: GadtD t xs) (GadtD fy :: GadtD t ys) = 58 | case closure (proxy :: Proxy xs) (proxy :: Proxy ys) of 59 | ListD -> GadtD (\(zs :: t zs) -> 60 | case assoc (proxy :: Proxy xs) (proxy :: Proxy ys) (proxy :: Proxy zs) of 61 | Equal -> fx (fy zs)) 62 | {-# INLINE mkOneD #-} 63 | mkOneD f = GadtD f 64 | {-# INLINE evalD #-} 65 | evalD nil (GadtD f :: GadtD t xs) = 66 | case rightIdent (proxy :: Proxy xs) of 67 | Equal -> f nil 68 | 69 | class List a where 70 | closure :: forall b. List b => 71 | Proxy a -> Proxy b -> 72 | ListD (a :++: b) 73 | assoc :: forall b c. 74 | Proxy a -> Proxy b -> Proxy c -> 75 | ((a :++: (b :++: c)) :==: ((a :++: b) :++: c)) 76 | rightIdent :: Proxy a -> 77 | (a :++: '[]) :==: a 78 | 79 | instance List '[] where 80 | {-# INLINE closure #-} 81 | closure _ _ = ListD 82 | {-# INLINE assoc #-} 83 | assoc _ _ _ = Equal 84 | {-# INLINE rightIdent #-} 85 | rightIdent _ = Equal 86 | 87 | instance List t => List (h ': t) where 88 | {-# INLINE closure #-} 89 | closure _ b = case closure (proxy :: Proxy t) b of 90 | ListD -> ListD 91 | {-# INLINE assoc #-} 92 | assoc _ b c = case assoc (proxy :: Proxy t) b c of 93 | Equal -> Equal 94 | {-# INLINE rightIdent #-} 95 | rightIdent _ = case rightIdent (proxy :: Proxy t) of 96 | Equal -> Equal 97 | 98 | data a :==: b where 99 | Equal :: forall (a :: [Type]). a :==: a 100 | data ListD a where 101 | ListD :: List a => ListD a 102 | 103 | 104 | ----- UnsafeCoerce implementation (cheating, nonrecursive) ---------------- 105 | newtype CoerceD t xs = CoerceD (forall ys. t ys -> t (xs :++: ys)) 106 | 107 | instance Difference CoerceD where 108 | zeroD = CoerceD id 109 | plusD (CoerceD fx :: CoerceD t xs) (CoerceD fy :: CoerceD t ys) = 110 | CoerceD (\(zs :: t zs) -> 111 | case assoc2 (proxy :: Proxy xs) (proxy :: Proxy ys) (proxy :: Proxy zs) of 112 | Equal -> fx (fy zs)) 113 | mkOneD f = CoerceD f 114 | evalD nil (CoerceD f :: CoerceD t xs) = 115 | case rightIdent2 (proxy :: Proxy xs) of 116 | Equal -> f nil 117 | 118 | assoc2 :: Proxy a -> Proxy b -> Proxy c -> (a :++: (b :++: c)) :==: ((a :++: b) :++: c) 119 | assoc2 _ _ _ = unsafeCoerce Equal 120 | 121 | rightIdent2 :: Proxy a -> (a :++: '[]) :==: a 122 | rightIdent2 _ = unsafeCoerce Equal 123 | 124 | -------------------------------------------------------------------------------- /Data/Pattern/Common.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module: Data.Pattern.Common 4 | -- License: BSD3 5 | -- Maintainer: Brent Yorgey 6 | -- Stability: experimental 7 | -- Portability: non-portable (see .cabal) 8 | -- 9 | -- A collection of useful pattern combinators. 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | module Data.Pattern.Common ( 15 | 16 | -- * Pattern combinators 17 | -- ** Basic patterns 18 | var, give, __, pfail, cst, (/\), (\/), 19 | view, (-->), tryView, (-?>), 20 | is, 21 | 22 | -- ** Computational patterns 23 | pfilter, pmap, pfoldr, 24 | 25 | -- * Running matches 26 | match, tryMatch, mmatch, 27 | elim, 28 | 29 | -- * Patterns for common data types 30 | -- ** Booleans 31 | true, false, 32 | -- ** Tuples 33 | -- $tuples 34 | unit, tup0, pair, tup2, tup3, tup4, tup5, 35 | -- ** @Maybe@ 36 | nothing, just, 37 | -- ** @Either@ 38 | left, right, 39 | -- ** Lists 40 | nil, cons, 41 | -- ** Numerics 42 | zero, suc, 43 | 44 | -- * Building your own patterns 45 | -- ** Smart constructors for patterns 46 | -- | Build patterns from a selector function. 47 | mk0, mk1, mk2, mk3, mk4, mk5, 48 | 49 | ) where 50 | 51 | import Data.Pattern.Base 52 | 53 | import Control.Applicative 54 | import Control.Monad 55 | import Control.Monad.Trans.Reader 56 | 57 | import qualified Data.Foldable as F 58 | import qualified Data.Traversable as T 59 | 60 | import Data.Maybe 61 | 62 | 63 | ------------------------------------------------------------ 64 | -- Basic patterns 65 | 66 | -- XXX todo: add examples of each combinator! 67 | 68 | -- | Variable pattern: always succeeds, and binds the value to a variable. 69 | var :: Pattern '[a] a 70 | var = Pattern (Just . oneT) 71 | 72 | -- | @give b@ always succeeds, ignoring the matched value and 73 | -- providing the value @b@ instead. Useful in conjunction with 74 | -- @('/\')@ for providing default values in cases that would otherwise 75 | -- not bind any values. 76 | give :: b -> Pattern '[b] a 77 | give b = Pattern (const (Just $ oneT b)) 78 | 79 | -- | Wildcard pattern: always succeeds, binding no variables. (This is 80 | -- written as two underscores.) 81 | __ :: Pattern '[] a 82 | __ = is (const True) 83 | 84 | -- | Failure pattern: never succeeds. 85 | pfail :: Pattern '[] a 86 | pfail = is (const False) 87 | 88 | -- | Predicate pattern. Succeeds if the given predicate yields 'True', 89 | -- fails otherwise. 90 | -- 91 | -- Can be used with @('/\')@ for some uses similar to pattern guards: 92 | -- 93 | -- > match a $ 94 | -- > left (var /\ is even) ->> id 95 | -- > <|> left __ ->> const 0 96 | -- > <|> right __ ->> const 1 97 | -- 98 | -- Note that 'is' is like 'mk0' but with 'Bool' instead of @'Maybe' 99 | -- ()@. 100 | is :: (a -> Bool) -> Pattern '[] a 101 | is g = mk0 (\a -> if g a then Just () else Nothing) 102 | 103 | -- | Constant pattern: test for equality to the given constant. 104 | -- 105 | -- @cst x = is (==x)@. 106 | cst :: (Eq a) => a -> Pattern '[] a 107 | cst x = is (==x) 108 | 109 | -- | Conjunctive (and) pattern: matches a value against two patterns, 110 | -- and succeeds only if both succeed, binding variables from both. 111 | -- 112 | -- @(/\\) = 'mk2' (\\a -> Just (a,a))@ 113 | (/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a 114 | (/\) = mk2 (\a -> Just (a,a)) 115 | 116 | -- | Disjunctive (or) pattern: matches a value against the first 117 | -- pattern, or against the second pattern if the first one fails. 118 | (\/) :: Pattern as a -> Pattern as a -> Pattern as a 119 | (Pattern l) \/ (Pattern r) = Pattern (\a -> l a `mplus` r a) 120 | 121 | -- | View pattern: do some computation, then pattern match on the 122 | -- result. 123 | view :: (a -> b) -> Pattern vs b -> Pattern vs a 124 | view f = mk1 (Just . f) 125 | 126 | -- ->> is infix 4, so this ought to have higher precedence 127 | infix 5 --> 128 | 129 | -- | Convenient infix synonym for 'view'. 130 | (-->) :: (a -> b) -> Pattern vs b -> Pattern vs a 131 | (-->) = view 132 | 133 | -- | Partial view pattern: do some (possibly failing) computation, 134 | -- then pattern match on the result if the computation is successful. 135 | tryView :: (a -> Maybe b) -> Pattern vs b -> Pattern vs a 136 | tryView = mk1 137 | 138 | infix 5 -?> 139 | 140 | -- | Convenient infix synonym for 'tryView'. 141 | (-?>) :: (a -> Maybe b) -> Pattern vs b -> Pattern vs a 142 | (-?>) = tryView 143 | 144 | 145 | ------------------------------------------------------------ 146 | -- Computational patterns 147 | 148 | -- XXX use (Tup vs ': '[]) or something like that instead of (Map [] vs)? 149 | 150 | -- | @pfilter p@ matches every element of a 'F.Foldable' data structure 151 | -- against the pattern @p@, discarding elements that do not match. 152 | -- From the matching elements, binds a list of values corresponding 153 | -- to each pattern variable. 154 | pfilter :: (Distribute vs, F.Foldable t) => Pattern vs a -> Pattern (Map [] vs) (t a) 155 | pfilter (Pattern p) = Pattern $ Just . distribute . catMaybes . map p . F.toList 156 | 157 | -- | @pmap p@ matches every element of a 'T.Traversable' data 158 | -- structure against the pattern @p@. The entire match fails if any 159 | -- of the elements fail to match @p@. If all the elements match, 160 | -- binds a @t@-structure full of bound values corresponding to each 161 | -- variable bound in @p@. 162 | pmap :: (Distribute vs, T.Traversable t) => Pattern vs a -> Pattern (Map t vs) (t a) 163 | pmap (Pattern p) = Pattern $ fmap distribute . T.traverse p 164 | 165 | -- | @pfoldr p f b@ matches every element of a 'F.Foldable' data 166 | -- structure against the pattern @p@, discarding elements that do 167 | -- not match. Folds over the bindings produced by the matching 168 | -- elements to produce a summary value. 169 | -- 170 | -- The same functionality could be achieved by matching with 171 | -- @pfilter p@ and then appropriately combining and folding the 172 | -- resulting lists of bound values. In particular, if @p@ binds 173 | -- only one value we have 174 | -- 175 | -- > match t (pfoldr p f b ->> id) === match t (pfilter p ->> foldr f b) 176 | -- 177 | -- However, when @p@ binds more than one value, it can be convenient 178 | -- to be able to process the bindings from each match together, 179 | -- rather than having to deal with them once they are separated out 180 | -- into separate lists. 181 | pfoldr :: (F.Foldable t, Functor t) => Pattern vs a -> (Fun vs (b -> b)) -> b -> Pattern '[b] (t a) 182 | pfoldr (Pattern p) f b = Pattern $ Just . oneT . foldr (flip runTuple f) b . catMaybes . F.toList . fmap p 183 | 184 | 185 | ------------------------------------------------------------ 186 | -- Running matches 187 | 188 | -- | \"Runs\" a 'Clause', by matching it against a value and returning 189 | -- a result if it matches, or @Nothing@ if the match fails. 190 | tryMatch :: a -> Clause a r -> Maybe r 191 | tryMatch = flip (runReaderT.runClause) 192 | 193 | -- | 'match' satisfies the identity @match a c = fromJust (tryMatch a c)@. 194 | match :: a -> Clause a r -> r 195 | match = (fmap.fmap) (fromMaybe $ error "failed match") tryMatch 196 | 197 | -- | @mmatch m p = m >>= 'elim' p@ 198 | -- 199 | -- Useful for applicative-looking monadic pattern matching, as in 200 | -- 201 | -- > ex7 :: IO () 202 | -- > ex7 = mmatch getLine $ 203 | -- > cst "" ->> return () 204 | -- > <|> var ->> putStrLn . ("You said " ++) 205 | mmatch :: (Monad m) => m a -> Clause a (m b) -> m b 206 | mmatch m p = m >>= elim p 207 | 208 | -- | @elim = flip 'match'@ 209 | -- 210 | -- Useful for anonymous matching (or for building \"eliminators\", 211 | -- like 'maybe' and 'either'). For example: 212 | -- 213 | -- > either withLeft withRight = elim $ 214 | -- > left var ->> withLeft 215 | -- > <|> right var ->> withRight 216 | elim :: Clause a r -> a -> r 217 | elim = flip match 218 | 219 | 220 | ------------------------------------------------------------ 221 | -- Boolean patterns 222 | 223 | -- | Match @True@. 224 | true :: Pattern '[] Bool 225 | true = is id 226 | 227 | -- | Match @False@. 228 | false :: Pattern '[] Bool 229 | false = is not -- is too! 230 | 231 | 232 | ------------------------------------------------------------ 233 | -- Tuple patterns 234 | 235 | -- $tuples 236 | -- 237 | -- If you need to pattern match on tuples bigger than 5-tuples, you 238 | -- are Doing It Wrong. 239 | 240 | -- | A strict match on the unit value @()@. 241 | unit :: Pattern '[] () 242 | unit = mk0 (\() -> Just ()) 243 | 244 | -- | A synonym for 'unit'. 245 | tup0 :: Pattern '[] () 246 | tup0 = unit 247 | 248 | -- | Construct a pattern match against a pair from a pair of patterns. 249 | pair :: Pattern vs1 a -> Pattern vs2 b -> Pattern (vs1 :++: vs2) (a,b) 250 | pair (Pattern pa) (Pattern pb) = Pattern (\(a,b) -> (<+>) <$> pa a <*> pb b) 251 | 252 | -- | A synonym for 'pair'. 253 | tup2 :: Pattern vs1 a -> Pattern vs2 b -> Pattern (vs1 :++: vs2) (a,b) 254 | tup2 = pair 255 | 256 | -- | Match a 3-tuple. 257 | tup3 :: Pattern vs1 a -> 258 | Pattern vs2 b -> 259 | Pattern vs3 c -> 260 | Pattern (vs1 :++: vs2 :++: vs3) (a,b,c) 261 | tup3 (Pattern pa) (Pattern pb) (Pattern pc) = 262 | Pattern (\(a,b,c) -> (<+>) <$> pa a <*> ((<+>) <$> pb b <*> pc c)) 263 | 264 | -- | Match a 4-tuple. 265 | tup4 :: Pattern vs1 a -> 266 | Pattern vs2 b -> 267 | Pattern vs3 c -> 268 | Pattern vs4 d -> 269 | Pattern (vs1 :++: vs2 :++: vs3 :++: vs4) (a,b,c,d) 270 | tup4 (Pattern pa) (Pattern pb) (Pattern pc) (Pattern pd) = 271 | Pattern (\(a,b,c,d) -> (<+>) <$> pa a <*> ((<+>) <$> pb b <*> ((<+>) <$> pc c <*> pd d))) 272 | 273 | -- | Match a 5-tuple. 274 | tup5 :: Pattern vs1 a -> 275 | Pattern vs2 b -> 276 | Pattern vs3 c -> 277 | Pattern vs4 d -> 278 | Pattern vs5 e -> 279 | Pattern (vs1 :++: vs2 :++: vs3 :++: vs4 :++: vs5) (a,b,c,d,e) 280 | tup5 (Pattern pa) (Pattern pb) (Pattern pc) (Pattern pd) (Pattern pe) = 281 | Pattern (\(a,b,c,d,e) -> (<+>) <$> pa a <*> ((<+>) <$> pb b <*> ((<+>) <$> pc c <*> ((<+>) <$> pd d <*> pe e)))) 282 | 283 | 284 | ------------------------------------------------------------ 285 | -- Maybe 286 | 287 | -- | Match the 'Nothing' constructor of 'Maybe'. 288 | nothing :: Pattern '[] (Maybe a) 289 | nothing = is isNothing 290 | 291 | -- | Match the 'Just' constructor of 'Maybe'. 292 | just :: Pattern vs a -> Pattern vs (Maybe a) 293 | just = mk1 id 294 | 295 | 296 | ------------------------------------------------------------ 297 | -- Either 298 | 299 | -- | Match the 'Left' constructor of 'Either'. 300 | left :: Pattern vs a -> Pattern vs (Either a b) 301 | left = mk1 (either Just (const Nothing)) 302 | 303 | -- | Match the 'Right' constructor of 'Either'. 304 | right :: Pattern vs b -> Pattern vs (Either a b) 305 | right = mk1 (either (const Nothing) Just) 306 | 307 | 308 | ------------------------------------------------------------ 309 | -- Lists 310 | 311 | -- | Match the empty list. 312 | nil :: Pattern '[] [a] 313 | nil = is null 314 | 315 | -- | Match a cons. 316 | cons :: Pattern vs1 a -> Pattern vs2 [a] -> Pattern (vs1 :++: vs2) [a] 317 | cons = mk2 (\l -> case l of { (x:xs) -> Just (x,xs); _ -> Nothing }) 318 | 319 | 320 | ------------------------------------------------------------ 321 | -- Numerics 322 | 323 | -- | Match zero. 324 | zero :: (Integral a, Eq a) => Pattern '[] a 325 | zero = cst 0 326 | 327 | -- | Match a natural number which is the successor of another natural 328 | -- (and match the predecessor with a nested pattern). Together, 329 | -- 'zero' and 'suc' allow viewing @Integral@ types as Peano numbers. 330 | -- 331 | -- Note that 'suc' never matches negative numbers. 332 | suc :: (Integral a, Eq a) => Pattern vs a -> Pattern vs a 333 | suc = mk1 (\n -> if (n <= 0) then Nothing else Just (n-1)) 334 | 335 | 336 | -- XXX better names? and export 337 | twice :: (Integral a, Eq a) => Pattern vs a -> Pattern vs a 338 | twice = mk1 (\n -> if even n then Just (n `div` 2) else Nothing) 339 | 340 | succtwice :: (Integral a, Eq a) => Pattern vs a -> Pattern vs a 341 | succtwice = mk1 (\n -> if odd n then Just (n `div` 2) else Nothing) 342 | 343 | 344 | 345 | ------------------------------------------------------------ 346 | -- Constructing patterns 347 | 348 | mk0 :: (a -> Maybe ()) -> Pattern '[] a 349 | mk0 g = Pattern (fmap (const zeroT) . g) 350 | 351 | mk1 :: (a -> Maybe b) -> Pattern vs b -> Pattern vs a 352 | mk1 g (Pattern p) = Pattern (\a -> g a >>= p) 353 | 354 | mk2 :: (a -> Maybe (b,c)) -> 355 | Pattern vs1 b -> 356 | Pattern vs2 c -> 357 | Pattern (vs1 :++: vs2) a 358 | mk2 g b c = mk1 g (pair b c) 359 | 360 | mk3 :: (a -> Maybe (b,c,d)) -> 361 | Pattern vs1 b -> 362 | Pattern vs2 c -> 363 | Pattern vs3 d -> 364 | Pattern (vs1 :++: vs2 :++: vs3) a 365 | mk3 g b c d = mk1 g (tup3 b c d) 366 | 367 | mk4 :: (a -> Maybe (b,c,d,e)) -> 368 | Pattern vs1 b -> 369 | Pattern vs2 c -> 370 | Pattern vs3 d -> 371 | Pattern vs4 e -> 372 | Pattern (vs1 :++: vs2 :++: vs3 :++: vs4) a 373 | mk4 g b c d e = mk1 g (tup4 b c d e) 374 | 375 | mk5 :: (a -> Maybe (b,c,d,e,f)) -> 376 | Pattern vs1 b -> 377 | Pattern vs2 c -> 378 | Pattern vs3 d -> 379 | Pattern vs4 e -> 380 | Pattern vs5 f -> 381 | Pattern (vs1 :++: vs2 :++: vs3 :++: vs4 :++: vs5) a 382 | mk5 g b c d e f = mk1 g (tup5 b c d e f) 383 | 384 | 385 | 386 | -- XXX de Bruijn references for nonlinear patterns? 387 | {- 388 | data Ref :: * -> * -> * 389 | RZero :: Ref (h ': t) h 390 | RSucc :: Ref t a -> Ref (h ': t) a 391 | 392 | -- Can't implement this with the current definition of Pattern -- 393 | -- there is no way to access previously matched values. Plus the type 394 | -- will be a problem: can't infer the type xs that the reference is 395 | -- indexing into, since the reference itself doesn't bind any 396 | -- variables. 397 | -- 398 | -- Essentially what it boils down to is that this pattern is rather 399 | -- non-compositional. =( 400 | ref :: Ref xs a -> Pattern '[] a 401 | ref = undefined 402 | -} 403 | --------------------------------------------------------------------------------