Add end position information to BNFC'Position

Co-authored-by: Nikolai Kudasov <[email protected]>
BNFC · Oct 25, 2023 · c180b2c · c180b2c
1 parent 4edadac
commit c180b2c
Show file tree

Hide file tree

Showing 3 changed files with 64 additions and 12 deletions.
diff --git a/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs b/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs
@@ -92,15 +92,34 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat
       -- regardless whether it is used in the abstract syntax.
       -- It may be used in the parser.
     , [ vcat
-        [ "-- | Start position (line, column) of something."
+        [ "-- | Position range ((startLine, startColumn), (endLine, endColumn)) of something."
         , ""
-        , "type" <+> posType <+> "=" <+> "C.Maybe (C.Int, C.Int)"
+        , "type" <+> posType <+> "=" <+> "C.Maybe ((C.Int, C.Int), (C.Int, C.Int))"
         , ""
         , "pattern" <+> noPosConstr <+> "::" <+> posType
         , "pattern" <+> noPosConstr <+> "=" <+> "C.Nothing"
         , ""
-        , "pattern" <+> posConstr <+> ":: C.Int -> C.Int ->" <+> posType
-        , "pattern" <+> posConstr <+> "line col =" <+> "C.Just (line, col)"
+        , "pattern" <+> posConstr <+> ":: (C.Int, C.Int) -> (C.Int, C.Int) ->" <+> posType
+        , "pattern" <+> posConstr <+> "start end =" <+> "C.Just (start, end)"
+        , ""
+        , "{-# COMPLETE" <+> posConstr <> "," <+> noPosConstr <+> "#-}"
+        , ""
+        , "startLineCol" <> posConstr <+> "::" <+> posType <+> "-> C.Maybe (C.Int, C.Int)"
+        , "startLineCol" <> posConstr <+> "= C.fmap C.fst"
+        , ""
+        , "endLineCol" <> posConstr <+> "::" <+> posType <+> "-> C.Maybe (C.Int, C.Int)"
+        , "endLineCol" <> posConstr <+> "= C.fmap C.snd"
+        , ""
+        , "span" <> posConstr <+> "::" <+> posType <+> "->" <+> posType <+> "->" <+> posType
+        , "span" <> posConstr
+            <+> "(" <+> posConstr <+> "start _end" <+> ")"
+            <+> "(" <+> posConstr <+> "_start end" <+> ") =" <+> posConstr <+> "start end"
+        , "span" <> posConstr
+            <+> "(" <+> posConstr <+> "start end" <+> ") _ =" <+> posConstr <+> "start end"
+        , "span" <> posConstr
+            <+> "_ (" <+> posConstr <+> "start end" <+> ") =" <+> posConstr <+> "start end"
+        , "span" <> posConstr
+            <+> noPosConstr <+> noPosConstr <+> "=" <+> noPosConstr
         ]
       | defPosition
       ]
@@ -159,6 +178,7 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat
       [ [ text $ List.intercalate ", " stdClasses | hasTextualToks || hasData ]
       , [ text $ List.intercalate ", " funClasses | fun ]
       , [ text $ "Int, Maybe(..)" | defPosition ]
+      , [ text $ "fmap, fst, snd"]
       ]
 
 -- |

diff --git a/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs b/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs
@@ -191,17 +191,33 @@ restOfAlex tokenText cf = concat
     , "tokenPosn (PT posn _len _tok) = posn"
     , "tokenPosn (Err posn)  = posn"
     , ""
+    , "-- | Get the length of a token."
+    , "tokenLen :: Token -> Int"
+    , "tokenLen (PT _posn len _tok) = len"
+    , "tokenLen (Err _)  = 0"
+    , ""
     , "-- | Get start line and column of a token."
     , "tokenLineCol :: Token -> (Int, Int)"
     , "tokenLineCol = posLineCol . tokenPosn"
     , ""
+    , "-- | Get end line and column of a token."
+    , "tokenLineColEnd :: Token -> (Int, Int)"
+    , "tokenLineColEnd t = (l, c + n)"
+    , "  where"
+    , "    (l, c) = tokenLineCol t"
+    , "    n = tokenLen t"
+    , ""
+    , "-- | Get line and column for both start and end of a token."
+    , "tokenSpan :: Token -> ((Int, Int), (Int, Int))"
+    , "tokenSpan t = (tokenLineCol t, tokenLineColEnd t)"
+    , ""
     , "-- | Get line and column of a position."
     , "posLineCol :: Posn -> (Int, Int)"
     , "posLineCol (Pn _ l c) = (l,c)"
     , ""
     , "-- | Convert a token into \"position token\" form."
-    , "mkPosToken :: Token -> ((Int, Int), " ++ stringType ++ ")"
-    , "mkPosToken t = (tokenLineCol t, tokenText t)"
+    , "mkPosToken :: Token -> (((Int, Int), Int), " ++ stringType ++ ")"
+    , "mkPosToken t = ((tokenLineCol t, tokenLen t), tokenText t)"
     , ""
     , "-- | Convert a token to its text."
     , "tokenText :: Token -> " ++ stringType

diff --git a/source/src/BNFC/Backend/Haskell/CFtoHappy.hs b/source/src/BNFC/Backend/Haskell/CFtoHappy.hs
@@ -157,7 +157,7 @@ rulesForHappy absM functor cf = for (ruleGroups cf) $ \ (cat, rules) ->
 -- Coercion are much simpler:
 --
 -- >>> constructRule "Foo" True (npRule "_" (Cat "Exp") [Right "(", Left (Cat "Exp"), Right ")"] Parsable)
--- ("'(' Exp ')'","(uncurry Foo.BNFC'Position (tokenLineCol $1), (snd $2))")
+-- ("'(' Exp ')'","(uncurry Foo.BNFC'Position (tokenSpan $1), (snd $2))")
 --
 constructRule :: IsFun f => String -> Bool -> Rul f -> (Pattern, Action)
 constructRule absName functor (Rule fun0 _cat rhs Parsable) = (pat, action)
@@ -167,10 +167,26 @@ constructRule absName functor (Rule fun0 _cat rhs Parsable) = (pat, action)
     action
       | functor   = "(" ++ actionPos id ++ ", " ++ actionValue ++ ")"
       | otherwise = actionValue
-    actionPos paren = case rhs of
-      []          -> qualify noPosConstr
-      (Left _:_)  -> paren "fst $1"
-      (Right _:_) -> paren $ unwords [ "uncurry", qualify posConstr , "(tokenLineCol $1)" ]
+    actionPos paren = case headAndLast rhs of
+      Nothing                 -> qualify noPosConstr
+      Just (startTok, endTok) -> paren $ unwords
+        [ qualify ("span" ++ posConstr)
+        , startOf startTok
+        , endOf endTok
+        ]
+      where
+        startOf :: Either a b -> String
+        startOf Left{} = "(fst $1)"
+        startOf Right{} = unwords [ "(uncurry", qualify posConstr , "(tokenSpan $1))" ]
+        endOf :: Either a b -> String
+        endOf Left{} = "(fst $" ++ show (length rhs) ++ ")"
+        endOf Right{} = unwords [ "(uncurry", qualify posConstr , "(tokenSpan $" ++ show (length rhs) ++"))" ]
+
+        headAndLast :: [a] -> Maybe (a, a)
+        headAndLast xs =
+          case (xs, reverse xs) of
+            (x:_, z:_) -> Just (x, z)
+            _          -> Nothing
     actionValue
       | isCoercion fun = unwords metavars
       | isNilCons  fun = unwords (qualify fun : metavars)
@@ -323,7 +339,7 @@ specialRules absName functor tokenText cf = unlines . intersperse "" . (`map` li
   where
     mkTypePart tokenCat = if functor then concat [ "(", qualify posType, ", ", tokenCat, ")" ] else tokenCat
     mkBodyPart tokenCat
-      | functor   = "(" ++ unwords ["uncurry", qualify posConstr, "(tokenLineCol $1)"] ++ ", " ++ mkValPart tokenCat ++ ")"
+      | functor   = "(" ++ unwords ["uncurry", qualify posConstr, "(tokenSpan $1)"] ++ ", " ++ mkValPart tokenCat ++ ")"
       | otherwise = mkValPart tokenCat
     mkValPart tokenCat =
       case tokenCat of