egison-pattern-src 0.1.1.0 → 0.2.0.0

raw patch · 21 files changed

+396/−157 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +3/−2
• egison-pattern-src.cabal +5/−1
• src/Language/Egison/Parser/Pattern.hs +48/−36
• src/Language/Egison/Parser/Pattern/Expr.hs +14/−5
• src/Language/Egison/Parser/Pattern/Parsable.hs +60/−0
• src/Language/Egison/Parser/Pattern/Prim.hs +2/−8
• src/Language/Egison/Parser/Pattern/Prim/Error.hs +2/−0
• src/Language/Egison/Parser/Pattern/Prim/Parse.hs +30/−11
• src/Language/Egison/Parser/Pattern/Prim/ParseMode.hs +2/−1
• src/Language/Egison/Parser/Pattern/Prim/Source.hs +34/−3
• src/Language/Egison/Parser/Pattern/Token.hs +17/−11
• src/Language/Egison/Pretty/Pattern.hs +26/−13
• src/Language/Egison/Pretty/Pattern/Context.hs +1/−1
• src/Language/Egison/Pretty/Pattern/Prim.hs +2/−0
• src/Language/Egison/Syntax/Pattern/Combinator.hs +36/−28
• src/Language/Egison/Syntax/Pattern/Expr.hs +4/−0
• src/Language/Egison/Syntax/Pattern/Fixity/Primitive.hs +0/−4
• test/Language/Egison/Parser/PatternSpec.hs +55/−6
• test/Language/Egison/Pretty/PatternSpec.hs +28/−9
• test/TestImport.hs +11/−18

@@ -1,3 +1,19 @@+## 0.2.0.0++Breaking changes:+- Add a tuple pattern [#12](https://github.com/egison/egison-pattern-src/issues/12)+- Add a collection pattern [#17](https://github.com/egison/egison-pattern-src/issues/17)+- `UnexpectedEndOfFile` error variant is added for greedy parsers (change in [#19](https://github.com/egison/egison-pattern-src/issues/19))+- The name of parsing file is passed in `ParseMode`, not in the argument of `parseExpr` (change in [#19](https://github.com/egison/egison-pattern-src/issues/19))+- Fix syntax of constructor patterns [#18](https://github.com/egison/egison-pattern-src/issues/18)+  * We do not require constructor patterns to be parenthaized++Non-breacking changes:+- Add non-greedy parsers [#19](https://github.com/egison/egison-pattern-src/issues/19)+  * Variants of parsers are provided via `Parsable` class+- not patterns are now parsed as atom patterns (change in [#18](https://github.com/egison/egison-pattern-src/issues/18))+- `Source` type constraint is now just a type class providing few additional methods to `Stream` (change in [#19](https://github.com/egison/egison-pattern-src/issues/19))+ ## 0.1.1.0  Nothing changed (updated as other two adaptor packages)

@@ -17,12 +17,13 @@     | $v                    (pattern variable)     | #e                    (value pattern)     | ?e                    (predicate pattern)+    | (p_1, p_2, ..., p_n)  (tuple pattern)+    | [p_1, p_2, ..., p_n]  (collection pattern)     | p & p                 (and pattern)     | p | p                 (or pattern)     | !p                    (not pattern)     | p op p                (user-defined infix pattern)-    | x                     (constructor pattern without argument)-    | (x p_1 p_2 ... p_n)   (constructor pattern with arguments)+    | x p_1 p_2 ... p_n     (constructor pattern) ```  ## License

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               egison-pattern-src-version:            0.1.1.0+version:            0.2.0.0 synopsis:   Manipulating Egison patterns: abstract syntax, parser, and pretty-printer @@ -53,6 +53,7 @@   other-modules:     Language.Egison.Parser.Pattern.Combinator     Language.Egison.Parser.Pattern.Expr+    Language.Egison.Parser.Pattern.Parsable     Language.Egison.Parser.Pattern.Prim     Language.Egison.Parser.Pattern.Prim.Error     Language.Egison.Parser.Pattern.Prim.Location@@ -81,6 +82,7 @@   default-language:   Haskell2010   default-extensions:     ConstraintKinds+    DefaultSignatures     DeriveDataTypeable     DeriveFoldable     DeriveFunctor@@ -93,6 +95,7 @@     FlexibleInstances     GeneralizedNewtypeDeriving     KindSignatures+    MultiParamTypeClasses     NamedFieldPuns     OverloadedStrings     RankNTypes@@ -123,6 +126,7 @@     GeneralizedNewtypeDeriving     NamedFieldPuns     OverloadedStrings+    TypeApplications    -- cabal-fmt: expand test   other-modules:

@@ -6,10 +6,11 @@ -- -- A parser for Egison patterns. +{-# OPTIONS_GHC -Wno-orphans #-}+ module Language.Egison.Parser.Pattern-  ( parseExprL-  , parseExpr-  -- * Re-exports+  ( parseExpr+  , parseExprL   , module X   ) where@@ -39,11 +40,16 @@ import           Language.Egison.Parser.Pattern.Token                                                as X                                                 ( IsToken(..) )+import           Language.Egison.Parser.Pattern.Parsable+                                               as X+                                                ( Parsable(..) )  -- main import           Control.Monad.Except           ( MonadError ) import           Control.Applicative            ( (<|>) )-import           Control.Monad.Combinators      ( many )+import           Control.Monad.Combinators      ( many+                                                , sepBy+                                                ) import           Control.Comonad.Cofree         ( unwrap )  import           Language.Egison.Parser.Pattern.Prim@@ -54,7 +60,6 @@                                                 , name                                                 , varName                                                 , valueExpr-                                                , try                                                 , (<?>)                                                 ) import           Language.Egison.Parser.Pattern.Combinator@@ -63,39 +68,27 @@                                                 ) import           Language.Egison.Parser.Pattern.Expr                                                 ( exprParser+                                                , atomParser                                                 , Table(..)                                                 , initTable                                                 , addInfix-                                                , addPrefix                                                 ) import qualified Language.Egison.Parser.Pattern.Token                                                as Token-                                                ( underscore-                                                , hash-                                                , question-                                                , exclamation-                                                , and-                                                , vertical-                                                , dollar-                                                )+                                                ( IsToken(..) ) import qualified Language.Egison.Syntax.Pattern.Fixity.Primitive                                                as PrimOp import           Language.Egison.Syntax.Pattern.Expr                                                 ( Expr ) import           Language.Egison.Syntax.Pattern.Base                                                 ( ExprF(..) )-import           Language.Egison.Syntax.Pattern.Combinator-                                                ( unAnnotate )   primInfixes   :: Source s   => [(Precedence, Table (Parse n v e s) (ExprF n v e) (ExprL n v e))] primInfixes =-  [ ( PrimOp.notPrecedence-    , addPrefix (NotF <$ token Token.exclamation) initTable-    )-  , ( PrimOp.andPrecedence+  [ ( PrimOp.andPrecedence     , addInfix PrimOp.andAssociativity (AndF <$ token Token.and) initTable     )   , ( PrimOp.orPrecedence@@ -125,43 +118,62 @@   pure $ PredicateF e  constr :: Source s => Parse n v e s (ExprF n v e (ExprL n v e))-constr = withArgs <|> withoutArgs- where-  withArgs = parens $ do-    n  <- lexeme name-    es <- many expr-    pure $ PatternF n es-  withoutArgs = do-    n <- lexeme name-    pure $ PatternF n []+constr = do+  n  <- lexeme name+  es <- many $ atomParser atom+  pure $ PatternF n es +collection :: Source s => Parse n v e s (ExprF n v e (ExprL n v e))+collection = do+  token Token.bracketLeft+  es <- expr `sepBy` token Token.comma+  token Token.bracketRight+  pure $ CollectionF es++not_ :: Source s => Parse n v e s (ExprF n v e (ExprL n v e))+not_ = do+  token Token.exclamation+  e <- atomParser atom+  pure $ NotF e++tupleOrParens :: Source s => Parse n v e s (ExprF n v e (ExprL n v e))+tupleOrParens = parens $ do+  es <- expr `sepBy` token Token.comma+  pure $ case es of+    [x] -> unwrap x  -- parens, discarding location once+    _   -> TupleF es  -- tuple+ atom :: Source s => Parse n v e s (ExprF n v e (ExprL n v e)) atom =-  try (unwrap <$> parens expr) -- discarding location once-    <|> wildcard+  wildcard     <|> variable+    <|> not_     <|> value+    <|> collection     <|> constr     <|> predicate+    <|> tupleOrParens     <?> "atomic pattern"  expr :: Source s => Parse n v e s (ExprL n v e) expr = exprParser primInfixes atom +instance Source s => Parsable (Expr n v e) s (ParseMode n v e s) where+  parseNonGreedyWithLocation = runParse (space *> expr)+ -- | Parse 'Expr' with locations annotated. parseExprL-  :: (Source s, MonadError (Errors s) m)+  :: forall m s n v e+   . (Source s, MonadError (Errors s) m)   => ParseMode n v e s-  -> FilePath   -> s   -> m (ExprL n v e)-parseExprL = runParse (space *> expr)+parseExprL = parseWithLocation @(Expr n v e)  -- | Parse 'Expr'. parseExpr   :: (Source s, MonadError (Errors s) m)   => ParseMode n v e s-  -> FilePath   -> s   -> m (Expr n v e)-parseExpr mode path = fmap unAnnotate . parseExprL mode path+parseExpr = parse

@@ -9,6 +9,7 @@ module Language.Egison.Parser.Pattern.Expr   ( ExprL   , exprParser+  , atomParser   , Table(..)   , initTable   , addInfix@@ -84,16 +85,17 @@ addPrefix :: m (a -> f a) -> Table m f a -> Table m f a addPrefix op table@Table { prefix } = table { prefix = op : prefix } +locate :: Locate m => m (f (Cofree f Location)) -> m (Cofree f Location)+locate m = do+  (x, loc) <- getLocation m+  pure (loc :< x)+ makeExprParser   :: (Alternative m, Locate m)   => m (f (Cofree f Location))   -> [Table m f (Cofree f Location)]   -> m (Cofree f Location) makeExprParser atom = foldl addPrecLevel $ locate atom- where-  locate m = do-    (x, loc) <- getLocation m-    pure (loc :< x)  addPrecLevel   :: (Alternative m, Locate m)@@ -159,7 +161,7 @@   addPrecToTable prec f = adjustWithDefault f (f initTable) $ Prec.toInt prec   adjustWithDefault f def = IntMap.alter (Just . maybe def f) --- | Build an v expression parser with location information, from an atom parser.+-- | Build an expression parser with location information, from an atom parser. exprParser   :: Source s   => [(Precedence, Table (Parse n v e s) (ExprF n v e) (ExprL n v e))]@@ -168,3 +170,10 @@ exprParser primInfixes atom = do   ops <- buildOperatorTable primInfixes   makeExprParser atom ops++-- | Build an atom parser with location information, from an atom parser. (i.e. just adds a location information)+atomParser+  :: Source s+  => Parse n v e s (ExprF n v e (ExprL n v e))+  -> Parse n v e s (ExprL n v e)+atomParser = locate

@@ -0,0 +1,60 @@+-- |+--+-- Module:      Language.Egison.Parser.Pattern.Parsable+-- Description: Type class providing functions for parsing+-- Stability:   experimental+--+-- This module provides a type class for parsing many types.++{-# LANGUAGE AllowAmbiguousTypes #-}++module Language.Egison.Parser.Pattern.Parsable+  ( Parsable(..)+  )+where++import           Control.Monad                  ( unless )+import           Control.Monad.Except           ( MonadError(..) )+import           Data.Bifunctor                 ( first )+import           Control.Comonad.Cofree         ( Cofree )+import           Control.Comonad.Trans.Cofree   ( CofreeF(..) )+import           Data.Functor.Foldable          ( Base+                                                , Recursive(..)+                                                , Corecursive(..)+                                                )++import           Language.Egison.Parser.Pattern.Prim.Location+                                                ( Location )+import           Language.Egison.Parser.Pattern.Prim.Source+                                                ( Source(..) )+import           Language.Egison.Parser.Pattern.Prim.Error+                                                ( Errors )+import qualified Language.Egison.Parser.Pattern.Prim.Error+                                               as Error+                                                ( Error(..) )+++unAnnotate :: (Recursive x, Corecursive x) => Cofree (Base x) a -> x+unAnnotate = cata go where go (_ :< x) = embed x++-- | Type class providing functions for parsing.+class Source s => Parsable a s mode where+  -- | Parse a source stream.+  parse :: MonadError (Errors s) m => mode -> s -> m a+  -- | Parse a source stream with location annotations.+  parseWithLocation :: MonadError (Errors s) m => mode -> s -> m (Cofree (Base a) Location)+  -- | Parse a source stream non-greedily. That is, this parser will only consume the input until a is fully parsed, and return the rest of the input.+  parseNonGreedy :: MonadError (Errors s) m => mode -> s -> m (a, s)+  -- | Parse a source stream non-greedily with location annotations.+  parseNonGreedyWithLocation :: MonadError (Errors s) m => mode -> s -> m (Cofree (Base a) Location, s)++  parseWithLocation mode s = do+    (a, rest) <- parseNonGreedyWithLocation @a mode s+    unless (eof rest) . throwError . pure . Error.UnexpectedEndOfFile $ tokens rest+    pure a++  default parseNonGreedy :: (Recursive a, Corecursive a, MonadError (Errors s) m) => mode -> s -> m (a, s)+  parseNonGreedy mode = fmap (first unAnnotate) . parseNonGreedyWithLocation @a mode++  default parse :: (Recursive a, Corecursive a, MonadError (Errors s) m) => mode -> s -> m a+  parse mode = fmap unAnnotate . parseWithLocation @a mode

@@ -50,7 +50,6 @@                                                 )  -- main-import           Data.Proxy                     ( Proxy(..) ) import           Control.Monad                  ( void ) import           Control.Monad.Reader           ( ask ) import           Control.Applicative            ( Alternative((<|>))@@ -61,9 +60,6 @@                                                 , takeWhileP                                                 , manyTill                                                 , chunk-                                                , chunkToTokens-                                                , tokensToChunk-                                                , Stream(..)                                                 , customFailure                                                 , single                                                 , anySingle@@ -93,7 +89,7 @@                                                 )  import           Language.Egison.Parser.Pattern.Prim.Source-                                                ( Source+                                                ( Source(..)                                                 , Token                                                 , Tokens                                                 )@@ -138,9 +134,7 @@     ck   <- Parsec.takeWhileP (Just "lexical chunk (in parens)")                               endOfChunkInParens     right <- Parsec.single Token.parenRight-    -- TODO: better solution?-    let tk = left : Parsec.chunkToTokens (Proxy @s) ck ++ [right]-    pure $ Parsec.tokensToChunk (Proxy @s) tk+    pure $ consTokens @s left (snocTokens @s ck right)   withoutParens = Parsec.takeWhileP (Just "lexical chunk") endOfChunk   endOfChunkInParens x = x /= Token.parenRight   endOfChunk x = not (Token.isSpace x) && x /= Token.parenRight

@@ -71,6 +71,8 @@                   , input :: Tokens s                   , message :: String                   }+  | UnexpectedEndOfFile { rest :: Tokens s+                        }  deriving instance Show (Tokens s) => Show (Error s) deriving instance Eq (Tokens s) => Eq (Error s)

@@ -6,6 +6,8 @@ -- -- This module defines a parser monad 'Parse'. +{-# LANGUAGE CPP #-}+ module Language.Egison.Parser.Pattern.Prim.Parse   ( Parse   , runParse@@ -23,11 +25,16 @@  import           Text.Megaparsec                ( Parsec                                                 , MonadParsec+                                                , State(..)+                                                , PosState(..)                                                 ) import qualified Text.Megaparsec               as Parsec                                                 ( Stream-                                                , parse-                                                , eof+                                                , State(..)+                                                , PosState(..)+                                                , runParser'+                                                , initialPos+                                                , defaultTabWidth                                                 , getSourcePos                                                 ) @@ -38,7 +45,7 @@                                                 , fromSourcePos                                                 ) import           Language.Egison.Parser.Pattern.Prim.ParseMode-                                                ( ParseMode )+                                                ( ParseMode(..) ) import           Language.Egison.Parser.Pattern.Prim.Error                                                 ( Errors                                                 , CustomError@@ -61,13 +68,25 @@   :: (Source s, MonadError (Errors s) m)   => Parse n v e s a   -> ParseMode n v e s-  -> FilePath   -> s-  -> m a-runParse parse mode filename content =-  case Parsec.parse parsec filename content of-    Left  bundle -> throwError $ fromParseErrorBundle bundle-    Right e      -> pure e+  -> m (a, s)+runParse parser mode@ParseMode { filename } content =+  case Parsec.runParser' parsec initState of+    (_, Left bundle) -> throwError $ fromParseErrorBundle bundle+    (Parsec.State { stateInput }, Right e) -> pure (e, stateInput)  where-  parsec = runReaderT (unParse file) mode-  file   = parse <* Parsec.eof+  parsec    = runReaderT (unParse parser) mode+  initState = Parsec.State+    { stateInput       = content+    , stateOffset      = 0+    , statePosState    = Parsec.PosState+                           { pstateInput      = content+                           , pstateOffset     = 0+                           , pstateSourcePos  = Parsec.initialPos filename+                           , pstateTabWidth   = Parsec.defaultTabWidth+                           , pstateLinePrefix = ""+                           }+#if MIN_VERSION_megaparsec(8,0,0)+    , stateParseErrors = []+#endif+    }

@@ -30,7 +30,8 @@  -- | Parser configuration. data ParseMode n v e s-  = ParseMode { fixities        :: [ParseFixity n s]+  = ParseMode { filename        :: FilePath+              , fixities        :: [ParseFixity n s]               , blockComment    :: Maybe (Tokens s, Tokens s)               , lineComment     :: Maybe (Tokens s)               , varNameParser   :: ExtParser s v

@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ -- | -- -- Module:      Language.Egison.Parser.Pattern.Prim.Source@@ -7,12 +9,18 @@ -- A constraint and property of the source of parser  module Language.Egison.Parser.Pattern.Prim.Source-  ( Source+  ( Source(..)   , Token   , Tokens   ) where +import           Data.Text                      ( Text )+import qualified Data.Text                     as T+                                                ( null+                                                , cons+                                                , snoc+                                                ) import qualified Text.Megaparsec               as Parsec                                                 ( Stream(..) ) @@ -20,9 +28,32 @@                                                 ( IsToken )  --- | Constraint for the source of parser.-type Source s = (Parsec.Stream s, IsToken (Token s)) -- | Type of token in the source. type Token s = Parsec.Token s -- | Type of tokens in the source. type Tokens s = Parsec.Tokens s+++-- | Constraint for the source of parser.+-- TODO: Hide these methods in haddock (see haskell/haddock#330)+class (Parsec.Stream s, IsToken (Token s)) => Source s where+  -- | Check if the stream is null or not.+  eof :: s -> Bool+  -- | Reify the input stream into a chunk of tokens.+  tokens :: s -> Tokens s+  -- | Add a token to the front of a chunk.+  consTokens :: Token s -> Tokens s -> Tokens s+  -- | Add a token to the back of a chunk.+  snocTokens :: Tokens s -> Token s -> Tokens s++instance Source Text where+  eof        = T.null+  tokens     = id+  consTokens = T.cons+  snocTokens = T.snoc++instance Source String where+  eof        = null+  tokens     = id+  consTokens = (:)+  snocTokens xs x = xs ++ [x]

@@ -28,16 +28,22 @@   and :: c   vertical :: c   dollar :: c+  bracketLeft :: c+  bracketRight :: c+  comma :: c  instance IsToken Char where-  isSpace     = Char.isSpace-  newline     = '\n'-  parenLeft   = '('-  parenRight  = ')'-  underscore  = '_'-  hash        = '#'-  question    = '?'-  exclamation = '!'-  and         = '&'-  vertical    = '|'-  dollar      = '$'+  isSpace      = Char.isSpace+  newline      = '\n'+  parenLeft    = '('+  parenRight   = ')'+  underscore   = '_'+  hash         = '#'+  question     = '?'+  exclamation  = '!'+  and          = '&'+  vertical     = '|'+  dollar       = '$'+  bracketLeft  = '['+  bracketRight = ']'+  comma        = ','

@@ -38,6 +38,8 @@ import           Language.Egison.Pretty.Pattern.Prim                                                 ( Doc                                                 , hsep+                                                , list+                                                , tupled                                                 , text                                                 , parens                                                 , (<+>)@@ -68,19 +70,26 @@ import           Language.Egison.Syntax.Pattern ( Expr(..) )  -smartParens :: Operator -> Doc -> Print n v e Doc-smartParens opr doc = do+parensIf :: Bool -> Doc -> Doc+parensIf True  = parens+parensIf False = id++parensWhen :: (Context -> Bool) -> Doc -> Print n v e Doc+parensWhen f doc = do   ctx <- askContext-  if check ctx opr then pure $ parens doc else pure doc+  pure $ parensIf (f ctx) doc++smartParens :: Operator -> Doc -> Print n v e Doc+smartParens opr = parensWhen (check opr)  where-  check World               _          = False-  check ConstructorArgument PrefixOp{} = False-  check ConstructorArgument _          = True-  check (Under uPrec side) InfixOp { precedence, associativity }+  check _          World = False+  check PrefixOp{} Atom  = False+  check _          Atom  = True+  check InfixOp { precedence, associativity } (Under uPrec side)     | uPrec > precedence = True     | uPrec == precedence && not (matching associativity side) = True     | otherwise          = False-  check (Under uPrec _) PrefixOp { precedence } | uPrec >= precedence = True+  check PrefixOp { precedence } (Under uPrec _) | uPrec >= precedence = True                                                 | otherwise           = False   matching AssocRight RightSide = True   matching AssocLeft  LeftSide  = True@@ -116,9 +125,10 @@                 , symbol        = "|"                 } expr (Not e) = do-  d <- withContext (Under PrimOp.notPrecedence RightSide) $ expr e-  smartParens opr $ "!" <> d-  where opr = PrefixOp { precedence = PrimOp.notPrecedence, symbol = "!" }+  d <- withContext Atom $ expr e+  pure $ "!" <> d+expr (Tuple      es) = tupled <$> traverse expr es+expr (Collection es) = list <$> traverse expr es expr (Infix n e1 e2) = do   opr <- operatorOf n   case opr of@@ -130,8 +140,11 @@ expr (Pattern n []) = name n expr (Pattern n es) = do   dn <- name n-  ds <- withContext ConstructorArgument $ traverse expr es-  pure . parens $ dn <+> hsep ds+  ds <- withContext Atom $ traverse expr es+  parensWhen check $ dn <+> hsep ds+ where+  check Atom = True+  check _    = False  -- | Pretty print 'Expr'. prettyExpr

@@ -18,7 +18,7 @@  data Context   = World+  | Atom   | Under Precedence Side-  | ConstructorArgument  data Side = LeftSide | RightSide

@@ -21,6 +21,8 @@ import           Data.Text.Prettyprint.Doc     as X                                                 ( parens                                                 , hsep+                                                , list+                                                , tupled                                                 , (<+>)                                                 ) 

@@ -46,31 +46,35 @@ mapName :: (n -> n') -> Expr n v e -> Expr n' v e mapName f = cata go  where-  go (InfixF n a b ) = Infix (f n) a b-  go (PatternF n ps) = Pattern (f n) ps+  go (InfixF n a b )  = Infix (f n) a b+  go (PatternF n ps)  = Pattern (f n) ps   -- TODO: omit these verbose matches-  go WildcardF       = Wildcard-  go (VariableF  n)  = Variable n-  go (ValueF     e)  = Value e-  go (PredicateF e)  = Predicate e-  go (AndF p1 p2  )  = And p1 p2-  go (OrF  p1 p2  )  = Or p1 p2-  go (NotF p1     )  = Not p1+  go WildcardF        = Wildcard+  go (VariableF  n  ) = Variable n+  go (ValueF     e  ) = Value e+  go (PredicateF e  ) = Predicate e+  go (AndF p1 p2    ) = And p1 p2+  go (OrF  p1 p2    ) = Or p1 p2+  go (NotF        p1) = Not p1+  go (CollectionF ps) = Collection ps+  go (TupleF      ps) = Tuple ps  -- | Map over @v@ in @Expr n v e@. mapVarName :: (v -> v') -> Expr n v e -> Expr n v' e mapVarName f = cata go  where-  go (VariableF v)   = Variable (f v)+  go (VariableF v)    = Variable (f v)   -- TODO: omit these verbose matches-  go WildcardF       = Wildcard-  go (ValueF     e ) = Value e-  go (PredicateF e ) = Predicate e-  go (AndF p1 p2   ) = And p1 p2-  go (OrF  p1 p2   ) = Or p1 p2-  go (NotF p1      ) = Not p1-  go (InfixF n a b ) = Infix n a b-  go (PatternF n ps) = Pattern n ps+  go WildcardF        = Wildcard+  go (ValueF     e  ) = Value e+  go (PredicateF e  ) = Predicate e+  go (AndF p1 p2    ) = And p1 p2+  go (OrF  p1 p2    ) = Or p1 p2+  go (NotF        p1) = Not p1+  go (CollectionF ps) = Collection ps+  go (TupleF      ps) = Tuple ps+  go (InfixF n a b  ) = Infix n a b+  go (PatternF n ps ) = Pattern n ps  -- | Map over @e@ in @Expr n v e@. mapValueExpr :: (e -> e') -> Expr n v e -> Expr n v e'@@ -80,7 +84,9 @@   go (PredicateF e)   = Predicate (f e)   -- TODO: omit these verbose matches   go WildcardF        = Wildcard-  go (VariableF n   ) = Variable n+  go (VariableF   n ) = Variable n+  go (CollectionF ps) = Collection ps+  go (TupleF      ps) = Tuple ps   go (InfixF n p1 p2) = Infix n p1 p2   go (PatternF n  ps) = Pattern n ps   go (AndF     p1 p2) = And p1 p2@@ -91,13 +97,15 @@ variables :: Alternative f => Expr n v e -> f v variables = cata go  where-  go (VariableF n)   = pure n+  go (VariableF n)    = pure n   -- TODO: omit these verbose matches-  go WildcardF       = empty-  go (ValueF     _ ) = empty-  go (PredicateF _ ) = empty-  go (AndF p1 p2   ) = p1 <|> p2-  go (OrF  p1 p2   ) = p1 <|> p2-  go (NotF p1      ) = p1-  go (InfixF _ a b ) = a <|> b-  go (PatternF _ ps) = asum ps+  go WildcardF        = empty+  go (ValueF     _  ) = empty+  go (PredicateF _  ) = empty+  go (AndF p1 p2    ) = p1 <|> p2+  go (OrF  p1 p2    ) = p1 <|> p2+  go (NotF p1       ) = p1+  go (InfixF _ a b  ) = a <|> b+  go (PatternF _ ps ) = asum ps+  go (CollectionF ps) = asum ps+  go (TupleF      ps) = asum ps

@@ -36,6 +36,10 @@   | Or (Expr n v e) (Expr n v e)   -- | Not pattern. Match when the given pattern does not match.   | Not (Expr n v e)+  -- | Tuple pattern. Match with tuples whose elements match with respective patterns.+  | Tuple [Expr n v e]+  -- | Collection pattern. Match with collections whose elements match with respective patterns.+  | Collection [Expr n v e]   -- | User-defined infix pattern.   | Infix n (Expr n v e) (Expr n v e)   -- | User-defined normal pattern.

@@ -11,7 +11,6 @@   , andAssociativity   , orPrecedence   , orAssociativity-  , notPrecedence   ) where @@ -32,6 +31,3 @@  orAssociativity :: Associativity orAssociativity = AssocRight--notPrecedence :: Precedence-notPrecedence = Precedence 5

@@ -3,6 +3,7 @@   , test_primitive_pattern_operators   , test_user_defined_pattern_operators   , test_user_defined_comments+  , test_non_greedy   ) where @@ -13,10 +14,21 @@   assertParseExpr :: String -> Expr Name Name ValueExpr -> Assertion-assertParseExpr content expected = case testParseExpr content of+assertParseExpr content expected = case parse testParseMode content of   Left  err -> fail $ show err   Right got -> assertEqual ("while parsing \"" ++ content ++ "\"") expected got +assertParseExprNonGreedy+  :: String -> Expr Name Name ValueExpr -> String -> Assertion+assertParseExprNonGreedy content expectedExpr expectedRest =+  case parseNonGreedy testParseMode content of+    Left  err         -> fail $ show err+    Right (got, rest) -> do+      assertEqual ("while parsing \"" ++ content ++ "\"") expectedExpr got+      assertEqual ("while taking the parsed rest of \"" ++ content ++ "\"")+                  expectedRest+                  rest+ test_atom_patterns :: [TestTree] test_atom_patterns =   [ testCase "wildcard pattern" $ assertParseExpr "_" Wildcard@@ -27,9 +39,15 @@   , testCase "predicate pattern"     $ assertParseExpr "?10" (Predicate $ ValueExprInt 10)   , testCase "constructor pattern" $ assertParseExpr+    "ctor _ _ _"+    (Pattern (Name "ctor") [Wildcard, Wildcard, Wildcard])+  , testCase "constructor pattern between parentheses" $ assertParseExpr     "(ctor _ _ _)"     (Pattern (Name "ctor") [Wildcard, Wildcard, Wildcard])   , testCase "constructor pattern that the name is between parentheses"+    $ assertParseExpr "(++) _ _" (Pattern (Name "++") [Wildcard, Wildcard])+  , testCase+      "constructor pattern that the name and pattern itself is between parentheses"     $ assertParseExpr "((++) _ _)" (Pattern (Name "++") [Wildcard, Wildcard])   , testCase "constructor pattern without arguments"     $ assertParseExpr "nil" (Pattern (Name "nil") [])@@ -40,7 +58,7 @@   , testCase "constructor pattern without arguments between parentheses"     $ assertParseExpr "((c))" (Pattern (Name "c") [])   , testCase "nested constructor pattern" $ assertParseExpr-    "(ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE)"+    "ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE"     (Pattern       (Name "ctorA")       [ Pattern (Name "ctorB") [Wildcard]@@ -49,13 +67,34 @@       , Pattern (Name "ctorE") []       ]     )+  , testCase "collection pattern"+    $ assertParseExpr "[_, _, _]" (Collection [Wildcard, Wildcard, Wildcard])+  , testCase "nested collection pattern" $ assertParseExpr+    "[_, [_, _], _]"+    (Collection [Wildcard, Collection [Wildcard, Wildcard], Wildcard])+  , testCase "nil collection pattern" $ assertParseExpr "[]" (Collection [])+  , testCase "tuple pattern"+    $ assertParseExpr "(_, _, _)" (Tuple [Wildcard, Wildcard, Wildcard])+  , testCase "tuple pattern between parentheses"+    $ assertParseExpr "((_, _, _))" (Tuple [Wildcard, Wildcard, Wildcard])+  , testCase "nested tuple pattern" $ assertParseExpr+    "(_, (_, _), _)"+    (Tuple [Wildcard, Tuple [Wildcard, Wildcard], Wildcard])+  , testCase "nil tuple pattern" $ assertParseExpr "()" (Tuple [])+  , testCase "not pattern" $ assertParseExpr "!_" (Not Wildcard)+  , testCase "not pattern in constructor arguments" $ assertParseExpr+    "ctor !_ !_"+    (Pattern (Name "ctor") [Not Wildcard, Not Wildcard])+  , testCase "not pattern on constructor pattern" $ assertParseExpr+    "!ctor _ _"+    (Not (Pattern (Name "ctor") [Wildcard, Wildcard]))+  , testCase "nested not patterns" $ assertParseExpr "!!_" (Not (Not Wildcard))   ]  test_primitive_pattern_operators :: [TestTree] test_primitive_pattern_operators =   [ testCase "and pattern" $ assertParseExpr "_ & _" (And Wildcard Wildcard)   , testCase "or pattern" $ assertParseExpr "_ | _" (Or Wildcard Wildcard)-  , testCase "not pattern" $ assertParseExpr "!_" (Not Wildcard)   -- associativity   , testCase "nested and pattern"     $ assertParseExpr "_ & _ & _" (And Wildcard (And Wildcard Wildcard))@@ -69,9 +108,11 @@     $ assertParseExpr "! _ | _" (Or (Not Wildcard) Wildcard)   , testCase "nested not, and pattern"     $ assertParseExpr "! _ & _" (And (Not Wildcard) Wildcard)-  , testCase "not pattern in constructor arguments" $ assertParseExpr-    "(ctor !_ !_)"-    (Pattern (Name "ctor") [Not Wildcard, Not Wildcard])+  , testCase "constructor pattern in infix operands" $ assertParseExpr+    "_ & ctor _ _ | ctor _ _"+    (Or (And Wildcard (Pattern (Name "ctor") [Wildcard, Wildcard]))+        (Pattern (Name "ctor") [Wildcard, Wildcard])+    )   ]  test_user_defined_pattern_operators :: [TestTree]@@ -115,4 +156,12 @@     $ assertParseExpr "_-- comment -- yeah" Wildcard   , testCase "ignore a line comment at beginning of line"     $ assertParseExpr "-- comment -- yeah \n_-- comment" Wildcard+  ]++test_non_greedy :: [TestTree]+test_non_greedy =+  [ testCase "preserve the rest of input stream" $ assertParseExprNonGreedy+      "$x : _ -> x"+      (Infix (Name ":") (Variable (Name "x")) Wildcard)+      "-> x"   ]

@@ -13,7 +13,7 @@   assertPrintExpr :: Expr Name Name ValueExpr -> Text -> Assertion-assertPrintExpr e expected = case testPrintExpr e of+assertPrintExpr e expected = case prettyExpr testPrintMode e of   Left  err -> fail $ show err   Right got -> assertEqual ("while printing \"" ++ show e ++ "\"") expected got @@ -26,7 +26,7 @@     $ assertPrintExpr (Predicate $ ValueExprInt 10) "?10"   , testCase "constructor pattern" $ assertPrintExpr     (Pattern (Name "ctor") [Wildcard, Wildcard, Wildcard])-    "(ctor _ _ _)"+    "ctor _ _ _"   , testCase "constructor pattern without arguments"     $ assertPrintExpr (Pattern (Name "nil") []) "nil"   , testCase "nested constructor pattern" $ assertPrintExpr@@ -38,14 +38,33 @@       , Pattern (Name "ctorE") []       ]     )-    "(ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE)"+    "ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE"+  , testCase "collection pattern"+    $ assertPrintExpr (Collection [Wildcard, Wildcard, Wildcard]) "[_, _, _]"+  , testCase "nested collection pattern" $ assertPrintExpr+    (Collection [Wildcard, Collection [Wildcard, Wildcard], Wildcard])+    "[_, [_, _], _]"+  , testCase "nil collection pattern" $ assertPrintExpr (Collection []) "[]"+  , testCase "tuple pattern"+    $ assertPrintExpr (Tuple [Wildcard, Wildcard, Wildcard]) "(_, _, _)"+  , testCase "nested tuple pattern" $ assertPrintExpr+    (Tuple [Wildcard, Tuple [Wildcard, Wildcard], Wildcard])+    "(_, (_, _), _)"+  , testCase "nil tuple pattern" $ assertPrintExpr (Tuple []) "()"+  , testCase "not pattern" $ assertPrintExpr (Not Wildcard) "!_"+  , testCase "not pattern in constructor arguments" $ assertPrintExpr+    (Pattern (Name "ctor") [Not Wildcard, Not Wildcard])+    "ctor !_ !_"+  , testCase "not pattern on constructor pattern" $ assertPrintExpr+    (Not (Pattern (Name "ctor") [Wildcard, Wildcard]))+    "!(ctor _ _)"+  , testCase "nested not patterns" $ assertPrintExpr (Not (Not Wildcard)) "!!_"   ]  test_primitive_pattern_operators :: [TestTree] test_primitive_pattern_operators =   [ testCase "and pattern" $ assertPrintExpr (And Wildcard Wildcard) "_ & _"   , testCase "or pattern" $ assertPrintExpr (Or Wildcard Wildcard) "_ | _"-  , testCase "not pattern" $ assertPrintExpr (Not Wildcard) "!_"   -- associativity   , testCase "nested and pattern"     $ assertPrintExpr (And Wildcard (And Wildcard Wildcard)) "_ & _ & _"@@ -66,11 +85,11 @@     $ assertPrintExpr (Or (Not Wildcard) Wildcard) "!_ | _"   , testCase "nested not, and pattern"     $ assertPrintExpr (Not (And Wildcard Wildcard)) "!(_ & _)"-  , testCase "nested not patterns"-    $ assertPrintExpr (Not (Not Wildcard)) "!(!_)"-  , testCase "not pattern in constructor arguments" $ assertPrintExpr-    (Pattern (Name "ctor") [Not Wildcard, Not Wildcard])-    "(ctor !_ !_)"+  , testCase "constructor pattern in infix operands" $ assertPrintExpr+    (Or (And Wildcard (Pattern (Name "ctor") [Wildcard, Wildcard]))+        (Pattern (Name "ctor") [Wildcard, Wildcard])+    )+    "_ & ctor _ _ | ctor _ _"   ]  test_user_defined_pattern_operators :: [TestTree]

@@ -1,6 +1,6 @@ module TestImport-  ( testParseExpr-  , testPrintExpr+  ( testParseMode+  , testPrintMode   , Name(..)   , ValueExpr(..)   -- * Re-exports@@ -11,17 +11,20 @@ -- re-exports import           Language.Egison.Syntax.Pattern.Expr                                                as X+import           Language.Egison.Parser.Pattern+                                               as X+                                                ( Parsable(..) )+import           Language.Egison.Pretty.Pattern+                                               as X+                                                ( prettyExpr )  -- main-import           Data.Text                      ( Text-                                                , pack-                                                )+import           Data.Text                      ( pack ) import           Data.Functor                   ( void ) import           Data.Void                      ( Void ) import           Control.Applicative            ( (<|>)                                                 , some                                                 )-import           Control.Monad.Except           ( MonadError )  import           Text.Megaparsec                ( Parsec ) import qualified Text.Megaparsec               as Parsec@@ -41,13 +44,9 @@                                                 , Fixity(..)                                                 , Precedence(..)                                                 , Associativity(..)-                                                , Errors-                                                , parseExpr                                                 ) import           Language.Egison.Pretty.Pattern ( PrintMode(..)                                                 , PrintFixity(..)-                                                , Error-                                                , prettyExpr                                                 )  @@ -97,7 +96,8 @@     pure $ negate d  testParseMode :: ParseMode Name Name ValueExpr String-testParseMode = ParseMode { fixities        = map toParseFixity testFixities+testParseMode = ParseMode { filename        = "test"+                          , fixities        = map toParseFixity testFixities                           , blockComment    = Just ("{-", "-}")                           , lineComment     = Just "--"                           , varNameParser   = unParsec testParseName@@ -115,10 +115,3 @@  where   namePrinter (Name name) = pack name   valueExprPrinter (ValueExprInt i) = pack $ show i--testParseExpr-  :: MonadError (Errors String) m => String -> m (Expr Name Name ValueExpr)-testParseExpr = parseExpr testParseMode "test"--testPrintExpr :: MonadError (Error Name) m => Expr Name Name ValueExpr -> m Text-testPrintExpr = prettyExpr testPrintMode