Merge branch 'master' into docs-updates

src/Data/Syntax/Assignment.hs

@@ -74,6 +74,7 @@ module Data.Syntax.Assignment
 , Error(..)
 , ErrorCause(..)
 , showError
+, showExpectation
 , assign
 , runAssignment
 , AssignmentState(..)
@@ -147,7 +148,7 @@ type AST grammar = Rose (Node grammar)
 
 
 -- | The result of assignment, possibly containing an error.
-data Result symbol a = Result { resultErrors :: [Error symbol], resultValue :: Maybe a }
+data Result symbol a = Result { resultError :: Maybe (Error symbol), resultValue :: Maybe a }
   deriving (Eq, Foldable, Functor, Traversable)
 
 data Error symbol where
@@ -168,22 +169,24 @@ data ErrorCause symbol
 
 -- | Pretty-print an Error with reference to the source where it occurred.
 showError :: Show symbol => Source.Source -> Error symbol -> ShowS
-showError source Error{..}
+showError source error@Error{..}
-  = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation . showChar '\n'
+  = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n'
   . showString context -- actualLines results include line endings, so no newline here
   . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n'
   . showString (prettyCallStack callStack) . showChar '\n'
-  where showExpectation = case errorCause of
+  where context = maybe "\n" (toS . Source.sourceText . sconcat) (nonEmpty [ Source.Source (toS (showLineNumber i)) <> Source.Source ": " <> l | (i, l) <- zip [1..] (Source.actualLines source), inRange (Info.line errorPos - 2, Info.line errorPos) i ])
-          UnexpectedEndOfInput [] -> showString "no rule to match at end of input nodes"
-          UnexpectedEndOfInput symbols -> showString "expected " . showSymbols symbols . showString " at end of input nodes"
-          UnexpectedSymbol symbols a -> showString "expected " . showSymbols symbols . showString ", but got " . shows a
-          ParseError symbols -> showString "expected " . showSymbols symbols . showString ", but got parse error"
-        context = maybe "\n" (toS . Source.sourceText . sconcat) (nonEmpty [ Source.Source (toS (showLineNumber i)) <> Source.Source ": " <> l | (i, l) <- zip [1..] (Source.actualLines source), inRange (Info.line errorPos - 2, Info.line errorPos) i ])
         showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
         lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.line errorPos) :: Double)))
         showSGRCode = showString . setSGRCode
         withSGRCode code s = showSGRCode code . s . showSGRCode []
 
+showExpectation :: Show symbol => Error symbol -> ShowS
+showExpectation Error{..} = case errorCause of
+  UnexpectedEndOfInput [] -> showString "no rule to match at end of input nodes"
+  UnexpectedEndOfInput symbols -> showString "expected " . showSymbols symbols . showString " at end of input nodes"
+  UnexpectedSymbol symbols a -> showString "expected " . showSymbols symbols . showString ", but got " . shows a
+  ParseError symbols -> showString "expected " . showSymbols symbols . showString ", but got parse error"
+
 showSymbols :: Show symbol => [symbol] -> ShowS
 showSymbols [] = showString "end of input nodes"
 showSymbols [symbol] = shows symbol
@@ -200,15 +203,15 @@ assign assignment source = fmap snd . assignAllFrom assignment . makeState sourc
 
 assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, HasCallStack) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a)
 assignAllFrom assignment state = case runAssignment assignment state of
-  Result es (Just (state, a)) -> case stateNodes (dropAnonymous state) of
+  Result err (Just (state, a)) -> case stateNodes (dropAnonymous state) of
-    [] -> Result [] (Just (state, a))
+    [] -> Result Nothing (Just (state, a))
-    Rose (Just s :. _) _ :_ -> Result (if null es then [ Error (statePos state) (UnexpectedSymbol [] s) ] else es) Nothing
+    Rose (Just s :. _) _ :_ -> Result (err <|> Just (Error (statePos state) (UnexpectedSymbol [] s))) Nothing
-    Rose (Nothing :. _) _ :_ -> Result (if null es then [ Error (statePos state) (ParseError []) ] else es) Nothing
+    Rose (Nothing :. _) _ :_ -> Result (err <|> Just (Error (statePos state) (ParseError []))) Nothing
   r -> r
 
 -- | Run an assignment of nodes in a grammar onto terms in a syntax.
 runAssignment :: forall grammar a. (Symbol grammar, Enum grammar, Eq grammar, HasCallStack) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a)
-runAssignment = iterFreer run . fmap (\ a state -> Result [] (Just (state, a)))
+runAssignment = iterFreer run . fmap (\ a state -> pure (state, a))
   where run :: AssignmentF (Node grammar) x -> (x -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a)) -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a)
         run assignment yield initialState = case (assignment, stateNodes) of
           (Location, Rose (_ :. location) _ : _) -> yield location state
@@ -216,18 +219,16 @@ runAssignment = iterFreer run . fmap (\ a state -> Result [] (Just (state, a)))
           (Source, Rose (_ :. range :. _) _ : _) -> yield (Source.sourceText (Source.slice (offsetRange range (negate stateOffset)) stateSource)) (advanceState state)
           (Children childAssignment, Rose _ children : _) -> case assignAllFrom childAssignment state { stateNodes = children } of
             Result _ (Just (state', a)) -> yield a (advanceState state' { stateNodes = stateNodes })
-            Result es Nothing -> Result es Nothing
+            Result err Nothing -> Result err Nothing
           (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
+          (Throw e, _) -> Result (Just e) Nothing
           (Catch during handler, _) -> case yield during state of
-            Result _ (Just (state', a)) -> Result [] (Just (state', a))
+            Result _ (Just (state', a)) -> Result Nothing (Just (state', a))
-            Result (e:_) Nothing -> yield (handler e) state
+            Result err Nothing -> maybe (Result Nothing Nothing) (flip yield state . handler) err
-            Result [] Nothing -> Result [] Nothing
+          (_, []) -> Result (Just (Error statePos (UnexpectedEndOfInput expectedSymbols))) Nothing
-          (_, []) -> Result [ Error statePos (UnexpectedEndOfInput expectedSymbols) ] Nothing
+          (_, Rose (symbol :. _ :. nodeSpan :. Nil) _:_) -> Result (Just (maybe (Error (Info.spanStart nodeSpan) (ParseError expectedSymbols)) (Error (Info.spanStart nodeSpan) . UnexpectedSymbol expectedSymbols) symbol)) 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
           where state@AssignmentState{..} = case assignment of
                   Choose choices | all ((== Regular) . symbolType) (choiceSymbols choices) -> dropAnonymous initialState
                   _ -> initialState
@@ -305,13 +306,13 @@ instance Show1 ErrorCause where
     ParseError expected -> showsUnaryWith (liftShowsPrec sp sl) "ParseError" d expected
 
 instance Applicative (Result symbol) where
-  pure = Result [] . Just
+  pure = Result Nothing . Just
-  Result e1 f <*> Result e2 a = Result (e1 <> e2) (f <*> a)
+  Result e1 f <*> Result e2 a = Result (e1 <|> e2) (f <*> a)
 
 instance Alternative (Result symbol) where
-  empty = Result [] Nothing
+  empty = Result Nothing Nothing
   Result e (Just a) <|> _ = Result e (Just a)
-  Result e1 Nothing <|> Result e2 b = Result (e1 <> e2) b
+  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

src/Data/Syntax/Declaration.hs

@@ -55,8 +55,16 @@ instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
 instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
 
 
+-- | Comprehension (e.g. ((a for b in c) in Python)
+data Comprehension a = Comprehension { comprehensionMap :: !a, comprehensionBindings :: ![a], comprehensionContext :: !a }
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Comprehension where liftEq = genericLiftEq
+instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
+
+
 -- | Import declarations.
-data Import a = Import { importContent :: ByteString }
+data Import a = Import { importContent :: ![a] }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Import where liftEq = genericLiftEq

src/Data/Syntax/Expression.hs

@@ -8,21 +8,34 @@ import GHC.Generics
 import Prologue
 
 -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
-data Call a = Call { callFunction :: a, callParams :: [a] }
+data Call a = Call { callFunction :: !a, callParams :: ![a] }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Call where liftEq = genericLiftEq
 instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
 
+
+data Comparison a
+  = LessThan !a !a
+  | LessThanEqual !a !a
+  | GreaterThan !a !a
+  | GreaterThanEqual !a !a
+  | Equal !a !a
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Comparison where liftEq = genericLiftEq
+instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
+
+
 -- | Binary arithmetic operators.
 data Arithmetic a
-  = Plus a a
+  = Plus !a !a
-  | Minus a a
+  | Minus !a !a
-  | Times a a
+  | Times !a !a
-  | DividedBy a a
+  | DividedBy !a !a
-  | Modulo a a
+  | Modulo !a !a
-  | Power a a
+  | Power !a !a
-  | Negate a
+  | Negate !a
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Arithmetic where liftEq = genericLiftEq
@@ -30,9 +43,9 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
 
 -- | Boolean operators.
 data Boolean a
-  = Or a a
+  = Or !a !a
-  | And a a
+  | And !a !a
-  | Not a
+  | Not !a
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Boolean where liftEq = genericLiftEq
@@ -40,13 +53,38 @@ instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
 -- | Bitwise operators.
 data Bitwise a
-  = BOr a a
+  = BOr !a !a
-  | BAnd a a
+  | BAnd !a !a
-  | BXOr a a
+  | BXOr !a !a
-  | LShift a a
+  | LShift !a !a
-  | RShift a a
+  | RShift !a !a
   | Complement a
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Bitwise where liftEq = genericLiftEq
 instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
+
+-- | Member Access (e.g. a.b)
+data MemberAccess a
+  = MemberAccess !a !a
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 MemberAccess where liftEq = genericLiftEq
+instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
+
+-- | Subscript (e.g a[1])
+data Subscript a
+  = Subscript !a ![a]
+  | Member !a !a
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Subscript where liftEq = genericLiftEq
+instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
+
+-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
+data ScopeResolution a
+  = ScopeResolution ![a]
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 ScopeResolution where liftEq = genericLiftEq
+instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Literal.hs

@@ -4,10 +4,9 @@ module Data.Syntax.Literal where
 import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
-import Data.Syntax.Comment
 import Data.Functor.Union
 import GHC.Generics
-import Prologue
+import Prologue hiding (Set)
 
 -- Boolean
 
@@ -45,8 +44,7 @@ instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
 instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
 
 
-
+data Range a = Range { rangeStart :: !a, rangeEnd :: !a }
-data Range a = Range { rangeStart :: a, rangeEnd :: a }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Range where liftEq = genericLiftEq
@@ -97,14 +95,14 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
 
 -- Collections
 
-newtype Array a = Array { arrayElements :: [Union '[Identity, Comment] a] }
+newtype Array a = Array { arrayElements :: [a] }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Array where liftEq = genericLiftEq
 instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
 
 
-newtype Hash a = Hash { hashElements :: [Union '[KeyValue, Comment] a] }
+newtype Hash a = Hash { hashElements :: [a] }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Hash where liftEq = genericLiftEq
@@ -117,12 +115,21 @@ data KeyValue a = KeyValue { key :: !a, value :: !a }
 instance Eq1 KeyValue where liftEq = genericLiftEq
 instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
 
-data Tuple a = Tuple { tupleContents :: ![a]}
+
+newtype Tuple a = Tuple { tupleContents :: [a]}
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Tuple where liftEq = genericLiftEq
 instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
 
+
+newtype Set a = Set { setElements :: [a] }
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Set where liftEq = genericLiftEq
+instance Show1 Set where liftShowsPrec = genericLiftShowsPrec
+
 -- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”?
 -- TODO: Function literals (lambdas, procs, anonymous functions, what have you).
 -- TODO: Regexp literals.
+

src/Language/Python/Syntax.hs

@@ -4,6 +4,7 @@ module Language.Python.Syntax
 , Syntax
 , Syntax'
 , Grammar
+, Error
 ) where
 
 import Data.Align.Generic
@@ -11,7 +12,8 @@ import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import Data.Functor.Union
 import qualified Data.Syntax as Syntax
-import Data.Syntax.Assignment
+import Data.Syntax.Assignment hiding (Error)
+import qualified Data.Syntax.Assignment as Assignment
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
 import qualified Data.Syntax.Expression as Expression
@@ -26,16 +28,26 @@ import Term
 type Syntax = Union Syntax'
 type Syntax' =
   '[ Comment.Comment
+   , Declaration.Comprehension
+   , Declaration.Function
    , Declaration.Import
    , Declaration.Variable
    , Expression.Arithmetic
    , Expression.Boolean
    , Expression.Bitwise
    , Expression.Call
+   , Expression.Comparison
+   , Expression.ScopeResolution
+   , Expression.MemberAccess
+   , Expression.Subscript
+   , Literal.Array
    , Literal.Boolean
    , Literal.Float
+   , Literal.Hash
    , Literal.Integer
+   , Literal.KeyValue
    , Literal.Null
+   , Literal.Set
    , Literal.String
    , Literal.TextElement
    , Literal.Tuple
@@ -44,12 +56,23 @@ type Syntax' =
    , Statement.If
    , Statement.Return
    , Statement.Yield
+   , Language.Python.Syntax.Ellipsis
    , Syntax.Empty
-   , Syntax.Error [Error Grammar]
+   , Syntax.Error Error
    , Syntax.Identifier
    , []
    ]
 
+type Error = Assignment.Error Grammar
+
+-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
+data Ellipsis a = Ellipsis
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Ellipsis where liftEq = genericLiftEq
+instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec
+
+
 data Redirect a = Redirect !a !a
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
@@ -60,28 +83,75 @@ instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec
 assignment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 assignment = makeTerm <$> symbol Module <*> children (many declaration)
 
-
 declaration :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-declaration = comment <|> literal <|> statement <|> import' <|> importFrom
+declaration = handleError $ comment <|> statement <|> expression
-
 
 statement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-statement = expressionStatement
+statement = assertStatement
-          <|> ifStatement
-          <|> returnStatement
-          <|> identifier
           <|> assignment'
           <|> augmentedAssignment
-          <|> printStatement
+          <|> expressionStatement
-          <|> assertStatement
           <|> globalStatement
+          <|> ifStatement
+          <|> identifier
+          <|> import'
+          <|> importFrom
+          <|> printStatement
+          <|> returnStatement
+
+expressionStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+expressionStatement = symbol ExpressionStatement *> children expression
+
+expression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+expression = await
+          <|> binaryOperator
+          <|> booleanOperator
+          <|> call
+          <|> comparisonOperator
+          <|> comprehension
+          <|> conditionalExpression
+          <|> dottedName
+          <|> ellipsis
+          <|> lambda
+          <|> keywordIdentifier
+          <|> literal
+          <|> memberAccess
+          <|> notOperator
+          <|> subscript
+          <|> statement
+          <|> tuple
+          <|> unaryOperator
+
+dottedName :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+dottedName = makeTerm <$> symbol DottedName <*> children (Expression.ScopeResolution <$> many expression)
+
+ellipsis :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+ellipsis = makeTerm <$> symbol Grammar.Ellipsis <*> (Language.Python.Syntax.Ellipsis <$ source)
+
+comparisonOperator :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+comparisonOperator = symbol ComparisonOperator >>= \ loc -> children (expression >>= \ lexpression -> makeComparison loc lexpression)
+  where
+    makeComparison loc lexpression =  makeTerm loc <$ symbol AnonLAngle      <*> (Expression.LessThan lexpression <$> expression)
+                                  <|> makeTerm loc <$ symbol AnonLAngleEqual <*> (Expression.LessThanEqual lexpression <$> expression)
+                                  <|> makeTerm loc <$ symbol AnonRAngle      <*> (Expression.GreaterThan lexpression <$> expression)
+                                  <|> makeTerm loc <$ symbol AnonRAngleEqual <*> (Expression.GreaterThanEqual lexpression <$> expression)
+                                  <|> makeTerm loc <$ symbol AnonEqualEqual  <*> (Expression.Equal lexpression <$> expression)
+                                  <|> makeTerm loc <$ symbol AnonBangEqual   <*> (Expression.Not <$> (makeTerm <$> location <*> (Expression.Equal lexpression <$> expression)))
+                                  <|> makeTerm loc <$ symbol AnonNot         <*> (Expression.Not <$> (makeTerm <$> location <*> (Expression.Member lexpression <$> expression)))
+                                  <|> makeTerm loc <$ symbol AnonIn          <*> (Expression.Member lexpression <$> expression)
+                                                    -- source is used here to push the cursor to the next node to enable matching against `AnonNot`
+                                  <|> symbol AnonIs *> source *> (symbol AnonNot *> (makeTerm loc <$> Expression.Not <$> (makeTerm <$> location <*> (Expression.Equal lexpression <$> expression)))
+                                                                <|> (makeTerm loc <$> Expression.Equal lexpression <$> expression))
+
+notOperator :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+notOperator = makeTerm <$> symbol NotOperator <*> children (Expression.Not <$> expression)
+
+keywordIdentifier :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+keywordIdentifier = makeTerm <$> symbol KeywordIdentifier <*> children (Syntax.Identifier <$> source)
 
 tuple :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 tuple = makeTerm <$> symbol Tuple <*> children (Literal.Tuple <$> (many expression))
 
-expression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-expression = identifier <|> statement <|> unaryOperator <|> binaryOperator <|> booleanOperator <|> tuple <|> literal
-
 -- TODO: Consider flattening single element lists
 expressionList :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 expressionList = makeTerm <$> symbol ExpressionList <*> children (many expression)
@@ -145,7 +215,17 @@ identifier :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier <$> source)
 
 literal :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-literal = string <|> integer <|> float <|> boolean <|> none <|> concatenatedString
+literal = string <|> integer <|> float <|> boolean <|> none <|> concatenatedString <|> list' <|> dictionary <|> set
+
+set :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+set = makeTerm <$> symbol Set <*> children (Literal.Set <$> many expression)
+
+dictionary :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+dictionary = makeTerm <$> symbol Dictionary <*> children (Literal.Hash <$> many pairs)
+  where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> expression)
+
+list' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+list' = makeTerm <$> symbol List <*> children (Literal.Array <$> many expression)
 
 -- TODO: Wrap `Literal.TextElement` with a `Literal.String`
 string :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
@@ -163,17 +243,13 @@ integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)
 comment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source)
 
-expressionStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-expressionStatement = symbol ExpressionStatement *> children (statement <|> literal <|> expression)
-
-
 -- TODO Possibly match against children for dotted name and identifiers
 import' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-import' = makeTerm <$> symbol ImportStatement <*> (Declaration.Import <$> source)
+import' = makeTerm <$> symbol ImportStatement <*> children (Declaration.Import <$> many expression)
 
 -- TODO Possibly match against children nodes
 importFrom :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-importFrom = makeTerm <$> symbol ImportFromStatement <*> (Declaration.Import <$> source)
+importFrom = makeTerm <$> symbol ImportFromStatement <*> children (Declaration.Import <$> many expression)
 
 assertStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 assertStatement = makeTerm <$ symbol AssertStatement <*> location <*> children (Expression.Call <$> (makeTerm <$> symbol AnonAssert <*> (Syntax.Identifier <$> source)) <*> many expression)
@@ -192,18 +268,29 @@ printStatement = do
 globalStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 globalStatement = makeTerm <$> symbol GlobalStatement <*> children (Expression.Call <$> (makeTerm <$> symbol AnonGlobal <*> (Syntax.Identifier <$> source)) <*> many identifier)
 
+await :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+await = makeTerm <$> symbol Await <*> children (Expression.Call <$> (makeTerm <$> symbol AnonAwait <*> (Syntax.Identifier <$> source)) <*> many expression)
+
 returnStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 returnStatement = makeTerm <$> symbol ReturnStatement <*> (Statement.Return <$> children expressionList)
 
 
 ifStatement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
-ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> condition <*> statement <*> (flip (foldr makeElif) <$> many elifClause <*> optionalElse))
+ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> expression <*> statement <*> (flip (foldr makeElif) <$> many elifClause <*> optionalElse))
   where elseClause = symbol ElseClause *> children statement
-        elifClause = (,) <$ symbol ElifClause <*> location <*> children (Statement.If <$> condition <*> statement)
+        elifClause = (,) <$ symbol ElifClause <*> location <*> children (Statement.If <$> expression <*> statement)
-        condition = boolean
         optionalElse = fromMaybe <$> emptyTerm <*> optional elseClause
         makeElif (loc, makeIf) rest = makeTerm loc (makeIf rest)
 
+memberAccess :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+memberAccess = makeTerm <$> symbol Attribute <*> children (Expression.MemberAccess <$> expression <*> expression)
+
+subscript :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+subscript = makeTerm <$> symbol Subscript <*> children (Expression.Subscript <$> expression <*> many expression)
+
+call :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+call = makeTerm <$> symbol Call <*> children (Expression.Call <$> identifier <*> (symbol ArgumentList *> children (many expression)
+                                                                                <|> some comprehension))
 
 boolean :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 boolean =  makeTerm <$> symbol Grammar.True  <*> (Literal.true <$ source)
@@ -212,8 +299,33 @@ boolean =  makeTerm <$> symbol Grammar.True  <*> (Literal.true <$ source)
 none :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
 none = makeTerm <$> symbol None <*> (Literal.Null <$ source)
 
+lambda :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+lambda = makeTerm <$> symbol Lambda <*> children (Declaration.Function <$> lambdaIdentifier <*> lambdaParameters <*> lambdaBody)
+  where lambdaIdentifier = makeTerm <$> symbol AnonLambda <*> (Syntax.Identifier <$> source)
+        lambdaParameters = many identifier
+        lambdaBody = expression
+
+comprehension :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+comprehension =  makeTerm <$> symbol GeneratorExpression <*> children (comprehensionDeclaration expression)
+             <|> makeTerm <$> symbol ListComprehension <*> children (comprehensionDeclaration expression)
+             <|> makeTerm <$> symbol SetComprehension <*> children (comprehensionDeclaration expression)
+             <|> makeTerm <$> symbol DictionaryComprehension <*> children (comprehensionDeclaration keyValue)
+  where
+    keyValue = makeTerm <$> location <*> (Literal.KeyValue <$> expression <*> expression)
+    comprehensionDeclaration preceeding = Declaration.Comprehension <$> preceeding <* symbol Variables <*> children (many expression) <*> (flip (foldr makeComprehension) <$> many nestedComprehension <*> expression)
+    makeComprehension (loc, makeRest) rest = makeTerm loc (makeRest rest)
+    nestedComprehension = (,) <$> location <*> (Declaration.Comprehension <$> expression <* symbol Variables <*> children (many expression))
+
+conditionalExpression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
+conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (expression >>= \ thenBranch -> expression >>= \ conditional -> Statement.If conditional thenBranch <$> (expression <|> emptyTerm))
+
 makeTerm :: HasCallStack => InUnion Syntax' f => a -> f (Term Syntax a) -> Term Syntax a
 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/Language/Ruby/Syntax.hs

@@ -4,11 +4,13 @@ module Language.Ruby.Syntax
 , Syntax
 , Syntax'
 , Grammar
+, Error
 ) where
 
 import Data.Functor.Union
 import qualified Data.Syntax as Syntax
-import Data.Syntax.Assignment
+import Data.Syntax.Assignment hiding (Error)
+import qualified Data.Syntax.Assignment as Assignment
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
 import qualified Data.Syntax.Expression as Expression
@@ -46,11 +48,13 @@ type Syntax' =
   , Statement.While
   , Statement.Yield
   , Syntax.Empty
-  , Syntax.Error [Error Grammar]
+  , Syntax.Error Error
   , Syntax.Identifier
   , []
   ]
 
+type Error = Assignment.Error Grammar
+
 
 -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
 assignment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location)
@@ -157,4 +161,4 @@ 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)
+  _ -> makeTerm <$> location <*> (Syntax.Error error <$ source)

src/Parser.hs

@@ -30,7 +30,7 @@ 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, InUnion fs (Syntax.Error [Error grammar]))
+  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.
@@ -63,9 +63,9 @@ runParser parser = case parser of
   ASTParser language -> parseToAST language
   AssignmentParser parser assignment -> \ source -> do
     ast <- runParser parser source
-    let Result errors term = assign assignment source ast
+    let Result err term = assign assignment source ast
-    traverse_ (putStr . ($ "") . showError source) errors
+    traverse_ (putStr . ($ "") . showError source) err
-    pure (fromMaybe (cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error errors))) term)
+    pure (fromMaybe (cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error (fromMaybe (Error (SourcePos 0 0) (UnexpectedEndOfInput [])) err)))) term)
   TreeSitterParser language tslanguage -> treeSitterParser language tslanguage
   MarkdownParser -> cmarkParser
   LineByLineParser -> lineByLineParser

src/Renderer.hs

@@ -9,6 +9,7 @@ module Renderer
 , renderJSONTerm
 , renderToC
 , declarationAlgebra
+, syntaxDeclarationAlgebra
 , identifierAlgebra
 , Summaries(..)
 , File(..)

src/Renderer/TOC.hs

@@ -4,23 +4,24 @@ module Renderer.TOC
 , diffTOC
 , Summaries(..)
 , JSONSummary(..)
-, Summarizable(..)
 , isValidSummary
 , Declaration(..)
 , declaration
 , declarationAlgebra
+, syntaxDeclarationAlgebra
 , Entry(..)
 , tableOfContentsBy
 , dedupe
 , entrySummary
 ) where
 
-import Category as C
 import Data.Aeson
 import Data.Align (crosswalk)
 import Data.Functor.Both hiding (fst, snd)
 import qualified Data.Functor.Both as Both
 import Data.Functor.Listable
+import Data.Functor.Union
+import Data.Proxy
 import Data.Text (toLower)
 import Data.Text.Listable
 import Data.These
@@ -33,6 +34,9 @@ import qualified Data.List as List
 import qualified Data.Map as Map hiding (null)
 import Source hiding (null)
 import Syntax as S
+import Data.Syntax.Algebra (RAlgebra)
+import qualified Data.Syntax as Syntax
+import qualified Data.Syntax.Declaration as Declaration
 import Term
 
 data Summaries = Summaries { changes, errors :: !(Map Text [Value]) }
@@ -48,27 +52,24 @@ instance StringConv Summaries ByteString where
 instance ToJSON Summaries where
   toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
 
-data JSONSummary = JSONSummary { info :: Summarizable }
+data JSONSummary
-                 | ErrorSummary { error :: Text, errorSpan :: SourceSpan }
+  = JSONSummary
-                 deriving (Generic, Eq, Show)
+    { summaryCategoryName :: Text
+    , summaryTermName :: Text
+    , summarySourceSpan :: SourceSpan
+    , summaryChangeType :: Text
+    }
+  | ErrorSummary { error :: Text, errorSpan :: SourceSpan }
+  deriving (Generic, Eq, Show)
 
 instance ToJSON JSONSummary where
-  toJSON (JSONSummary Summarizable{..}) = object [ "changeType" .= summarizableChangeType, "category" .= toCategoryName summarizableCategory, "term" .= summarizableTermName, "span" .= summarizableSourceSpan ]
+  toJSON JSONSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySourceSpan ]
   toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan ]
 
 isValidSummary :: JSONSummary -> Bool
 isValidSummary ErrorSummary{} = False
 isValidSummary _ = True
 
-data Summarizable
-  = Summarizable
-    { summarizableCategory :: Category
-    , summarizableTermName :: Text
-    , summarizableSourceSpan :: SourceSpan
-    , summarizableChangeType :: Text
-    }
-  deriving (Eq, Show)
-
 -- | A declaration’s identifier and type.
 data Declaration
   = MethodDeclaration   { declarationIdentifier :: Text }
@@ -76,16 +77,17 @@ data Declaration
   | ErrorDeclaration    { declarationIdentifier :: Text }
   deriving (Eq, Generic, NFData, Show)
 
+getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration
+getDeclaration = getField
+
 -- | Produce the annotations of nodes representing declarations.
-declaration :: (HasField fields (Maybe Declaration), HasField fields Category) => TermF (Syntax Text) (Record fields) a -> Maybe (Record fields)
+declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields)
-declaration (annotation :< syntax)
+declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Declaration)
-  | S.ParseError{} <- syntax = Just (setCategory annotation C.ParseError)
-  | otherwise                = annotation <$ (getField annotation :: Maybe Declaration)
 
 
--- | Compute 'Declaration's for methods and functions.
+-- | Compute 'Declaration's for methods and functions in 'Syntax'.
-declarationAlgebra :: HasField fields Range => Source -> TermF (Syntax Text) (Record fields) (Term (Syntax Text) (Record fields), Maybe Declaration) -> Maybe Declaration
+syntaxDeclarationAlgebra :: HasField fields Range => Source -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration)
-declarationAlgebra source r = case tailF r of
+syntaxDeclarationAlgebra source r = case tailF r of
   S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier)
   S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier)
   S.Method _ (identifier, _) (Just (receiver, _)) _ _
@@ -96,6 +98,18 @@ declarationAlgebra source r = case tailF r of
   _ -> Nothing
   where getSource = toText . flip Source.slice source . byteRange . extract
 
+-- | Compute 'Declaration's for methods and functions.
+declarationAlgebra :: (InUnion fs Declaration.Function, InUnion fs Declaration.Method, InUnion fs (Syntax.Error error), Show error, Functor (Union fs), HasField fields Range)
+                   => Proxy error
+                   -> Source
+                   -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
+declarationAlgebra proxy source r
+  | Just (Declaration.Function (identifier, _) _ _) <- prj (tailF r) = Just $ FunctionDeclaration (getSource identifier)
+  | Just (Declaration.Method (identifier, _) _ _) <- prj (tailF r) = Just $ MethodDeclaration (getSource identifier)
+  | Just (Syntax.Error err) <- prj (tailF r) = Just $ ErrorDeclaration (show (err `asProxyTypeOf` proxy))
+  | otherwise = Nothing
+  where getSource = toText . flip Source.slice source . byteRange . extract
+
 
 -- | An entry in a table of contents.
 data Entry a
@@ -121,7 +135,7 @@ tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap
                       | otherwise = fold r
         patchEntry = these Deleted Inserted (const Replaced) . unPatch
 
-dedupe :: (HasField fields Category, HasField fields (Maybe Declaration)) => [Entry (Record fields)] -> [Entry (Record fields)]
+dedupe :: HasField fields (Maybe Declaration) => [Entry (Record fields)] -> [Entry (Record fields)]
 dedupe = foldl' go []
   where go xs x | (_, _:_) <- find (exactMatch `on` entryPayload) x xs = xs
                 | (front, similar : back) <- find (similarMatch `on` entryPayload) x xs =
@@ -131,24 +145,23 @@ dedupe = foldl' go []
         find p x = List.break (p x)
         exactMatch = (==) `on` getDeclaration
         similarMatch a b = sameCategory a b && similarDeclaration a b
-        sameCategory = (==) `on` category
+        sameCategory = (==) `on` fmap toCategoryName . getDeclaration
         similarDeclaration = (==) `on` fmap (toLower . declarationIdentifier) . getDeclaration
-        getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration
-        getDeclaration = getField
 
 -- | Construct a 'JSONSummary' from an 'Entry'. Returns 'Nothing' for 'Unchanged' patches.
-entrySummary :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Entry (Record fields) -> Maybe JSONSummary
+entrySummary :: (HasField fields (Maybe Declaration), HasField fields SourceSpan) => Entry (Record fields) -> Maybe JSONSummary
 entrySummary entry = case entry of
   Unchanged _ -> Nothing
-  Changed a   -> Just (recordSummary a "modified")
+  Changed a   -> recordSummary a "modified"
-  Deleted a   -> Just (recordSummary a "removed")
+  Deleted a   -> recordSummary a "removed"
-  Inserted a  -> Just (recordSummary a "added")
+  Inserted a  -> recordSummary a "added"
-  Replaced a  -> Just (recordSummary a "modified")
+  Replaced a  -> recordSummary a "modified"
-  where recordSummary record
+  where recordSummary record = case getDeclaration record of
-          | C.ParseError <- category record = const (ErrorSummary (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record))
+          Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record))
-          | otherwise = JSONSummary . Summarizable (category record) (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record)
+          Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record)
+          Nothing -> const Nothing
 
-renderToC :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Both SourceBlob -> Diff (Syntax Text) (Record fields) -> Summaries
+renderToC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Both SourceBlob -> Diff f (Record fields) -> Summaries
 renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
   where toMap [] = mempty
         toMap as = Map.singleton summaryKey (toJSON <$> as)
@@ -158,14 +171,15 @@ renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValid
                           | before == after -> after
                           | otherwise -> before <> " -> " <> after
 
-diffTOC :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Diff (Syntax Text) (Record fields) -> [JSONSummary]
+diffTOC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Diff f (Record fields) -> [JSONSummary]
 diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration
 
 -- The user-facing category name
-toCategoryName :: Category -> Text
+toCategoryName :: Declaration -> Text
-toCategoryName category = case category of
+toCategoryName declaration = case declaration of
-  C.SingletonMethod -> "Method"
+  FunctionDeclaration _ -> "Function"
-  c -> show c
+  MethodDeclaration _ -> "Method"
+  ErrorDeclaration _ -> "ParseError"
 
 instance Listable Declaration where
   tiers

src/Semantic.hs

@@ -11,11 +11,15 @@ import Algorithm hiding (diff)
 import Data.Align.Generic (GAlign)
 import Data.Functor.Both as Both
 import Data.Functor.Classes (Eq1, Show1)
+import Data.Functor.Union
+import Data.Proxy
 import Data.Record
+import qualified Data.Syntax.Declaration as Declaration
 import Diff
 import Info
 import Interpreter
 import qualified Language
+import qualified Language.Python.Syntax as Python
 import Patch
 import Parser
 import Prologue
@@ -55,14 +59,15 @@ diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) .
 -- | A task to parse a pair of 'SourceBlob's, diff them, and render the 'Diff'.
 diffBlobPair :: DiffRenderer output -> Both SourceBlob -> Task output
 diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
-  (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (declarationAlgebra source)) diffTerms (renderToC blobs)
+  (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source  >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToC blobs)
+  (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToC blobs)
   (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs)
   (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs)
   (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderPatch blobs)
   (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs)
   (SExpressionDiffRenderer, Just Language.Python) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel)
   (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory)
-  (IdentityDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (declarationAlgebra source)) diffTerms Just
+  (IdentityDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms Just
   where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs)
         syntaxParser = parserForLanguage effectiveLanguage
 

test/Data/Syntax/Assignment/Spec.hs

@@ -14,11 +14,11 @@ spec :: Spec
 spec = do
   describe "Applicative" $
     it "matches in sequence" $
-      runAssignment ((,) <$> red <*> red) (makeState "helloworld" [Rose (rec Red 0 5) [], Rose (rec Red 5 10) []]) `shouldBe` Result [] (Just (AssignmentState 10 (Info.SourcePos 1 11) "" [], (Out "hello", Out "world")))
+      runAssignment ((,) <$> red <*> red) (makeState "helloworld" [Rose (rec Red 0 5) [], Rose (rec Red 5 10) []]) `shouldBe` Result Nothing (Just (AssignmentState 10 (Info.SourcePos 1 11) "" [], (Out "hello", Out "world")))
 
   describe "Alternative" $ do
     it "attempts multiple alternatives" $
-      runAssignment (green <|> red) (makeState "hello" [Rose (rec Red 0 5) []]) `shouldBe` Result [] (Just (AssignmentState 5 (Info.SourcePos 1 6) "" [], Out "hello"))
+      runAssignment (green <|> red) (makeState "hello" [Rose (rec Red 0 5) []]) `shouldBe` Result Nothing (Just (AssignmentState 5 (Info.SourcePos 1 6) "" [], Out "hello"))
 
     it "matches repetitions" $
       let s = "colourless green ideas sleep furiously"
@@ -31,35 +31,35 @@ spec = do
 
   describe "symbol" $ do
     it "matches nodes with the same symbol" $
-      snd <$> runAssignment red (makeState "hello" [Rose (rec Red 0 5) []]) `shouldBe` Result [] (Just (Out "hello"))
+      snd <$> runAssignment red (makeState "hello" [Rose (rec Red 0 5) []]) `shouldBe` Result Nothing (Just (Out "hello"))
 
     it "does not advance past the current node" $
       let initialState = makeState "hi" [ Rose (rec Red 0 2) [] ] in
-      fst <$> runAssignment (symbol Red) initialState `shouldBe` Result [] (Just initialState)
+      fst <$> runAssignment (symbol Red) initialState `shouldBe` Result Nothing (Just initialState)
 
   describe "source" $ do
     it "produces the node’s source" $
-      assign source "hi" (Rose (rec Red 0 2) []) `shouldBe` Result [] (Just "hi")
+      assign source "hi" (Rose (rec Red 0 2) []) `shouldBe` Result Nothing (Just "hi")
 
     it "advances past the current node" $
-      fst <$> runAssignment source (makeState "hi" [ Rose (rec Red 0 2) [] ]) `shouldBe` Result [] (Just (AssignmentState 2 (Info.SourcePos 1 3) "" []))
+      fst <$> runAssignment source (makeState "hi" [ Rose (rec Red 0 2) [] ]) `shouldBe` Result Nothing (Just (AssignmentState 2 (Info.SourcePos 1 3) "" []))
 
   describe "children" $ do
     it "advances past the current node" $
-      fst <$> runAssignment (children (pure (Out ""))) (makeState "a" [Rose (rec Red 0 1) []]) `shouldBe` Result [] (Just (AssignmentState 1 (Info.SourcePos 1 2) "" []))
+      fst <$> runAssignment (children (pure (Out ""))) (makeState "a" [Rose (rec Red 0 1) []]) `shouldBe` Result Nothing (Just (AssignmentState 1 (Info.SourcePos 1 2) "" []))
 
     it "matches if its subrule matches" $
-      () <$ runAssignment (children red) (makeState "a" [Rose (rec Blue 0 1) [Rose (rec Red 0 1) []]]) `shouldBe` Result [] (Just ())
+      () <$ runAssignment (children red) (makeState "a" [Rose (rec Blue 0 1) [Rose (rec Red 0 1) []]]) `shouldBe` Result Nothing (Just ())
 
     it "does not match if its subrule does not match" $
-      (runAssignment (children red) (makeState "a" [Rose (rec Blue 0 1) [Rose (rec Green 0 1) []]])) `shouldBe` Result [ Error (Info.SourcePos 1 1) (UnexpectedSymbol [Red] Green) ] Nothing
+      (runAssignment (children red) (makeState "a" [Rose (rec Blue 0 1) [Rose (rec Green 0 1) []]])) `shouldBe` Result (Just (Error (Info.SourcePos 1 1) (UnexpectedSymbol [Red] Green))) Nothing
 
     it "matches nested children" $
       runAssignment
         (symbol Red *> children (symbol Green *> children (symbol Blue *> source)))
         (makeState "1" [ Rose (rec Red 0 1) [ Rose (rec Green 0 1) [ Rose (rec Blue 0 1) [] ] ] ])
       `shouldBe`
-        Result [] (Just (AssignmentState 1 (Info.SourcePos 1 2) "" [], "1"))
+        Result Nothing (Just (AssignmentState 1 (Info.SourcePos 1 2) "" [], "1"))
 
     it "continues after children" $
       resultValue (runAssignment
@@ -76,17 +76,17 @@ spec = do
         (makeState "12" [ Rose (rec Red 0 2) [ Rose (rec Green 0 1) [ Rose (rec Blue 0 1) [] ]
                                              , Rose (rec Green 1 2) [ Rose (rec Blue 1 2) [] ] ] ])
       `shouldBe`
-        Result [] (Just (AssignmentState 2 (Info.SourcePos 1 3) "" [], ["1", "2"]))
+        Result Nothing (Just (AssignmentState 2 (Info.SourcePos 1 3) "" [], ["1", "2"]))
 
   describe "runAssignment" $ do
     it "drops anonymous nodes before matching symbols" $
-      runAssignment red (makeState "magenta red" [Rose (rec Magenta 0 7) [], Rose (rec Red 8 11) []]) `shouldBe` Result [] (Just (AssignmentState 11 (Info.SourcePos 1 12) "" [], Out "red"))
+      runAssignment red (makeState "magenta red" [Rose (rec Magenta 0 7) [], Rose (rec Red 8 11) []]) `shouldBe` Result Nothing (Just (AssignmentState 11 (Info.SourcePos 1 12) "" [], Out "red"))
 
     it "does not drop anonymous nodes after matching" $
-      runAssignment red (makeState "red magenta" [Rose (rec Red 0 3) [], Rose (rec Magenta 4 11) []]) `shouldBe` Result [] (Just (AssignmentState 3 (Info.SourcePos 1 4) " magenta" [Rose (rec Magenta 4 11) []], Out "red"))
+      runAssignment red (makeState "red magenta" [Rose (rec Red 0 3) [], Rose (rec Magenta 4 11) []]) `shouldBe` Result Nothing (Just (AssignmentState 3 (Info.SourcePos 1 4) " magenta" [Rose (rec Magenta 4 11) []], Out "red"))
 
     it "does not drop anonymous nodes when requested" $
-      runAssignment ((,) <$> magenta <*> red) (makeState "magenta red" [Rose (rec Magenta 0 7) [], Rose (rec Red 8 11) []]) `shouldBe` Result [] (Just (AssignmentState 11 (Info.SourcePos 1 12) "" [], (Out "magenta", Out "red")))
+      runAssignment ((,) <$> magenta <*> red) (makeState "magenta red" [Rose (rec Magenta 0 7) [], Rose (rec Red 8 11) []]) `shouldBe` Result Nothing (Just (AssignmentState 11 (Info.SourcePos 1 12) "" [], (Out "magenta", Out "red")))
 
 rec :: symbol -> Int -> Int -> Record '[Maybe symbol, Range, SourceSpan]
 rec symbol start end = Just symbol :. Range start end :. Info.SourceSpan (Info.SourcePos 1 (succ start)) (Info.SourcePos 1 (succ end)) :. Nil

test/TOCSpec.hs

@@ -60,39 +60,39 @@ spec = parallel $ do
       sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.SingletonMethod "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added"
+        [ JSONSummary "Method" "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added"
-        , JSONSummary $ Summarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified"
+        , JSONSummary "Method" "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified"
-        , JSONSummary $ Summarizable C.Method "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ]
+        , JSONSummary "Method" "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ]
 
     it "dedupes changes in same parent method" $ do
       sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.Function "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ]
+        [ JSONSummary "Function" "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ]
 
     it "dedupes similar methods" $ do
       sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.Function "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ]
+        [ JSONSummary "Function" "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ]
 
     it "summarizes Go methods with receivers with special formatting" $ do
       sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.Method "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ]
+        [ JSONSummary "Method" "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ]
 
     it "summarizes Ruby methods that start with two identifiers" $ do
       sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ]
+        [ JSONSummary "Method" "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ]
 
     it "handles unicode characters in file" $ do
       sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb")
       Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs)
       diffTOC diff `shouldBe`
-        [ JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ]
+        [ JSONSummary "Method" "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ]
 
     prop "inserts of methods and functions are summarized" $
       \name body ->
@@ -124,12 +124,12 @@ spec = parallel $ do
         diffTOC (diffTerms (pure term)) `shouldBe` []
 
   describe "JSONSummary" $ do
-    it "encodes InSummarizable to JSON" $ do
+    it "encodes modified summaries to JSON" $ do
-      let summary = JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified"
+      let summary = JSONSummary "Method" "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified"
       encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[4,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"modified\"}"
 
-    it "encodes Summarizable to JSON" $ do
+    it "encodes added summaries to JSON" $ do
-      let summary = JSONSummary $ Summarizable C.SingletonMethod "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added"
+      let summary = JSONSummary "Method" "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added"
       encode summary `shouldBe` "{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"}"
 
   describe "diff with ToCDiffRenderer" $ do