infix decl

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
+                    , array
-                    , containers >= 0.6.7 && < 0.7
+                    , data-default-class
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , unordered-containers
-                    , pretty >= 1.1.3 && < 1.2
+                    , hashable
-                    , data-default-class >= 0.1.2 && < 0.2
+                    , pretty
-                    , hashable >= 1.4.3 && < 1.5
+                    -- TODO: either learn recursion-schemes, or stop depending
-                    , mtl >= 2.3.1 && < 2.4
+                    -- on it.
-                    , text >= 2.0.2 && < 2.1
+                    , recursion-schemes
-                    , megaparsec >= 9.6.1 && < 9.7
+                    , megaparsec                ^>=9.6.0
-                    , microlens >= 0.4.13 && < 0.5
+                    , text
-                    , microlens-mtl >= 0.2.0 && < 0.3
+                    , data-fix
-                    , 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
 
     hs-source-dirs:   src
     default-language: GHC2021

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