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,107 @@
+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 Bwd
+
+import Text.Megaparsec (PosState(..), SourcePos(..), TraversableStream(..), VisualStream(..))
+import Text.Megaparsec.Pos (mkPos)
+
+opener :: Tok -> Maybe BracketType
+opener LParen = Just Paren
+opener LSquare = Just Square
+opener LBrace = Just Brace
+opener _ = Nothing
+
+closer :: Tok -> Maybe BracketType
+closer RParen = Just Paren
+closer RSquare = Just Square
+closer RBrace = Just Brace
+closer _ = 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 ++ 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))
+
+-- Parse between two brackets of the same type
+within :: (FC, BracketType) -- The nearest opening bracket to the left of us
+       -> Bwd BToken -- The tokens that we've passed since that open bracket
+       -> [Token]    -- The tokens to the right of us, unparsed
+       -> Either Error (FC         -- The location of the closing bracket
+                       ,Bwd BToken -- The tokens between the open and close
+                       ,[Token]    -- Tokens after the closing bracket
+                       )
+within (openFC, b) _ [] = Left $ eofErr openFC b
+within ctx@(_, b) acc (t:ts)
+ | Just b' <- closer (_tok t) = if b' == b
+                                then pure (fc t, acc, ts)
+                                else Left $ openCloseMismatchErr ctx (fc t, b')
+ | Just b' <- opener (_tok t) = do
+     let innerOpenFC = fc t
+     (innerCloseFC, xs, ts) <- within (innerOpenFC, b') B0 ts
+     let fc = spanFC innerOpenFC innerCloseFC
+     within ctx (acc :< Bracketed fc b' (xs <>> [])) ts
+ | otherwise = within ctx (acc :< FlatTok t) ts
+
+brackets :: [Token] -> Either Error [BToken]
+brackets ts = (<>> []) <$> bracketsWorker B0 ts
+ where
+  bracketsWorker :: Bwd BToken -> [Token] -> Either Error (Bwd BToken)
+  bracketsWorker acc [] = pure acc
+  bracketsWorker acc (t:ts)
+   | Just b <- opener (_tok t) = do
+       (closeFC, xs, ts) <- within (fc t, b) B0 ts
+       let enclosingFC = spanFC (fc t) closeFC
+       bracketsWorker (acc :< Bracketed enclosingFC b (xs <>> [])) ts
+   | Just b <- closer (_tok t) = Left $ unexpectedCloseErr (fc t) b
+   | otherwise = bracketsWorker (acc :< FlatTok t) 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