Merge pull request #1140 from github/assignment-error-handling

Assignment error handling

src/Data/Syntax/Assignment.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, InstanceSigs, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
 -- | Assignment of AST onto some other structure (typically terms).
 --
 --   Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and SourceSpan). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference.
@@ -108,6 +108,8 @@ data AssignmentF node a where
   Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF node a
   Alt :: HasCallStack => a -> a -> AssignmentF symbol a
   Empty :: HasCallStack => AssignmentF symbol a
+  Throw :: HasCallStack => Error symbol -> AssignmentF (Node symbol) a
+  Catch :: HasCallStack => a -> (Error symbol -> a) -> AssignmentF (Node symbol) a
 
 -- | Zero-width production of the current location.
 --
@@ -218,6 +220,11 @@ runAssignment = iterFreer run . fmap (\ a state -> Result [] (Just (state, a)))
           (Choose choices, Rose (Just symbol :. _) _ : _) | Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state
           -- Nullability: some rules, e.g. 'pure a' and 'many a', should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input.
           (Alt a b, _) -> yield a state <|> yield b state
+          (Throw e, _) -> Result [ e ] Nothing
+          (Catch during handler, _) -> case yield during state of
+            Result _ (Just (state', a)) -> Result [] (Just (state', a))
+            Result (e:_) Nothing -> yield (handler e) state
+            Result [] Nothing -> Result [] Nothing
           (_, []) -> Result [ Error statePos (UnexpectedEndOfInput expectedSymbols) ] Nothing
           (_, Rose (Just symbol :. _ :. nodeSpan :. Nil) _:_) -> Result [ Error (Info.spanStart nodeSpan) (UnexpectedSymbol expectedSymbols symbol) ] Nothing
           (_, Rose (Nothing :. _ :. nodeSpan :. Nil) _ : _) -> Result [ Error (Info.spanStart nodeSpan) (ParseError expectedSymbols) ] Nothing
@@ -271,6 +278,8 @@ instance Show symbol => Show1 (AssignmentF (Node symbol)) where
     Choose choices -> showsUnaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) "Choose" d (IntMap.toList choices)
     Alt a b -> showsBinaryWith sp sp "Alt" d a b
     Empty -> showString "Empty"
+    Throw e -> showsUnaryWith showsPrec "Throw" d e
+    Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler
 
 type instance Base (Rose a) = RoseF a
 
@@ -303,3 +312,10 @@ instance Alternative (Result symbol) where
   empty = Result [] Nothing
   Result e (Just a) <|> _ = Result e (Just a)
   Result e1 Nothing <|> Result e2 b = Result (e1 <> e2) b
+
+instance MonadError (Error symbol) (Assignment (Node symbol)) where
+  throwError :: HasCallStack => Error symbol -> Assignment (Node symbol) a
+  throwError error = withFrozenCallStack $ Throw error `Then` return
+
+  catchError :: HasCallStack => Assignment (Node symbol) a -> (Error symbol -> Assignment (Node symbol) a) -> Assignment (Node symbol) a
+  catchError during handler = withFrozenCallStack $ Catch during handler `Then` identity

src/Language/Python/Syntax.hs

@@ -45,6 +45,7 @@ type Syntax' =
    , Statement.Return
    , Statement.Yield
    , Syntax.Empty
+   , Syntax.Error [Error Grammar]
    , Syntax.Identifier
    , []
    ]

src/Language/Ruby/Syntax.hs

@@ -46,6 +46,7 @@ type Syntax' =
   , Statement.While
   , Statement.Yield
   , Syntax.Empty
+  , Syntax.Error [Error Grammar]
   , Syntax.Identifier
   , []
   ]
@@ -56,7 +57,7 @@ assignment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 assignment = makeTerm <$> symbol Program <*> children (many declaration)
 
 declaration :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-declaration = comment <|> class' <|> method
+declaration = handleError $ comment <|> class' <|> method
 
 class' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 class' = makeTerm <$> symbol Class <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration)
@@ -76,7 +77,8 @@ statements :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 statements = makeTerm <$> location <*> many statement
 
 statement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-statement  =  exit Statement.Return Return
+statement  = handleError
+           $  exit Statement.Return Return
           <|> exit Statement.Yield Yield
           <|> exit Statement.Break Break
           <|> exit Statement.Continue Next
@@ -151,3 +153,8 @@ makeTerm a f = cofree $ a :< inj f
 
 emptyTerm :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 emptyTerm = makeTerm <$> location <*> pure Syntax.Empty
+
+handleError :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) -> Assignment (Node Grammar) (Term Syntax Location)
+handleError = flip catchError $ \ error -> case errorCause error of
+  UnexpectedEndOfInput _ -> throwError error
+  _ -> makeTerm <$> location <*> (Syntax.Error [error] <$ source)

src/Parser.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables #-}
 module Parser where
 
 import Data.Functor.Union
@@ -30,10 +30,10 @@ data Parser term where
   -- | A parser producing 'AST' using a 'TS.Language'.
   ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST grammar)
   -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. Assignment errors will result in a top-level 'Syntax.Error' node.
-  AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, Functor (Union fs))
-                   => Parser (AST grammar)                                                -- ^ A parser producing 'AST'.
-                   -> Assignment (Node grammar) (Term (Union fs) Location)                -- ^ An assignment from 'AST' onto 'Term's.
-                   -> Parser (Term (Union (Syntax.Error [Error grammar] ': fs)) Location) -- ^ A parser of 'Term's, weakened to allow for 'Syntax.Error' cases.
+  AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, InUnion fs (Syntax.Error [Error grammar]))
+                   => Parser (AST grammar)                                 -- ^ A parser producing 'AST'.
+                   -> Assignment (Node grammar) (Term (Union fs) Location) -- ^ An assignment from 'AST' onto 'Term's.
+                   -> Parser (Term (Union fs) Location)                    -- ^ A parser of 'Term's.
   -- | A tree-sitter parser.
   TreeSitterParser :: Language -> Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields)
   -- | A parser for 'Markdown' using cmark.
@@ -52,10 +52,10 @@ parserForLanguage (Just language) = case language of
   TypeScript -> TreeSitterParser TypeScript tree_sitter_typescript
   _ -> LineByLineParser
 
-rubyParser :: Parser (Term (Union (Syntax.Error [Error Ruby.Grammar] ': Ruby.Syntax')) Location)
+rubyParser :: Parser (Term (Union Ruby.Syntax') Location)
 rubyParser = AssignmentParser (ASTParser tree_sitter_ruby) Ruby.assignment
 
-pythonParser :: Parser (Term (Union (Syntax.Error [Error Python.Grammar] ': Python.Syntax')) Location)
+pythonParser :: Parser (Term (Union Python.Syntax') Location)
 pythonParser = AssignmentParser (ASTParser tree_sitter_python) Python.assignment
 
 runParser :: Parser term -> Source -> IO term
@@ -65,7 +65,7 @@ runParser parser = case parser of
     ast <- runParser parser source
     let Result errors term = assign assignment source ast
     traverse_ (putStr . ($ "") . showError source) errors
-    pure (maybe (cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error errors))) (hoistCofree weaken) term)
+    pure (fromMaybe (cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error errors))) term)
   TreeSitterParser language tslanguage -> treeSitterParser language tslanguage
   MarkdownParser -> cmarkParser
   LineByLineParser -> lineByLineParser