rlp.cabal

@@ -69,6 +69,7 @@ library
                     , data-fix >= 0.3.2 && < 0.4
                     , utf8-string >= 1.0.2 && < 1.1
                     , extra >= 1.7.0 && < 2
+                    , semigroupoids
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Compiler/RlpcError.hs

@@ -48,6 +48,7 @@ data Severity = SevWarning
 data SrcSpan = SrcSpan
     !Int -- ^ Line
     !Int -- ^ Column
+    !Int -- ^ Absolute
     !Int -- ^ Length
     deriving Show
 

src/Rlp/Lex.x

@@ -164,10 +164,10 @@ alexGetByte inp = case inp ^. aiBytes of
                        -- report the previous char
                        & aiPrevChar .~ c
                        -- update the position
-                       & aiPos %~ \ (ln,col) ->
+                       & aiPos %~ \ (ln,col,a) ->
                                    if c == '\n'
-                                   then (ln+1,1)
-                                   else (ln,col+1)
+                                   then (ln+1, 1, a+1)
+                                   else (ln, col+1, a+1)
         pure (b, inp')
     
     _ -> Just (head bs, inp')
@@ -225,7 +225,7 @@ initAlexInput s = AlexInput
     { _aiPrevChar   = '\0'
     , _aiSource     = s
     , _aiBytes      = []
-    , _aiPos        = (1,1)
+    , _aiPos        = (1,1,0)
     }
 
 runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)

src/Rlp/Parse.y

@@ -117,34 +117,34 @@ Type        :: { Type }
             | Type1                     { $1 }
 
 FunDecl     :: { Decl' RlpcPs }
-FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
+FunDecl     : Var Params '=' Expr       { FunD undefined $2 $4 Nothing }
 
 Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
 Pat1        :: { Pat' RlpcPs }
-            : Var                       { VarP $1 }
-            | Lit                       { LitP $1 }
+            : Var                       { undefined }
+            | Lit                       { LitP <$> $1 }
 
 Expr        :: { RlpExpr' RlpcPs }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            : Expr1 varsym Expr         { undefined }
             | Expr1                     { $1 }
 
 Expr1       :: { RlpExpr' RlpcPs }
-            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
-            | Lit                       { Fix . E $ LitEF $1 }
-            | Var                       { Fix . E $ VarEF $1 }
+            : '(' Expr ')'              { fmap ParE' $2 }
+            | Lit                       { fmap LitE' $1 }
+            | Var                       { fmap VarE' $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   :: { RlpExpr' RlpcPs }
-            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            : Expr1 varsym Expr         { undefined }
 
 InfixOp     :: { PsName }
-            : consym                    { $1 }
-            | varsym                    { $1 }
+            : consym                    { undefined }
+            | varsym                    { undefined }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
 Lit         :: { Lit' RlpcPs }
@@ -172,8 +172,8 @@ mkProgram ds = do
     pure $ RlpProgram (associate pt <$> ds)
 
 parseError :: Located RlpToken -> P a
-parseError (Located (l,c,s) t) = addFatal $
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
+parseError (Located (l,c,a,s) t) = addFatal $
+    errorMsg (SrcSpan l c a s) RlpParErrUnexpectedToken
 
 mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do

src/Rlp/Parse/Types.hs

@@ -34,6 +34,7 @@ import Data.Fix
 import Data.Functor.Foldable
 import Data.Functor.Const
 import Data.Functor.Classes
+import Data.Functor.Apply
 import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
@@ -50,6 +51,8 @@ type instance XRec RlpcPs f = Located (f RlpcPs)
 type instance IdP RlpcPs = PsName
 
 type instance XInfixD RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLitE RlpcPs = ()
 
 type PsName = Text
 
@@ -66,8 +69,9 @@ data AlexInput = AlexInput
     deriving Show
 
 type Position =
-    ( Int -- line
-    , Int -- column
+    ( Int -- ^ line
+    , Int -- ^ column
+    , Int -- ^ Absolutely
     )
 
 posLine :: Lens' Position Int
@@ -76,6 +80,9 @@ posLine = _1
 posColumn :: Lens' Position Int
 posColumn = _2
 
+posAbsolute :: Lens' Position Int
+posAbsolute = _3
+
 data RlpToken
     -- literals
     = TokenLitInt Int
@@ -154,12 +161,24 @@ data Layout = Explicit
             | Implicit Int
             deriving (Show, Eq)
 
--- | Token wrapped with a span (line, column, length)
-data Located a = Located !(Int, Int, Int) a
+-- | Token wrapped with a span (line, column, absolute, length)
+data Located a = Located !(Int, Int, Int, Int) a
     deriving (Show, Functor)
 
-spanFromPos :: Position -> Int -> (Int, Int, Int)
-spanFromPos (l,c) s = (l,c,s)
+instance Apply Located where
+    liftF2 f (Located (la,ca,aa,sa) p) (Located (lb,cb,ab,sb) q)
+            = Located (l,c,a,s) (p `f` q)
+        where
+            l = min la lb
+            c = min ca cb
+            a = min aa ab
+            s = case aa `compare` ab of
+                EQ -> max sa sb
+                LT -> max sa (ab + sb)
+                GT -> max sb (aa + sa)
+
+spanFromPos :: Position -> Int -> (Int, Int, Int, Int)
+spanFromPos (l,c,a) s = (l,c,a,s)
 
 {-# INLINE spanFromPos #-}
 
@@ -187,6 +206,7 @@ addWoundHere l e = P $ \st ->
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
                                     (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
                                     l
             , _msgDiagnostic = e
             , _msgSeverity = SevError
@@ -199,6 +219,7 @@ addFatalHere l e = P $ \st ->
             { _msgSpan = let pos = psInput . aiPos
                          in SrcSpan (st ^. pos . posLine)
                                     (st ^. pos . posColumn)
+                                    (st ^. pos . posAbsolute)
                                     l
             , _msgDiagnostic = e
             , _msgSeverity = SevError

src/Rlp/Syntax.hs

@@ -15,7 +15,10 @@ module Rlp.Syntax
     , ConAlt(..)
 
     -- * Pattern synonyms for unused extensions
+    -- ** Decl
     , pattern InfixD'
+    -- ** RlpExpr
+    , pattern ParE', pattern VarE', pattern LitE'
 
     -- * Trees That Grow extensions
     , XRec, IdP
@@ -103,6 +106,15 @@ type family XXRlpExpr p
 
 type family IdP p
 
+pattern ParE' :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
+pattern ParE' e = ParE () e
+
+pattern LitE' :: (XLitE p ~ ()) => Lit p -> RlpExpr p
+pattern LitE' e = LitE () e
+
+pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p
+pattern VarE' e = VarE () e
+
 type Where p = [Bind p]
 
 -- do we want guards?