egison-pattern-src-haskell-mode (empty) → 0.1.0.0
raw patch · 11 files changed
+739/−0 lines, 11 filesdep +basedep +egison-pattern-srcdep +egison-pattern-src-haskell-modesetup-changed
Dependencies added: base, egison-pattern-src, egison-pattern-src-haskell-mode, haskell-src-exts, mtl, tasty, tasty-hunit, text
Files
- CHANGELOG.md +3/−0
- LICENSE +11/−0
- README.md +12/−0
- Setup.hs +4/−0
- egison-pattern-src-haskell-mode.cabal +80/−0
- src/Language/Egison/Parser/Pattern/Mode/Haskell.hs +162/−0
- src/Language/Egison/Pretty/Pattern/Mode/Haskell.hs +120/−0
- test/Language/Egison/Parser/Pattern/Mode/HaskellSpec.hs +151/−0
- test/Language/Egison/Pretty/Pattern/Mode/HaskellSpec.hs +115/−0
- test/TestImport.hs +80/−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,12 @@+# Egison Pattern Source (Haskell Mode)++[](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-haskell-mode)+[](http://packdeps.haskellers.com/reverse/egison-pattern-src-haskell-mode)++The [egison-pattern-src-haskell-mode](https://hackage.haskell.org/package/egison-pattern-src-haskell-mode) provides a parser and pretty printer for [egison-pattern-src](https://hackage.haskell.org/package/egison-pattern-src) to use it in Haskell source code.++## License++[egison-pattern-src-haskell-mode](https://hackage.haskell.org/package/egison-pattern-src-haskell-mode) 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-haskell-mode.cabal view
@@ -0,0 +1,80 @@+cabal-version: 2.0+name: egison-pattern-src-haskell-mode+version: 0.1.0.0+synopsis:+ Parser and pretty printer for Egison pattern expressions in Haskell source code++description:+ @egison-pattern-src-haskell-mode@ provides a parser and pretty printer for @egison-pattern-src@ to use it in Haskell source code.+ See <https://github.com/egison/egison-pattern-src> for more information.++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.7 && <5+ , egison-pattern-src ^>=0.1.0+ , haskell-src-exts >=1.11.1 && <1.24+ , mtl ^>=2.2.1+ , text >=0.1.0 && <1.3++ hs-source-dirs: src+ exposed-modules:+ Language.Egison.Parser.Pattern.Mode.Haskell+ Language.Egison.Pretty.Pattern.Mode.Haskell++ if impl(ghc >=8)+ ghc-options: -Wredundant-constraints++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns++ default-language: Haskell2010+ default-extensions:+ FlexibleContexts+ NamedFieldPuns++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+ , egison-pattern-src-haskell-mode+ , haskell-src-exts+ , mtl+ , tasty+ , tasty-hunit+ , text++ default-extensions: FlexibleContexts++ -- cabal-fmt: expand test+ other-modules:+ Language.Egison.Parser.Pattern.Mode.HaskellSpec+ Language.Egison.Pretty.Pattern.Mode.HaskellSpec+ TestImport++ build-tool-depends: tasty-discover:tasty-discover -any
+ src/Language/Egison/Parser/Pattern/Mode/Haskell.hs view
@@ -0,0 +1,162 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Mode.Haskell+-- Description: Parser for Egison pattern expressions in Haskell source code+-- Stability: experimental+--+-- A parser for Egison pattern expressions in Haskell source code.++module Language.Egison.Parser.Pattern.Mode.Haskell+ (+ -- * Parsers+ Expr+ , parseExpr+ , parseExprWithFixities+ -- * Converting @haskell-src-exts@'s entities+ , ParseMode+ , ParseFixity+ , Fixity+ , makeHaskellMode+ , makeFixity+ , makeParseFixity+ , makeParseFixities+ )+where++import Data.Functor ( void )+import Data.Maybe ( mapMaybe )+import Control.Monad.Except ( MonadError )++import Language.Haskell.Exts.Syntax ( QName(..)+ , Exp(..)+ , Name(..)+ , ModuleName(..)+ , Exp+ )+import Language.Haskell.Exts.SrcLoc ( SrcSpanInfo )+import qualified Language.Haskell.Exts.Fixity as Haskell+ ( Fixity(..) )+import qualified Language.Haskell.Exts.Syntax as Haskell+ ( Assoc(..) )+import qualified Language.Haskell.Exts.Parser as Haskell+ ( parseExpWithMode+ , ParseMode(..)+ , ParseResult(..)+ )++import qualified Language.Egison.Syntax.Pattern+ as Egison+ ( Expr )+import qualified Language.Egison.Parser.Pattern+ as Egison+ ( ParseMode(..)+ , ParseFixity(..)+ , Fixity(..)+ , Associativity(..)+ , parseExpr+ )+import Language.Egison.Parser.Pattern ( Precedence(..)+ , Errors+ )+++-- | Type synonym of 'Egison.Expr' to be parsed in Haskell's source code.+type Expr = Egison.Expr (QName ()) (Name ()) (Exp SrcSpanInfo)++-- | Type synonym of 'Egison.ParseMode' to parse 'Expr'.+type ParseMode = Egison.ParseMode (QName ()) (Name ()) (Exp SrcSpanInfo) String++-- | Type synonym of 'Egison.Fixity' to parse 'Expr'.+type Fixity = Egison.Fixity (QName ())++-- | Type synonym of 'Egison.ParseFixity' to parse 'Expr'.+type ParseFixity = Egison.ParseFixity (QName ()) String++resultToEither :: Haskell.ParseResult a -> Either String a+resultToEither (Haskell.ParseOk a ) = Right a+resultToEither (Haskell.ParseFailed _ e) = Left e++parseVarNameWithMode :: Haskell.ParseMode -> String -> Either String (Name ())+parseVarNameWithMode mode content =+ case resultToEither $ Haskell.parseExpWithMode mode content of+ Right (Var _ (UnQual _ name)) -> Right $ void name+ Right e -> Left (show e ++ " is not a variable")+ Left err -> Left err++parseNameWithMode :: Haskell.ParseMode -> String -> Either String (QName ())+parseNameWithMode mode content =+ case resultToEither $ Haskell.parseExpWithMode mode content of+ Right (Var _ name) -> Right $ void name+ Right (Con _ name) -> Right $ void name+ Right e -> Left (show e ++ " is not a name")+ Left err -> Left err++-- | Build 'Egison.Fixity' using 'Haskell.Fixity' from @haskell-src-exts@.+-- Note that a built-in constructor with special syntax, that is represented as 'Special' in 'QName', is just ignored here.+makeFixity :: Haskell.Fixity -> Fixity+makeFixity (Haskell.Fixity assoc prec name) = fixity+ where+ fixity = Egison.Fixity (makeAssoc assoc) (Precedence prec) name+ makeAssoc (Haskell.AssocRight ()) = Egison.AssocRight+ makeAssoc (Haskell.AssocLeft ()) = Egison.AssocLeft+ makeAssoc (Haskell.AssocNone ()) = Egison.AssocNone++-- | Build 'Egison.ParseFixity' using 'Egison.Fixity' to parse Haskell-style operators+-- Note that a built-in constructor with special syntax, that is represented as 'Special' in 'QName', is just ignored here.+makeParseFixity :: Fixity -> Maybe ParseFixity+makeParseFixity fixity = Egison.ParseFixity fixity <$> makeNameParser symbol+ where+ Egison.Fixity { Egison.symbol } = fixity+ makeNameParser (UnQual () (Ident () n)) = Just $ makeIdentOpParser Nothing n+ makeNameParser (UnQual () (Symbol () n)) =+ Just $ makeSymbolOpParser Nothing n+ makeNameParser (Qual () (ModuleName () m) (Ident () n)) =+ Just $ makeIdentOpParser (Just m) n+ makeNameParser (Qual () (ModuleName () m) (Symbol () n)) =+ Just $ makeSymbolOpParser (Just m) n+ makeNameParser (Special () _) = Nothing -- Skipping special built-in constructors+ -- TODO: Maybe we could do better here+ makeIdentOpParser mModName ident content+ | content == printed = Right ()+ | otherwise = Left "not an operator name"+ where printed = '`' : maybe ident (++ '.' : ident) mModName ++ "`"+ makeSymbolOpParser mModName sym content+ | content == printed = Right ()+ | otherwise = Left "not an operator name"+ where printed = maybe sym (++ '.' : sym) mModName++-- | @'makeParseFixities' = 'mapMaybe' $ 'makeParseFixity' . 'makeFixity'@+makeParseFixities :: [Haskell.Fixity] -> [ParseFixity]+makeParseFixities = mapMaybe $ makeParseFixity . makeFixity++-- | Build 'ParseMode' using 'Haskell.ParseMode' from @haskell-src-exts@.+makeHaskellMode :: Haskell.ParseMode -> ParseMode+makeHaskellMode mode@Haskell.ParseMode { Haskell.fixities } = Egison.ParseMode+ { Egison.fixities = maybe [] makeParseFixities fixities+ , Egison.blockComment = Just ("{-", "-}")+ , Egison.lineComment = Just "--"+ , Egison.varNameParser = parseVarNameWithMode mode+ , Egison.nameParser = parseNameWithMode mode+ , Egison.valueExprParser = resultToEither . Haskell.parseExpWithMode mode+ }++-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@.+parseExpr+ :: MonadError (Errors String) m => Haskell.ParseMode -> String -> m Expr+parseExpr mode@Haskell.ParseMode { Haskell.parseFilename } =+ Egison.parseExpr (makeHaskellMode mode) parseFilename++-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@, while supplying an explicit list of 'ParseFixity'.+-- Note that fixities obtained from 'Haskell.ParseMode' are just ignored here.+parseExprWithFixities+ :: MonadError (Errors String) m+ => Haskell.ParseMode+ -> [Fixity]+ -> String+ -> m Expr+parseExprWithFixities mode@Haskell.ParseMode { Haskell.parseFilename } fixities+ = Egison.parseExpr hsModeWithFixities parseFilename+ where+ hsMode = makeHaskellMode mode+ hsModeWithFixities =+ hsMode { Egison.fixities = mapMaybe makeParseFixity fixities }
+ src/Language/Egison/Pretty/Pattern/Mode/Haskell.hs view
@@ -0,0 +1,120 @@+-- |+--+-- Module: Language.Egison.Pretty.Pattern.Mode.Haskell+-- Description: Printer for Egison pattern expressions in Haskell source code+-- Stability: experimental+--+-- A printer for Egison pattern expressions in Haskell source code.++module Language.Egison.Pretty.Pattern.Mode.Haskell+ (+ -- * Printers+ Expr+ , prettyExpr+ , prettyExprWithFixities+ -- * Converting @haskell-src-exts@'s entities+ , PrintMode+ , PrintFixity+ , Fixity+ , makePageMode+ , makeHaskellMode+ , makePrintFixity+ )+where++import Data.Text ( Text+ , pack+ )+import Control.Monad.Except ( MonadError )+import Language.Haskell.Exts.Syntax ( QName(..)+ , Exp+ , Name(..)+ , ModuleName(..)+ )+import qualified Language.Haskell.Exts.Pretty as Haskell+ ( Style(..)+ , PPHsMode+ , Pretty+ , prettyPrint+ , prettyPrintStyleMode+ )+import qualified Language.Egison.Syntax.Pattern+ as Egison+ ( Expr )+import qualified Language.Egison.Pretty.Pattern+ as Egison+ ( PrintMode(..)+ , PrintFixity(..)+ , Fixity(..)+ , PageMode(..)+ , prettyExpr+ )+import Language.Egison.Pretty.Pattern ( Error )+++-- | Type synonym of 'Egison.Expr' to be printed with Haskell's source code.+type Expr = Egison.Expr (QName ()) (Name ()) (Exp ())++-- | Type synonym of 'Egison.PrintMode' to print 'Expr'.+type PrintMode = Egison.PrintMode (QName ()) (Name ()) (Exp ())++-- | Type synonym of 'Egison.Fixity' to print 'Expr'.+type Fixity = Egison.Fixity (QName ())++-- | Type synonym of 'Egison.PrintFixity' to print 'Expr'.+type PrintFixity = Egison.PrintFixity (QName ())++-- | Build 'Egison.PageMode' using 'Haskell.Style' from @haskell-src-exts@.+makePageMode :: Haskell.Style -> Egison.PageMode+makePageMode Haskell.Style { Haskell.lineLength, Haskell.ribbonsPerLine } =+ Egison.PageMode { Egison.lineLength+ , Egison.ribbonsPerLine = realToFrac ribbonsPerLine+ }++-- | Build 'PrintFixity' using 'Fixity' to print Haskell operators.+makePrintFixity :: Fixity -> PrintFixity+makePrintFixity fixity@(Egison.Fixity _ _ sym) = Egison.PrintFixity+ { Egison.fixity+ , Egison.printed = pack $ printSym sym+ }+ where+ printSym (UnQual () (Ident () n) ) = printIdentOp Nothing n+ printSym (UnQual () (Symbol () n) ) = printSymbolOp Nothing n+ printSym (Qual () (ModuleName () m) (Ident () n)) = printIdentOp (Just m) n+ printSym (Qual () (ModuleName () m) (Symbol () n)) = printSymbolOp (Just m) n+ printSym (Special () s ) = Haskell.prettyPrint s+ printIdentOp mModName n = '`' : maybe n (++ '.' : n) mModName ++ "`"+ printSymbolOp mModName n = maybe n (++ '.' : n) mModName++-- | Build 'PrintMode' using 'Haskell.Style' and 'Haskell.PPHsMode' from @haskell-src-exts@, and the list of fixities.+makeHaskellMode :: Haskell.Style -> Haskell.PPHsMode -> [Fixity] -> PrintMode+makeHaskellMode style mode fixities = Egison.PrintMode+ { Egison.fixities = map makePrintFixity fixities+ , Egison.varNamePrinter = pprint+ , Egison.namePrinter = pprint+ , Egison.valueExprPrinter = pprint+ , Egison.pageMode = Just $ makePageMode style+ }+ where+ pprint :: Haskell.Pretty a => a -> Text+ pprint = pack . Haskell.prettyPrintStyleMode style mode++-- | Print 'Expr' using 'Haskell.Style' and 'Haskell.PPHsMode' from @haskell-src-exts@.+prettyExpr+ :: MonadError (Error (QName ())) m+ => Haskell.Style+ -> Haskell.PPHsMode+ -> Expr+ -> m Text+prettyExpr style mode = Egison.prettyExpr (makeHaskellMode style mode [])++-- | Print 'Expr' using 'Haskell.Style' and 'Haskell.PPHsMode' from @haskell-src-exts@, while supplying an explicit list of 'Fixity'.+prettyExprWithFixities+ :: MonadError (Error (QName ())) m+ => Haskell.Style+ -> Haskell.PPHsMode+ -> [Fixity]+ -> Expr+ -> m Text+prettyExprWithFixities style mode fixities =+ Egison.prettyExpr (makeHaskellMode style mode fixities)
+ test/Language/Egison/Parser/Pattern/Mode/HaskellSpec.hs view
@@ -0,0 +1,151 @@+module Language.Egison.Parser.Pattern.Mode.HaskellSpec+ ( test_atom_patterns+ , test_pattern_operators+ , test_special_pattern_operators+ , test_comments+ )+where++import TestImport++import Test.Tasty+import Test.Tasty.HUnit++import Data.Functor ( void )+import Language.Haskell.Exts.Build ( name+ , sym+ , op+ , paren+ , infixApp+ , intE+ )+++makeAssertion+ :: (String -> Either (Errors String) (Expr (QName ()) (Name ()) (Exp ())))+ -> String+ -> Expr (QName ()) (Name ()) (Exp ())+ -> Assertion+makeAssertion parser content expected = case parser content of+ Left err -> fail $ show err+ Right got -> assertEqual ("while parsing \"" ++ content ++ "\"") expected got++assertParseExpr :: String -> Expr (QName ()) (Name ()) (Exp ()) -> Assertion+assertParseExpr = makeAssertion $ fmap (mapValueExpr void) . testParseExpr++assertParseExprSpecialFixities+ :: String -> Expr (QName ()) (Name ()) (Exp ()) -> Assertion+assertParseExprSpecialFixities =+ makeAssertion $ fmap (mapValueExpr void) . testParseExprSpecialFixities+++uqname :: String -> QName ()+uqname = UnQual () . name++qname :: String -> String -> QName ()+qname modName = Qual () (ModuleName () modName) . name++uqsym :: String -> QName ()+uqsym = UnQual () . sym++qsym :: String -> String -> QName ()+qsym modName = Qual () (ModuleName () modName) . sym++test_atom_patterns :: [TestTree]+test_atom_patterns =+ [ testCase "wildcard pattern" $ assertParseExpr "_" Wildcard+ , testCase "variable pattern" $ assertParseExpr "$x" (Variable $ name "x")+ , testCase "variable pattern of symbols"+ $ assertParseExpr "$(%)" (Variable $ sym "%")+ , testCase "value pattern" $ assertParseExpr "#10" (Value $ intE 10)+ , testCase "value pattern between parentheses" $ assertParseExpr+ "#(1 + 2)"+ (Value . paren $ infixApp (intE 1) (op $ sym "+") (intE 2))+ , testCase "predicate pattern" $ assertParseExpr "?10" (Predicate $ intE 10)+ , testCase "constructor pattern" $ assertParseExpr+ "(ctor _ _ _)"+ (Pattern (uqname "ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern with data constructor" $ assertParseExpr+ "(Ctor _ _ _)"+ (Pattern (uqname "Ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern with qualified name" $ assertParseExpr+ "(Mod.ctor _ _ _)"+ (Pattern (qname "Mod" "ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern that the symbol is between parentheses"+ $ assertParseExpr "((++) _ _)" (Pattern (uqsym "++") [Wildcard, Wildcard])+ , testCase+ "constructor pattern that the qualified symbol is between parentheses"+ $ assertParseExpr "((Mod.++) _ _)"+ (Pattern (qsym "Mod" "++") [Wildcard, Wildcard])+ , testCase "constructor pattern without arguments"+ $ assertParseExpr "nil" (Pattern (uqname "nil") [])+ , testCase "constructor pattern with qualified name without arguments"+ $ assertParseExpr "Mod.nil" (Pattern (qname "Mod" "nil") [])+ , testCase "constructor pattern between parentheses"+ $ assertParseExpr "((c _))" (Pattern (uqname "c") [Wildcard])+ , testCase "wildcard pattern between parentheses"+ $ assertParseExpr "((_))" Wildcard+ , testCase "constructor pattern without arguments between parentheses"+ $ assertParseExpr "((c))" (Pattern (uqname "c") [])+ , testCase+ "constructor pattern with qualified name without arguments between parentheses"+ $ assertParseExpr "((Mod.c))" (Pattern (qname "Mod" "c") [])+ ]++test_pattern_operators :: [TestTree]+test_pattern_operators =+ [ testCase "right associativity" $ assertParseExpr+ "_ && _ && _"+ (Infix (uqsym "&&") Wildcard (Infix (uqsym "&&") Wildcard Wildcard))+ , testCase "left associativity" $ assertParseExpr+ "_ >> _ >> _"+ (Infix (uqsym ">>") (Infix (uqsym ">>") Wildcard Wildcard) Wildcard)+ , testCase "precedence (right associativity)" $ assertParseExpr+ "_ . _ ^ _"+ (Infix (uqsym "^") (Infix (uqsym ".") Wildcard Wildcard) Wildcard)+ , testCase "precedence (left associativity)" $ assertParseExpr+ "_ * _ !! _"+ (Infix (uqsym "*") Wildcard (Infix (uqsym "!!") Wildcard Wildcard))+ , testCase "precedence (mixed)" $ assertParseExpr+ "_ $ _ >> _"+ (Infix (uqsym "$") Wildcard (Infix (uqsym ">>") Wildcard Wildcard))+ , testCase "non-symbol"+ $ assertParseExpr "_ `mod` _" (Infix (uqname "mod") Wildcard Wildcard)+ ]++test_special_pattern_operators :: [TestTree]+test_special_pattern_operators =+ [ testCase "cons pattern" $ assertParseExprSpecialFixities+ "_ : _"+ (Infix (uqsym ":") Wildcard Wildcard)+ , testCase "join pattern" $ assertParseExprSpecialFixities+ "_ ++ _"+ (Infix (uqsym "++") Wildcard Wildcard)+ , testCase "nested cons pattern" $ assertParseExprSpecialFixities+ "_ : _ : _"+ (Infix (uqsym ":") Wildcard (Infix (uqsym ":") Wildcard Wildcard))+ , testCase "nested join pattern" $ assertParseExprSpecialFixities+ "_ ++ _ ++ _"+ (Infix (uqsym "++") Wildcard (Infix (uqsym "++") Wildcard Wildcard))+ , testCase "nested join, cons pattern" $ assertParseExprSpecialFixities+ "_ ++ _ : _"+ (Infix (uqsym "++") Wildcard (Infix (uqsym ":") Wildcard Wildcard))+ , testCase "nested cons, join pattern" $ assertParseExprSpecialFixities+ "_ : _ ++ _"+ (Infix (uqsym ":") Wildcard (Infix (uqsym "++") Wildcard Wildcard))+ ]++test_comments :: [TestTree]+test_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/Pattern/Mode/HaskellSpec.hs view
@@ -0,0 +1,115 @@+module Language.Egison.Pretty.Pattern.Mode.HaskellSpec+ ( test_atom_patterns+ , test_special_pattern_operators+ )+where++import TestImport++import Data.Text ( pack )+import Test.Tasty+import Test.Tasty.HUnit++import Language.Haskell.Exts.Build ( name+ , sym+ , op+ , infixApp+ , intE+ )+++assertPrintExpr :: Expr (QName ()) (Name ()) (Exp ()) -> String -> Assertion+assertPrintExpr e expected = case testPrintExpr e of+ Left err -> fail $ show err+ Right got ->+ assertEqual ("while printing \"" ++ show e ++ "\"") (pack expected) got++uqname :: String -> QName ()+uqname = UnQual () . name++qname :: String -> String -> QName ()+qname modName = Qual () (ModuleName () modName) . name++uqsym :: String -> QName ()+uqsym = UnQual () . sym++qsym :: String -> String -> QName ()+qsym modName = Qual () (ModuleName () modName) . sym++test_atom_patterns :: [TestTree]+test_atom_patterns =+ [ testCase "wildcard pattern" $ assertPrintExpr Wildcard "_"+ , testCase "variable pattern" $ assertPrintExpr (Variable $ name "x") "$x"+ , testCase "variable pattern of symbols"+ $ assertPrintExpr (Variable $ sym "%") "$(%)"+ , testCase "value pattern" $ assertPrintExpr (Value $ intE 10) "#10"+ , testCase "value pattern between parentheses" $ assertPrintExpr+ (Value $ infixApp (intE 1) (op $ sym "+") (intE 2))+ "#(1 + 2)"+ , testCase "predicate pattern" $ assertPrintExpr (Predicate $ intE 10) "?10"+ , testCase "constructor pattern" $ assertPrintExpr+ (Pattern (uqname "ctor") [Wildcard, Wildcard, Wildcard])+ "(ctor _ _ _)"+ , testCase "constructor pattern with data constructor" $ assertPrintExpr+ (Pattern (uqname "Ctor") [Wildcard, Wildcard, Wildcard])+ "(Ctor _ _ _)"+ , testCase "constructor pattern with qualified name" $ assertPrintExpr+ (Pattern (qname "Mod" "ctor") [Wildcard, Wildcard, Wildcard])+ "(Mod.ctor _ _ _)"+ , testCase "constructor pattern that the symbol is between parentheses"+ $ assertPrintExpr (Pattern (uqsym "++") [Wildcard, Wildcard]) "((++) _ _)"+ , testCase+ "constructor pattern that the qualified symbol is between parentheses"+ $ assertPrintExpr (Pattern (qsym "Mod" "++") [Wildcard, Wildcard])+ "((Mod.++) _ _)"+ , testCase "constructor pattern without arguments"+ $ assertPrintExpr (Pattern (uqname "nil") []) "nil"+ , testCase "constructor pattern with qualified name without arguments"+ $ assertPrintExpr (Pattern (qname "Mod" "nil") []) "Mod.nil"+ ]++test_special_pattern_operators :: [TestTree]+test_special_pattern_operators =+ [ testCase "cons pattern"+ $ assertPrintExpr (Infix (uqsym ":") Wildcard Wildcard) "_ : _"+ , testCase "join pattern"+ $ assertPrintExpr (Infix (uqsym "++") Wildcard Wildcard) "_ ++ _"+ , testCase "nested cons pattern" $ assertPrintExpr+ (Infix (uqsym ":") Wildcard (Infix (uqsym ":") Wildcard Wildcard))+ "_ : _ : _"+ , testCase "nested cons pattern (with parentheses)" $ assertPrintExpr+ (Infix (uqsym ":") (Infix (uqsym ":") Wildcard Wildcard) Wildcard)+ "(_ : _) : _"+ , testCase "nested cons pattern (qualified, with parentheses)"+ $ assertPrintExpr+ (Infix (uqsym ":")+ (Infix (qsym "Special" ":") Wildcard Wildcard)+ Wildcard+ )+ "(_ Special.: _) : _"+ , testCase "nested join pattern" $ assertPrintExpr+ (Infix (uqsym "++") Wildcard (Infix (uqsym "++") Wildcard Wildcard))+ "_ ++ _ ++ _"+ , testCase "nested join pattern (with parentheses)" $ assertPrintExpr+ (Infix (uqsym "++") (Infix (uqsym "++") Wildcard Wildcard) Wildcard)+ "(_ ++ _) ++ _"+ , testCase "nested join, cons pattern" $ assertPrintExpr+ (Infix (uqsym "++") Wildcard (Infix (uqsym ":") Wildcard Wildcard))+ "_ ++ _ : _"+ , testCase "nested cons, join pattern" $ assertPrintExpr+ (Infix (uqsym ":") Wildcard (Infix (uqsym "++") Wildcard Wildcard))+ "_ : _ ++ _"+ , testCase "nested cons, join pattern (with parentheses)" $ assertPrintExpr+ (Infix (uqsym "++") (Infix (uqsym ":") Wildcard Wildcard) Wildcard)+ "(_ : _) ++ _"+ , testCase "qualified non-symbol" $ assertPrintExpr+ (Infix (qname "Special" "mod") Wildcard Wildcard)+ "_ `Special.mod` _"+ , testCase "nested qualified non-symbol and symbol" $ assertPrintExpr+ (Infix (qsym "Special" ":")+ Wildcard+ (Infix (qname "Special" "mod") Wildcard Wildcard)+ )+ "_ Special.: _ `Special.mod` _"+ ]+
+ test/TestImport.hs view
@@ -0,0 +1,80 @@+module TestImport+ ( testParseExpr+ , testParseExprSpecialFixities+ , testPrintExpr+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Haskell.Exts.Syntax as X+ ( QName(..)+ , Name(..)+ , ModuleName(..)+ , Exp(..)+ )++import Language.Egison.Parser.Pattern+ as X+ ( Errors )+import Language.Egison.Syntax.Pattern+ as X++-- main+import Data.Text ( Text )+import Control.Monad.Except ( MonadError )++import qualified Language.Haskell.Exts.Parser as Haskell+ ( defaultParseMode )+import qualified Language.Haskell.Exts.Pretty as Haskell+ ( style+ , defaultMode+ )++import Language.Egison.Syntax.Pattern.Fixity+ ( Fixity(..)+ , Precedence(..)+ , Associativity(..)+ )+import qualified Language.Egison.Parser.Pattern.Mode.Haskell+ as HaskellParseMode+ ( Expr+ , parseExpr+ , parseExprWithFixities+ )+import Language.Egison.Pretty.Pattern ( Error )+import qualified Language.Egison.Pretty.Pattern.Mode.Haskell+ as HaskellPrettyMode+ ( Expr+ , prettyExprWithFixities+ )+++testParseExpr+ :: MonadError (Errors String) m => String -> m HaskellParseMode.Expr+testParseExpr = HaskellParseMode.parseExpr Haskell.defaultParseMode++specialFixities :: [Fixity (QName ())]+specialFixities =+ [ Fixity AssocRight (Precedence 5) (sym "++")+ , Fixity AssocRight (Precedence 5) (sym ":")+ , Fixity AssocRight (Precedence 5) (qsym ":")+ , Fixity AssocLeft (Precedence 7) (qname "mod")+ ]+ where+ sym = UnQual () . Symbol ()+ qsym = Qual () (ModuleName () "Special") . Symbol ()+ qname = Qual () (ModuleName () "Special") . Ident ()++testParseExprSpecialFixities+ :: MonadError (Errors String) m => String -> m HaskellParseMode.Expr+testParseExprSpecialFixities = HaskellParseMode.parseExprWithFixities+ Haskell.defaultParseMode+ specialFixities++testPrintExpr+ :: MonadError (Error (QName ())) m => HaskellPrettyMode.Expr -> m Text+testPrintExpr = HaskellPrettyMode.prettyExprWithFixities Haskell.style+ Haskell.defaultMode+ specialFixities
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}