sigh i'm gonna have to nuke the ast again in a month

src/Compiler/Types.hs

@@ -1,8 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Compiler.Types
     ( SrcSpan(..)
     , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
     , Located(..)
-    , locating
+    , _Located
     , nolo
     , (<<~), (<~>), (<#>)
 
@@ -58,9 +59,6 @@ srcspanLen = tupling . _4
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
-locating :: Lens (Located a) (Located b) a b
-locating = lens extract ($>)
-
 instance Semigroup SrcSpan where
     SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
         l = min la lb
@@ -93,3 +91,5 @@ fab <#> a = fmap ($ a) fab
 
 infixl 4 <#>
 
+makePrisms ''Located
+

src/Rlp/Parse.y

@@ -173,15 +173,22 @@ Pat1        :: { Pat' RlpcPs }
             | '(' Pat ')'               { $1 .> $2 <. $3 }
 
 Expr        :: { RlpExpr' RlpcPs }
-            : Expr1 InfixOp Expr        { $2 =>> \o ->
+            -- infixities delayed till next release :(
-                                          OAppE (extract o) $1 $3 }
+            -- : Expr1 InfixOp Expr        { $2 =>> \o ->
+            --                              OAppE (extract o) $1 $3 }
+            : TempInfixExpr             { $1 }
             | LetExpr                   { $1 }
             | CaseExpr                  { $1 }
-            | ExprApp                   { $1 }
+            | AppExpr                   { $1 }
 
-ExprApp     :: { RlpExpr' RlpcPs }
+TempInfixExpr :: { RlpExpr' RlpcPs }
+TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
+              | Expr1 InfixOp Expr1 { $2 =>> \o ->
+                                      OAppE (extract o) $1 $3 }
+
+AppExpr     :: { RlpExpr' RlpcPs }
             : Expr1                     { $1 }
-            | ExprApp Expr1             { AppE <<~ $1 <~> $2 }
+            | AppExpr Expr1             { AppE <<~ $1 <~> $2 }
 
 LetExpr     :: { RlpExpr' RlpcPs }
             : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
@@ -288,5 +295,12 @@ mkInfixD a p n = do
 intOfToken :: Located RlpToken -> Int
 intOfToken (Located _ (TokenLitInt n)) = n
 
+tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
+tempInfixExprErr (Located a _) (Located b _) =
+    addFatal $ errorMsg (a <> b) $ RlpParErrOther
+        [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
+        , "In the mean time, don't mix any infix operators."
+        ]
+
 }
 

src/Rlp/Parse/Associate.hs

@@ -1,18 +1,25 @@
 module Rlp.Parse.Associate
+    {-# WARNING "unimplemented" #-}
     ( associate
     )
     where
 --------------------------------------------------------------------------------
 import Data.HashMap.Strict              qualified as H
 import Data.Functor.Foldable
+import Data.Functor.Foldable.TH
 import Data.Functor.Const
+import Data.Functor
+import Data.Text                        qualified as T
+import Text.Printf
 import Lens.Micro
 import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate :: OpTable -> RlpExpr' RlpcPs -> RlpExpr' RlpcPs
+associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
-associate pt e = undefined
+associate _ p = p
+
+{-# WARNING associate "unimplemented" #-}
 
 examplePrecTable :: OpTable
 examplePrecTable = H.fromList

src/Rlp/Parse/Types.hs

@@ -200,12 +200,11 @@ data Layout = Explicit
 type OpTable = H.HashMap Name OpInfo
 type OpInfo = (Assoc, Int)
 
--- data WithLocation a = WithLocation [String] a
-
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
                    | RlpParErrDuplicateInfixD Name
                    | RlpParErrLexical
                    | RlpParErrUnexpectedToken RlpToken [String]
+                   | RlpParErrOther [Text]
                    deriving (Show)
 
 instance IsRlpcError RlpParseError where
@@ -224,6 +223,8 @@ instance IsRlpcError RlpParseError where
             Text [ "Unexpected token " <> tshow t
                  , "Expected: " <> tshow exp
                  ]
+        RlpParErrOther ts ->
+            Text ts
         where
             tshow :: (Show a) => a -> T.Text
             tshow = T.pack . show

src/Rlp/Syntax.hs

@@ -9,7 +9,7 @@ module Rlp.Syntax
     -- * AST
       RlpProgram(..)
     , progDecls
-    , Decl(..), Decl', RlpExpr(..), RlpExpr'
+    , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
     , Pat(..), Pat'
     , Alt(..), Where
     , Assoc(..)