diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Adam Vogt + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Adam Vogt nor the names of other + 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 +OWNER 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. diff --git a/OrPatterns.cabal b/OrPatterns.cabal new file mode 100644 --- /dev/null +++ b/OrPatterns.cabal @@ -0,0 +1,61 @@ +name: OrPatterns +version: 0.1 +synopsis: A quasiquoter for or-patterns +description: A quasiquoter for or-patterns. It allows one additional + form for patterns: + . + > f [o| p1 | p2 | p3 |] = rhs + . + Above, @p1@, @p2@ and @p3@ are three arbitrary patterns + that bind the same variables. These variables are + available in the expression @rhs@. Nesting of or-patterns + is not supported yet. + . + See also: + . + * http://hackage.haskell.org/package/first-class-patterns + supports @\\\/@ (or). However, variables bound with + those patterns are not named. This means: + . + > g :: Either (x, y) (y, x) -> (x, y) + > g [o| Left (x,y) | Right (y,x) |] = (x,y) + . + > -- ends up slightly longer + > g = elim $ left (pair var var) \/ right flipped ->> (,) + > where + > flipped = (\(a,b) -> (b,a)) --> pair var var + . + * http://hackage.haskell.org/trac/ghc/ticket/3919 + is the feature request for or-patterns in ghc + +license: BSD3 +license-file: LICENSE +author: Adam Vogt +maintainer: Adam Vogt +category: Development +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.8.2, + GHC == 7.6.2, + GHC == 7.4.1 + +source-repository head + type: darcs + location: http://code.haskell.org/~aavogt/OrPatterns + + +library + exposed-modules: OrPatterns + OrPatterns.Internal + other-extensions: TemplateHaskell + + build-depends: base >=4.5 && <4.8, + template-haskell >=2.4 && <2.10, + mtl >=2.1 && <2.2, + syb >=0.4 && <0.5, + split >=0.2 && <0.3, + haskell-src-meta >=0.6 && <0.7, + haskell-src-exts >=1.15 && <1.16, + containers >=0.3 && <0.6 + + default-language: Haskell2010 diff --git a/OrPatterns.hs b/OrPatterns.hs new file mode 100644 --- /dev/null +++ b/OrPatterns.hs @@ -0,0 +1,82 @@ +{- | + Module : OrPatterns + Copyright : (c) Adam Vogt 2011 - 2014 + License : BSD3 + Maintainer : Adam Vogt + Stability : experimental + Portability : GHC>=7 -XTemplateHaskell, -XViewPatterns + + +Quasiquoter for /or patterns/ separated by @\" | \"@, like other languages +(ML family). + + +Example: + + +>>> :set -XQuasiQuotes -XViewPatterns -w + + +>>> :{ +>>> let f :: Either (a,b) (b,a) -> (a,b) +>>> f [o| Left (x,y) | Right (y,x) |] = (x,y) +>>> :} + + +>>> map f [Left ('a',0), Right (2, 'b')] +[('a',0),('b',2)] + + +A more confusing example (to show that the string " | " is interpreted +correctly by the parser): + +>>> :{ +>>> let g [o| " | " | "|||" | " | " |] = True +>>> g _ = False +>>> :} + +>>> map g [ "|", " | " , "|||" , " | "] +[False,True,True,True] + + +f is desugared to something like: + +> f ( (\v -> case v of +> Left (x,y) -> Just (x,y) +> Right (y,x) -> Just (x,y) +> _ -> Nothing +> ) -> Just (x,y) ) = (x,y) + +So failing to match will pass on to the next equation. + +Limitations include: + +* compilation could probably be more efficient + +* incorrect patterns, such as those binding the wrong variables or the wrong + number of variables could be reported better + +* generated code can have overlapped patterns, and so -Wall doesn't help the + above example. Duplicating or using ghc's check for this should be done, + in which case the the desugared code should look like /f2/. + +> f2 ( (\v -> case v of +> Left (x,y) -> (x,y) +> Right (y,x) -> (x,y)) +> -> a) = a + + +-} + +module OrPatterns ( o ) where + +import Language.Haskell.TH.Quote +import OrPatterns.Internal + + +-- | or pattern quasiquote. See above. +o :: QuasiQuoter +o = QuasiQuoter { quotePat = either fail id . pats, + quoteExp = error "OrPatterns.quoteExp", + quoteType = error "OrPatterns.quoteType", + quoteDec = error "OrPatterns.quoteDec" } diff --git a/OrPatterns/Internal.hs b/OrPatterns/Internal.hs new file mode 100644 --- /dev/null +++ b/OrPatterns/Internal.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | + Module : OrPatterns.Internal + Copyright : (c) Adam Vogt 2011 - 2014 + License : BSD3 + Maintainer : Adam Vogt + Stability : experimental + Portability : GHC>=7 -XTemplateHaskell, -XViewPatterns, syb + +-} + +module OrPatterns.Internal ( + pats, + tryParseSplits, + combineSplits, + ) where + +import Control.Monad.Error +import Data.Generics +import Data.List.Split +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.Meta.Syntax.Translate (ToPat(toPat)) +import qualified Language.Haskell.Exts as E +import qualified Data.Map as M +import Data.List + +-- | parser used in 'OrPatterns.o' +pats :: String -> Either String PatQ +pats str = combineSplits =<< tryParseSplits sep parsePatAllExts (splitOn sep str) + where sep = " | " + +tryParseSplits :: [s] -> ([s] -> Either e r) -> [[s]] -> Either e [r] +tryParseSplits filler parsePat pieces = + let go accum (a:b:bs) = case parsePat a of + Left {} -> go accum ((a ++ filler ++ b) : bs) + Right x -> go (x:accum) (b:bs) + go accum [a] = case parsePat a of + Left msg -> Left msg + Right x -> Right (reverse (x : accum)) + go accum [] = Right (reverse accum) + in go [] pieces + +combineSplits :: [Pat] -> Either String PatQ +combineSplits opts = do + let counts = map + (everything + (M.unionWith (+)) + (mkQ M.empty (\x -> case x of + VarP n -> M.singleton n 1 + _ -> M.empty)) + ) + opts + -- assume that patterns may not repeat names of variables + unless (all (== length counts) $ M.elems $ M.unionsWith (+) counts) + (fail "Equations do not bind equal variables") + + let vars = M.keys (head counts) + dest = [| Just $(tupE (map varE vars)) |] + destP = conP 'Just [ tupP (map varP vars) ] + + return $ viewP + [| \x -> $(caseE [| x |] $ + [ match (return p) (normalB dest) [] | p <- opts] + ++ [match wildP (normalB [| Nothing |]) []] + ) + |] + destP + + +parsePatAllExts :: String -> Either String Pat +parsePatAllExts str = toEither $ E.parsePatWithMode allExtensionsMode str + +toEither :: (ToPat a, Show a) => E.ParseResult a -> Either String Pat +toEither (E.ParseOk x) = Right (toPat x) +toEither err = Left (show err) + +allExtensionsMode :: E.ParseMode +allExtensionsMode = + E.defaultParseMode{ + E.fixities = Nothing, -- these get filled in later + E.extensions = map E.EnableExtension [ + E.ImplicitParams, + E.BangPatterns, + E.NamedFieldPuns, + E.PatternGuards, + E.TypeFamilies, + E.UnicodeSyntax, + E.TypeOperators, + E.RecordWildCards, + E.LambdaCase, + E.ViewPatterns, + E.TupleSections, + E.NPlusKPatterns, + E.DataKinds, + E.PolyKinds, + E.MultiWayIf ]} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain