diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 6e5d0c226..b68944390 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/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{..} - = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation . showChar '\n' +showError source error@Error{..} + = 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 - 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 ]) + 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 ]) 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 [] (Just (state, a)) - Rose (Just s :. _) _ :_ -> Result (if null es then [ Error (statePos state) (UnexpectedSymbol [] s) ] else es) Nothing - Rose (Nothing :. _) _ :_ -> Result (if null es then [ Error (statePos state) (ParseError []) ] else es) Nothing + Result err (Just (state, a)) -> case stateNodes (dropAnonymous state) of + [] -> Result Nothing (Just (state, a)) + Rose (Just s :. _) _ :_ -> Result (err <|> Just (Error (statePos state) (UnexpectedSymbol [] s))) 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 (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 + Result _ (Just (state', a)) -> Result Nothing (Just (state', a)) + Result err Nothing -> maybe (Result Nothing Nothing) (flip yield state . handler) err + (_, []) -> Result (Just (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 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 - Result e1 f <*> Result e2 a = Result (e1 <> e2) (f <*> a) + pure = Result Nothing . Just + 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 diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 65278fc43..37c38daa6 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/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 diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index be63dc9e7..6ecea473e 100644 --- a/src/Data/Syntax/Expression.hs +++ b/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 - | Minus a a - | Times a a - | DividedBy a a - | Modulo a a - | Power a a - | Negate a + = Plus !a !a + | Minus !a !a + | Times !a !a + | DividedBy !a !a + | Modulo !a !a + | Power !a !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 - | And a a - | Not a + = Or !a !a + | And !a !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 - | BAnd a a - | BXOr a a - | LShift a a - | RShift a a + = BOr !a !a + | BAnd !a !a + | BXOr !a !a + | LShift !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 diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 03479b444..cabbde891 100644 --- a/src/Data/Syntax/Literal.hs +++ b/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. + diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 12d1fae7e..158849b9d 100644 --- a/src/Language/Python/Syntax.hs +++ b/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 - <|> ifStatement - <|> returnStatement - <|> identifier +statement = assertStatement <|> assignment' <|> augmentedAssignment - <|> printStatement - <|> assertStatement + <|> expressionStatement <|> 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) - condition = boolean + elifClause = (,) <$ symbol ElifClause <*> location <*> children (Statement.If <$> expression <*> statement) 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) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 194820a0a..a03c3fb14 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/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) diff --git a/src/Parser.hs b/src/Parser.hs index 95d7fa539..d455ef05f 100644 --- a/src/Parser.hs +++ b/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 - traverse_ (putStr . ($ "") . showError source) errors - pure (fromMaybe (cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error errors))) term) + let Result err term = assign assignment source ast + traverse_ (putStr . ($ "") . showError source) err + 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 diff --git a/src/Renderer.hs b/src/Renderer.hs index e91e7351e..57809aed3 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -9,6 +9,7 @@ module Renderer , renderJSONTerm , renderToC , declarationAlgebra +, syntaxDeclarationAlgebra , identifierAlgebra , Summaries(..) , File(..) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 4aaf17433..e88e09746 100644 --- a/src/Renderer/TOC.hs +++ b/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 } - | ErrorSummary { error :: Text, errorSpan :: SourceSpan } - deriving (Generic, Eq, Show) +data JSONSummary + = JSONSummary + { 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 (annotation :< syntax) - | S.ParseError{} <- syntax = Just (setCategory annotation C.ParseError) - | otherwise = annotation <$ (getField annotation :: Maybe Declaration) +declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) +declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Declaration) --- | Compute 'Declaration's for methods and functions. -declarationAlgebra :: HasField fields Range => Source -> TermF (Syntax Text) (Record fields) (Term (Syntax Text) (Record fields), Maybe Declaration) -> Maybe Declaration -declarationAlgebra source r = case tailF r of +-- | Compute 'Declaration's for methods and functions in 'Syntax'. +syntaxDeclarationAlgebra :: HasField fields Range => Source -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration) +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") - Deleted a -> Just (recordSummary a "removed") - Inserted a -> Just (recordSummary a "added") - Replaced a -> Just (recordSummary a "modified") - where recordSummary record - | C.ParseError <- category record = const (ErrorSummary (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record)) - | otherwise = JSONSummary . Summarizable (category record) (maybe "" declarationIdentifier (getField record :: Maybe Declaration)) (sourceSpan record) + Changed a -> recordSummary a "modified" + Deleted a -> recordSummary a "removed" + Inserted a -> recordSummary a "added" + Replaced a -> recordSummary a "modified" + where recordSummary record = case getDeclaration record of + Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (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 category = case category of - C.SingletonMethod -> "Method" - c -> show c +toCategoryName :: Declaration -> Text +toCategoryName declaration = case declaration of + FunctionDeclaration _ -> "Function" + MethodDeclaration _ -> "Method" + ErrorDeclaration _ -> "ParseError" instance Listable Declaration where tiers diff --git a/src/Semantic.hs b/src/Semantic.hs index 882441177..984563354 100644 --- a/src/Semantic.hs +++ b/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 diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 511a8a861..0c9af36bf 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/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 diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 29d2475fe..0578f7613 100644 --- a/test/TOCSpec.hs +++ b/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 $ Summarizable C.Method "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified" - , JSONSummary $ Summarizable C.Method "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ] + [ JSONSummary "Method" "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added" + , JSONSummary "Method" "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified" + , 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 - let summary = JSONSummary $ Summarizable C.Method "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" + it "encodes modified summaries to JSON" $ do + 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 - let summary = JSONSummary $ Summarizable C.SingletonMethod "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added" + it "encodes added summaries to JSON" $ do + 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