egison-pattern-src-th-mode (empty) → 0.1.0.0
raw patch · 11 files changed
+554/−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, egison-pattern-src-th-mode, haskell-src-exts, haskell-src-meta, mtl, pretty, tasty, tasty-hunit, template-haskell, text
Files
- CHANGELOG.md +3/−0
- LICENSE +11/−0
- README.md +12/−0
- Setup.hs +4/−0
- egison-pattern-src-th-mode.cabal +85/−0
- src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs +77/−0
- src/Language/Egison/Pretty/Pattern/Mode/Haskell/TH.hs +96/−0
- test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs +96/−0
- test/Language/Egison/Pretty/Pattern/Mode/Haskell/THSpec.hs +107/−0
- test/TestImport.hs +62/−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 (Template 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-th-mode)+[](http://packdeps.haskellers.com/reverse/egison-pattern-src-th-mode)++The [egison-pattern-src-th-mode](https://hackage.haskell.org/package/egison-pattern-src-th-mode) provides a parser and pretty printer for [egison-pattern-src](https://hackage.haskell.org/package/egison-pattern-src) to use it with Template Haskell.++## License++[egison-pattern-src-th-mode](https://hackage.haskell.org/package/egison-pattern-src-th-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-th-mode.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.0+name: egison-pattern-src-th-mode+version: 0.1.0.0+synopsis:+ Parser and pretty printer for Egison pattern expressions to use with TH++description:+ @egison-pattern-src-th-mode@ provides a parser and pretty printer for @egison-pattern-src@ to use it with Template Haskell.+ 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, Template Haskell+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+ , egison-pattern-src-haskell-mode ^>=0.1.0+ , haskell-src-exts >=1.11.1 && <1.24+ , haskell-src-meta >=0.0.0 && <0.9+ , mtl ^>=2.2.1+ , pretty >=1.0.0 && <1.2+ , template-haskell >=2.2.0 && <2.16+ , text >=0.1.0 && <1.3++ hs-source-dirs: src+ exposed-modules:+ Language.Egison.Parser.Pattern.Mode.Haskell.TH+ Language.Egison.Pretty.Pattern.Mode.Haskell.TH++ 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-th-mode+ , haskell-src-exts+ , mtl+ , tasty+ , tasty-hunit+ , template-haskell >=2.6.0 && <2.15+ , text++ default-extensions: FlexibleContexts++ -- cabal-fmt: expand test+ other-modules:+ Language.Egison.Parser.Pattern.Mode.Haskell.THSpec+ Language.Egison.Pretty.Pattern.Mode.Haskell.THSpec+ TestImport++ build-tool-depends: tasty-discover:tasty-discover -any
+ src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs view
@@ -0,0 +1,77 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Mode.Haskell+-- Description: Parser for Egison pattern expressions to use with Template Haskell+-- Stability: experimental+--+-- A parser for Egison pattern expressions to use with Template Haskell.++module Language.Egison.Parser.Pattern.Mode.Haskell.TH+ (+ -- * Parsers+ Expr+ , parseExpr+ , parseExprWithFixities+ -- * Converting 'Expr'+ , toTH+ )+where++import Control.Monad.Except ( MonadError )++import qualified Language.Haskell.TH.Syntax as TH+ ( Name+ , Exp+ )+import qualified Language.Haskell.Meta.Syntax.Translate+ as TH+ ( toExp+ , toName+ )+import qualified Language.Haskell.Exts.Syntax as Haskell+ ( QName+ , Name+ , Exp+ )+import qualified Language.Haskell.Exts.Parser as Haskell+ ( ParseMode )++import qualified Language.Egison.Syntax.Pattern+ as Egison+ ( Expr )+import Language.Egison.Syntax.Pattern ( mapValueExpr+ , mapVarName+ , mapName+ )+import Language.Egison.Parser.Pattern ( Errors )+import qualified Language.Egison.Parser.Pattern.Mode.Haskell+ as HaskellMode+ ( Fixity+ , parseExpr+ , parseExprWithFixities+ )+++-- | Type synonym of 'Egison.Expr' to be used with Template Haskell.+type Expr = Egison.Expr TH.Name TH.Name TH.Exp++-- | Convert 'Egison.Expr' with @haskell-src-exts@ AST into 'Expr' with Template Haskell AST+toTH+ :: Egison.Expr (Haskell.QName l1) (Haskell.Name l2) (Haskell.Exp l3) -> Expr+toTH = mapValueExpr TH.toExp . mapVarName TH.toName . mapName TH.toName++-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@.+parseExpr+ :: MonadError (Errors String) m => Haskell.ParseMode -> String -> m Expr+parseExpr mode = fmap toTH . HaskellMode.parseExpr mode++-- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@, while supplying an explicit list of 'HaskellMode.Fixity'.+-- Note that fixities obtained from 'Haskell.ParseMode' are just ignored here.+parseExprWithFixities+ :: MonadError (Errors String) m+ => Haskell.ParseMode+ -> [HaskellMode.Fixity]+ -> String+ -> m Expr+parseExprWithFixities mode fixities =+ fmap toTH . HaskellMode.parseExprWithFixities mode fixities
+ src/Language/Egison/Pretty/Pattern/Mode/Haskell/TH.hs view
@@ -0,0 +1,96 @@+-- |+--+-- Module: Language.Egison.Parser.Pattern.Mode.Haskell+-- Description: Printer for Egison pattern expressions to use with Template Haskell+-- Stability: experimental+--+-- A printer for Egison pattern expressions to use with Template Haskell.++module Language.Egison.Pretty.Pattern.Mode.Haskell.TH+ (+ -- * Printers+ Expr+ , prettyExpr+ , prettyExprWithFixities+ -- * Converting @template-haskell@'s entities+ , PrintMode+ , PrintFixity+ , Fixity+ , makeTHMode+ , makePrintFixity+ )+where++import Data.Text ( Text+ , pack+ )+import Control.Monad.Except ( MonadError )++import qualified Text.PrettyPrint as PP+ ( render )+import qualified Language.Haskell.TH.Syntax as TH+ ( Name+ , Exp+ , NameIs(..)+ )+import qualified Language.Haskell.TH.PprLib as TH+ ( to_HPJ_Doc+ , pprName'+ )+import qualified Language.Haskell.TH.Ppr as TH+ ( pprint )++import qualified Language.Egison.Syntax.Pattern+ as Egison+ ( Expr )+import qualified Language.Egison.Pretty.Pattern+ as Egison+ ( PrintMode(..)+ , Fixity(..)+ , PrintFixity(..)+ , Error+ , prettyExpr+ )+++-- | Type synonym of 'Egison.Expr' to be printed with Template Haskell.+type Expr = Egison.Expr TH.Name TH.Name TH.Exp++-- | Type synonym of 'Egison.PrintMode' to print 'Expr'.+type PrintMode = Egison.PrintMode TH.Name TH.Name TH.Exp++-- | Type synonym of 'Egison.Fixity' to print 'Expr'.+type Fixity = Egison.Fixity TH.Name++-- | Type synonym of 'Egison.PrintFixity' to print 'Expr'.+type PrintFixity = Egison.PrintFixity TH.Name++-- | Build 'PrintFixity' using 'Fixity' to print Haskell operators.+makePrintFixity :: Fixity -> PrintFixity+makePrintFixity fixity@(Egison.Fixity _ _ sym) = Egison.PrintFixity+ { Egison.fixity+ , Egison.printed = printSym sym+ }+ where printSym s = pack . PP.render . TH.to_HPJ_Doc $ TH.pprName' TH.Infix s++-- | Build 'PrintMode' using the list of fixities.+makeTHMode :: [Fixity] -> PrintMode+makeTHMode fixities = Egison.PrintMode+ { Egison.fixities = map makePrintFixity fixities+ , Egison.varNamePrinter = printName+ , Egison.namePrinter = printName+ , Egison.valueExprPrinter = printValueExpr+ , Egison.pageMode = Nothing+ }+ where+ printValueExpr = pack . TH.pprint+ printName n = pack . PP.render . TH.to_HPJ_Doc $ TH.pprName' TH.Applied n++-- | Print 'Expr'.+prettyExpr :: MonadError (Egison.Error TH.Name) m => Expr -> m Text+prettyExpr = Egison.prettyExpr $ makeTHMode []++-- | Print 'Expr' with an explicit list of 'Fixity'.+prettyExprWithFixities+ :: MonadError (Egison.Error TH.Name) m => [Fixity] -> Expr -> m Text+prettyExprWithFixities = Egison.prettyExpr . makeTHMode
+ test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs view
@@ -0,0 +1,96 @@+module Language.Egison.Parser.Pattern.Mode.Haskell.THSpec+ ( test_atom_patterns+ , test_pattern_operators+ , test_comments+ )+where++import TestImport++import Test.Tasty+import Test.Tasty.HUnit+++assertParseExpr :: String -> Expr Name Name Exp -> Assertion+assertParseExpr content expected = case testParseExpr content of+ Left err -> fail $ show err+ Right got -> assertEqual ("while parsing \"" ++ content ++ "\"") expected got++name :: String -> Name+name = mkName++sym :: String -> Name+sym = mkName++intE :: Integer -> Exp+intE = LitE . IntegerL++{-# ANN infixApp "HLint: ignore Eta reduce" #-}+infixApp :: Exp -> Name -> Exp -> Exp+infixApp l op r = UInfixE l (VarE op) r++paren :: Exp -> Exp+paren = ParensE++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) (sym "+") (intE 2))+ , testCase "predicate pattern" $ assertParseExpr "?10" (Predicate $ intE 10)+ , testCase "constructor pattern" $ assertParseExpr+ "(ctor _ _ _)"+ (Pattern (name "ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern with data constructor" $ assertParseExpr+ "(Ctor _ _ _)"+ (Pattern (name "Ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern with qualified name" $ assertParseExpr+ "(Mod.ctor _ _ _)"+ (Pattern (name "Mod.ctor") [Wildcard, Wildcard, Wildcard])+ , testCase "constructor pattern that the symbol is between parentheses"+ $ assertParseExpr "((++) _ _)" (Pattern (sym "++") [Wildcard, Wildcard])+ , testCase+ "constructor pattern that the qualified symbol is between parentheses"+ $ assertParseExpr "((Mod.++) _ _)"+ (Pattern (sym "Mod.++") [Wildcard, Wildcard])+ , testCase "constructor pattern without arguments"+ $ assertParseExpr "nil" (Pattern (name "nil") [])+ , testCase "constructor pattern with qualified name without arguments"+ $ assertParseExpr "Mod.nil" (Pattern (name "Mod.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+ "constructor pattern with qualified name without arguments between parentheses"+ $ assertParseExpr "((Mod.c))" (Pattern (name "Mod.c") [])+ ]++test_pattern_operators :: [TestTree]+test_pattern_operators =+ [ testCase "operator" $ assertParseExpr+ "_ && _ && _"+ (Infix (sym "&&") Wildcard (Infix (sym "&&") 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/Haskell/THSpec.hs view
@@ -0,0 +1,107 @@+module Language.Egison.Pretty.Pattern.Mode.Haskell.THSpec+ ( test_atom_patterns+ , test_pattern_operators+ )+where++import TestImport++import Data.Text ( pack )+import Test.Tasty+import Test.Tasty.HUnit+++assertPrintExpr :: Expr Name 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++name :: String -> Name+name = mkName++sym :: String -> Name+sym = mkName++intE :: Integer -> Exp+intE = LitE . IntegerL++{-# ANN infixApp "HLint: ignore Eta reduce" #-}+infixApp :: Exp -> Name -> Exp -> Exp+infixApp l op r = UInfixE l (VarE op) r++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) (sym "+") (intE 2)) "#(1 + 2)"+ , testCase "predicate pattern" $ assertPrintExpr (Predicate $ intE 10) "?10"+ , testCase "constructor pattern" $ assertPrintExpr+ (Pattern (name "ctor") [Wildcard, Wildcard, Wildcard])+ "(ctor _ _ _)"+ , testCase "constructor pattern with data constructor" $ assertPrintExpr+ (Pattern (name "Ctor") [Wildcard, Wildcard, Wildcard])+ "(Ctor _ _ _)"+ , testCase "constructor pattern with qualified name" $ assertPrintExpr+ (Pattern (name "Mod.ctor") [Wildcard, Wildcard, Wildcard])+ "(Mod.ctor _ _ _)"+ , testCase "constructor pattern that the symbol is between parentheses"+ $ assertPrintExpr (Pattern (sym "++") [Wildcard, Wildcard]) "((++) _ _)"+ , testCase+ "constructor pattern that the qualified symbol is between parentheses"+ $ assertPrintExpr (Pattern (sym "Mod.++") [Wildcard, Wildcard])+ "((Mod.++) _ _)"+ , testCase "constructor pattern without arguments"+ $ assertPrintExpr (Pattern (name "nil") []) "nil"+ , testCase "constructor pattern with qualified name without arguments"+ $ assertPrintExpr (Pattern (name "Mod.nil") []) "Mod.nil"+ ]++test_pattern_operators :: [TestTree]+test_pattern_operators =+ [ testCase "cons pattern"+ $ assertPrintExpr (Infix (sym ":") Wildcard Wildcard) "_ : _"+ , testCase "join pattern"+ $ assertPrintExpr (Infix (sym "++") Wildcard Wildcard) "_ ++ _"+ , testCase "nested cons pattern" $ assertPrintExpr+ (Infix (sym ":") Wildcard (Infix (sym ":") Wildcard Wildcard))+ "_ : _ : _"+ , testCase "nested cons pattern (with parentheses)" $ assertPrintExpr+ (Infix (sym ":") (Infix (sym ":") Wildcard Wildcard) Wildcard)+ "(_ : _) : _"+ , testCase "nested cons pattern (qualified, with parentheses)"+ $ assertPrintExpr+ (Infix (sym ":") (Infix (sym "Special.:") Wildcard Wildcard) Wildcard)+ "(_ Special.: _) : _"+ , testCase "nested join pattern" $ assertPrintExpr+ (Infix (sym "++") Wildcard (Infix (sym "++") Wildcard Wildcard))+ "_ ++ _ ++ _"+ , testCase "nested join pattern (with parentheses)" $ assertPrintExpr+ (Infix (sym "++") (Infix (sym "++") Wildcard Wildcard) Wildcard)+ "(_ ++ _) ++ _"+ , testCase "nested join, cons pattern" $ assertPrintExpr+ (Infix (sym "++") Wildcard (Infix (sym ":") Wildcard Wildcard))+ "_ ++ _ : _"+ , testCase "nested cons, join pattern" $ assertPrintExpr+ (Infix (sym ":") Wildcard (Infix (sym "++") Wildcard Wildcard))+ "_ : _ ++ _"+ , testCase "nested cons, join pattern (with parentheses)" $ assertPrintExpr+ (Infix (sym "++") (Infix (sym ":") Wildcard Wildcard) Wildcard)+ "(_ : _) ++ _"+ , testCase "non-symbol"+ $ assertPrintExpr (Infix (name "mod") Wildcard Wildcard) "_ `mod` _"+ , testCase "qualified non-symbol" $ assertPrintExpr+ (Infix (name "Special.mod") Wildcard Wildcard)+ "_ `Special.mod` _"+ , testCase "nested qualified non-symbol and symbol" $ assertPrintExpr+ (Infix (name "Special.:")+ Wildcard+ (Infix (name "Special.mod") Wildcard Wildcard)+ )+ "_ Special.: _ `Special.mod` _"+ ]+
+ test/TestImport.hs view
@@ -0,0 +1,62 @@+module TestImport+ ( testParseExpr+ , testPrintExpr+ -- * Re-exports+ , module X+ )+where++-- re-exports+import Language.Haskell.TH.Syntax as X+ ( Exp(..)+ , Name(..)+ , Lit(..)+ , mkName+ )++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 Language.Egison.Syntax.Pattern.Fixity+ ( Fixity(..)+ , Precedence(..)+ , Associativity(..)+ )+import qualified Language.Egison.Parser.Pattern.Mode.Haskell.TH+ as THParseMode+ ( Expr+ , parseExpr+ )+import Language.Egison.Pretty.Pattern ( Error )+import qualified Language.Egison.Pretty.Pattern.Mode.Haskell.TH+ as THPrintMode+ ( Expr+ , prettyExprWithFixities+ )+++testParseExpr :: MonadError (Errors String) m => String -> m THParseMode.Expr+testParseExpr = THParseMode.parseExpr Haskell.defaultParseMode+++specialFixities :: [Fixity Name]+specialFixities =+ [ Fixity AssocRight (Precedence 5) (mkName "++")+ , Fixity AssocRight (Precedence 5) (mkName ":")+ , Fixity AssocRight (Precedence 5) (mkName "Special.:")+ , Fixity AssocLeft (Precedence 7) (mkName "mod")+ , Fixity AssocLeft (Precedence 7) (mkName "Special.mod")+ ]++testPrintExpr :: MonadError (Error Name) m => THPrintMode.Expr -> m Text+testPrintExpr = THPrintMode.prettyExprWithFixities specialFixities
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}