diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index dbcb3e757..c15bb1d40 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE DataKinds, GADTs, InstanceSigs, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} -- | Assignment of AST onto some other structure (typically terms). -- -- Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and SourceSpan). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference. @@ -86,6 +86,7 @@ import qualified Data.IntMap.Lazy as IntMap import Data.Ix (inRange) import Data.List.NonEmpty (nonEmpty) import Data.Record +import GHC.Stack import qualified Info import Prologue hiding (Alt, get, Location, state) import Range (offsetRange) @@ -99,32 +100,32 @@ import Text.Show hiding (show) type Assignment node = Freer (AssignmentF node) data AssignmentF node a where - Location :: AssignmentF node Location - Source :: AssignmentF symbol ByteString - Children :: Assignment symbol a -> AssignmentF symbol a - Choose :: IntMap.IntMap a -> AssignmentF node a - Alt :: a -> a -> AssignmentF symbol a - Empty :: AssignmentF symbol a + Location :: HasCallStack => AssignmentF node Location + Source :: HasCallStack => AssignmentF symbol ByteString + Children :: HasCallStack => Assignment symbol a -> AssignmentF symbol a + Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF node a + Alt :: HasCallStack => a -> a -> AssignmentF symbol a + Empty :: HasCallStack => AssignmentF symbol a -- | Zero-width production of the current location. -- -- If assigning at the end of input or at the end of a list of children, the loccation will be returned as an empty Range and SourceSpan at the current offset. Otherwise, it will be the Range and SourceSpan of the current node. -location :: Assignment (Node grammar) Location +location :: HasCallStack => Assignment (Node grammar) Location location = Location `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. -- -- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (symbol A *> b)' is fine, but 'many (symbol A)' is not. -symbol :: (Enum symbol, Eq symbol) => symbol -> Assignment (Node symbol) Location -symbol s = Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location) +symbol :: (Enum symbol, Eq symbol, HasCallStack) => symbol -> Assignment (Node symbol) Location +symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location) -- | A rule to produce a node’s source as a ByteString. -source :: Assignment symbol ByteString -source = Source `Then` return +source :: HasCallStack => Assignment symbol ByteString +source = withFrozenCallStack $ Source `Then` return -- | Match a node by applying an assignment to its children. -children :: Assignment symbol a -> Assignment symbol a -children forEach = Children forEach `Then` return +children :: HasCallStack => Assignment symbol a -> Assignment symbol a +children forEach = withFrozenCallStack $ Children forEach `Then` return -- | A rose tree. @@ -145,17 +146,22 @@ type AST grammar = Rose (Node grammar) data Result symbol a = Result { resultErrors :: [Error symbol], resultValue :: Maybe a } deriving (Eq, Foldable, Functor, Traversable) -data Error symbol = Error - { errorPos :: Info.SourcePos - , errorExpected :: [symbol] - , errorActual :: Maybe symbol - } - deriving (Eq, Show) +data Error symbol where + Error + :: HasCallStack + => { errorPos :: Info.SourcePos + , errorExpected :: [symbol] + , errorActual :: Maybe symbol + } -> Error symbol + +deriving instance Eq symbol => Eq (Error symbol) +deriving instance Show symbol => Show (Error symbol) -- | Pretty-print an Error with reference to the source where it occurred. showError :: Show symbol => Source.Source -> Error symbol -> ShowS showError source Error{..} = showSourcePos errorPos . showString ": error: " . showExpectation . showChar '\n' + . showString (prettyCallStack callStack) . showChar '\n' . showString context -- actualLines results include line endings, so no newline here . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . showChar '^' . showChar '\n' where showExpectation = case (errorExpected, errorActual) of @@ -177,10 +183,10 @@ showSourcePos :: Info.SourcePos -> ShowS showSourcePos Info.SourcePos{..} = shows line . showChar ':' . shows column -- | Run an assignment over an AST exhaustively. -assign :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> Source.Source -> AST grammar -> Result grammar a +assign :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar, HasCallStack) => Assignment (Node grammar) a -> Source.Source -> AST grammar -> Result grammar a assign assignment source = fmap snd . assignAllFrom assignment . makeState source . pure -assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) +assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Show 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)) @@ -188,7 +194,7 @@ assignAllFrom assignment state = case runAssignment assignment state of 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, Show grammar) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) +runAssignment :: forall grammar a. (Symbol grammar, Enum grammar, Eq grammar, Show grammar, HasCallStack) => Assignment (Node grammar) a -> AssignmentState grammar -> Result grammar (AssignmentState grammar, a) runAssignment = iterFreer run . fmap (\ a state -> Result [] (Just (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 @@ -236,7 +242,9 @@ makeState source nodes = AssignmentState 0 (Info.SourcePos 1 1) source nodes -- Instances instance Enum symbol => Alternative (Assignment (Node symbol)) where + empty :: HasCallStack => Assignment (Node symbol) a empty = Empty `Then` return + (<|>) :: HasCallStack => Assignment (Node symbol) a -> Assignment (Node symbol) a -> Assignment (Node symbol) a a <|> b = case (a, b) of (_, Empty `Then` _) -> a (Empty `Then` _, _) -> b diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 482ff1993..c64f4e152 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -11,6 +11,7 @@ import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement +import GHC.Stack import Language.Haskell.TH hiding (location, Range(..)) import Prologue hiding (for, get, Location, state, unless) import Term @@ -54,30 +55,30 @@ mkSymbolDatatype (mkName "Grammar") tree_sitter_ruby -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax. -assignment :: Assignment (Node Grammar) [Term Syntax Location] +assignment :: HasCallStack => Assignment (Node Grammar) [Term Syntax Location] assignment = symbol Program *> children (many declaration) -declaration :: Assignment (Node Grammar) (Term Syntax Location) +declaration :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) declaration = comment <|> class' <|> method -class' :: Assignment (Node Grammar) (Term Syntax Location) +class' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) class' = makeTerm <$> symbol Class <*> children (Declaration.Class <$> (constant <|> scopeResolution) <*> (superclass <|> pure []) <*> many declaration) where superclass = pure <$ symbol Superclass <*> children constant scopeResolution = symbol ScopeResolution *> children (constant <|> identifier) -constant :: Assignment (Node Grammar) (Term Syntax Location) +constant :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) constant = makeTerm <$> symbol Constant <*> (Syntax.Identifier <$> source) -identifier :: Assignment (Node Grammar) (Term Syntax Location) +identifier :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier <$> source) -method :: Assignment (Node Grammar) (Term Syntax Location) +method :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) method = makeTerm <$> symbol Method <*> children (Declaration.Method <$> identifier <*> pure [] <*> statements) -statements :: Assignment (Node Grammar) (Term Syntax Location) +statements :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) statements = makeTerm <$> location <*> many statement -statement :: Assignment (Node Grammar) (Term Syntax Location) +statement :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) statement = exit Statement.Return Return <|> exit Statement.Yield Yield <|> exit Statement.Break Break @@ -91,36 +92,36 @@ statement = exit Statement.Return Return <|> assignment' where exit construct sym = makeTerm <$> symbol sym <*> children ((construct .) . fromMaybe <$> emptyTerm <*> optional (symbol ArgumentList *> children statement)) -lvalue :: Assignment (Node Grammar) (Term Syntax Location) +lvalue :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) lvalue = identifier -expression :: Assignment (Node Grammar) (Term Syntax Location) +expression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) expression = identifier <|> statement -comment :: Assignment (Node Grammar) (Term Syntax Location) +comment :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -if' :: Assignment (Node Grammar) (Term Syntax Location) +if' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) if' = ifElsif If <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> statement <*> statement <*> (makeTerm <$> location <*> pure Syntax.Empty)) where ifElsif s = makeTerm <$> symbol s <*> children (Statement.If <$> statement <*> statements <*> (fromMaybe <$> emptyTerm <*> optional (ifElsif Elsif <|> makeTerm <$> symbol Else <*> children (many statement)))) -unless :: Assignment (Node Grammar) (Term Syntax Location) +unless :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert statement <*> statements <*> (fromMaybe <$> emptyTerm <*> optional (makeTerm <$> symbol Else <*> children (many statement)))) <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> statement <*> invert statement <*> (makeTerm <$> location <*> pure Syntax.Empty)) -while :: Assignment (Node Grammar) (Term Syntax Location) +while :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) while = makeTerm <$> symbol While <*> children (Statement.While <$> statement <*> statements) <|> makeTerm <$> symbol WhileModifier <*> children (flip Statement.While <$> statement <*> statement) -until :: Assignment (Node Grammar) (Term Syntax Location) +until :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) until = makeTerm <$> symbol Until <*> children (Statement.While <$> invert statement <*> statements) <|> makeTerm <$> symbol UntilModifier <*> children (flip Statement.While <$> statement <*> invert statement) -for :: Assignment (Node Grammar) (Term Syntax Location) +for :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) for = makeTerm <$> symbol For <*> children (Statement.ForEach <$> identifier <*> statement <*> statements) -assignment' :: Assignment (Node Grammar) (Term Syntax Location) +assignment' :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) assignment' = makeTerm <$> symbol Assignment <*> children (Statement.Assignment <$> lvalue <*> expression) <|> makeTerm <$> symbol OperatorAssignment <*> children (lvalue >>= \ var -> Statement.Assignment var <$> @@ -138,20 +139,20 @@ assignment' <|> makeTerm <$> symbol AnonLAngleLAngleEqual <*> (Expression.LShift var <$> expression) <|> makeTerm <$> symbol AnonCaretEqual <*> (Expression.BXOr var <$> expression))) -literal :: Assignment (Node Grammar) (Term Syntax Location) +literal :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) literal = makeTerm <$> symbol Language.Ruby.Syntax.True <*> (Literal.true <$ source) <|> makeTerm <$> symbol Language.Ruby.Syntax.False <*> (Literal.false <$ source) <|> makeTerm <$> symbol Language.Ruby.Syntax.Integer <*> (Literal.Integer <$> source) <|> makeTerm <$> symbol Symbol <*> (Literal.Symbol <$> source) <|> makeTerm <$> symbol Range <*> children (Literal.Range <$> statement <*> statement) -- FIXME: represent the difference between .. and ... -invert :: InUnion fs Expression.Boolean => Assignment (Node grammar) (Term (Union fs) Location) -> Assignment (Node grammar) (Term (Union fs) Location) +invert :: (InUnion fs Expression.Boolean, HasCallStack) => Assignment (Node grammar) (Term (Union fs) Location) -> Assignment (Node grammar) (Term (Union fs) Location) invert term = makeTerm <$> location <*> fmap Expression.Not term -makeTerm :: InUnion fs f => a -> f (Term (Union fs) a) -> (Term (Union fs) a) +makeTerm :: (InUnion fs f, HasCallStack) => a -> f (Term (Union fs) a) -> (Term (Union fs) a) makeTerm a f = cofree $ a :< inj f -emptyTerm :: Assignment (Node Grammar) (Term Syntax Location) +emptyTerm :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) emptyTerm = makeTerm <$> location <*> pure Syntax.Empty