diff --git a/rlp.cabal b/rlp.cabal index dbdb12c..dc83431 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -46,21 +46,17 @@ library -- other-extensions: build-depends: base ^>=4.18.0.0 -- required for happy - , array >= 0.5.5 && < 0.6 - , containers >= 0.6.7 && < 0.7 - , template-haskell >= 2.20.0 && < 2.21 - , pretty >= 1.1.3 && < 1.2 - , data-default-class >= 0.1.2 && < 0.2 - , hashable >= 1.4.3 && < 1.5 - , mtl >= 2.3.1 && < 2.4 - , text >= 2.0.2 && < 2.1 - , megaparsec >= 9.6.1 && < 9.7 - , microlens >= 0.4.13 && < 0.5 - , microlens-mtl >= 0.2.0 && < 0.3 - , microlens-platform >= 0.4.3 && < 0.5 - , microlens-th >= 0.4.3 && < 0.5 - , unordered-containers >= 0.2.20 && < 0.3 - , recursion-schemes >= 5.2.2 && < 5.3 + , array + , data-default-class + , unordered-containers + , hashable + , pretty + -- TODO: either learn recursion-schemes, or stop depending + -- on it. + , recursion-schemes + , megaparsec ^>=9.6.0 + , text + , data-fix hs-source-dirs: src default-language: GHC2021 diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index c8a0a33..3c28017 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -24,6 +24,7 @@ import Data.Functor import Data.Functor.Const import Data.Fix hiding (cata) import Lens.Micro +import Lens.Micro.Platform import Rlp.Parse.Types import Rlp.Syntax ---------------------------------------------------------------------------------- @@ -128,7 +129,40 @@ isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~") isSym :: Char -> Bool isSym c = c == ':' || isVarSym c -infixD = undefined +infixD :: Parser (Decl' e) +infixD = do + o <- getOffset + a <- infixWord + p <- prec + op <- infixOp + region (setErrorOffset o) $ updateOpTable a p op + pure $ InfixD a p op + where + infixWord :: Parser Assoc + infixWord = choice $ lexeme <$> + [ "infixr" $> InfixR + , "infixl" $> InfixL + , "infix" $> Infix + ] + + prec :: Parser Int + prec = do + o <- getOffset + n <- lexeme L.decimal + if 0 <= n && n <= 9 then + pure n + else + region (setErrorOffset o) $ + registerCustomFailure (RlpParErrOutOfBoundsPrecedence n) + $> 9 + + updateOpTable :: Assoc -> Int -> Name -> Parser () + updateOpTable a p op = do + t <- use psOpTable + psOpTable <~ H.alterF f op t + where + f Nothing = pure (Just (a,p)) + f (Just _) = customFailure RlpParErrDuplicateInfixD tySigD = undefined dataD = undefined diff --git a/src/RLP/Parse/Types.hs b/src/RLP/Parse/Types.hs index d3e7bd1..16a0ed9 100644 --- a/src/RLP/Parse/Types.hs +++ b/src/RLP/Parse/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {- Description : Supporting types for the parser @@ -16,8 +18,13 @@ module Rlp.Parse.Types -- * Parser types , Parser , ParserState(..) + , psOpTable + , RlpParseError(..) , OpTable , OpInfo + + -- * Extras + , registerCustomFailure ) where ---------------------------------------------------------------------------------- @@ -29,14 +36,17 @@ import Data.Functor.Const import Data.Functor.Classes import Data.Void import Data.Maybe +import Data.Set qualified as S import Text.Megaparsec hiding (State) +import Text.Printf import Lens.Micro +import Lens.Micro.TH import Rlp.Syntax ---------------------------------------------------------------------------------- -- parser types -type Parser = ParsecT Void Text (State ParserState) +type Parser = ParsecT RlpParseError Text (State ParserState) data ParserState = ParserState { _psOpTable :: OpTable @@ -46,6 +56,23 @@ data ParserState = ParserState type OpTable = H.HashMap Name OpInfo type OpInfo = (Assoc, Int) +-- data WithLocation a = WithLocation [String] a + +data RlpParseError = RlpParErrOutOfBoundsPrecedence Int + | RlpParErrDuplicateInfixD + deriving (Eq, Ord, Show) + +instance ShowErrorComponent RlpParseError where + showErrorComponent = \case + -- TODO: wrap text to 80 characters + RlpParErrOutOfBoundsPrecedence n -> + printf "%d is an invalid precedence level! rl' currently only\ + \allows custom precedences between 0 and 9 (inclusive).\ + \ This is an arbitrary limit put in place for legibility\ + \ concerns, and may change in the future." n + RlpParErrDuplicateInfixD -> + "duplicate infix decl" + ---------------------------------------------------------------------------------- -- absolute psycho shit (partial ASTs) @@ -90,3 +117,10 @@ instance Show1 Partial where type PartialExpr' = Fix Partial +---------------------------------------------------------------------------------- + +makeLenses ''ParserState + +registerCustomFailure :: MonadParsec e s m => e -> m () +registerCustomFailure = registerFancyFailure . S.singleton . ErrorCustom + diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index b314d7b..4a43cb9 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -9,6 +9,7 @@ module Rlp.Syntax , RlpExprF(..) , RlpExprF' , Decl(..) + , Decl' , Assoc(..) , VarId(..) , Pat(..) @@ -50,6 +51,8 @@ data Decl e b = FunD VarId [Pat b] (e b) | InfixD Assoc Int Name deriving Show +type Decl' e = Decl e Name + data Assoc = InfixL | InfixR | Infix