feat: Add bracketing to lexer

brat/Brat/Error.hs

@@ -1,5 +1,6 @@
 module Brat.Error (ParseError(..)
                   ,LengthConstraintF(..), LengthConstraint
+                  ,BracketErrMsg(..)
                   ,ErrorMsg(..)
                   ,Error(..), showError
                   ,SrcErr(..)
@@ -9,6 +10,7 @@
                   ) where
 
 import Brat.FC
+import Data.Bracket
 import Brat.Syntax.Port (PortName)
 
 import Data.List (intercalate)
@@ -26,6 +28,28 @@
 
 type LengthConstraint = LengthConstraintF Int
 
+data BracketErrMsg
+  = EOFInBracket BracketType -- FC in enclosing `Err` should point to the open bracket
+  -- FC here is opening; closing FC in the enclosing `Err`
+  | OpenCloseMismatch (FC, BracketType) BracketType
+  | UnexpectedClose BracketType
+
+instance Show BracketErrMsg where
+  show (EOFInBracket b) = "File ended before this " ++ showOpen b ++ " was closed"
+  show (OpenCloseMismatch (openFC, bOpen) bClose) = unwords ["This"
+                                                            ,showClose bClose
+                                                            ,"doesn't match the"
+                                                            ,showOpen bOpen
+                                                            ,"at"
+                                                            ,show openFC
+                                                            ]
+  show (UnexpectedClose b) = unwords ["There is no"
+                                     ,showOpen b
+                                     ,"for this"
+                                     ,showClose b
+                                     ,"to close"
+                                     ]
+
 data ErrorMsg
  = TypeErr String
  -- Term, Expected type, Actual type
@@ -83,6 +107,7 @@
  -- The argument is the row of unused connectors
  | ThunkLeftOvers String
  | ThunkLeftUnders String
+ | BracketErr BracketErrMsg
 
 instance Show ErrorMsg where
   show (TypeErr x) = "Type error: " ++ x
@@ -166,6 +191,7 @@
   show UnreachableBranch = "Branch cannot be reached"
   show (ThunkLeftOvers overs) = "Expected function to address all inputs, but " ++ overs ++ " wasn't used"
   show (ThunkLeftUnders unders) = "Expected function to return additional values of type: " ++ unders
+  show (BracketErr msg) = show msg
 
 
 data Error = Err { fc  :: Maybe FC
@@ -213,8 +239,8 @@
     ls = lines contents
   in case endLineN - startLineN of
        0 -> [ls!!startLineN, highlightSection startCol endCol]
        n | n > 0 -> let (first:rest) = drop (startLineN - 1) $ take (endLineN + 1) ls
                         (last:rmid) = reverse rest
                     in [first, highlightSection startCol (length first)]
                        ++ (reverse rmid >>= (\l -> [l, highlightSection 0 (length l)]))
                        ++ [last, highlightSection 0 endCol]

brat/Brat/FC.hs

@@ -35,3 +35,9 @@ fcOf (WC fc _) = fc
 -- TODO: Remove this
 dummyFC :: a -> WC a
 dummyFC = WC (FC (Pos 0 0) (Pos 0 0))
+
+spanFC :: FC -> FC -> FC
+spanFC afc bfc = FC (start afc) (end bfc)
+
+spanFCOf :: WC a -> WC b -> FC
+spanFCOf (WC afc _) (WC bfc _) = spanFC afc bfc

brat/Brat/Lexer/Bracketed.hs

@@ -0,0 +1,98 @@
+module Brat.Lexer.Bracketed (BToken(..), brackets) where
+
+import Data.Bracket
+import Brat.Error (BracketErrMsg(..), Error(Err), ErrorMsg(..))
+import Brat.FC
+import Brat.Lexer.Token
+
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Bifunctor (first)
+import Text.Megaparsec (PosState(..), SourcePos(..), TraversableStream(..), VisualStream(..))
+import Text.Megaparsec.Pos (mkPos)
+
+data OpenClose = Open BracketType | Close BracketType
+
+openClose :: Tok -> Maybe OpenClose
+openClose LParen = Just (Open Paren)
+openClose LSquare = Just (Open Square)
+openClose LBrace = Just (Open Brace)
+openClose RParen = Just (Close Paren)
+openClose RSquare = Just (Close Square)
+openClose RBrace = Just (Close Brace)
+openClose _ = Nothing
+
+-- Well bracketed tokens
+data BToken
+  = Bracketed FC BracketType [BToken]
+  | FlatTok Token
+ deriving (Eq, Ord)
+
+btokLen :: BToken -> Int
+btokLen (FlatTok tok) = length (show tok)
+btokLen (Bracketed _ _ bs) = sum (btokLen <$> bs) + 2
+
+instance Show BToken where
+  show (FlatTok t) = show t
+  show (Bracketed _ b ts) = showOpen b ++ concatMap show ts ++ showClose b
+
+instance VisualStream [BToken] where
+  showTokens _ = concatMap show
+  tokensLength _ = sum . fmap btokLen
+
+instance TraversableStream [BToken] where
+  reachOffsetNoLine i pos = let fileName = sourceName (pstateSourcePos pos)
+                                (Pos line col, rest) = skipChars (i - pstateOffset pos + 1) (pstateInput pos)
+                            in pos
+                            { pstateInput = rest
+                            , pstateOffset = max (pstateOffset pos) i
+                            , pstateSourcePos = SourcePos fileName (mkPos line) (mkPos col)
+                            }
+   where
+    skipChars :: Int -> [BToken] -> (Pos, [BToken])
+    skipChars 0 inp@(Bracketed fc _ _:_) = (start fc, inp)
+    skipChars 0 inp@(FlatTok t:_) = (start (fc t), inp)
+    skipChars i ((Bracketed fc b bts):rest) =
+      let Pos closeLine closeCol = end fc
+          closeFC = FC (Pos closeLine (closeCol - 1)) (Pos closeLine closeCol)
+      in  skipChars (i - 1) (bts ++ [FlatTok (Token closeFC (closeTok b))] ++ rest)
+    skipChars i (FlatTok t:rest)
+     | i >= tokenLen t = skipChars (i - tokenLen t) rest
+     | otherwise = (start (fc t), FlatTok t:rest)
+
+    closeTok Paren = RParen
+    closeTok Square = RSquare
+    closeTok Brace = RBrace
+
+eofErr :: (FC, BracketType) -> Error
+eofErr (fc, b) = Err (Just fc) (BracketErr (EOFInBracket b))
+
+openCloseMismatchErr :: (FC, BracketType) -> (FC, BracketType) -> Error
+openCloseMismatchErr open (fcClose, bClose)
+  = Err (Just fcClose) (BracketErr (OpenCloseMismatch open bClose))
+
+unexpectedCloseErr :: (FC, BracketType) -> Error
+unexpectedCloseErr (fc, b) = Err (Just fc) (BracketErr (UnexpectedClose b))
+
+brackets :: [Token] -> Either Error [BToken]
+brackets ts = helper ts >>= \case
+  (res, Nothing) -> pure res
+  (_, Just (b, t:|_)) -> Left $ unexpectedCloseErr (fc t, b)
+ where
+  -- Given a list of tokens, either
+  -- (success) return [BToken] consisting of the prefix of the input [Token] in which all opened brackets are closed,
+  --           and any remaining [Token] beginning with a closer that does not match any opener in the input
+  --               (either Nothing = no remaining tokens; or tokens with the BracketType that the first token closes)
+  -- (failure) return an error, if a bracket opened in the input, is either not closed (EOF) or does not match the closer
+  helper :: [Token] -> Either Error ([BToken], Maybe (BracketType, NonEmpty Token))
+  helper [] = pure ([], Nothing)
+  helper (t:ts) = case openClose (_tok t) of
+    Just (Open b) -> let openFC = fc t in helper ts >>= \case
+      (_, Nothing) -> Left $ eofErr (fc t, b)
+      (within, Just (b', r :| rs)) ->
+        let closeFC = fc r
+            enclosingFC = spanFC openFC closeFC
+        in  if b == b'
+            then first (Bracketed enclosingFC b within:) <$> helper rs
+            else Left $ openCloseMismatchErr (openFC, b) (closeFC, b')
+    Just (Close b) -> pure ([], Just (b, t :| ts)) -- return closer for caller
+    Nothing -> first (FlatTok t:) <$> helper ts

brat/Brat/Lexer/Flat.hs

@@ -54,8 +54,8 @@ tok = try (char '(' $> LParen)
       <|> try (char ')' $> RParen)
       <|> try (char '{' $> LBrace)
       <|> try (char '}' $> RBrace)
-      <|> try (char '[' $> LBracket)
-      <|> try (char ']' $> RBracket)
+      <|> try (char '[' $> LSquare)
+      <|> try (char ']' $> RSquare)
       <|> try (Underscore <$ string "_")
       <|> try (Quoted <$> (char '"' *> printChar `manyTill` char '"'))
       <|> try (FloatLit <$> float)

brat/Brat/Lexer/Token.hs

@@ -1,4 +1,4 @@
-module Brat.Lexer.Token (Tok(..), Token(..), Keyword(..)) where
+module Brat.Lexer.Token (Tok(..), Token(..), Keyword(..), tokenLen) where
 
 import Brat.FC
 
@@ -21,8 +21,8 @@ data Tok
  | RParen
  | LBrace
  | RBrace
- | LBracket
- | RBracket
+ | LSquare
+ | RSquare
  | Semicolon
  | Into
  | Comma
@@ -66,8 +66,8 @@ instance Show Tok where
   show RParen = ")"
   show LBrace = "{"
   show RBrace = "}"
-  show LBracket = "["
-  show RBracket = "]"
+  show LSquare = "["
+  show RSquare = "]"
   show Semicolon = ";"
   show Into = "|>"
   show Comma = ","
@@ -102,7 +102,8 @@ instance Eq Token where
   (Token fc t) == (Token fc' t') = t == t' && fc == fc'
 
 instance Show Token where
-  show (Token _ t) = show t ++ " "
+  show (Token _ t) = show t
+
 instance Ord Token where
   compare (Token (FC st nd) _) (Token (FC st' nd') _) = if st == st'
                                                         then compare nd nd'
@@ -128,6 +129,8 @@ instance Show Keyword where
 tokLen :: Tok -> Int
 tokLen = length . show
 
+tokenLen = tokLen . _tok
+
 instance VisualStream [Token] where
   tokensLength _ = sum . fmap (\(Token _ t) -> tokLen t)
   showTokens _ = concatMap show