egison-pattern-src (empty) → 0.1.0.0
raw patch · 35 files changed
+2264/−0 lines, 35 filesdep +basedep +containersdep +egison-pattern-srcsetup-changed
Dependencies added: base, containers, egison-pattern-src, free, megaparsec, mtl, parser-combinators, prettyprinter, recursion-schemes, tasty, tasty-hunit, text
Files
- CHANGELOG.md +3/−0
- LICENSE +11/−0
- README.md +30/−0
- Setup.hs +4/−0
- egison-pattern-src.cabal +133/−0
- src/Language/Egison/Parser/Pattern.hs +167/−0
- src/Language/Egison/Parser/Pattern/Combinator.hs +48/−0
- src/Language/Egison/Parser/Pattern/Expr.hs +170/−0
- src/Language/Egison/Parser/Pattern/Prim.hs +177/−0
- src/Language/Egison/Parser/Pattern/Prim/Error.hs +132/−0
- src/Language/Egison/Parser/Pattern/Prim/Location.hs +62/−0
- src/Language/Egison/Parser/Pattern/Prim/Parse.hs +73/−0
- src/Language/Egison/Parser/Pattern/Prim/ParseMode.hs +39/−0
- src/Language/Egison/Parser/Pattern/Prim/Source.hs +28/−0
- src/Language/Egison/Parser/Pattern/Token.hs +43/−0
- src/Language/Egison/Pretty/Pattern.hs +141/−0
- src/Language/Egison/Pretty/Pattern/Context.hs +24/−0
- src/Language/Egison/Pretty/Pattern/Error.hs +17/−0
- src/Language/Egison/Pretty/Pattern/External.hs +75/−0
- src/Language/Egison/Pretty/Pattern/Operator.hs +29/−0
- src/Language/Egison/Pretty/Pattern/Prim.hs +61/−0
- src/Language/Egison/Pretty/Pattern/Print.hs +94/−0
- src/Language/Egison/Pretty/Pattern/PrintMode.hs +46/−0
- src/Language/Egison/Syntax/Pattern.hs +19/−0
- src/Language/Egison/Syntax/Pattern/Base.hs +24/−0
- src/Language/Egison/Syntax/Pattern/Combinator.hs +103/−0
- src/Language/Egison/Syntax/Pattern/Expr.hs +43/−0
- src/Language/Egison/Syntax/Pattern/Fixity.hs +27/−0
- src/Language/Egison/Syntax/Pattern/Fixity/Associativity.hs +22/−0
- src/Language/Egison/Syntax/Pattern/Fixity/Precedence.hs +28/−0
- src/Language/Egison/Syntax/Pattern/Fixity/Primitive.hs +37/−0
- test/Language/Egison/Parser/PatternSpec.hs +118/−0
- test/Language/Egison/Pretty/PatternSpec.hs +111/−0
- test/TestImport.hs +124/−0
- test/test.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1.0.0++- Initial Release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2020 coord_e++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,30 @@+# Egison Pattern Source++[](https://github.com/egison/egison-pattern-src/actions?workflow=latest)+[](https://github.com/egison/egison-pattern-src/actions?workflow=release)+[](https://hackage.haskell.org/package/egison-pattern-src)+[](http://packdeps.haskellers.com/reverse/egison-pattern-src)++The [egison-pattern-src](https://hackage.haskell.org/package/egison-pattern-src) provides a standalone syntax definition for patterns in [Egison programming language](https://www.egison.org/).+This package enables you to embed Egison's patterns in your parser (pretty-printer) by supplying expression and name parsers (printers) externally.++## Syntax++The following is a simplified syntax of pattern expressions where `x`, `v`, `op` and `e` are respectively names, variable names, user-defined infix operators and expressions in host language.++```+p ::= _ (wildcard pattern)+ | $v (pattern variable)+ | #e (value pattern)+ | ?e (predicate 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)+```++## License++[egison-pattern-src](https://hackage.haskell.org/package/egison-pattern-src) is distributed as open source software under the terms of the 3 clause BSD License. See `LICENSE` for details.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple ( defaultMain )++main :: IO ()+main = defaultMain
+ egison-pattern-src.cabal view
@@ -0,0 +1,133 @@+cabal-version: 2.0+name: egison-pattern-src+version: 0.1.0.0+synopsis:+ Manipulating Egison patterns: abstract syntax, parser, and pretty-printer++description:+ @egison-pattern-src@ provides a standalone syntax definition for patterns in [Egison programming language](https://www.egison.org/).+ This package enables you to embed Egison's patterns in your parser (pretty-printer) by supplying expression and name parsers (printers) externally.++bug-reports: https://github.com/egison/egison-pattern-src/issues+homepage: https://github.com/egison/egison-pattern-src#readme+license: BSD3+license-file: LICENSE+author: coord_e+maintainer: coord_e <me@coord-e.com>, Satoshi Egi <egi@egison.org>+copyright: Copyright 2020 coord_e+category: Language, Parser, Pretty Printer+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++-- see .github/workflows+tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1++source-repository head+ type: git+ location: https://github.com/egison/egison-pattern-src++library+ build-depends:+ base >=4.8 && <5+ , containers >=0.5.4 && <0.7+ , free >=5.0.1 && <5.2+ , megaparsec >=7.0.0 && <8.1+ , mtl ^>=2.2.1+ , parser-combinators >=1.0.0 && <1.3+ , prettyprinter >=1.0.0 && <1.7+ , recursion-schemes >=5.0.2 && <5.2+ , text >=0.1.0 && <1.3++ hs-source-dirs: src+ exposed-modules:+ Language.Egison.Parser.Pattern+ Language.Egison.Pretty.Pattern+ Language.Egison.Syntax.Pattern+ Language.Egison.Syntax.Pattern.Base+ Language.Egison.Syntax.Pattern.Combinator+ Language.Egison.Syntax.Pattern.Expr+ Language.Egison.Syntax.Pattern.Fixity++ other-modules:+ Language.Egison.Parser.Pattern.Combinator+ Language.Egison.Parser.Pattern.Expr+ Language.Egison.Parser.Pattern.Prim+ Language.Egison.Parser.Pattern.Prim.Error+ Language.Egison.Parser.Pattern.Prim.Location+ Language.Egison.Parser.Pattern.Prim.Parse+ Language.Egison.Parser.Pattern.Prim.ParseMode+ Language.Egison.Parser.Pattern.Prim.Source+ Language.Egison.Parser.Pattern.Token+ Language.Egison.Pretty.Pattern.Context+ Language.Egison.Pretty.Pattern.Error+ Language.Egison.Pretty.Pattern.External+ Language.Egison.Pretty.Pattern.Operator+ Language.Egison.Pretty.Pattern.Prim+ Language.Egison.Pretty.Pattern.Print+ Language.Egison.Pretty.Pattern.PrintMode+ Language.Egison.Syntax.Pattern.Fixity.Associativity+ Language.Egison.Syntax.Pattern.Fixity.Precedence+ Language.Egison.Syntax.Pattern.Fixity.Primitive++ if impl(ghc >=8)+ ghc-options: -Wredundant-constraints++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns++ default-language: Haskell2010+ default-extensions:+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DuplicateRecordFields+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ KindSignatures+ NamedFieldPuns+ OverloadedStrings+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TypeApplications+ TypeFamilies++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ build-depends:+ base+ , egison-pattern-src+ , megaparsec+ , mtl+ , tasty+ , tasty-hunit+ , text++ default-extensions:+ DerivingStrategies+ DuplicateRecordFields+ FlexibleContexts+ GeneralizedNewtypeDeriving+ NamedFieldPuns+ OverloadedStrings++ -- cabal-fmt: expand test+ other-modules:+ Language.Egison.Parser.PatternSpec+ Language.Egison.Pretty.PatternSpec+ TestImport++ build-tool-depends: tasty-discover:tasty-discover -any
+ src/Language/Egison/Parser/Pattern.hs view
@@ -0,0 +1,167 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern+-- Description: Parser for Egison patterns+-- Stability: experimental+--+-- A parser for Egison patterns.++module Language.Egison.Parser.Pattern+ ( parseExprL+ , parseExpr+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Egison.Parser.Pattern.Prim+ as X+ ( Source+ , Token+ , Tokens+ , ExtParser+ , ParseMode(..)+ , ParseFixity(..)+ , Errors+ , Error(..)+ , ErrorItem(..)+ , Location(..)+ , Position(..)+ )+import Language.Egison.Parser.Pattern.Expr+ as X+ ( Precedence(..)+ , Associativity(..)+ , Fixity(..)+ , ExprL+ )+import Language.Egison.Parser.Pattern.Token+ as X+ ( IsToken(..) )++-- main+import Control.Monad.Except ( MonadError )+import Control.Applicative ( (<|>) )+import Control.Monad.Combinators ( many )+import Control.Comonad.Cofree ( unwrap )++import Language.Egison.Parser.Pattern.Prim+ ( Parse+ , runParse+ , lexeme+ , space+ , name+ , varName+ , valueExpr+ , try+ , (<?>)+ )+import Language.Egison.Parser.Pattern.Combinator+ ( token+ , parens+ )+import Language.Egison.Parser.Pattern.Expr+ ( exprParser+ , Table(..)+ , initTable+ , addInfix+ , addPrefix+ )+import qualified Language.Egison.Parser.Pattern.Token+ as Token+ ( underscore+ , hash+ , question+ , exclamation+ , and+ , vertical+ , dollar+ )+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+ , addInfix PrimOp.andAssociativity (AndF <$ token Token.and) initTable+ )+ , ( PrimOp.orPrecedence+ , addInfix PrimOp.orAssociativity (OrF <$ token Token.vertical) initTable+ )+ ]++wildcard :: Source s => Parse n v e s (ExprF n v e a)+wildcard = WildcardF <$ token Token.underscore++variable :: Source s => Parse n v e s (ExprF n v e a)+variable = do+ token Token.dollar+ v <- lexeme varName+ pure $ VariableF v++value :: Source s => Parse n v e s (ExprF n v e a)+value = do+ token Token.hash+ e <- lexeme valueExpr+ pure $ ValueF e++predicate :: Source s => Parse n v e s (ExprF n v e a)+predicate = do+ token Token.question+ e <- lexeme valueExpr+ 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 []++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+ <|> variable+ <|> value+ <|> constr+ <|> predicate+ <?> "atomic pattern"++expr :: Source s => Parse n v e s (ExprL n v e)+expr = exprParser primInfixes atom++-- | Parse 'Expr' with locations annotated.+parseExprL+ :: (Source s, MonadError (Errors s) m)+ => ParseMode n v e s+ -> FilePath+ -> s+ -> m (ExprL n v e)+parseExprL = runParse (space *> expr)++-- | 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
+ src/Language/Egison/Parser/Pattern/Combinator.hs view
@@ -0,0 +1,48 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Combinator+-- Description: Useful combinators to build lexeme parsers+-- Stability: experimental+--+-- A helper module to build lexeme parsers.+--+-- Note that functions exported from this module produce lexeme parsers (i.e. skip spaces after that),+-- while parsers from 'Language.Egison.Pattern.Parser.Prim' do not.++module Language.Egison.Parser.Pattern.Combinator+ ( token+ , symbol+ , parens+ )+where++import Control.Monad.Combinators ( between )+import Data.Functor ( void )++import Language.Egison.Parser.Pattern.Prim+ ( Parse+ , Source+ , Token+ , Tokens+ , lexeme+ , single+ , chunk+ )+import qualified Language.Egison.Parser.Pattern.Token+ as Token+ ( parenLeft+ , parenRight+ )+++-- | Parser for a single token.+token :: Source s => Token s -> Parse n v e s ()+token = void . lexeme . single++-- | Parser for a chunk of tokens.+symbol :: Source s => Tokens s -> Parse n v e s ()+symbol = void . lexeme . chunk++-- | Wrap a parser with parentheses.+parens :: Source s => Parse n v e s a -> Parse n v e s a+parens = between (token Token.parenLeft) (token Token.parenRight)
+ src/Language/Egison/Parser/Pattern/Expr.hs view
@@ -0,0 +1,170 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Expr+-- Description: Helpers to build a parser for expressions+-- Stability: experimental+--+-- A helper module to build a parser for expressions.++module Language.Egison.Parser.Pattern.Expr+ ( ExprL+ , exprParser+ , Table(..)+ , initTable+ , addInfix+ , addPrefix+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Egison.Syntax.Pattern.Fixity+ as X++-- main+import qualified Data.IntMap as IntMap+ ( toDescList+ , fromList+ , alter+ )+import Data.Bifunctor ( first )+import Control.Monad.Reader ( MonadReader(..) )+import Control.Comonad.Cofree ( Cofree(..) )+import Control.Applicative ( Alternative((<|>)) )+import Control.Applicative.Combinators+ ( choice+ , optional+ )++import Language.Egison.Syntax.Pattern.Base+ ( ExprF(..) )+import Language.Egison.Syntax.Pattern.Fixity+ ( Fixity(..)+ , Precedence(..)+ , Associativity(..)+ )+import qualified Language.Egison.Syntax.Pattern.Fixity.Precedence+ as Prec+ ( toInt )+import Language.Egison.Parser.Pattern.Prim+ ( ParseFixity(..)+ , ParseMode(..)+ , Source+ , Parse+ , extParser+ , lexeme+ , Locate(..)+ , Location(..)+ )+++-- | A list of operators with same precedence.+data Table m f a+ = Table { infixRight :: [m (a -> a -> f a)]+ , infixLeft :: [m (a -> a -> f a)]+ , infixNone :: [m (a -> a -> f a)]+ , prefix :: [m (a -> f a)]+ }++-- | Initial 'Table' with no operator.+initTable :: Table m f a+initTable = Table [] [] [] []++-- | Add an infix operator to 'Table'.+addInfix :: Associativity -> m (a -> a -> f a) -> Table m f a -> Table m f a+addInfix AssocRight op table@Table { infixRight } =+ table { infixRight = op : infixRight }+addInfix AssocLeft op table@Table { infixLeft } =+ table { infixLeft = op : infixLeft }+addInfix AssocNone op table@Table { infixNone } =+ table { infixNone = op : infixNone }++-- | Add a prefix operator to 'Table'.+addPrefix :: m (a -> f a) -> Table m f a -> Table m f a+addPrefix op table@Table { prefix } = table { prefix = op : prefix }++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)+ => m (Cofree f Location)+ -> Table m f (Cofree f Location)+ -> m (Cofree f Location)+addPrecLevel atom table = do+ begin <- getPosition+ x <- atom'+ choice [right begin x, left begin x, none begin x, pure x]+ where+ Table { infixRight, infixLeft, infixNone, prefix } = table+ atom' = pPrefix (choice prefix)+ right = pInfixR (choice infixRight) atom'+ left = pInfixL (choice infixLeft) atom'+ none = pInfixN (choice infixNone) atom'+ pPrefix op = do+ begin <- getPosition+ mpre <- optional op+ x <- atom+ case mpre of+ Nothing -> pure x+ Just f -> ends begin $ f x+ pInfixR op p begin x = do+ f <- op+ y <- do+ begin' <- getPosition+ r <- p+ pInfixR op p begin' r <|> pure r+ ends begin $ f x y+ pInfixL op p begin x = do+ r <- do+ f <- op+ y <- p+ ends begin $ f x y+ pInfixL op p begin r <|> pure r+ pInfixN op p begin x = do+ f <- op+ y <- p+ ends begin $ f x y+ ends begin x = do+ end <- getPosition+ let location = Location { begin, end }+ pure (location :< x)++-- | 'Language.Egison.Syntax.Pattern.Expr.Expr' with locations annotated.+type ExprL n v e = Cofree (ExprF n v e) Location++-- | Build an operator table from primitive operator table and 'ParseMode' context.+-- Note that the behavior is undefined when the supplied 'ParseMode' contains some fixities that conflict with ones provided via the parameter.+buildOperatorTable+ :: (MonadReader (ParseMode n v e s) m, Source s)+ => [(Precedence, Table (Parse n v e s) (ExprF n v e) (ExprL n v e))]+ -> m [Table (Parse n v e s) (ExprF n v e) (ExprL n v e)]+buildOperatorTable primInfixes = do+ ParseMode { fixities } <- ask+ pure . map snd . IntMap.toDescList $ foldr go prim fixities+ where+ go (ParseFixity (Fixity assoc prec n) p) =+ addPrecToTable prec . addInfix assoc $ makeOperator n p+ makeOperator n p = InfixF n <$ lexeme (extParser p)+ prim = IntMap.fromList $ map (first Prec.toInt) primInfixes+ 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.+exprParser+ :: Source s+ => [(Precedence, Table (Parse n v e s) (ExprF n v e) (ExprL n v e))]+ -> Parse n v e s (ExprF n v e (ExprL n v e))+ -> Parse n v e s (ExprL n v e)+exprParser primInfixes atom = do+ ops <- buildOperatorTable primInfixes+ makeExprParser atom ops
+ src/Language/Egison/Parser/Pattern/Prim.hs view
@@ -0,0 +1,177 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim+-- Description: Parser monad and primitive parsers+-- Stability: experimental+--+-- A parser monad and primitive parsers.+--+-- Note that all dependencies on parser library are in this module.++module Language.Egison.Parser.Pattern.Prim+ (+ -- * Parser Configuration+ ParseFixity(..)+ , ParseMode(..)+ , ExtParser+ -- * Parser Monad+ , Parse+ , runParse+ -- * Primitive Parsers+ , extParser+ , space+ , lexeme+ , name+ , varName+ , valueExpr+ -- * Errors+ , Errors+ , Error(..)+ , ErrorItem(..)+ -- * Locations+ , Position(..)+ , Location(..)+ , Locate(..)+ -- * Source Stream Class+ , Source+ , Token+ , Tokens+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Text.Megaparsec as X+ ( MonadParsec(..)+ , (<?>)+ , single+ , chunk+ )++-- main+import Data.Proxy ( Proxy(..) )+import Control.Monad ( void )+import Control.Monad.Reader ( ask )+import Control.Applicative ( Alternative((<|>))+ , empty+ )+import qualified Text.Megaparsec as Parsec+ ( takeWhile1P+ , takeWhileP+ , manyTill+ , chunk+ , chunkToTokens+ , tokensToChunk+ , Stream(..)+ , customFailure+ , single+ , anySingle+ )+import qualified Text.Megaparsec.Char.Lexer as L+ ( lexeme+ , space+ )++import qualified Language.Egison.Parser.Pattern.Token+ as Token+ ( isSpace+ , parenLeft+ , parenRight+ , newline+ )+import Language.Egison.Parser.Pattern.Prim.Location+ ( Position(..)+ , Location(..)+ , Locate(..)+ )+import Language.Egison.Parser.Pattern.Prim.Error+ ( Error(..)+ , ErrorItem(..)+ , Errors+ , CustomError(..)+ )++import Language.Egison.Parser.Pattern.Prim.Source+ ( Source+ , Token+ , Tokens+ )+import Language.Egison.Parser.Pattern.Prim.ParseMode+ ( ParseMode(..)+ , ParseFixity(..)+ , ExtParser+ )+import Language.Egison.Parser.Pattern.Prim.Parse+ ( Parse+ , runParse+ )+++skipBlockComment :: Source s => Tokens s -> Tokens s -> Parse n v e s ()+skipBlockComment start end = cs *> void (Parsec.manyTill Parsec.anySingle ce)+ where+ cs = Parsec.chunk start+ ce = Parsec.chunk end++skipLineComment :: Source s => Tokens s -> Parse n v e s ()+skipLineComment prefix = Parsec.chunk prefix+ *> void (Parsec.takeWhileP (Just "chars") (/= Token.newline))++-- | Skip one or more spaces.+space :: Source s => Parse n v e s ()+space = do+ ParseMode { blockComment, lineComment } <- ask+ let block = emptyOr (uncurry skipBlockComment) blockComment+ line = emptyOr skipLineComment lineComment+ L.space space1 line block+ where+ space1 = void $ Parsec.takeWhile1P (Just "whitespace") Token.isSpace+ emptyOr = maybe empty++-- | Parse a lexical chunk.+takeChunk :: forall n v e s . Source s => Parse n v e s (Tokens s)+takeChunk = withParens <|> withoutParens+ where+ withParens = do+ left <- Parsec.single Token.parenLeft+ 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+ withoutParens = Parsec.takeWhileP (Just "lexical chunk") endOfChunk+ endOfChunkInParens x = x /= Token.parenRight+ endOfChunk x = not (Token.isSpace x) && x /= Token.parenRight++-- | Apply an external parser.+extParser :: Source s => ExtParser s a -> Parse n v e s a+extParser p = try $ do+ lchunk <- takeChunk+ case p lchunk of+ Left err -> Parsec.customFailure (ExtParserError lchunk err)+ Right x -> pure x++-- | Make a lexical token.+-- @lexeme p@ first applies parser @p@ then 'space' parser.+lexeme :: Source s => Parse n v e s a -> Parse n v e s a+lexeme = L.lexeme space++-- | Parser for @n@ in @Parse n v e s@ monad.+name :: Source s => Parse n v e s n+name = do+ ParseMode { nameParser } <- ask+ extParser nameParser++-- | Parser for @v@ in @Parse n v e s@ monad.+varName :: Source s => Parse n v e s v+varName = do+ ParseMode { varNameParser } <- ask+ extParser varNameParser++-- | Parser for @e@ in @Parse n v e s@ monad.+valueExpr :: Source s => Parse n v e s e+valueExpr = do+ ParseMode { valueExprParser } <- ask+ extParser valueExprParser
+ src/Language/Egison/Parser/Pattern/Prim/Error.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE UndecidableInstances #-}++-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim.Error+-- Description: Parse errors+-- Stability: experimental+--+-- This module defines datatypes representing parser errors++module Language.Egison.Parser.Pattern.Prim.Error+ ( Error(..)+ , ErrorItem(..)+ , Errors+ -- * Internal Errors+ , CustomError(..)+ -- * Conversion+ , fromParseErrorBundle+ )+where++import Data.Proxy ( Proxy(..) )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NonEmpty+ ( toList )+import qualified Data.Set as Set+ ( toList+ , size+ , elemAt+ )++import Language.Egison.Parser.Pattern.Prim.Source+ ( Tokens+ , Token+ )+import Language.Egison.Parser.Pattern.Prim.Location+ ( Position+ , fromSourcePos+ )++import qualified Text.Megaparsec as Parsec+ ( Stream+ , ErrorItem(..)+ , ErrorFancy(..)+ , SourcePos+ , ParseError(..)+ , ParseErrorBundle(..)+ , attachSourcePos+ , errorOffset+ , tokensToChunk+ )+++-- | Token representation in 'Error'.+data ErrorItem s+ = Tokens (Tokens s)+ | Label String+ | EndOfInput++deriving instance Show (Tokens s) => Show (ErrorItem s)+deriving instance Eq (Tokens s) => Eq (ErrorItem s)+++-- | Parse error.+data Error s+ = UnexpectedToken { position :: Position+ , expected :: [ErrorItem s]+ , found :: Maybe (ErrorItem s)+ }+ | ExternalError { position :: Position+ , input :: Tokens s+ , message :: String+ }++deriving instance Show (Tokens s) => Show (Error s)+deriving instance Eq (Tokens s) => Eq (Error s)++-- | Type synonym for an error list.+type Errors s = NonEmpty (Error s)+++-- | Internal error type to use as a custom error in 'Text.Megaparsec.Parsec' monad.+data CustomError s = ExtParserError { input :: Tokens s+ , message :: String+ }++deriving instance Eq (Tokens s) => Eq (CustomError s)+deriving instance Ord (Tokens s) => Ord (CustomError s)+++makeErrorItem+ :: forall s . Parsec.Stream s => Parsec.ErrorItem (Token s) -> ErrorItem s+makeErrorItem (Parsec.Tokens ts) =+ Tokens . Parsec.tokensToChunk (Proxy @s) $ NonEmpty.toList ts+makeErrorItem (Parsec.Label cs) = Label $ NonEmpty.toList cs+makeErrorItem Parsec.EndOfInput = EndOfInput++makeFancyError+ :: Parsec.SourcePos -> Parsec.ErrorFancy (CustomError s) -> Error s+makeFancyError pos (Parsec.ErrorCustom err) = extError+ where+ position = fromSourcePos pos+ ExtParserError { input, message } = err+ extError = ExternalError { position, input, message }+makeFancyError _ _ = error "unreachable: unused fancy error"++makeError+ :: forall s+ . Parsec.Stream s+ => (Parsec.ParseError s (CustomError s), Parsec.SourcePos)+ -> Error s+makeError (Parsec.FancyError _ es, pos) | Set.size es == 1 =+ makeFancyError pos $ Set.elemAt 0 es+makeError (Parsec.TrivialError _ mfound expectedSet, pos) = UnexpectedToken+ { position+ , expected+ , found+ }+ where+ found = fmap (makeErrorItem @s) mfound+ expected = map (makeErrorItem @s) $ Set.toList expectedSet+ position = fromSourcePos pos+makeError _ = error "unreachable: unused error"++-- | Convert 'Parsec.ParseErrorBundle' to 'Errors'.+fromParseErrorBundle+ :: Parsec.Stream s => Parsec.ParseErrorBundle s (CustomError s) -> Errors s+fromParseErrorBundle Parsec.ParseErrorBundle { Parsec.bundleErrors = errors, Parsec.bundlePosState = posState }+ = fmap makeError errorsWithPos+ where+ (errorsWithPos, _) =+ Parsec.attachSourcePos Parsec.errorOffset errors posState
+ src/Language/Egison/Parser/Pattern/Prim/Location.hs view
@@ -0,0 +1,62 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim.Location+-- Description: Helpers to handle source code locations+-- Stability: experimental+--+-- A helper module to handle source code locations during parsing.++module Language.Egison.Parser.Pattern.Prim.Location+ ( Location(..)+ , Position(..)+ , Locate(..)+ -- * Conversion+ , fromSourcePos+ )+where++import GHC.Generics ( Generic )+import Data.Data ( Data+ , Typeable+ )++import qualified Text.Megaparsec as Parsec+ ( SourcePos(..)+ , unPos+ )+++-- | Position in source code.+data Position+ = Position { line :: Int+ , column :: Int+ }+ deriving (Show, Eq, Generic, Data, Typeable)++-- | Location, a range of positions in source code.+data Location+ = Location { begin :: Position+ , end :: Position+ }+ deriving (Show, Eq, Generic, Data, Typeable)++-- | 'Monad' that scans over a source code.+class Monad m => Locate m where+ getPosition :: m Position+ getLocation :: m a -> m (a, Location)++ getLocation m = do+ begin <- getPosition+ x <- m+ end <- getPosition+ let location = Location { begin, end }+ pure (x, location)+++-- | Make 'Position' from 'Parsec.SourcePos'+fromSourcePos :: Parsec.SourcePos -> Position+fromSourcePos Parsec.SourcePos { Parsec.sourceLine, Parsec.sourceColumn } =+ Position { line, column }+ where+ line = Parsec.unPos sourceLine+ column = Parsec.unPos sourceColumn
+ src/Language/Egison/Parser/Pattern/Prim/Parse.hs view
@@ -0,0 +1,73 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim.Parse+-- Description: Parser monad+-- Stability: experimental+--+-- This module defines a parser monad 'Parse'.++module Language.Egison.Parser.Pattern.Prim.Parse+ ( Parse+ , runParse+ )+where++import Control.Applicative ( Alternative )+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Reader ( ReaderT+ , MonadReader(..)+ , runReaderT+ )+import Control.Monad.Fail ( MonadFail )+import Control.Monad ( MonadPlus )++import Text.Megaparsec ( Parsec+ , MonadParsec+ )+import qualified Text.Megaparsec as Parsec+ ( Stream+ , parse+ , eof+ , getSourcePos+ )++import Language.Egison.Parser.Pattern.Prim.Source+ ( Source )+import Language.Egison.Parser.Pattern.Prim.Location+ ( Locate(..)+ , fromSourcePos+ )+import Language.Egison.Parser.Pattern.Prim.ParseMode+ ( ParseMode )+import Language.Egison.Parser.Pattern.Prim.Error+ ( Errors+ , CustomError+ , fromParseErrorBundle+ )+++-- | Parser monad.+newtype Parse n v e s a = Parse { unParse :: ReaderT (ParseMode n v e s) (Parsec (CustomError s) s) a }+ deriving newtype (Functor, Applicative, Alternative, Monad, MonadFail, MonadPlus)+ deriving newtype (MonadReader (ParseMode n v e s))+ deriving newtype (MonadParsec (CustomError s) s)++instance Parsec.Stream s => Locate (Parse n v e s) where+ getPosition = fromSourcePos <$> Parsec.getSourcePos+++-- | Run 'Parse' monad and produce a parse result.+runParse+ :: (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+ where+ parsec = runReaderT (unParse file) mode+ file = parse <* Parsec.eof
+ src/Language/Egison/Parser/Pattern/Prim/ParseMode.hs view
@@ -0,0 +1,39 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim.ParseMode+-- Description: Parser configuration+-- Stability: experimental+--+-- A parser configuration type, that contains a set of external parsers++module Language.Egison.Parser.Pattern.Prim.ParseMode+ ( ParseMode(..)+ , ParseFixity(..)+ , ExtParser+ )+where++import Language.Egison.Syntax.Pattern.Fixity+ ( Fixity )+import Language.Egison.Parser.Pattern.Prim.Source+ ( Tokens )+++-- | @'ExtParser' s a@ is a type for externally provided parser of @a@.+type ExtParser s a = Tokens s -> Either String a++-- | Fixity of infix operators.+data ParseFixity n s =+ ParseFixity { fixity :: Fixity n+ , parser :: ExtParser s ()+ }++-- | Parser configuration.+data ParseMode n v e s+ = ParseMode { fixities :: [ParseFixity n s]+ , blockComment :: Maybe (Tokens s, Tokens s)+ , lineComment :: Maybe (Tokens s)+ , varNameParser :: ExtParser s v+ , nameParser :: ExtParser s n+ , valueExprParser :: ExtParser s e+ }
+ src/Language/Egison/Parser/Pattern/Prim/Source.hs view
@@ -0,0 +1,28 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Prim.Source+-- Description: Constraint for the source of parser+-- Stability: experimental+--+-- A constraint and property of the source of parser++module Language.Egison.Parser.Pattern.Prim.Source+ ( Source+ , Token+ , Tokens+ )+where++import qualified Text.Megaparsec as Parsec+ ( Stream(..) )++import Language.Egison.Parser.Pattern.Token+ ( 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
+ src/Language/Egison/Parser/Pattern/Token.hs view
@@ -0,0 +1,43 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Token+-- Description: Tokens in expressions+-- Stability: experimental+--+-- This module defines a set of tokens for token types.++module Language.Egison.Parser.Pattern.Token+ ( IsToken(..)+ )+where++import qualified Data.Char as Char+ ( isSpace )+++-- | Provide a set of tokens needed to parse pattern expressions.+class IsToken c where+ isSpace :: c -> Bool+ newline :: c+ parenLeft :: c+ parenRight :: c+ underscore :: c+ hash :: c+ question :: c+ exclamation :: c+ and :: c+ vertical :: c+ dollar :: c++instance IsToken Char where+ isSpace = Char.isSpace+ newline = '\n'+ parenLeft = '('+ parenRight = ')'+ underscore = '_'+ hash = '#'+ question = '?'+ exclamation = '!'+ and = '&'+ vertical = '|'+ dollar = '$'
+ src/Language/Egison/Pretty/Pattern.hs view
@@ -0,0 +1,141 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern+-- Description: Pretty printer for Egison patterns+-- Stability: experimental+--+-- A pretty printer for Egison patterns.++module Language.Egison.Pretty.Pattern+ ( prettyExpr+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Egison.Pretty.Pattern.Error+ as X+ ( Error(..) )+import Language.Egison.Pretty.Pattern.PrintMode+ as X+ ( ExtPrinter+ , PrintMode(..)+ , PageMode(..)+ , PrintFixity(..)+ )+import Language.Egison.Syntax.Pattern.Fixity+ as X+ ( Fixity(..)+ , Associativity(..)+ , Precedence(..)+ )++-- main+import Data.Semigroup ( (<>) )+import Data.Text ( Text )+import Control.Monad.Except ( MonadError(..) )+import Language.Egison.Pretty.Pattern.Prim+ ( Doc+ , hsep+ , text+ , parens+ , (<+>)+ , renderDoc+ )+import Language.Egison.Pretty.Pattern.Error+ ( Error(UnknownInfixOperator) )+import Language.Egison.Pretty.Pattern.External+ ( name+ , varName+ , valueExpr+ )+import Language.Egison.Pretty.Pattern.Print+ ( Print+ , runPrint+ , askContext+ , withContext+ , operatorOf+ )+import Language.Egison.Pretty.Pattern.Context+ ( Context(..)+ , Side(..)+ )+import Language.Egison.Pretty.Pattern.Operator+ ( Operator(..) )+import qualified Language.Egison.Syntax.Pattern.Fixity.Primitive+ as PrimOp+import Language.Egison.Syntax.Pattern ( Expr(..) )+++smartParens :: Operator -> Doc -> Print n v e Doc+smartParens opr doc = do+ ctx <- askContext+ if check ctx opr then pure $ parens doc else pure doc+ where+ check World _ = False+ check ConstructorArgument PrefixOp{} = False+ check ConstructorArgument _ = True+ check (Under uPrec side) InfixOp { precedence, associativity }+ | uPrec > precedence = True+ | uPrec == precedence && not (matching associativity side) = True+ | otherwise = False+ check (Under uPrec _) PrefixOp { precedence } | uPrec >= precedence = True+ | otherwise = False+ matching AssocRight RightSide = True+ matching AssocLeft LeftSide = True+ matching _ _ = False++expr :: Ord n => Expr n v e -> Print n v e Doc+expr Wildcard = pure "_"+expr (Variable v) = do+ dv <- varName v+ pure $ "$" <> dv+expr (Value e) = do+ de <- valueExpr e+ pure $ "#" <> de+expr (Predicate e) = do+ de <- valueExpr e+ pure $ "?" <> de+expr (And e1 e2) = do+ d1 <- withContext (Under PrimOp.andPrecedence LeftSide) $ expr e1+ d2 <- withContext (Under PrimOp.andPrecedence RightSide) $ expr e2+ smartParens opr $ d1 <+> "&" <+> d2+ where+ opr = InfixOp { precedence = PrimOp.andPrecedence+ , associativity = PrimOp.andAssociativity+ , symbol = "&"+ }+expr (Or e1 e2) = do+ d1 <- withContext (Under PrimOp.orPrecedence LeftSide) $ expr e1+ d2 <- withContext (Under PrimOp.orPrecedence RightSide) $ expr e2+ smartParens opr $ d1 <+> "|" <+> d2+ where+ opr = InfixOp { precedence = PrimOp.orPrecedence+ , associativity = PrimOp.orAssociativity+ , symbol = "|"+ }+expr (Not e) = do+ d <- withContext (Under PrimOp.notPrecedence RightSide) $ expr e+ smartParens opr $ "!" <> d+ where opr = PrefixOp { precedence = PrimOp.notPrecedence, symbol = "!" }+expr (Infix n e1 e2) = do+ opr <- operatorOf n+ case opr of+ InfixOp { precedence, symbol } -> do+ d1 <- withContext (Under precedence LeftSide) $ expr e1+ d2 <- withContext (Under precedence RightSide) $ expr e2+ smartParens opr $ d1 <+> text symbol <+> d2+ _ -> throwError $ UnknownInfixOperator n+expr (Pattern n []) = name n+expr (Pattern n es) = do+ dn <- name n+ ds <- withContext ConstructorArgument $ traverse expr es+ pure . parens $ dn <+> hsep ds++-- | Pretty print 'Expr'.+prettyExpr+ :: (MonadError (Error n) m, Ord n) => PrintMode n v e -> Expr n v e -> m Text+prettyExpr mode e = do+ doc <- runPrint (expr e) mode+ pure $ renderDoc mode doc
+ src/Language/Egison/Pretty/Pattern/Context.hs view
@@ -0,0 +1,24 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Context+-- Description: Pretty-printing context+-- Stability: experimental+--+-- A pretty-printing context, utilized to control parentheses in infix expressions++module Language.Egison.Pretty.Pattern.Context+ ( Context(..)+ , Side(..)+ )+where++import Language.Egison.Syntax.Pattern.Fixity+ ( Precedence )+++data Context+ = World+ | Under Precedence Side+ | ConstructorArgument++data Side = LeftSide | RightSide
+ src/Language/Egison/Pretty/Pattern/Error.hs view
@@ -0,0 +1,17 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Error+-- Description: Pretty-printing errors+-- Stability: experimental+--+-- This module defines datatypes representing pretty-printer errors++module Language.Egison.Pretty.Pattern.Error+ ( Error(..)+ )+where+++-- | A pretty printer error.+newtype Error n = UnknownInfixOperator n+ deriving (Show, Eq)
+ src/Language/Egison/Pretty/Pattern/External.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ViewPatterns #-}++-- |+--+-- Module: Language.Egison.Pretty.Pattern.External+-- Description: Externally privided printers+-- Stability: experimental+--+-- This module defines a set of combinators that access to externally provided printers++module Language.Egison.Pretty.Pattern.External+ ( name+ , varName+ , valueExpr+ )+where++import Data.Text ( Text+ , unpack+ )++import Language.Egison.Pretty.Pattern.Prim+ ( Doc+ , text+ , parens+ )+import Language.Egison.Pretty.Pattern.Print+ ( Print+ , askMode+ )+import Language.Egison.Pretty.Pattern.PrintMode+ ( PrintMode(..) )+++-- | Check whether the string is surrounded by parentheses.+--+-- >>> surroundedByParens "(Hello, World)"+-- True+--+-- >>> surroundedByParens "Hello, World"+-- False+--+-- >>> surroundedByParens "(Hello)(World)"+-- False+surroundedByParens :: String -> Bool+surroundedByParens ('(' : (reverse -> (')' : body))) = foldr go 0 body == 0+ where+ go :: Char -> Int -> Int+ go '(' = (+) 1+ go ')' = (-) 1+ go _ = id+surroundedByParens _ = False++lexicalChunk :: Text -> Doc+lexicalChunk txt+ | containSpace str && not (surroundedByParens str) = parens $ text txt+ | otherwise = text txt+ where+ containSpace = elem ' '+ str = unpack txt++varName :: v -> Print n v e Doc+varName v = do+ PrintMode { varNamePrinter } <- askMode+ pure . lexicalChunk $ varNamePrinter v++name :: n -> Print n v e Doc+name n = do+ PrintMode { namePrinter } <- askMode+ pure . lexicalChunk $ namePrinter n++valueExpr :: e -> Print n v e Doc+valueExpr e = do+ PrintMode { valueExprPrinter } <- askMode+ pure . lexicalChunk $ valueExprPrinter e
+ src/Language/Egison/Pretty/Pattern/Operator.hs view
@@ -0,0 +1,29 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Operator+-- Description: Infix operator datatypes+-- Stability: experimental+--+-- A datatypes for infix operators.++module Language.Egison.Pretty.Pattern.Operator+ ( Operator(..)+ )+where++import Data.Text ( Text )++import Language.Egison.Syntax.Pattern.Fixity+ ( Precedence+ , Associativity+ )+++data Operator+ = InfixOp { associativity :: Associativity+ , precedence :: Precedence+ , symbol :: Text+ }+ | PrefixOp { precedence :: Precedence+ , symbol :: Text+ }
+ src/Language/Egison/Pretty/Pattern/Prim.hs view
@@ -0,0 +1,61 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Prim+-- Description: Primitive printers+-- Stability: experimental+--+-- Primitive printers.+--+-- Note that all dependencies on printer library are in this module.++module Language.Egison.Pretty.Pattern.Prim+ ( Doc+ , renderDoc+ , text+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Data.Text.Prettyprint.Doc as X+ ( parens+ , hsep+ , (<+>)+ )++-- main+import Data.Void ( Void )+import Data.Text ( Text )++import qualified Data.Text.Prettyprint.Doc as PP+ ( Doc+ , PageWidth(..)+ , LayoutOptions(..)+ , pretty+ , layoutPretty+ )+import qualified Data.Text.Prettyprint.Doc.Render.Text+ as PP+ ( renderStrict )++import Language.Egison.Pretty.Pattern.PrintMode+ ( PrintMode(..)+ , PageMode(..)+ )+++type Doc = PP.Doc Void++text :: Text -> Doc+text = PP.pretty++renderDoc :: PrintMode n v e -> Doc -> Text+renderDoc PrintMode { pageMode } doc = PP.renderStrict stream+ where+ stream = PP.layoutPretty layoutOptions doc+ layoutOptions = PP.LayoutOptions { PP.layoutPageWidth }+ layoutPageWidth = case pageMode of+ Just PageMode { lineLength, ribbonsPerLine } ->+ PP.AvailablePerLine lineLength ribbonsPerLine+ Nothing -> PP.Unbounded
+ src/Language/Egison/Pretty/Pattern/Print.hs view
@@ -0,0 +1,94 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Print+-- Description: Printer monad+-- Stability: experimental+--+-- This module defines a pretty printing monad 'Print'.++module Language.Egison.Pretty.Pattern.Print+ ( Print+ , askMode+ , askContext+ , operatorOf+ , withContext+ , runPrint+ )+where++import qualified Data.Map as Map+ ( Map+ , empty+ , lookup+ , insert+ )+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Reader ( ReaderT+ , MonadReader(..)+ , runReaderT+ )++import Language.Egison.Pretty.Pattern.Error+ ( Error(UnknownInfixOperator) )+import Language.Egison.Pretty.Pattern.Context+ ( Context(World) )+import Language.Egison.Pretty.Pattern.PrintMode+ ( PrintMode(..)+ , PrintFixity(..)+ , Fixity(..)+ )+import Language.Egison.Pretty.Pattern.Operator+ ( Operator(..) )+++type OperatorTable n = Map.Map n Operator++data Env n v e+ = Env { mode :: PrintMode n v e+ , table :: OperatorTable n+ , context :: Context+ }++buildOperatorTable :: Ord n => [PrintFixity n] -> OperatorTable n+buildOperatorTable = foldr go Map.empty+ where+ go fixity@PrintFixity { fixity = Fixity { symbol } } =+ Map.insert symbol (toOperator fixity)+ toOperator PrintFixity { fixity = Fixity { precedence, associativity }, printed }+ = InfixOp { precedence, associativity, symbol = printed }++initialEnv :: Ord n => PrintMode n v e -> Env n v e+initialEnv mode@PrintMode { fixities } =+ Env { mode, table = buildOperatorTable fixities, context = World }++newtype Print n v e a = Print { unParse :: ReaderT (Env n v e) (Either (Error n)) a }+ deriving newtype (Functor, Applicative, Monad)+ deriving newtype (MonadReader (Env n v e))+ deriving newtype (MonadError (Error n))++askMode :: Print n v e (PrintMode n v e)+askMode = do+ Env { mode } <- ask+ pure mode++askContext :: Print n v e Context+askContext = do+ Env { context } <- ask+ pure context++withContext :: Context -> Print n v e a -> Print n v e a+withContext = local . updateContext+ where updateContext context env = env { context }++runPrint+ :: (Ord n, MonadError (Error n) m) => Print n v e a -> PrintMode n v e -> m a+runPrint p mode = case runReaderT (unParse p) (initialEnv mode) of+ Left err -> throwError err+ Right x -> pure x++operatorOf :: Ord n => n -> Print n v e Operator+operatorOf n = do+ Env { table } <- ask+ case Map.lookup n table of+ Just op -> pure op+ Nothing -> throwError $ UnknownInfixOperator n
+ src/Language/Egison/Pretty/Pattern/PrintMode.hs view
@@ -0,0 +1,46 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.PrintMode+-- Description: Printer configuration+-- Stability: experimental+--+-- A printer configuration type, that contains a set of external printers++module Language.Egison.Pretty.Pattern.PrintMode+ ( ExtPrinter+ , PrintFixity(..)+ , PrintMode(..)+ , PageMode(..)+ , Fixity(..)+ )+where++import Data.Text ( Text )++import Language.Egison.Syntax.Pattern.Fixity+ ( Fixity(..) )+++-- | @'ExtPrinter' a@ is a type for externally provided printer of @a@.+type ExtPrinter a = a -> Text++-- | Fixity of infix operators.+data PrintFixity n =+ PrintFixity { fixity :: Fixity n+ , printed :: Text+ }++-- | Rendering style configuration.+data PageMode =+ PageMode { lineLength :: Int+ , ribbonsPerLine :: Double+ }++-- | Printer configuration.+data PrintMode n v e+ = PrintMode { fixities :: [PrintFixity n]+ , varNamePrinter :: ExtPrinter v+ , namePrinter :: ExtPrinter n+ , valueExprPrinter :: ExtPrinter e+ , pageMode :: Maybe PageMode+ }
+ src/Language/Egison/Syntax/Pattern.hs view
@@ -0,0 +1,19 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern+-- Description: Manipulating Egison patterns: abstract syntax, parser, and pretty-printer+-- Stability: experimental+--+-- This package provides a standalone syntax definition for patterns in [Egison programming language](https://www.egison.org/).++module Language.Egison.Syntax.Pattern+ ( module X+ )+where++import Language.Egison.Syntax.Pattern.Expr+ as X+import Language.Egison.Syntax.Pattern.Base+ as X+import Language.Egison.Syntax.Pattern.Combinator+ as X
+ src/Language/Egison/Syntax/Pattern/Base.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+--+-- Module: Language.Egison.Syntax.Pattern.Base+-- Description: Base functor for Egison pattern expression+-- Stability: experimental+--+-- This module defines a base functor of 'Expr' that is useful to abstract recursive computations on 'Expr'.++module Language.Egison.Syntax.Pattern.Base+ ( ExprF(..)+ )+where++import Data.Functor.Foldable.TH ( makeBaseFunctor )++import Language.Egison.Syntax.Pattern.Expr+ ( Expr(..) )+++-- | Base functor of 'Expr'.+$(makeBaseFunctor ''Expr)
+ src/Language/Egison/Syntax/Pattern/Combinator.hs view
@@ -0,0 +1,103 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Parser.Combinator+-- Description: Useful combinators to manipulate Egison pattern ASTs+-- Stability: experimental+--+-- Useful combinators to manipulate Egison pattern ASTs.++module Language.Egison.Syntax.Pattern.Combinator+ ( unAnnotate+ , foldExpr+ , mapName+ , mapVarName+ , mapValueExpr+ , variables+ )+where++import Control.Applicative ( Alternative(..) )+import Data.Foldable ( asum )+import Data.Functor.Foldable ( cata+ , embed+ )+import Control.Comonad.Cofree ( Cofree )+import Control.Comonad.Trans.Cofree ( CofreeF(..) )++import Language.Egison.Syntax.Pattern.Expr+ ( Expr(..) )+import Language.Egison.Syntax.Pattern.Base+ ( ExprF(..) )+++-- | Unwrap annotations from AST.+unAnnotate :: Cofree (ExprF n v e) a -> Expr n v e+unAnnotate = cata go where go (_ :< x) = embed x++-- | fold an v expr.+--+-- Note that this is just a type specialization of 'cata'.+foldExpr :: (ExprF n v e a -> a) -> Expr n v e -> a+foldExpr = cata++-- TODO: Implement 'mapName' and 'mapValueExpr' by adding newtype wrapper for them and making them instances of 'MonoFunctor'++-- | Map over @n@ in @Expr n v e@.+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+ -- 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++-- | 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)+ -- 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++-- | Map over @e@ in @Expr n v e@.+mapValueExpr :: (e -> e') -> Expr n v e -> Expr n v e'+mapValueExpr f = cata go+ where+ go (ValueF e) = Value (f e)+ go (PredicateF e) = Predicate (f e)+ -- TODO: omit these verbose matches+ go WildcardF = Wildcard+ go (VariableF n ) = Variable n+ go (InfixF n p1 p2) = Infix n p1 p2+ go (PatternF n ps) = Pattern n ps+ go (AndF p1 p2) = And p1 p2+ go (OrF p1 p2) = Or p1 p2+ go (NotF p1 ) = Not p1++-- | List bound pattern variables in a pattern.+variables :: Alternative f => Expr n v e -> f v+variables = cata go+ where+ 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
+ src/Language/Egison/Syntax/Pattern/Expr.hs view
@@ -0,0 +1,43 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Base+-- Description: Abstract syntax tree for Egison pattern expression+-- Stability: experimental+--+-- This module defines an AST (Abstract Syntax Tree) for Egison pattern expression.++module Language.Egison.Syntax.Pattern.Expr+ ( Expr(..)+ )+where++import GHC.Generics ( Generic )+import Data.Data ( Data+ , Typeable+ )+++-- | Egison pattern expressions.+-- @n@ is a type for name references in patterns, such as them in pattern constructors.+-- @v@ is a type for name bindings in patterns, such as them in pattern variables.+-- @e@ is a type for expressions in patterns, such as them in value patterns.+data Expr n v e+ -- | Wildcard pattern. Match with everything.+ = Wildcard+ -- | Pattern variable. The matched term is bound to the name.+ | Variable v+ -- | Value pattern. Match with equal terms.+ | Value e+ -- | Predicate pattern. Match with terms that satisfy the given predicate.+ | Predicate e+ -- | And pattern. Match when both patterns matches.+ | And (Expr n v e) (Expr n v e)+ -- | Or pattern. Match when one of given patterns matches.+ | Or (Expr n v e) (Expr n v e)+ -- | Not pattern. Match when the given pattern does not match.+ | Not (Expr n v e)+ -- | User-defined infix pattern.+ | Infix n (Expr n v e) (Expr n v e)+ -- | User-defined normal pattern.+ | Pattern n [Expr n v e]+ deriving (Eq, Ord, Show, Typeable, Data, Generic)
+ src/Language/Egison/Syntax/Pattern/Fixity.hs view
@@ -0,0 +1,27 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Fixity+-- Description: Fixity of infix operators+-- Stability: experimental+--+-- A fixity of infix operators.++module Language.Egison.Syntax.Pattern.Fixity+ ( Fixity(..)+ , Associativity(..)+ , Precedence(..)+ )+where++import Language.Egison.Syntax.Pattern.Fixity.Associativity+ ( Associativity(..) )+import Language.Egison.Syntax.Pattern.Fixity.Precedence+ ( Precedence(..) )+++-- | Fixity of infix operators.+data Fixity n =+ Fixity { associativity :: Associativity+ , precedence :: Precedence+ , symbol :: n+ }
+ src/Language/Egison/Syntax/Pattern/Fixity/Associativity.hs view
@@ -0,0 +1,22 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Fixity.Associativity+-- Description: Associativity of infix operators+-- Stability: experimental+--+-- An associativity of infix operators.++module Language.Egison.Syntax.Pattern.Fixity.Associativity+ ( Associativity(..)+ )+where++import GHC.Generics ( Generic )+import Data.Data ( Data+ , Typeable+ )+++-- | Associativity of infix operators.+data Associativity = AssocLeft | AssocRight | AssocNone+ deriving (Show, Eq, Generic, Data, Typeable)
+ src/Language/Egison/Syntax/Pattern/Fixity/Precedence.hs view
@@ -0,0 +1,28 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Fixity.Precedence+-- Description: A precedence of infix operators+-- Stability: experimental+--+-- A precedence of infix operators.++module Language.Egison.Syntax.Pattern.Fixity.Precedence+ ( Precedence(..)+ , toInt+ )+where++import GHC.Generics ( Generic )+import Data.Data ( Data+ , Typeable+ )+++-- | A precedence of infix operators.+newtype Precedence = Precedence Int+ deriving newtype (Eq, Ord)+ deriving stock (Show, Generic, Data, Typeable)++-- | Obtain an integer representation of 'Precedence'.+toInt :: Precedence -> Int+toInt (Precedence i) = i
+ src/Language/Egison/Syntax/Pattern/Fixity/Primitive.hs view
@@ -0,0 +1,37 @@+-- |+--+-- Module: Language.Egison.Syntax.Pattern.Fixity.Primitive+-- Description: Fixity of primitive operators+-- Stability: experimental+--+-- This internal module defines fixities of primitive operators.++module Language.Egison.Syntax.Pattern.Fixity.Primitive+ ( andPrecedence+ , andAssociativity+ , orPrecedence+ , orAssociativity+ , notPrecedence+ )+where++import Language.Egison.Syntax.Pattern.Fixity.Precedence+ ( Precedence(..) )+import Language.Egison.Syntax.Pattern.Fixity.Associativity+ ( Associativity(..) )+++andPrecedence :: Precedence+andPrecedence = Precedence 3++orPrecedence :: Precedence+orPrecedence = Precedence 2++andAssociativity :: Associativity+andAssociativity = AssocRight++orAssociativity :: Associativity+orAssociativity = AssocRight++notPrecedence :: Precedence+notPrecedence = Precedence 5
+ test/Language/Egison/Parser/PatternSpec.hs view
@@ -0,0 +1,118 @@+module Language.Egison.Parser.PatternSpec+ ( test_atom_patterns+ , test_primitive_pattern_operators+ , test_user_defined_pattern_operators+ , test_user_defined_comments+ )+where++import TestImport++import Test.Tasty+import Test.Tasty.HUnit+++assertParseExpr :: String -> Expr Name Name ValueExpr -> Assertion+assertParseExpr content expected = case testParseExpr content of+ Left err -> fail $ show err+ Right got -> assertEqual ("while parsing \"" ++ content ++ "\"") expected got++test_atom_patterns :: [TestTree]+test_atom_patterns =+ [ testCase "wildcard pattern" $ assertParseExpr "_" Wildcard+ , testCase "variable pattern" $ assertParseExpr "$x" (Variable $ Name "x")+ , testCase "value pattern" $ assertParseExpr "#10" (Value $ ValueExprInt 10)+ , testCase "value pattern between parentheses"+ $ assertParseExpr "#(-10)" (Value . ValueExprInt $ -10)+ , testCase "predicate pattern"+ $ assertParseExpr "?10" (Predicate $ ValueExprInt 10)+ , testCase "constructor pattern" $ 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 without arguments"+ $ assertParseExpr "nil" (Pattern (Name "nil") [])+ , testCase "constructor pattern between parentheses"+ $ assertParseExpr "((c _))" (Pattern (Name "c") [Wildcard])+ , testCase "wildcard pattern between parentheses"+ $ assertParseExpr "((_))" Wildcard+ , testCase "constructor pattern without arguments between parentheses"+ $ assertParseExpr "((c))" (Pattern (Name "c") [])+ , testCase "nested constructor pattern" $ assertParseExpr+ "(ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE)"+ (Pattern+ (Name "ctorA")+ [ Pattern (Name "ctorB") [Wildcard]+ , Pattern (Name "ctorC") [Wildcard, Pattern (Name "ctorD") [Wildcard]]+ , Wildcard+ , Pattern (Name "ctorE") []+ ]+ )+ ]++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))+ , testCase "nested or pattern"+ $ assertParseExpr "_ | _ | _" (Or Wildcard (Or Wildcard Wildcard))+ -- precedence+ , testCase "nested and, or pattern" $ assertParseExpr+ "_ & _ | _ & _"+ (Or (And Wildcard Wildcard) (And Wildcard Wildcard))+ , testCase "nested not, or pattern"+ $ 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])+ ]++test_user_defined_pattern_operators :: [TestTree]+test_user_defined_pattern_operators =+ [ testCase "cons pattern"+ $ assertParseExpr "_ : _" (Infix (Name ":") Wildcard Wildcard)+ , testCase "join pattern"+ $ assertParseExpr "_ ++ _" (Infix (Name "++") Wildcard Wildcard)+ -- associativity+ , testCase "nested cons pattern" $ assertParseExpr+ "_ : _ : _"+ (Infix (Name ":") Wildcard (Infix (Name ":") Wildcard Wildcard))+ , testCase "nested join pattern" $ assertParseExpr+ "_ ++ _ ++ _"+ (Infix (Name "++") Wildcard (Infix (Name "++") Wildcard Wildcard))+ , testCase "nested join, cons pattern" $ assertParseExpr+ "_ ++ _ : _"+ (Infix (Name "++") Wildcard (Infix (Name ":") Wildcard Wildcard))+ , testCase "nested cons, join pattern" $ assertParseExpr+ "_ : _ ++ _"+ (Infix (Name ":") Wildcard (Infix (Name "++") Wildcard Wildcard))+ -- and more+ , testCase "precedence" $ assertParseExpr+ "_ : _ <| _"+ (Infix (Name "<|") (Infix (Name ":") Wildcard Wildcard) Wildcard)+ , testCase "associativity" $ assertParseExpr+ "_ |> _ |> _"+ (Infix (Name "|>") (Infix (Name "|>") Wildcard Wildcard) Wildcard)+ ]++test_user_defined_comments :: [TestTree]+test_user_defined_comments =+ [ testCase "ignore a block comment"+ $ assertParseExpr "_ {- comment -} & _" (And Wildcard Wildcard)+ , testCase "ignore block comments" $ assertParseExpr+ "_ {- comment1 -}{- comment2 -} & (_ &{- comment3 -}_)"+ (And Wildcard (And Wildcard Wildcard))+ , testCase "ignore a block comment at beginning of line"+ $ assertParseExpr "{- comment -}_" Wildcard+ , testCase "ignore a line comment"+ $ assertParseExpr "_-- comment -- yeah" Wildcard+ , testCase "ignore a line comment at beginning of line"+ $ assertParseExpr "-- comment -- yeah \n_-- comment" Wildcard+ ]
+ test/Language/Egison/Pretty/PatternSpec.hs view
@@ -0,0 +1,111 @@+module Language.Egison.Pretty.PatternSpec+ ( test_atom_patterns+ , test_primitive_pattern_operators+ , test_user_defined_pattern_operators+ )+where++import TestImport++import Data.Text ( Text )+import Test.Tasty+import Test.Tasty.HUnit+++assertPrintExpr :: Expr Name Name ValueExpr -> Text -> Assertion+assertPrintExpr e expected = case testPrintExpr e of+ Left err -> fail $ show err+ Right got -> assertEqual ("while printing \"" ++ show e ++ "\"") expected got++test_atom_patterns :: [TestTree]+test_atom_patterns =+ [ testCase "wildcard pattern" $ assertPrintExpr Wildcard "_"+ , testCase "variable pattern" $ assertPrintExpr (Variable $ Name "x") "$x"+ , testCase "value pattern" $ assertPrintExpr (Value $ ValueExprInt 10) "#10"+ , testCase "predicate pattern"+ $ assertPrintExpr (Predicate $ ValueExprInt 10) "?10"+ , testCase "constructor pattern" $ assertPrintExpr+ (Pattern (Name "ctor") [Wildcard, Wildcard, Wildcard])+ "(ctor _ _ _)"+ , testCase "constructor pattern without arguments"+ $ assertPrintExpr (Pattern (Name "nil") []) "nil"+ , testCase "nested constructor pattern" $ assertPrintExpr+ (Pattern+ (Name "ctorA")+ [ Pattern (Name "ctorB") [Wildcard]+ , Pattern (Name "ctorC") [Wildcard, Pattern (Name "ctorD") [Wildcard]]+ , Wildcard+ , Pattern (Name "ctorE") []+ ]+ )+ "(ctorA (ctorB _) (ctorC _ (ctorD _)) _ ctorE)"+ ]++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)) "_ & _ & _"+ , testCase "nested and pattern (with parentheses)"+ $ assertPrintExpr (And (And Wildcard Wildcard) Wildcard) "(_ & _) & _"+ , testCase "nested or pattern"+ $ assertPrintExpr (Or Wildcard (Or Wildcard Wildcard)) "_ | _ | _"+ , testCase "nested or pattern (with parentheses)"+ $ assertPrintExpr (Or (Or Wildcard Wildcard) Wildcard) "(_ | _) | _"+ -- precedence+ , testCase "nested and, or pattern" $ assertPrintExpr+ (Or (And Wildcard Wildcard) (And Wildcard Wildcard))+ "_ & _ | _ & _"+ , testCase "nested and, or pattern (with parentheses)" $ assertPrintExpr+ (And (Or Wildcard Wildcard) (Or Wildcard Wildcard))+ "(_ | _) & (_ | _)"+ , testCase "nested not, or pattern"+ $ 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 !_ !_)"+ ]++test_user_defined_pattern_operators :: [TestTree]+test_user_defined_pattern_operators =+ [ testCase "cons pattern"+ $ assertPrintExpr (Infix (Name ":") Wildcard Wildcard) "_ : _"+ , testCase "join pattern"+ $ assertPrintExpr (Infix (Name "++") Wildcard Wildcard) "_ ++ _"+ -- associativity+ , testCase "nested cons pattern" $ assertPrintExpr+ (Infix (Name ":") Wildcard (Infix (Name ":") Wildcard Wildcard))+ "_ : _ : _"+ , testCase "nested join pattern" $ assertPrintExpr+ (Infix (Name "++") Wildcard (Infix (Name "++") Wildcard Wildcard))+ "_ ++ _ ++ _"+ , testCase "nested join, cons pattern" $ assertPrintExpr+ (Infix (Name "++") Wildcard (Infix (Name ":") Wildcard Wildcard))+ "_ ++ _ : _"+ , testCase "nested cons, join pattern" $ assertPrintExpr+ (Infix (Name ":") Wildcard (Infix (Name "++") Wildcard Wildcard))+ "_ : _ ++ _"+ , testCase "nested cons, join pattern (with parentheses)" $ assertPrintExpr+ (Infix (Name "++") (Infix (Name ":") Wildcard Wildcard) Wildcard)+ "(_ : _) ++ _"+ -- and more+ , testCase "precedence" $ assertPrintExpr+ (Infix (Name "<|") (Infix (Name ":") Wildcard Wildcard) Wildcard)+ "_ : _ <| _"+ , testCase "precedence (with parentheses)" $ assertPrintExpr+ (Infix (Name ":") Wildcard (Infix (Name "<|") Wildcard Wildcard))+ "_ : (_ <| _)"+ , testCase "associativity" $ assertPrintExpr+ (Infix (Name "|>") (Infix (Name "|>") Wildcard Wildcard) Wildcard)+ "_ |> _ |> _"+ , testCase "associativity (with parentheses)" $ assertPrintExpr+ (Infix (Name "|>") Wildcard (Infix (Name "|>") Wildcard Wildcard))+ "_ |> (_ |> _)"+ ]
+ test/TestImport.hs view
@@ -0,0 +1,124 @@+module TestImport+ ( testParseExpr+ , testPrintExpr+ , Name(..)+ , ValueExpr(..)+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Egison.Syntax.Pattern.Expr+ as X++-- main+import Data.Text ( 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+ ( chunk+ , single+ , parse+ )+import qualified Text.Megaparsec.Char as Parsec+ ( letterChar )+import qualified Text.Megaparsec.Char.Lexer as Parsec+ ( decimal )++import Language.Egison.Syntax.Pattern.Expr+ ( Expr(..) )+import Language.Egison.Parser.Pattern ( ParseMode(..)+ , ParseFixity(..)+ , Fixity(..)+ , Precedence(..)+ , Associativity(..)+ , Errors+ , parseExpr+ )+import Language.Egison.Pretty.Pattern ( PrintMode(..)+ , PrintFixity(..)+ , Error+ , prettyExpr+ )+++newtype Name = Name String+ deriving (Show, Eq, Ord)++newtype ValueExpr = ValueExprInt Int+ deriving newtype Num+ deriving stock (Show, Eq)++unParsec :: Parsec Void String a -> (String -> Either String a)+unParsec p input = case Parsec.parse p "test" input of+ Left e -> Left (show e)+ Right x -> Right x++testFixities :: [Fixity Name]+testFixities =+ [ Fixity AssocRight (Precedence 5) (Name "++")+ , Fixity AssocRight (Precedence 5) (Name ":")+ , Fixity AssocLeft (Precedence 4) (Name "|>")+ , Fixity AssocRight (Precedence 4) (Name "<|")+ ]++toParseFixity :: Fixity Name -> ParseFixity Name String+toParseFixity fixity@(Fixity _ _ (Name name)) = ParseFixity fixity+ $ unParsec parser+ where parser = void $ Parsec.chunk name++toPrintFixity :: Fixity Name -> PrintFixity Name+toPrintFixity fixity@(Fixity _ _ (Name name)) = PrintFixity fixity $ pack name++testParseName :: Parsec Void String Name+testParseName = withParens <|> name+ where+ name = Name <$> some Parsec.letterChar+ ops = Parsec.chunk "++"+ withParens = do+ op <- Parsec.single '(' *> ops <* Parsec.single ')'+ pure $ Name op++testParseValueExpr :: Parsec Void String ValueExpr+testParseValueExpr = withParens <|> dec+ where+ dec = ValueExprInt <$> Parsec.decimal+ withParens = do+ d <- Parsec.chunk "(-" *> dec <* Parsec.single ')'+ pure $ negate d++testParseMode :: ParseMode Name Name ValueExpr String+testParseMode = ParseMode { fixities = map toParseFixity testFixities+ , blockComment = Just ("{-", "-}")+ , lineComment = Just "--"+ , varNameParser = unParsec testParseName+ , nameParser = unParsec testParseName+ , valueExprParser = unParsec testParseValueExpr+ }++testPrintMode :: PrintMode Name Name ValueExpr+testPrintMode = PrintMode { fixities = map toPrintFixity testFixities+ , varNamePrinter = namePrinter+ , namePrinter+ , valueExprPrinter = valueExprPrinter+ , pageMode = Nothing+ }+ 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
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}