infix decl

rlp.cabal

@@ -63,7 +63,7 @@ library
                     -- TODO: either learn recursion-schemes, or stop depending
                     -- on it.
                     , recursion-schemes
-                    , megaparsec
+                    , megaparsec                ^>=9.6.0
                     , text
                     , data-fix
 

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

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
+

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