From 7e6bee3d4af31be28be3afba9ef062135a54fa69 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Wed, 17 Jan 2024 10:08:57 -0700
Subject: [PATCH] infix exprs

---
 Makefile_happysrcs     |  2 +-
 rlp.cabal              |  1 +
 src/Rlp/Lex.x          |  2 ++
 src/Rlp/Parse.y        | 52 ++++++++++++++++++++++++++++++++++++++----
 src/Rlp/Parse/Types.hs |  3 +++
 5 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/Makefile_happysrcs b/Makefile_happysrcs
index e0dc43e..a535179 100644
--- a/Makefile_happysrcs
+++ b/Makefile_happysrcs
@@ -1,5 +1,5 @@
 HAPPY = happy
-HAPPY_OPTS = -a -g -c
+HAPPY_OPTS = -a -g -c -d -i/tmp/happy-info
 ALEX = alex
 ALEX_OPTS = -g
 
diff --git a/rlp.cabal b/rlp.cabal
index dc47c0d..59867dc 100644
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -12,6 +12,7 @@ category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
+tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x
index 55b0191..6fd2428 100644
--- a/src/Rlp/Lex.x
+++ b/src/Rlp/Lex.x
@@ -90,6 +90,8 @@ $white_no_nl+       ;
 -- control characters
 <0>
 {
+    "("                 { constToken TokenLParen }
+    ")"                 { constToken TokenRParen }
     "{"                 { explicitLBrace }
     "}"                 { explicitRBrace }
     ";"                 { constToken TokenSemicolon }
diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y
index cd29a1f..edc4874 100644
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -1,28 +1,33 @@
 {
+{-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
-    ( parseRlpProgram
+    ( parseRlpProg
     )
     where
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
+import Lens.Micro
 import Lens.Micro.Mtl
+import Lens.Micro.Platform          ()
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
 }
 
-%name parseRlpProgram StandaloneProgram
+%name parseRlpProg StandaloneProgram
 
 %monad { P }
-%lexer { lexDebug } { Located _ TokenEOF }
+%lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
 %tokentype { Located RlpToken }
 
 %token
     varname         { Located _ (TokenVarName $$) }
     conname         { Located _ (TokenConName $$) }
+    consym          { Located _ (TokenConSym $$) }
+    varsym          { Located _ (TokenVarSym $$) }
     data            { Located _ TokenData }
     litint          { Located _ (TokenLitInt $$) }
     '='             { Located _ TokenEquals }
@@ -36,6 +41,9 @@ import Data.Functor.Const
     '}'             { Located _ TokenRBrace }
     vlbrace         { Located _ TokenLBraceV }
     vrbrace         { Located _ TokenRBraceV }
+    infixl          { Located _ TokenInfixL }
+    infixr          { Located _ TokenInfixR }
+    infix           { Located _ TokenInfix }
 
 %right '->'
 
@@ -67,8 +75,17 @@ VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
 Decl        :: { PartialDecl' }
-Decl        : FunDecl                   { $1 }
+            : FunDecl                   { $1 }
             | DataDecl                  { $1 }
+            | InfixDecl                 { $1 }
+
+InfixDecl   :: { PartialDecl' }
+            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+
+InfixWord   :: { Assoc }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix  }
 
 DataDecl    :: { PartialDecl' }
             : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
@@ -109,9 +126,24 @@ Pat1        :: { Pat' }
             | Lit                       { LitP $1 }
 
 Expr        :: { PartialExpr' }
-Expr        : Lit                       { Fix . E $ LitEF $1 }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            | Expr1                     { $1 }
+
+Expr1       :: { PartialExpr' }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
+            | Lit                       { Fix . E $ LitEF $1 }
             | Var                       { Fix . E $ VarEF $1 }
 
+-- TODO: happy prefers left-associativity. doing such would require adjusting
+-- the code in Rlp.Parse.Associate to expect left-associative input rather than
+-- right.
+InfixExpr   :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+
+InfixOp     :: { Name }
+            : consym                    { $1 }
+            | varsym                    { $1 }
+
 Lit         :: { Lit' }
 Lit         : litint                    { IntL $1 }
 
@@ -131,4 +163,14 @@ mkProgram ds = do
 parseError :: Located RlpToken -> P a
 parseError = error . show
 
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        -- TODO: non-fatal error
+        Just o  -> pure (Just o)
+        Nothing -> pure (Just (a,p))
+        )
+    pure $ InfixD a p n
 }
diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs
index d53009a..718a9e5 100644
--- a/src/Rlp/Parse/Types.hs
+++ b/src/Rlp/Parse/Types.hs
@@ -48,6 +48,9 @@ data RlpToken
     | TokenOf
     | TokenLet
     | TokenIn
+    | TokenInfixL
+    | TokenInfixR
+    | TokenInfix
     -- reserved ops
     | TokenArrow
     | TokenPipe