diff --git a/rlp.cabal b/rlp.cabal index 1ac0b54..61250c1 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index ae3751d..37edb40 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -48,6 +48,7 @@ data Severity = SevWarning data SrcSpan = SrcSpan !Int -- ^ Line !Int -- ^ Column + !Int -- ^ Absolute !Int -- ^ Length deriving Show diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index e4c78c3..a22a66f 100644 --- a/src/Rlp/Lex.x +++ b/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) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 6cc0a49..acb7fad 100644 --- a/src/Rlp/Parse.y +++ b/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 diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 794c28a..8fba710 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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 #-} @@ -186,8 +205,9 @@ addWoundHere l e = P $ \st -> let e' = MsgEnvelope { _msgSpan = let pos = psInput . aiPos in SrcSpan (st ^. pos . posLine) - (st ^. pos . posColumn) - l + (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 diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 76156c7..ced123b 100644 --- a/src/Rlp/Syntax.hs +++ b/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?