diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## 0.2.0.0 + +Breaking changes: +- Add `ParseMode` record to pass parser configurations (change in [#19](https://github.com/egison/egison-pattern-src/issues/19)) +- Remove the dependency on `egison-pattern-src-haskell-mode` (change in [#19](https://github.com/egison/egison-pattern-src/issues/19)) +- Provide several variants of parsers (location annotation/non-greedy) by adding `Parsable` instance (change in [#19](https://github.com/egison/egison-pattern-src/issues/19)) +- Some changes in `egison-pattern-src` are inherited here. For details, see [CHANGELOG](https://hackage.haskell.org/package/egison-pattern-src-0.2.0.0/changelog) in [egison-pattern-src-0.2.0.0](https://hackage.haskell.org/package/egison-pattern-src-0.2.0.0). + ## 0.1.1.0 - Add `parseExprWithParseFixities` to configure parsers flexibly (e.g. parse as `++`, but interpret it as `join`) diff --git a/egison-pattern-src-th-mode.cabal b/egison-pattern-src-th-mode.cabal --- a/egison-pattern-src-th-mode.cabal +++ b/egison-pattern-src-th-mode.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: egison-pattern-src-th-mode -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Parser and pretty printer for Egison pattern expressions to use with TH @@ -30,15 +30,14 @@ library build-depends: - base >=4.7 && <5 - , egison-pattern-src ^>=0.1.0 - , egison-pattern-src-haskell-mode ^>=0.1.1 - , 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 + base >=4.7 && <5 + , egison-pattern-src ^>=0.2.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: @@ -55,7 +54,11 @@ default-language: Haskell2010 default-extensions: FlexibleContexts + FlexibleInstances + MultiParamTypeClasses NamedFieldPuns + TypeApplications + TypeSynonymInstances test-suite test type: exitcode-stdio-1.0 diff --git a/src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs b/src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs --- a/src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs +++ b/src/Language/Egison/Parser/Pattern/Mode/Haskell/TH.hs @@ -10,82 +10,141 @@ ( -- * Parsers Expr + , ExprL + , ParseMode(..) , parseExpr - , parseExprWithFixities - , parseExprWithParseFixities - -- * Converting 'Expr' - , toTH + , parseExprL + -- * Converting @haskell-src-exts@'s entities + , makeParseMode + , makeFixity + , makeParseFixity ) where import Control.Monad.Except ( MonadError ) +import qualified Text.PrettyPrint as PP + ( render ) import qualified Language.Haskell.TH.Syntax as TH ( Name - , Exp + , Exp(..) + , NameIs(..) ) +import qualified Language.Haskell.TH.PprLib as TH + ( to_HPJ_Doc + , pprName' + ) import qualified Language.Haskell.Meta.Syntax.Translate as TH ( toExp , toName ) +import qualified Language.Haskell.Exts.Fixity as Haskell + ( Fixity(..) ) import qualified Language.Haskell.Exts.Syntax as Haskell - ( QName - , Name - , Exp - ) + ( Assoc(..) ) import qualified Language.Haskell.Exts.Parser as Haskell - ( ParseMode ) + ( ParseMode(..) + , ParseResult(..) + , parseExpWithMode + ) import qualified Language.Egison.Syntax.Pattern as Egison ( Expr ) -import Language.Egison.Syntax.Pattern ( mapValueExpr - , mapVarName - , mapName +import qualified Language.Egison.Parser.Pattern + as Egison + ( ExprL + , Fixity(..) + , Associativity(..) + , ParseFixity(..) + , ParseMode(..) ) -import Language.Egison.Parser.Pattern ( Errors ) -import qualified Language.Egison.Parser.Pattern.Mode.Haskell - as HaskellMode - ( Fixity - , ParseFixity - , parseExpr - , parseExprWithFixities - , parseExprWithParseFixities +import Language.Egison.Parser.Pattern ( Precedence(..) + , Parsable(..) + , Errors ) -- | 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 +-- | Type synonym of 'Egison.ExprL' to be used with Template Haskell. +type ExprL = Egison.ExprL TH.Name TH.Name TH.Exp --- | 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 +-- | Parser configuration in @egison-pattern-src-th-mode@. +data ParseMode + = ParseMode { + -- | 'Haskell.ParseMode' from @haskell-src-exts@ for our parsers to base on. + haskellMode :: Haskell.ParseMode + -- | List of fixities to parse infix pattern operators. + -- If @fixities = Just xs@, @xs@ overrides fixities obtained from 'haskellMode'. + -- Otherwise, our parsers use fixities from 'haskellMode'. + , fixities :: Maybe [Egison.ParseFixity TH.Name String] + } --- | 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 +resultToEither :: Haskell.ParseResult a -> Either String a +resultToEither (Haskell.ParseOk a ) = Right a +resultToEither (Haskell.ParseFailed _ e) = Left e --- | Parse 'Expr' using 'Haskell.ParseMode' from @haskell-src-exts@, while supplying an explicit list of 'HaskellMode.ParseFixity'. --- Note that fixities obtained from 'Haskell.ParseMode' are just ignored here. -parseExprWithParseFixities - :: MonadError (Errors String) m - => Haskell.ParseMode - -> [HaskellMode.ParseFixity] - -> String - -> m Expr -parseExprWithParseFixities mode fixities = - fmap toTH . HaskellMode.parseExprWithParseFixities mode fixities +parseNameWithMode :: Haskell.ParseMode -> String -> Either String TH.Name +parseNameWithMode mode content = + case resultToEither . fmap TH.toExp $ Haskell.parseExpWithMode mode content of + Right (TH.VarE name) -> Right name + Right (TH.ConE name) -> Right name + Right e -> Left (show e ++ " is not a variable") + Left err -> Left err + +-- | Build 'Egison.Fixity' using 'Haskell.Fixity' from @haskell-src-exts@. +makeFixity :: Haskell.Fixity -> Egison.Fixity TH.Name +makeFixity (Haskell.Fixity assoc prec name) = fixity + where + fixity = Egison.Fixity (makeAssoc assoc) (Precedence prec) $ TH.toName 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 +makeParseFixity :: Egison.Fixity TH.Name -> Egison.ParseFixity TH.Name String +makeParseFixity fixity = Egison.ParseFixity fixity $ makeNameParser symbol + where + Egison.Fixity { Egison.symbol } = fixity + printSym = PP.render . TH.to_HPJ_Doc . TH.pprName' TH.Infix + makeNameParser s input | input == printSym s = Right () + | otherwise = Left "not an operator name" + +-- | Build 'Egison.ParseMode' using 'Haskell.ParseMode' from @haskell-src-exts@. +makeParseMode + :: Haskell.ParseMode -> Egison.ParseMode TH.Name TH.Name TH.Exp String +makeParseMode mode@Haskell.ParseMode { Haskell.parseFilename, Haskell.fixities } + = Egison.ParseMode + { Egison.filename = parseFilename + , Egison.fixities = maybe [] makeParseFixities fixities + , Egison.blockComment = Just ("{-", "-}") + , Egison.lineComment = Just "--" + , Egison.varNameParser = parseNameWithMode mode + , Egison.nameParser = parseNameWithMode mode + , Egison.valueExprParser = resultToEither + . fmap TH.toExp + . Haskell.parseExpWithMode mode + } + where + makeParseFixities :: [Haskell.Fixity] -> [Egison.ParseFixity TH.Name String] + makeParseFixities = map $ makeParseFixity . makeFixity + +instance Parsable Expr String ParseMode where + parseNonGreedyWithLocation ParseMode { haskellMode, fixities } = + parseNonGreedyWithLocation @Expr mode' + where + mode = makeParseMode haskellMode + mode' = case fixities of + Just xs -> mode { Egison.fixities = xs } + Nothing -> mode + +-- | Parse 'Expr' using 'ParseMode'. +parseExpr :: MonadError (Errors String) m => ParseMode -> String -> m Expr +parseExpr = parse @Expr + +-- | Parse 'Expr' using 'ParseMode' with locations annotated. +parseExprL :: MonadError (Errors String) m => ParseMode -> String -> m ExprL +parseExprL = parseWithLocation @Expr diff --git a/test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs b/test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs --- a/test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs +++ b/test/Language/Egison/Parser/Pattern/Mode/Haskell/THSpec.hs @@ -44,19 +44,19 @@ (Value . paren $ infixApp (intE 1) (sym "+") (intE 2)) , testCase "predicate pattern" $ assertParseExpr "?10" (Predicate $ intE 10) , testCase "constructor pattern" $ assertParseExpr - "(ctor _ _ _)" + "ctor _ _ _" (Pattern (name "ctor") [Wildcard, Wildcard, Wildcard]) , testCase "constructor pattern with data constructor" $ assertParseExpr - "(Ctor _ _ _)" + "Ctor _ _ _" (Pattern (name "Ctor") [Wildcard, Wildcard, Wildcard]) , testCase "constructor pattern with qualified name" $ assertParseExpr - "(Mod.ctor _ _ _)" + "Mod.ctor _ _ _" (Pattern (name "Mod.ctor") [Wildcard, Wildcard, Wildcard]) , testCase "constructor pattern that the symbol is between parentheses" - $ assertParseExpr "((++) _ _)" (Pattern (sym "++") [Wildcard, Wildcard]) + $ assertParseExpr "(++) _ _" (Pattern (sym "++") [Wildcard, Wildcard]) , testCase "constructor pattern that the qualified symbol is between parentheses" - $ assertParseExpr "((Mod.++) _ _)" + $ assertParseExpr "(Mod.++) _ _" (Pattern (sym "Mod.++") [Wildcard, Wildcard]) , testCase "constructor pattern without arguments" $ assertParseExpr "nil" (Pattern (name "nil") []) diff --git a/test/Language/Egison/Pretty/Pattern/Mode/Haskell/THSpec.hs b/test/Language/Egison/Pretty/Pattern/Mode/Haskell/THSpec.hs --- a/test/Language/Egison/Pretty/Pattern/Mode/Haskell/THSpec.hs +++ b/test/Language/Egison/Pretty/Pattern/Mode/Haskell/THSpec.hs @@ -42,19 +42,19 @@ , testCase "predicate pattern" $ assertPrintExpr (Predicate $ intE 10) "?10" , testCase "constructor pattern" $ assertPrintExpr (Pattern (name "ctor") [Wildcard, Wildcard, Wildcard]) - "(ctor _ _ _)" + "ctor _ _ _" , testCase "constructor pattern with data constructor" $ assertPrintExpr (Pattern (name "Ctor") [Wildcard, Wildcard, Wildcard]) - "(Ctor _ _ _)" + "Ctor _ _ _" , testCase "constructor pattern with qualified name" $ assertPrintExpr (Pattern (name "Mod.ctor") [Wildcard, Wildcard, Wildcard]) - "(Mod.ctor _ _ _)" + "Mod.ctor _ _ _" , testCase "constructor pattern that the symbol is between parentheses" - $ assertPrintExpr (Pattern (sym "++") [Wildcard, Wildcard]) "((++) _ _)" + $ assertPrintExpr (Pattern (sym "++") [Wildcard, Wildcard]) "(++) _ _" , testCase "constructor pattern that the qualified symbol is between parentheses" $ assertPrintExpr (Pattern (sym "Mod.++") [Wildcard, Wildcard]) - "((Mod.++) _ _)" + "(Mod.++) _ _" , testCase "constructor pattern without arguments" $ assertPrintExpr (Pattern (name "nil") []) "nil" , testCase "constructor pattern with qualified name without arguments" diff --git a/test/TestImport.hs b/test/TestImport.hs --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -35,8 +35,11 @@ import qualified Language.Egison.Parser.Pattern.Mode.Haskell.TH as THParseMode ( Expr + , ParseMode(..) , parseExpr ) +import Language.Egison.Parser.Pattern.Mode.Haskell.TH + ( ParseMode(..) ) import Language.Egison.Pretty.Pattern ( Error ) import qualified Language.Egison.Pretty.Pattern.Mode.Haskell.TH as THPrintMode @@ -46,7 +49,11 @@ testParseExpr :: MonadError (Errors String) m => String -> m THParseMode.Expr -testParseExpr = THParseMode.parseExpr Haskell.defaultParseMode +testParseExpr = THParseMode.parseExpr mode + where + mode = THParseMode.ParseMode { haskellMode = Haskell.defaultParseMode + , fixities = Nothing + } specialFixities :: [Fixity Name]