From 37d9e6f219523f4b1584cf62e9ffb09286683ca5 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Tue, 9 Jan 2024 11:39:26 -0700
Subject: [PATCH] infix decl

---
 rlp.cabal              |  2 +-
 src/RLP/Parse/Decls.hs | 36 +++++++++++++++++++++++++++++++++++-
 src/RLP/Parse/Types.hs | 36 +++++++++++++++++++++++++++++++++++-
 src/RLP/Syntax.hs      |  3 +++
 4 files changed, 74 insertions(+), 3 deletions(-)

diff --git a/rlp.cabal b/rlp.cabal
index 88ab65c..f4a93e2 100644
--- a/rlp.cabal
+++ b/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
 
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