refactor: Add bracketing to parser + cleanup

brat/Brat/Error.hs

@@ -1,5 +1,6 @@
 module Brat.Error (ParseError(..)
                   ,LengthConstraintF(..), LengthConstraint
+                  ,BracketErrMsg(..)
                   ,ErrorMsg(..)
                   ,Error(..), showError
                   ,SrcErr(..)
@@ -9,6 +10,7 @@ module Brat.Error (ParseError(..)
                   ) where
 
 import Brat.FC
+import Data.Bracket
 
 import Data.List (intercalate)
 import System.Exit
@@ -25,6 +27,27 @@ instance Show a => Show (LengthConstraintF a) where
 
 type LengthConstraint = LengthConstraintF Int
 
+data BracketErrMsg
+  = EOFInBracket BracketType -- FC points to the open bracket
+  | OpenCloseMismatch (FC, BracketType) BracketType -- Closer FC is in the `Err` fc
+  | 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
@@ -82,6 +105,7 @@ data ErrorMsg
  -- The argument is the row of unused connectors
  | ThunkLeftOvers String
  | ThunkLeftUnders String
+ | BracketErr BracketErrMsg
 
 instance Show ErrorMsg where
   show (TypeErr x) = "Type error: " ++ x
@@ -165,6 +189,7 @@ instance Show ErrorMsg where
   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

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 _) = FC (start afc) (end bfc)

brat/Brat/Lexer/Bracketed.hs

@@ -0,0 +1,101 @@
+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 LBracket = Just Bracket
+opener LBrace = Just Brace
+opener _ = Nothing
+
+closer :: Tok -> Maybe BracketType
+closer RParen = Just Paren
+closer RBracket = Just Bracket
+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 _ ts = concatMap show ts
+  tokensLength _ = sum . fmap btokLen
+
+instance TraversableStream [BToken] where
+  reachOffsetNoLine i pos = let fileName = sourceName (pstateSourcePos pos)
+                                (Pos line col, rest) = worker (i - pstateOffset pos + 1) (pstateInput pos)
+                            in pos
+                            { pstateInput = rest
+                            , pstateOffset = max (pstateOffset pos) i
+                            , pstateSourcePos = SourcePos fileName (mkPos line) (mkPos col)
+                            }
+   where
+    worker :: Int -> [BToken] -> (Pos, [BToken])
+    worker 0 inp@(Bracketed fc _ _:_) = (start fc, inp)
+    worker 0 inp@(FlatTok t:_) = (start (fc t), inp)
+    worker i ((Bracketed fc b bts):rest) = let Pos closeLine closeCol = end fc
+                                               closeFC = FC (Pos closeLine (closeCol - 1)) (Pos closeLine closeCol)
+                                           in  worker (i - 1) (bts ++ [FlatTok (Token closeFC (closeTok b))] ++ rest)
+    worker i (FlatTok t:rest)
+     | i >= tokenLen t = worker (i - tokenLen t) rest
+     | otherwise = (start (fc t), FlatTok t:rest)
+
+    closeTok Paren = RParen
+    closeTok Bracket = RBracket
+    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))
+
+within :: (FC, BracketType) -> Bwd BToken -> [Token] -> Either Error (FC, Bwd BToken, [Token])
+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 >>= \case
+  (tokz, []) -> pure (tokz <>> [])
+  _ -> error "Incomplete bracket parse" -- Shouldn't happen
+ where
+  bracketsWorker :: Bwd BToken -> [Token] -> Either Error (Bwd BToken, [Token])
+  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/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
 
@@ -102,7 +102,7 @@ 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 +128,8 @@ instance Show Keyword where
 tokLen :: Tok -> Int
 tokLen = length . show
 
+tokenLen = tokLen . _tok
+
 instance VisualStream [Token] where
   showTokens _ ts = concatMap show ts
   tokensLength _ = sum . fmap (\(Token _ t) -> tokLen t)