diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 73f338ef3..6b3616f59 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -12,6 +12,7 @@ import Data.Blob import Data.Blob.IO (readBlobFromFile') import Data.Bifunctor import Data.Functor.Classes +import Data.Functor.Foldable (Base, Recursive) import "semantic" Data.Graph (Graph (..), topologicalSort) import Data.Graph.ControlFlowVertex import qualified Data.Language as Language @@ -25,24 +26,27 @@ import Semantic.Graph import Semantic.Task (SomeException, TaskSession (..), runTask, withOptions) import Semantic.Util hiding (evalPythonProject, evalRubyProject, evaluateProject) import Source.Loc +import Source.Span (HasSpan) import qualified System.Path as Path import System.Path (()) -- Duplicating this stuff from Util to shut off the logging callGraphProject' :: ( Language.SLanguage lang - , Ord1 syntax - , Declarations1 syntax - , Evaluatable syntax - , FreeVariables1 syntax - , AccessControls1 syntax , HasPrelude lang - , Functor syntax - , VertexDeclaration1 syntax + , AccessControls (term Loc) + , Declarations (term Loc) + , Evaluatable (Base (term Loc)) + , FreeVariables (term Loc) + , HasSpan (term Loc) + , Ord (term Loc) + , Recursive (term Loc) + , Show (term Loc) + , VertexDeclaration term ) => TaskSession -> Proxy lang - -> Parser (Term syntax Loc) + -> Parser (term Loc) -> Path.RelFile -> IO (Either String (Data.Graph.Graph ControlFlowVertex)) callGraphProject' session proxy parser path = fmap (first show) . runTask session $ do diff --git a/semantic.cabal b/semantic.cabal index 4f1687892..57a6efdc0 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -181,14 +181,18 @@ library -- Language-specific grammar/syntax types, & assignments , Language.Markdown.Assignment , Language.Markdown.Syntax + , Language.Markdown.Term , Language.Go.Assignment , Language.Go.Syntax + , Language.Go.Term , Language.Go.Type , Language.Ruby.Assignment , Language.Ruby.Syntax + , Language.Ruby.Term , Language.TSX.Assignment , Language.TSX.Syntax , Language.TSX.Syntax.JSX + , Language.TSX.Term , Language.TypeScript.Assignment , Language.TypeScript.Resolution , Language.TypeScript.Syntax @@ -196,10 +200,13 @@ library , Language.TypeScript.Syntax.JavaScript , Language.TypeScript.Syntax.TypeScript , Language.TypeScript.Syntax.Types + , Language.TypeScript.Term , Language.PHP.Assignment , Language.PHP.Syntax + , Language.PHP.Term , Language.Python.Assignment , Language.Python.Syntax + , Language.Python.Term , Numeric.Exts -- Parser glue , Parsing.CMark diff --git a/src/Analysis/Decorator.hs b/src/Analysis/Decorator.hs index 413ad7b16..7596d26cb 100644 --- a/src/Analysis/Decorator.hs +++ b/src/Analysis/Decorator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} module Analysis.Decorator ( decoratorWithAlgebra ) where @@ -7,8 +7,8 @@ import Data.Term import Prologue -- | Lift an algebra into a decorator for terms annotated with records. -decoratorWithAlgebra :: Functor syntax - => RAlgebra (TermF syntax a) (Term syntax a) b -- ^ An R-algebra on terms. - -> Term syntax a -- ^ A term to decorate with values produced by the R-algebra. - -> Term syntax b -- ^ A term decorated with values produced by the R-algebra. +decoratorWithAlgebra :: (Functor (Syntax term), IsTerm term, Recursive (term a), Base (term a) ~ TermF (Syntax term) a) + => RAlgebra (TermF (Syntax term) a) (term a) b -- ^ An R-algebra on terms. + -> term a -- ^ A term to decorate with values produced by the R-algebra. + -> term b -- ^ A term decorated with values produced by the R-algebra. decoratorWithAlgebra alg = para $ \ c@(In _ f) -> termIn (alg (fmap (second termAnnotation) c)) (fmap snd f) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index fc93e88b1..45b4d1391 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-} module Analysis.TOCSummary ( Declaration(..) , formatIdentifier @@ -64,8 +64,8 @@ formatKind = \case -- If you’re getting errors about missing a @'HasDeclarationBy' ''Custom'@ instance for your syntax type, you probably forgot step 1. -- -- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2. -declarationAlgebra :: (Foldable syntax, HasDeclaration syntax) - => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe Declaration) +declarationAlgebra :: (Foldable (Syntax term), HasDeclaration (Syntax term), IsTerm term) + => Blob -> RAlgebra (TermF (Syntax term) Loc) (term Loc) (Maybe Declaration) declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax -- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'Declaration's for a new type is done by defining an instance of @'HasDeclarationBy' ''Custom'@ instead. @@ -73,7 +73,7 @@ declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. class HasDeclaration syntax where -- | Compute a 'Declaration' for a syntax type using its @'HasDeclarationBy' ''Custom'@ instance, if any, or else falling back to the default definition (which simply returns 'Nothing'). - toDeclaration :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclaration :: (Foldable (Syntax term), IsTerm term) => Blob -> Loc -> syntax (term Loc, Maybe Declaration) -> Maybe Declaration -- | Define 'toDeclaration' using the @'HasDeclarationBy' ''Custom'@ instance for a type if there is one or else use the default definition. -- @@ -86,7 +86,7 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationBy strategy synta -- | Produce a 'Declaration' for a syntax node using either the 'Default' or 'Custom' strategy. class HasDeclarationBy (strategy :: Strategy) syntax where - toDeclarationBy :: Foldable whole => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration + toDeclarationBy :: (Foldable (Syntax term), IsTerm term) => Blob -> Loc -> syntax (term Loc, Maybe Declaration) -> Maybe Declaration -- | The 'Default' strategy produces 'Nothing'. instance HasDeclarationBy 'Default syntax where @@ -98,7 +98,7 @@ instance HasDeclarationBy 'Custom Markdown.Heading where toDeclarationBy blob@Blob{..} ann (Markdown.Heading level terms _) = Just $ Declaration (Heading level) (headingText terms) (Loc.span ann) (blobLanguage blob) where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms)) - headingByteRange (Term (In ann _), _) = byteRange ann + headingByteRange (t, _) = byteRange (termAnnotation t) getSource = firstLine . toText . Source.slice blobSource firstLine = T.takeWhile (/= '\n') @@ -110,7 +110,7 @@ instance HasDeclarationBy 'Custom Syntax.Error where -- | Produce a 'Function' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance HasDeclarationBy 'Custom Declaration.Function where - toDeclarationBy blob@Blob{..} ann (Declaration.Function _ (Term (In identifierAnn _), _) _ _) + toDeclarationBy blob@Blob{..} ann (Declaration.Function _ (termAnnotation -> identifierAnn, _) _ _) -- Do not summarize anonymous functions | isEmpty identifierAnn = Nothing -- Named functions @@ -119,12 +119,12 @@ instance HasDeclarationBy 'Custom Declaration.Function where -- | Produce a 'Method' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'identifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'. instance HasDeclarationBy 'Custom Declaration.Method where - toDeclarationBy blob@Blob{..} ann (Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _) + toDeclarationBy blob@Blob{..} ann (Declaration.Method _ (toTermF -> In receiverAnn receiverF, _) (termAnnotation -> identifierAnn, _) _ _ _) -- Methods without a receiver | isEmpty receiverAnn = Just $ Declaration (Method Nothing) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob) -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). | blobLanguage blob == Go - , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ Declaration (Method (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob) + , [ _, termAnnotation -> receiverType ] <- toList receiverF = Just $ Declaration (Method (Just (getSource blobSource receiverType))) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob) -- Methods with a receiver (class methods) are formatted like `receiver.method_name` | otherwise = Just $ Declaration (Method (Just (getSource blobSource receiverAnn))) (getSource blobSource identifierAnn) (Loc.span ann) (blobLanguage blob) where diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index 96711cbfc..59f788c33 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -21,8 +21,6 @@ import Data.Blob import qualified Data.Error as Error import qualified Data.Flag as Flag import qualified Data.Syntax as Syntax -import Data.Sum -import Data.Term import Data.Typeable import Parsing.CMark import Parsing.Parser @@ -80,14 +78,10 @@ data ParserCancelled = ParserTimedOut | AssignmentTimedOut instance Exception ParserCancelled -errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String] -errors = cata $ \ (In Assignment.Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (project syntax) runAssignment - :: ( Apply Foldable syntaxes - , Apply Functor syntaxes - , Element Syntax.Error syntaxes + :: ( Foldable term + , Syntax.HasErrors term , Member (Error SomeException) sig , Member (Reader TaskSession) sig , Member Telemetry sig @@ -96,11 +90,11 @@ runAssignment , Carrier sig m , MonadIO m ) - => (Source -> assignment (Term (Sum syntaxes) Assignment.Loc) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Loc)) + => (Source -> assignment (term Assignment.Loc) -> ast -> Either (Error.Error String) (term Assignment.Loc)) -> Parser ast -> Blob - -> assignment (Term (Sum syntaxes) Assignment.Loc) - -> m (Term (Sum syntaxes) Assignment.Loc) + -> assignment (term Assignment.Loc) + -> m (term Assignment.Loc) runAssignment assign parser blob@Blob{..} assignment = do taskSession <- ask let requestID' = ("github_request_id", requestID taskSession) @@ -124,7 +118,7 @@ runAssignment assign parser blob@Blob{..} assignment = do logError taskSession Error blob err (("task", "assign") : logFields) throwError (toException err) Right term -> do - for_ (zip (errors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of + for_ (zip (Syntax.getErrors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of Just "ParseError" -> do when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag) logError taskSession Warning blob err (("task", "parse") : logFields) diff --git a/src/Data/Abstract/AccessControls/Instances.hs b/src/Data/Abstract/AccessControls/Instances.hs index 6b08a9a2a..9c6d63852 100644 --- a/src/Data/Abstract/AccessControls/Instances.hs +++ b/src/Data/Abstract/AccessControls/Instances.hs @@ -15,16 +15,27 @@ import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type import qualified Language.Go.Syntax as Go +import qualified Language.Go.Term as Go import qualified Language.Go.Type as Go -import qualified Language.Markdown.Syntax as Markdown import qualified Language.PHP.Syntax as PHP +import qualified Language.PHP.Term as PHP import qualified Language.Python.Syntax as Python +import qualified Language.Python.Term as Python import qualified Language.Ruby.Syntax as Ruby +import qualified Language.Ruby.Term as Ruby import qualified Language.TSX.Syntax as TSX +import qualified Language.TSX.Term as TSX import qualified Language.TypeScript.Syntax as TypeScript +import qualified Language.TypeScript.Term as TypeScript import Data.Quieterm deriving instance AccessControls1 syntax => AccessControls (Term syntax ann) +deriving instance AccessControls (Go.Term ann) +deriving instance AccessControls (PHP.Term ann) +deriving instance AccessControls (Python.Term ann) +deriving instance AccessControls (Ruby.Term ann) +deriving instance AccessControls (TSX.Term ann) +deriving instance AccessControls (TypeScript.Term ann) instance (AccessControls recur, AccessControls1 syntax) => AccessControls (TermF syntax ann recur) where termToAccessControl = liftTermToAccessControl termToAccessControl . termFOut @@ -211,26 +222,6 @@ instance AccessControls1 Go.Select instance AccessControls1 Go.TypeSwitchGuard instance AccessControls1 Go.ReceiveOperator -instance AccessControls1 Markdown.Document -instance AccessControls1 Markdown.Paragraph -instance AccessControls1 Markdown.UnorderedList -instance AccessControls1 Markdown.OrderedList -instance AccessControls1 Markdown.BlockQuote -instance AccessControls1 Markdown.HTMLBlock -instance AccessControls1 Markdown.Table -instance AccessControls1 Markdown.TableRow -instance AccessControls1 Markdown.TableCell -instance AccessControls1 Markdown.Strong -instance AccessControls1 Markdown.Emphasis -instance AccessControls1 Markdown.Text -instance AccessControls1 Markdown.Strikethrough -instance AccessControls1 Markdown.Heading -instance AccessControls1 Markdown.ThematicBreak -instance AccessControls1 Markdown.Link -instance AccessControls1 Markdown.Image -instance AccessControls1 Markdown.Code -instance AccessControls1 Markdown.LineBreak - instance AccessControls1 PHP.Text instance AccessControls1 PHP.VariableName instance AccessControls1 PHP.Require diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 21d5dd823..bb5c9809e 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -25,80 +25,80 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph -- Combinators -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. -makeTerm :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann +makeTerm :: (HasCallStack, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => ann -> syntax (term ann) -> term ann makeTerm ann = makeTerm' ann . inject -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. -makeTerm' :: (HasCallStack, Semigroup ann, Foldable syntax) => ann -> syntax (Term syntax ann) -> Term syntax ann +makeTerm' :: (HasCallStack, Semigroup ann, Foldable (Syntax term), IsTerm term) => ann -> Syntax term (term ann) -> term ann makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item. -makeTerm'' :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes, Foldable syntax) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann +makeTerm'' :: (HasCallStack, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, Foldable syntax, IsTerm term) => ann -> syntax (term ann) -> term ann makeTerm'' ann children = case toList children of [x] -> x _ -> makeTerm' ann (inject children) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. -makeTerm1 :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann +makeTerm1 :: (HasCallStack, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => syntax (term ann) -> term ann makeTerm1 = makeTerm1' . inject -- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation. -makeTerm1' :: (HasCallStack, Semigroup ann, Foldable syntax) => syntax (Term syntax ann) -> Term syntax ann +makeTerm1' :: (HasCallStack, Semigroup ann, Foldable (Syntax term), IsTerm term) => Syntax term (term ann) -> term ann makeTerm1' syntax = case toList syntax of a : _ -> makeTerm' (termAnnotation a) syntax _ -> error "makeTerm1': empty structure" -- | Construct an empty term at the current position. -emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) +emptyTerm :: (HasCallStack, Empty :< syntaxes, Sum syntaxes ~ Syntax term, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment ast grammar (term Loc) emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty where startLocation Loc{..} = Loc (Range.point (Range.start byteRange)) (Span.point (Span.start span)) -- | Catch assignment errors into an error term. -handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) +handleError :: (HasCallStack, Error :< syntaxes, Sum syntaxes ~ Syntax term, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment ast grammar (term Loc) -> Assignment.Assignment ast grammar (term Loc) handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source) -- | Catch parse errors into an error term. -parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) +parseError :: (HasCallStack, Error :< syntaxes, Sum syntaxes ~ Syntax term, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment ast grammar (term Loc) parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") []) -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -contextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) - => m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) +contextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) + => m (term ann) + -> m (term ann) + -> m (term ann) contextualize context rule = make <$> Assignment.manyThrough context rule where make (cs, node) = case nonEmpty cs of Just cs -> makeTerm1 (Context cs node) _ -> node -- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise. -postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) - => m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) +postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) + => m (term ann) + -> m (term ann) -> m delimiter - -> m (Term (Sum syntaxes) ann, delimiter) + -> m (term ann, delimiter) postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end where make node (cs, end) = case nonEmpty cs of Just cs -> (makeTerm1 (Context cs node), end) _ -> (node, end) -- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -postContextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) - => m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) +postContextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) + => m (term ann) + -> m (term ann) + -> m (term ann) postContextualize context rule = make <$> rule <*> many context where make node cs = case nonEmpty cs of Just cs -> makeTerm1 (Context cs node) _ -> node -- | Match infix terms separated by any of a list of operators, with optional context terms following each operand. -infixContext :: (Context :< syntaxes, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes) - => m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) - -> m (Term (Sum syntaxes) ann) - -> [m (Term (Sum syntaxes) ann -> Term (Sum syntaxes) ann -> Sum syntaxes (Term (Sum syntaxes) ann))] - -> m (Sum syntaxes (Term (Sum syntaxes) ann)) +infixContext :: (Context :< syntaxes, Sum syntaxes ~ Syntax term, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes, IsTerm term) + => m (term ann) + -> m (term ann) + -> m (term ann) + -> [m (term ann -> term ann -> Sum syntaxes (term ann))] + -> m (Sum syntaxes (term ann)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where @@ -213,6 +213,14 @@ instance Ord ErrorStack where ] +class HasErrors term where + getErrors :: term Loc -> [Error.Error String] + +instance (Error :< fs, Apply Foldable fs, Apply Functor fs) => HasErrors (Term (Sum fs)) where + getErrors = cata $ \ (In Loc{..} syntax) -> + maybe (fold syntax) (pure . unError span) (Data.Sum.project syntax) + + data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a } deriving (Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, NFData1) deriving (Eq1, Show1, Ord1) via Generically Context diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 144f38998..6952efabb 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -1,17 +1,18 @@ {-# LANGUAGE FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Data.Term ( Term(..) -, termIn -, termAnnotation -, termOut -, injectTerm -, projectTerm -, guardTerm , TermF(..) , termSize , hoistTerm , hoistTermF , Annotated (..) +-- * Abstract term interfaces +, IsTerm(..) +, termAnnotation +, termOut +, projectTerm +, termIn +, injectTerm ) where import Prologue @@ -26,20 +27,6 @@ import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } -termAnnotation :: Term syntax ann -> ann -termAnnotation = termFAnnotation . unTerm - -termOut :: Term syntax ann -> syntax (Term syntax ann) -termOut = termFOut . unTerm - -projectTerm :: forall f syntax ann . (f :< syntax) => Term (Sum syntax) ann -> Maybe (f (Term (Sum syntax) ann)) -projectTerm = Sum.project . termOut - -guardTerm :: forall m f syntax ann . (f :< syntax, Alternative m) - => Term (Sum syntax) ann - -> m (f (Term (Sum syntax) ann)) -guardTerm = Sum.projectGuard . termOut - data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur } deriving (Eq, Ord, Foldable, Functor, Show, Traversable, Generic1) @@ -72,13 +59,6 @@ termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where size (In _ syntax) = 1 + sum syntax --- | Build a Term from its annotation and syntax. -termIn :: ann -> syntax (Term syntax ann) -> Term syntax ann -termIn = (Term .) . In - -injectTerm :: (f :< syntax) => ann -> f (Term (Sum syntax) ann) -> Term (Sum syntax) ann -injectTerm a = termIn a . Sum.inject - hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistTerm f = go where go (Term r) = Term (hoistTermF f (fmap go r)) @@ -171,3 +151,35 @@ instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSON (TermF f a b) where toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields + + +class IsTerm term where + type Syntax term :: * -> * + + toTermF :: term ann -> TermF (Syntax term) ann (term ann) + fromTermF :: TermF (Syntax term) ann (term ann) -> term ann + + +termAnnotation :: IsTerm term => term ann -> ann +termAnnotation = termFAnnotation . toTermF + +termOut :: IsTerm term => term ann -> Syntax term (term ann) +termOut = termFOut . toTermF + +projectTerm :: (f :< syntax, Sum syntax ~ Syntax term, IsTerm term) => term ann -> Maybe (f (term ann)) +projectTerm = Sum.project . termOut + + +-- | Build a term from its annotation and syntax. +termIn :: IsTerm term => ann -> Syntax term (term ann) -> term ann +termIn = fmap fromTermF . In + +injectTerm :: (f :< syntax, Sum syntax ~ Syntax term, IsTerm term) => ann -> f (term ann) -> term ann +injectTerm a = termIn a . Sum.inject + + +instance IsTerm (Term syntax) where + type Syntax (Term syntax) = syntax + + toTermF = unTerm + fromTermF = Term diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 8857eff15..4791d5128 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms , DiffTerms(..) @@ -31,17 +31,11 @@ stripDiff :: Functor syntax stripDiff = bimap snd snd -- | The class of term types for which we can compute a diff. -class Bifoldable (DiffFor term) => DiffTerms term where - -- | The type of diffs for the given term type. - -- - -- Note that the dependency means that the diff type is in 1:1 correspondence with the term type. This allows subclasses of 'DiffTerms' to receive e.g. @'DiffFor' term a b@ without incurring ambiguity, since every diff type is unique to its term type. - type DiffFor term = (diff :: * -> * -> *) | diff -> term - +class IsTerm term => DiffTerms term where -- | Diff an 'Edit' of terms. - diffTermPair :: Edit (term ann1) (term ann2) -> DiffFor term ann1 ann2 + diffTermPair :: Edit (term ann1) (term ann2) -> Diff.Diff (Syntax term) ann1 ann2 instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where - type DiffFor (Term syntax) = Diff.Diff syntax diffTermPair = edit Diff.deleting Diff.inserting diffTerms diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index f9ebde00c..8e2acadef 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.Go.Assignment ( assignment -, Syntax +, Go.Syntax , Grammar -, Term +, Go.Term(..) ) where import Prologue @@ -24,128 +23,24 @@ import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type import qualified Data.Term as Term import Language.Go.Syntax as Go.Syntax hiding (runeLiteral, labelName) +import Language.Go.Term as Go import Language.Go.Type as Go.Type import Data.ImportPath (importPath, defaultAlias) import TreeSitter.Go as Grammar -type Syntax = - '[ Comment.Comment - , Declaration.Constructor - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.Type - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BOr - , Expression.BAnd - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Subscript - , Expression.Member - , Statement.PostDecrement - , Statement.PostIncrement - , Expression.MemberAccess - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Go.Syntax.Composite - , Go.Syntax.DefaultPattern - , Go.Syntax.Defer - , Go.Syntax.Field - , Go.Syntax.Go - , Go.Syntax.Label - , Go.Syntax.Package - , Go.Syntax.Receive - , Go.Syntax.ReceiveOperator - , Go.Syntax.Rune - , Go.Syntax.Select - , Go.Syntax.Send - , Go.Syntax.Slice - , Go.Syntax.TypeAssertion - , Go.Syntax.TypeConversion - , Go.Syntax.TypeSwitch - , Go.Syntax.TypeSwitchGuard - , Go.Syntax.Variadic - , Go.Type.BidirectionalChannel - , Go.Type.ReceiveChannel - , Go.Type.SendChannel - , Go.Syntax.Import - , Go.Syntax.QualifiedImport - , Go.Syntax.SideEffectImport - , Literal.Array - , Literal.Complex - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Pointer - , Literal.Reference - , Literal.TextElement - , Statement.Assignment - , Statement.Break - , Statement.Continue - , Statement.For - , Statement.ForEach - , Statement.Goto - , Statement.If - , Statement.Match - , Statement.NoOp - , Statement.Pattern - , Statement.Return - , Statement.Statements - , Syntax.Context - , Syntax.Error - , Syntax.Empty - , Syntax.Identifier - , Type.Annotation - , Type.Array - , Type.Function - , Type.Interface - , Type.Map - , Type.Parenthesized - , Type.Pointer - , Type.Slice - , [] - , Literal.String - , Literal.EscapeSequence - , Literal.Null - , Literal.Boolean - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in Go's grammar onto a program in Go's syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError program <|> parseError -program :: Assignment Term +program :: Assignment (Term Loc) program = makeTerm <$> symbol SourceFile <*> children (Statement.Statements <$> manyTerm expression) -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = term (handleError (choice expressionChoices)) -expressionChoices :: [Assignment Term] +expressionChoices :: [Assignment (Term Loc)] expressionChoices = [ argumentList , assignment' @@ -213,7 +108,7 @@ expressionChoices = , types ] -types :: Assignment Term +types :: Assignment (Term Loc) types = choice [ arrayType , channelType @@ -234,86 +129,86 @@ types = , typeSwitchStatement ] -identifiers :: Assignment Term +identifiers :: Assignment (Term Loc) identifiers = makeTerm'' <$> location <*> manyTerm identifier -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = makeTerm'' <$> location <*> manyTerm expression -- Literals -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -compositeLiteral :: Assignment Term +compositeLiteral :: Assignment (Term Loc) compositeLiteral = makeTerm <$> symbol CompositeLiteral <*> children (Go.Syntax.Composite <$> expression <*> expression) -element :: Assignment Term +element :: Assignment (Term Loc) element = symbol Element *> children expression -fieldIdentifier :: Assignment Term +fieldIdentifier :: Assignment (Term Loc) fieldIdentifier = makeTerm <$> symbol FieldIdentifier <*> (Syntax.Identifier . name <$> source) -floatLiteral :: Assignment Term +floatLiteral :: Assignment (Term Loc) floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source) -identifier :: Assignment Term +identifier :: Assignment (Term Loc) identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) -imaginaryLiteral :: Assignment Term +imaginaryLiteral :: Assignment (Term Loc) imaginaryLiteral = makeTerm <$> symbol ImaginaryLiteral <*> (Literal.Complex <$> source) -interpretedStringLiteral :: Assignment Term +interpretedStringLiteral :: Assignment (Term Loc) interpretedStringLiteral = makeTerm' <$> symbol InterpretedStringLiteral <*> children ( (inject . Literal.String <$> some escapeSequence) <|> (inject . Literal.TextElement <$> source)) -escapeSequence :: Assignment Term +escapeSequence :: Assignment (Term Loc) escapeSequence = makeTerm <$> symbol EscapeSequence <*> (Literal.EscapeSequence <$> source) -intLiteral :: Assignment Term +intLiteral :: Assignment (Term Loc) intLiteral = makeTerm <$> symbol IntLiteral <*> (Literal.Integer <$> source) -literalValue :: Assignment Term +literalValue :: Assignment (Term Loc) literalValue = makeTerm <$> symbol LiteralValue <*> children (manyTerm expression) -packageIdentifier :: Assignment Term +packageIdentifier :: Assignment (Term Loc) packageIdentifier = makeTerm <$> symbol PackageIdentifier <*> (Syntax.Identifier . name <$> source) -parenthesizedType :: Assignment Term +parenthesizedType :: Assignment (Term Loc) parenthesizedType = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (Type.Parenthesized <$> expression) -rawStringLiteral :: Assignment Term +rawStringLiteral :: Assignment (Term Loc) rawStringLiteral = makeTerm <$> symbol RawStringLiteral <*> (Literal.TextElement <$> source) -runeLiteral :: Assignment Term +runeLiteral :: Assignment (Term Loc) runeLiteral = makeTerm <$> symbol Grammar.RuneLiteral <*> (Go.Syntax.Rune <$> source) -typeIdentifier :: Assignment Term +typeIdentifier :: Assignment (Term Loc) typeIdentifier = makeTerm <$> symbol TypeIdentifier <*> (Syntax.Identifier . name <$> source) -nil :: Assignment Term +nil :: Assignment (Term Loc) nil = makeTerm <$> symbol Nil <*> (Literal.Null <$ source) -boolean :: Assignment Term +boolean :: Assignment (Term Loc) boolean = makeTerm <$> token Grammar.True <*> pure Literal.true <|> makeTerm <$> token Grammar.False <*> pure Literal.false -- Primitive Types -arrayType :: Assignment Term +arrayType :: Assignment (Term Loc) arrayType = makeTerm <$> symbol ArrayType <*> children (Type.Array . Just <$> expression <*> expression) -channelType :: Assignment Term +channelType :: Assignment (Term Loc) channelType = makeTerm' <$> symbol ChannelType <*> children (mkChannelType <$> optional (token AnonLAngleMinus) <* token AnonChan <*> optional (token AnonLAngleMinus) <*> expression) where - mkChannelType :: Maybe a -> Maybe a -> b -> Sum Syntax b + mkChannelType :: Maybe a -> Maybe a -> b -> Sum Go.Syntax b mkChannelType receive send | Just _ <- receive = inject . Go.Type.ReceiveChannel | Just _ <- send = inject . Go.Type.SendChannel | otherwise = inject . Go.Type.BidirectionalChannel -fieldDeclaration :: Assignment Term +fieldDeclaration :: Assignment (Term Loc) fieldDeclaration = mkFieldDeclarationWithTag <$> symbol FieldDeclaration <*> children ((,,) <$> (manyTermsTill expression (void (symbol TypeIdentifier)) <|> manyTerm expression) <*> optional expression <*> optional expression) where mkFieldDeclarationWithTag loc (fields, type', tag) | Just ty <- type', Just tag' <- tag = makeTerm loc (Go.Syntax.Field [ty, tag'] (makeTerm loc fields)) @@ -321,38 +216,38 @@ fieldDeclaration = mkFieldDeclarationWithTag <$> symbol FieldDeclaration <*> ch | Just tag' <- tag = makeTerm loc (Go.Syntax.Field [tag'] (makeTerm loc fields)) | otherwise = makeTerm loc (Go.Syntax.Field [] (makeTerm loc fields)) -fieldDeclarationList :: Assignment Term +fieldDeclarationList :: Assignment (Term Loc) fieldDeclarationList = symbol FieldDeclarationList *> children expressions -functionType :: Assignment Term +functionType :: Assignment (Term Loc) functionType = makeTerm <$> symbol FunctionType <*> children (Type.Function <$> params <*> (expression <|> emptyTerm)) where params = symbol ParameterList *> children (manyTerm expression) -implicitLengthArrayType :: Assignment Term +implicitLengthArrayType :: Assignment (Term Loc) implicitLengthArrayType = makeTerm <$> symbol ImplicitLengthArrayType <*> children (Type.Array Nothing <$> expression) -interfaceType :: Assignment Term +interfaceType :: Assignment (Term Loc) interfaceType = makeTerm <$> symbol InterfaceType <*> children (Type.Interface <$> manyTerm expression) -mapType :: Assignment Term +mapType :: Assignment (Term Loc) mapType = makeTerm <$> symbol MapType <*> children (Type.Map <$> expression <*> expression) -pointerType :: Assignment Term +pointerType :: Assignment (Term Loc) pointerType = makeTerm <$> symbol PointerType <*> children (Type.Pointer <$> expression) -qualifiedType :: Assignment Term +qualifiedType :: Assignment (Term Loc) qualifiedType = makeTerm <$> symbol QualifiedType <*> children (Expression.MemberAccess <$> expression <*> typeIdentifier) -sliceType :: Assignment Term +sliceType :: Assignment (Term Loc) sliceType = makeTerm <$> symbol SliceType <*> children (Type.Slice <$> expression) -structType :: Assignment Term +structType :: Assignment (Term Loc) structType = makeTerm <$> symbol StructType <*> children (Declaration.Constructor [] <$> emptyTerm <*> expressions) -typeAlias :: Assignment Term +typeAlias :: Assignment (Term Loc) typeAlias = makeTerm <$> symbol TypeAlias <*> children (Declaration.TypeAlias [] <$> expression <*> expression) -typeDeclaration :: Assignment Term +typeDeclaration :: Assignment (Term Loc) typeDeclaration = makeTerm <$> symbol TypeDeclaration <*> children (manyTerm ( (makeTerm <$> symbol TypeSpec <*> children (Declaration.Type <$> typeIdentifier <*> expression)) <|> typeAlias )) @@ -360,10 +255,10 @@ typeDeclaration = makeTerm <$> symbol TypeDeclaration <*> children (manyTerm ( ( -- Expressions -argumentList :: Assignment Term +argumentList :: Assignment (Term Loc) argumentList = (symbol ArgumentList <|> symbol ArgumentList') *> children expressions -binaryExpression :: Assignment Term +binaryExpression :: Assignment (Term Loc) binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression expression [ (inject .) . Expression.Plus <$ symbol AnonPlus , (inject .) . Expression.Minus <$ symbol AnonMinus @@ -388,34 +283,34 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm where invert cons a b = Expression.Not (makeTerm1 (cons a b)) -block :: Assignment Term +block :: Assignment (Term Loc) block = symbol Block *> children expressions -defaultCase :: Assignment Term +defaultCase :: Assignment (Term Loc) defaultCase = makeTerm <$> symbol DefaultCase <*> children (Go.Syntax.DefaultPattern <$> (expressions <|> emptyTerm)) -defaultExpressionCase :: Assignment Term +defaultExpressionCase :: Assignment (Term Loc) defaultExpressionCase = makeTerm <$> symbol DefaultCase <*> (Go.Syntax.DefaultPattern <$ rawSource <*> (expressions <|> emptyTerm)) -callExpression :: Assignment Term +callExpression :: Assignment (Term Loc) callExpression = makeTerm <$> symbol CallExpression <*> children (Expression.Call [] <$> expression <*> manyTerm expression <*> emptyTerm) -expressionCase :: Assignment Term +expressionCase :: Assignment (Term Loc) expressionCase = makeTerm <$> symbol ExpressionCase <*> (Statement.Pattern <$> children expressions <*> expressions) -expressionList :: Assignment Term +expressionList :: Assignment (Term Loc) expressionList = symbol ExpressionList *> children expressions -expressionSwitchStatement :: Assignment Term +expressionSwitchStatement :: Assignment (Term Loc) expressionSwitchStatement = makeTerm <$> symbol ExpressionSwitchStatement <*> children (Statement.Match <$> (makeTerm <$> location <*> manyTermsTill expression (void (symbol ExpressionCase)) <|> emptyTerm) <*> expressions) -fallThroughStatement :: Assignment Term +fallThroughStatement :: Assignment (Term Loc) fallThroughStatement = makeTerm <$> symbol FallthroughStatement <*> (Statement.Pattern <$> (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> emptyTerm) -functionDeclaration :: Assignment Term +functionDeclaration :: Assignment (Term Loc) functionDeclaration = makeTerm <$> (symbol FunctionDeclaration <|> symbol FuncLiteral) <*> children (mkFunctionDeclaration <$> (term identifier <|> emptyTerm) <*> params <*> returnTypes <*> (term block <|> emptyTerm)) where returnTypes = pure <$> (term types <|> term identifier <|> term returnParameters) @@ -424,7 +319,7 @@ functionDeclaration = makeTerm <$> (symbol FunctionDeclaration <|> symbol FuncLi mkFunctionDeclaration name' params' types' block' = Declaration.Function types' name' params' block' returnParameters = makeTerm <$> symbol ParameterList <*> children (manyTerm expression) -importDeclaration :: Assignment Term +importDeclaration :: Assignment (Term Loc) importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTerm (importSpec <|> importSpecList)) where -- `import . "lib/Math"` @@ -447,10 +342,10 @@ importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTe importSpecList = makeTerm <$> symbol ImportSpecList <*> children (manyTerm (importSpec <|> comment)) importFromPath = symbol InterpretedStringLiteral *> (importPath <$> source) -indexExpression :: Assignment Term +indexExpression :: Assignment (Term Loc) indexExpression = makeTerm <$> symbol IndexExpression <*> children (Expression.Subscript <$> expression <*> manyTerm expression) -methodDeclaration :: Assignment Term +methodDeclaration :: Assignment (Term Loc) methodDeclaration = makeTerm <$> symbol MethodDeclaration <*> children (mkTypedMethodDeclaration <$> receiver <*> pure publicAccessControl <*> term fieldIdentifier <*> params <*> returnParameters <*> (term block <|> emptyTerm)) where params = symbol ParameterList *> children (manyTerm expression) @@ -460,7 +355,7 @@ methodDeclaration = makeTerm <$> symbol MethodDeclaration <*> children (mkTypedM <|> pure <$> expression <|> pure [] -methodSpec :: Assignment Term +methodSpec :: Assignment (Term Loc) methodSpec = makeTerm <$> symbol MethodSpec <*> children (mkMethodSpec publicAccessControl <$> expression <*> params <*> (expression <|> emptyTerm)) where params = symbol ParameterList *> children (manyTerm expression) @@ -469,43 +364,43 @@ methodSpec = makeTerm <$> symbol MethodSpec <*> children (mkMethodSpec publicAc publicAccessControl :: ScopeGraph.AccessControl publicAccessControl = ScopeGraph.Public -methodSpecList :: Assignment Term +methodSpecList :: Assignment (Term Loc) methodSpecList = symbol MethodSpecList *> children expressions -packageClause :: Assignment Term +packageClause :: Assignment (Term Loc) packageClause = makeTerm <$> symbol PackageClause <*> children (Go.Syntax.Package <$> expression <*> pure []) -parameters :: Assignment Term +parameters :: Assignment (Term Loc) parameters = symbol ParameterList *> children expressions -parameterDeclaration :: Assignment Term +parameterDeclaration :: Assignment (Term Loc) parameterDeclaration = makeTerm <$> symbol ParameterDeclaration <*> children (manyTerm expression) -parenthesizedExpression :: Assignment Term +parenthesizedExpression :: Assignment (Term Loc) parenthesizedExpression = symbol ParenthesizedExpression *> children expressions -selectorExpression :: Assignment Term +selectorExpression :: Assignment (Term Loc) selectorExpression = makeWithContext <$> symbol SelectorExpression <*> children ((,,) <$> expression <*> optional comment <*> fieldIdentifier) where makeWithContext loc (lhs, comment, rhs) = maybe (makeTerm loc (Expression.MemberAccess lhs rhs)) (\c -> makeTerm loc (Syntax.Context (c :| []) (makeTerm loc (Expression.MemberAccess lhs rhs)))) comment -sliceExpression :: Assignment Term +sliceExpression :: Assignment (Term Loc) sliceExpression = makeTerm <$> symbol SliceExpression <*> children (Go.Syntax.Slice <$> expression <* token AnonLBracket <*> (emptyTerm <|> expression) <* token AnonColon <*> (expression <|> emptyTerm) <* optional (token AnonColon) <*> (expression <|> emptyTerm)) -typeAssertion :: Assignment Term +typeAssertion :: Assignment (Term Loc) typeAssertion = makeTerm <$> symbol TypeAssertionExpression <*> children (Go.Syntax.TypeAssertion <$> expression <*> expression) -typeCase :: Assignment Term +typeCase :: Assignment (Term Loc) typeCase = symbol TypeCase *> children expressions -typeConversion :: Assignment Term +typeConversion :: Assignment (Term Loc) typeConversion = makeTerm <$> symbol TypeConversionExpression <*> children (Go.Syntax.TypeConversion <$> expression <*> expression) -typeSwitchStatement :: Assignment Term +typeSwitchStatement :: Assignment (Term Loc) typeSwitchStatement = makeTerm <$> symbol TypeSwitchStatement <*> children (Go.Syntax.TypeSwitch <$> typeSwitchSubject <*> expressions) where typeSwitchSubject = makeTerm <$> location <*> manyTermsTill expression (void (symbol TypeCase)) <|> emptyTerm -unaryExpression :: Assignment Term +unaryExpression :: Assignment (Term Loc) unaryExpression = makeTerm' <$> symbol UnaryExpression <*> ( notExpression <|> unaryMinus <|> unaryAmpersand @@ -522,16 +417,16 @@ unaryExpression = makeTerm' <$> symbol UnaryExpression <*> ( notExpression unaryPointer = inject <$> children (Literal.Pointer <$ symbol AnonStar <*> expression) unaryReceive = inject <$> children (Go.Syntax.ReceiveOperator <$ symbol AnonLAngleMinus <*> expression) -varDeclaration :: Assignment Term +varDeclaration :: Assignment (Term Loc) varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions -variadicArgument :: Assignment Term +variadicArgument :: Assignment (Term Loc) variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expressions) -variadicParameterDeclaration :: Assignment Term +variadicParameterDeclaration :: Assignment (Term Loc) variadicParameterDeclaration = makeTerm <$> symbol VariadicParameterDeclaration <*> children (flip Go.Syntax.Variadic <$> (expression <|> emptyTerm) <* token AnonDotDotDot <*> many expression) -varSpecification :: Assignment Term +varSpecification :: Assignment (Term Loc) varSpecification = makeTerm <$> (symbol ConstSpec <|> symbol VarSpec) <*> children (Statement.Assignment [] <$> (annotatedLHS <|> identifiers) <*> expressions) where annotatedLHS = makeTerm <$> location <*> (Type.Annotation <$> (makeTerm <$> location <*> manyTermsTill identifier (void (symbol TypeIdentifier))) <*> expression) @@ -539,7 +434,7 @@ varSpecification = makeTerm <$> (symbol ConstSpec <|> symbol VarSpec) <*> childr -- Statements -assignment' :: Assignment Term +assignment' :: Assignment (Term Loc) assignment' = makeTerm' <$> symbol AssignmentStatement <*> children (infixTerm expressionList expressionList [ assign <$ symbol AnonEqual , augmentedAssign Expression.Plus <$ symbol AnonPlusEqual @@ -555,95 +450,95 @@ assignment' = makeTerm' <$> symbol AssignmentStatement <*> children (infixTerm , augmentedAssign (invert Expression.BAnd) <$ symbol AnonAmpersandCaretEqual ]) where - assign :: Term -> Term -> Sum Syntax Term + assign :: Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc) assign l r = inject (Statement.Assignment [] l r) - augmentedAssign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term + augmentedAssign :: (f :< Go.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc) augmentedAssign c l r = assign l (makeTerm1 (c l r)) invert cons a b = Expression.Not (makeTerm1 (cons a b)) -breakStatement :: Assignment Term +breakStatement :: Assignment (Term Loc) breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (expression <|> emptyTerm)) -communicationCase :: Assignment Term +communicationCase :: Assignment (Term Loc) communicationCase = makeTerm <$> symbol CommunicationCase <*> children (Statement.Pattern <$> expression <*> expressions) -continueStatement :: Assignment Term +continueStatement :: Assignment (Term Loc) continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (expression <|> emptyTerm)) -decStatement :: Assignment Term +decStatement :: Assignment (Term Loc) decStatement = makeTerm <$> symbol DecStatement <*> children (Statement.PostDecrement <$> expression) -deferStatement :: Assignment Term +deferStatement :: Assignment (Term Loc) deferStatement = makeTerm <$> symbol DeferStatement <*> children (Go.Syntax.Defer <$> expression) -emptyStatement :: Assignment Term +emptyStatement :: Assignment (Term Loc) emptyStatement = makeTerm <$> token EmptyStatement <*> (Statement.NoOp <$> emptyTerm) -forStatement :: Assignment Term +forStatement :: Assignment (Term Loc) forStatement = makeTerm' <$> symbol ForStatement <*> children (forClause <|> forSimpleClause <|> rangeClause) where forClause = inject <$> (symbol ForClause *> children (Statement.For <$> (expression <|> emptyTerm) <*> (expression <|> emptyTerm) <*> (expression <|> emptyTerm)) <*> expression) forSimpleClause = inject <$> (Statement.For <$> emptyTerm <*> (expression <|> emptyTerm) <*> emptyTerm <*> expression) rangeClause = inject <$> (symbol RangeClause *> children (Statement.ForEach <$> (expression <|> emptyTerm) <*> expression) <*> expression) -goStatement :: Assignment Term +goStatement :: Assignment (Term Loc) goStatement = makeTerm <$> symbol GoStatement <*> children (Go.Syntax.Go <$> expression) -gotoStatement :: Assignment Term +gotoStatement :: Assignment (Term Loc) gotoStatement = makeTerm <$> symbol GotoStatement <*> children (Statement.Goto <$> expression) -ifStatement :: Assignment Term +ifStatement :: Assignment (Term Loc) ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> (makeTerm <$> location <*> manyTermsTill expression (void (symbol Block))) <*> expression <*> (expression <|> emptyTerm)) -incStatement :: Assignment Term +incStatement :: Assignment (Term Loc) incStatement = makeTerm <$> symbol IncStatement <*> children (Statement.PostIncrement <$> expression) -keyedElement :: Assignment Term +keyedElement :: Assignment (Term Loc) keyedElement = makeTerm <$> symbol KeyedElement <*> children (Literal.KeyValue <$> expression <*> expression) -labelName :: Assignment Term +labelName :: Assignment (Term Loc) labelName = makeTerm <$> symbol LabelName <*> (Syntax.Identifier . name <$> source) -labeledStatement :: Assignment Term +labeledStatement :: Assignment (Term Loc) labeledStatement = makeTerm <$> (symbol LabeledStatement <|> symbol LabeledStatement') <*> children (Go.Syntax.Label <$> expression <*> (expression <|> emptyTerm)) -returnStatement :: Assignment Term +returnStatement :: Assignment (Term Loc) returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (expression <|> emptyTerm)) -receiveStatement :: Assignment Term +receiveStatement :: Assignment (Term Loc) receiveStatement = makeTerm <$> symbol ReceiveStatement <*> children (Go.Syntax.Receive <$> (expression <|> emptyTerm) <*> expression) -shortVarDeclaration :: Assignment Term +shortVarDeclaration :: Assignment (Term Loc) shortVarDeclaration = makeTerm <$> symbol ShortVarDeclaration <*> children (Statement.Assignment [] <$> expression <*> expression) -selectStatement :: Assignment Term +selectStatement :: Assignment (Term Loc) selectStatement = makeTerm <$> symbol SelectStatement <*> children (Go.Syntax.Select <$> expressions) -sendStatement :: Assignment Term +sendStatement :: Assignment (Term Loc) sendStatement = makeTerm <$> symbol SendStatement <*> children (Go.Syntax.Send <$> expression <*> expression) -- Helpers -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc))] + -> Assignment (Sum Go.Syntax (Term Loc)) infixTerm = infixContext comment -- | Match a series of terms or comments until a delimiter is matched -manyTermsTill :: Assignment Term +manyTermsTill :: Assignment (Term Loc) -> Assignment b - -> Assignment [Term] + -> Assignment [Term Loc] manyTermsTill step end = manyTill (step <|> comment) end -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment Term -> Assignment [Term] +manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] manyTerm = many . term -- | Match a term and contextualize any comments preceding or proceeding the term. -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term' = contextualize comment term' <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm) diff --git a/src/Language/Go/Term.hs b/src/Language/Go/Term.hs new file mode 100644 index 000000000..7cc08ec46 --- /dev/null +++ b/src/Language/Go/Term.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.Go.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +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 qualified Data.Syntax.Type as Type +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import Language.Go.Syntax as Go.Syntax +import Language.Go.Type as Go.Type +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Declaration.Constructor + , Declaration.Function + , Declaration.Method + , Declaration.MethodSignature + , Declaration.Type + , Declaration.TypeAlias + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.BOr + , Expression.BAnd + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.UnsignedRShift + , Expression.Complement + , Expression.Call + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.Subscript + , Expression.Member + , Statement.PostDecrement + , Statement.PostIncrement + , Expression.MemberAccess + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Go.Syntax.Composite + , Go.Syntax.DefaultPattern + , Go.Syntax.Defer + , Go.Syntax.Field + , Go.Syntax.Go + , Go.Syntax.Label + , Go.Syntax.Package + , Go.Syntax.Receive + , Go.Syntax.ReceiveOperator + , Go.Syntax.Rune + , Go.Syntax.Select + , Go.Syntax.Send + , Go.Syntax.Slice + , Go.Syntax.TypeAssertion + , Go.Syntax.TypeConversion + , Go.Syntax.TypeSwitch + , Go.Syntax.TypeSwitchGuard + , Go.Syntax.Variadic + , Go.Type.BidirectionalChannel + , Go.Type.ReceiveChannel + , Go.Type.SendChannel + , Go.Syntax.Import + , Go.Syntax.QualifiedImport + , Go.Syntax.SideEffectImport + , Literal.Array + , Literal.Complex + , Literal.Float + , Literal.Hash + , Literal.Integer + , Literal.KeyValue + , Literal.Pointer + , Literal.Reference + , Literal.TextElement + , Statement.Assignment + , Statement.Break + , Statement.Continue + , Statement.For + , Statement.ForEach + , Statement.Goto + , Statement.If + , Statement.Match + , Statement.NoOp + , Statement.Pattern + , Statement.Return + , Statement.Statements + , Syntax.Context + , Syntax.Error + , Syntax.Empty + , Syntax.Identifier + , Type.Annotation + , Type.Array + , Type.Function + , Type.Interface + , Type.Map + , Type.Parenthesized + , Type.Pointer + , Type.Slice + , [] + , Literal.String + , Literal.EscapeSequence + , Literal.Null + , Literal.Boolean + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 2e8fd0bcd..d27165420 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/src/Language/Markdown/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.Markdown.Assignment ( assignment -, Syntax +, Markdown.Syntax , Grammar -, Language.Markdown.Assignment.Term +, Markdown.Term(..) ) where import Prologue @@ -17,45 +16,18 @@ import qualified Data.Syntax as Syntax import qualified Data.Term as Term import qualified Data.Text as Text import qualified Language.Markdown.Syntax as Markup +import Language.Markdown.Term as Markdown import Parsing.CMark as Grammar (Grammar (..)) -type Syntax = - '[ Markup.Document - -- Block elements - , Markup.BlockQuote - , Markup.Heading - , Markup.HTMLBlock - , Markup.OrderedList - , Markup.Paragraph - , Markup.ThematicBreak - , Markup.UnorderedList - , Markup.Table - , Markup.TableRow - , Markup.TableCell - -- Inline elements - , Markup.Code - , Markup.Emphasis - , Markup.Image - , Markup.LineBreak - , Markup.Link - , Markup.Strong - , Markup.Text - , Markup.Strikethrough - -- Assignment errors; cmark does not provide parse errors. - , Syntax.Error - , [] - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment (Term.TermF [] CMarkGFM.NodeType) Grammar -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = Syntax.handleError $ makeTerm <$> symbol Document <*> children (Markup.Document <$> many blockElement) -- Block elements -blockElement :: Assignment Term +blockElement :: Assignment (Term Loc) blockElement = choice [ paragraph , list @@ -67,10 +39,10 @@ blockElement = choice , table ] -paragraph :: Assignment Term +paragraph :: Assignment (Term Loc) paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) -list :: Assignment Term +list :: Assignment (Term Loc) list = Term.termIn <$> symbol List <*> (makeList . Term.termFAnnotation . Term.termFOut <$> currentNode <*> children (many item)) where makeList (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) = case listType of @@ -78,42 +50,42 @@ list = Term.termIn <$> symbol List <*> (makeList . Term.termFAnnotation . Term.t CMarkGFM.ORDERED_LIST -> inject . Markup.OrderedList makeList _ = inject . Markup.UnorderedList -item :: Assignment Term +item :: Assignment (Term Loc) item = makeTerm <$> symbol Item <*> children (many blockElement) -heading :: Assignment Term +heading :: Assignment (Term Loc) heading = makeTerm <$> symbol Heading <*> (makeHeading . Term.termFAnnotation . Term.termFOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof)) where makeHeading (CMarkGFM.HEADING level) = Markup.Heading level makeHeading _ = Markup.Heading 0 -blockQuote :: Assignment Term +blockQuote :: Assignment (Term Loc) blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) -codeBlock :: Assignment Term +codeBlock :: Assignment (Term Loc) codeBlock = makeTerm <$> symbol CodeBlock <*> (makeCode . Term.termFAnnotation . Term.termFOut <$> currentNode <*> source) where makeCode (CMarkGFM.CODE_BLOCK language _) = Markup.Code (nullText language) makeCode _ = Markup.Code Nothing -thematicBreak :: Assignment Term +thematicBreak :: Assignment (Term Loc) thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak -htmlBlock :: Assignment Term +htmlBlock :: Assignment (Term Loc) htmlBlock = makeTerm <$> symbol HTMLBlock <*> (Markup.HTMLBlock <$> source) -table :: Assignment Term +table :: Assignment (Term Loc) table = makeTerm <$> symbol Table <*> children (Markup.Table <$> many tableRow) -tableRow :: Assignment Term +tableRow :: Assignment (Term Loc) tableRow = makeTerm <$> symbol TableRow <*> children (Markup.TableRow <$> many tableCell) -tableCell :: Assignment Term +tableCell :: Assignment (Term Loc) tableCell = makeTerm <$> symbol TableCell <*> children (Markup.TableCell <$> many inlineElement) -- Inline elements -inlineElement :: Assignment Term +inlineElement :: Assignment (Term Loc) inlineElement = choice [ strong , emphasis @@ -127,40 +99,40 @@ inlineElement = choice , softBreak ] -strong :: Assignment Term +strong :: Assignment (Term Loc) strong = makeTerm <$> symbol Strong <*> children (Markup.Strong <$> many inlineElement) -emphasis :: Assignment Term +emphasis :: Assignment (Term Loc) emphasis = makeTerm <$> symbol Emphasis <*> children (Markup.Emphasis <$> many inlineElement) -strikethrough :: Assignment Term +strikethrough :: Assignment (Term Loc) strikethrough = makeTerm <$> symbol Strikethrough <*> children (Markup.Strikethrough <$> many inlineElement) -text :: Assignment Term +text :: Assignment (Term Loc) text = makeTerm <$> symbol Text <*> (Markup.Text <$> source) -htmlInline :: Assignment Term +htmlInline :: Assignment (Term Loc) htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) -link :: Assignment Term +link :: Assignment (Term Loc) link = makeTerm <$> symbol Link <*> (makeLink . Term.termFAnnotation . Term.termFOut <$> currentNode) <* advance where makeLink (CMarkGFM.LINK url title) = Markup.Link url (nullText title) makeLink _ = Markup.Link mempty Nothing -image :: Assignment Term +image :: Assignment (Term Loc) image = makeTerm <$> symbol Image <*> (makeImage . Term.termFAnnotation . Term.termFOut <$> currentNode) <* advance where makeImage (CMarkGFM.IMAGE url title) = Markup.Image url (nullText title) makeImage _ = Markup.Image mempty Nothing -code :: Assignment Term +code :: Assignment (Term Loc) code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) -lineBreak :: Assignment Term +lineBreak :: Assignment (Term Loc) lineBreak = makeTerm <$> token LineBreak <*> pure Markup.LineBreak -softBreak :: Assignment Term +softBreak :: Assignment (Term Loc) softBreak = makeTerm <$> token SoftBreak <*> pure Markup.LineBreak diff --git a/src/Language/Markdown/Term.hs b/src/Language/Markdown/Term.hs new file mode 100644 index 000000000..acb3bf79c --- /dev/null +++ b/src/Language/Markdown/Term.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.Markdown.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import qualified Language.Markdown.Syntax as Markup +import Source.Loc +import Source.Span + +type Syntax = + [ Markup.Document + -- Block elements + , Markup.BlockQuote + , Markup.Heading + , Markup.HTMLBlock + , Markup.OrderedList + , Markup.Paragraph + , Markup.ThematicBreak + , Markup.UnorderedList + , Markup.Table + , Markup.TableRow + , Markup.TableCell + -- Inline elements + , Markup.Code + , Markup.Emphasis + , Markup.Image + , Markup.LineBreak + , Markup.Link + , Markup.Strong + , Markup.Text + , Markup.Strikethrough + -- Assignment errors; cmark does not provide parse errors. + , Syntax.Error + , [] + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Declarations, Eq, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 27ca5a379..8d7e62927 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.PHP.Assignment ( assignment -, Syntax +, PHP.Syntax , Grammar -, Term +, PHP.Term(..) ) where import Prologue @@ -32,150 +31,23 @@ import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term import qualified Language.PHP.Syntax as Syntax +import Language.PHP.Term as PHP import TreeSitter.PHP as Grammar -type Syntax = '[ - Comment.Comment - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.VariableDeclaration - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.InstanceOf - , Expression.MemberAccess - , Expression.New - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Literal.Array - , Literal.Float - , Literal.Integer - , Literal.KeyValue - , Literal.TextElement - , Statement.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.Goto - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Return - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AliasAs - , Syntax.ArrayElement - , Syntax.BaseTypeDeclaration - , Syntax.CastType - , Syntax.ClassBaseClause - , Syntax.ClassConstDeclaration - , Syntax.ClassInterfaceClause - , Syntax.ClassModifier - , Syntax.Clone - , Syntax.ConstDeclaration - , Syntax.ConstructorDeclaration - , Syntax.Context - , Syntax.Declare - , Syntax.DeclareDirective - , Syntax.DestructorDeclaration - , Syntax.Echo - , Syntax.Empty - , Syntax.EmptyIntrinsic - , Syntax.Error - , Syntax.ErrorControl - , Syntax.EvalIntrinsic - , Syntax.ExitIntrinsic - , Syntax.GlobalDeclaration - , Syntax.Identifier - , Syntax.Include - , Syntax.IncludeOnce - , Syntax.InsteadOf - , Syntax.InterfaceBaseClause - , Syntax.InterfaceDeclaration - , Syntax.IssetIntrinsic - , Syntax.LabeledStatement - , Syntax.Namespace - , Syntax.NamespaceAliasingClause - , Syntax.NamespaceName - , Syntax.NamespaceUseClause - , Syntax.NamespaceUseDeclaration - , Syntax.NamespaceUseGroupClause - , Syntax.NewVariable - , Syntax.PrintIntrinsic - , Syntax.PropertyDeclaration - , Syntax.PropertyModifier - , Syntax.QualifiedName - , Syntax.RelativeScope - , Syntax.Require - , Syntax.RequireOnce - , Syntax.ReturnType - , Syntax.ScalarType - , Syntax.ShellCommand - , Syntax.Concat - , Syntax.SimpleVariable - , Syntax.Static - , Syntax.Text - , Syntax.TraitDeclaration - , Syntax.TraitUseClause - , Syntax.TraitUseSpecification - , Syntax.TypeDeclaration - , Syntax.Unset - , Syntax.Update - , Syntax.UseClause - , Syntax.VariableName - , Type.Annotation - , [] - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in PHP's grammar onto a program in PHP's syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> (bookend <$> (text <|> emptyTerm) <*> manyTerm statement <*> (text <|> emptyTerm))) <|> parseError -text :: Assignment Term +text :: Assignment (Term Loc) text = makeTerm <$> symbol Text <*> (Syntax.Text <$> source) -textInterpolation :: Assignment Term +textInterpolation :: Assignment (Term Loc) textInterpolation = makeTerm <$> symbol TextInterpolation <*> (Syntax.Text <$> source) -statement :: Assignment Term +statement :: Assignment (Term Loc) statement = handleError everything where everything = choice [ @@ -200,7 +72,7 @@ statement = handleError everything , functionStaticDeclaration ] -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = choice [ assignmentExpression, augmentedAssignmentExpression, @@ -214,7 +86,7 @@ expression = choice [ unaryExpression ] -unaryExpression :: Assignment Term +unaryExpression :: Assignment (Term Loc) unaryExpression = choice [ cloneExpression, exponentiationExpression, @@ -223,10 +95,10 @@ unaryExpression = choice [ primaryExpression ] -assignmentExpression :: Assignment Term +assignmentExpression :: Assignment (Term Loc) assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (variable <|> list <|> arrayCreationExpression) <*> term (expression <|> variable)) -augmentedAssignmentExpression :: Assignment Term +augmentedAssignmentExpression :: Assignment (Term Loc) augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm variable (term expression) [ assign Expression.Power <$ symbol AnonStarStarEqual , assign Expression.Times <$ symbol AnonStarEqual @@ -243,7 +115,7 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi where assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r))) -binaryExpression :: Assignment Term +binaryExpression :: Assignment (Term Loc) binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term (expression <|> classTypeDesignator)) [ (inject .) . Expression.And <$ symbol AnonAnd , (inject .) . Expression.Or <$ symbol AnonOr @@ -274,19 +146,19 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm , (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof ]) where invert cons a b = Expression.Not (makeTerm1 (cons a b)) -conditionalExpression :: Assignment Term +conditionalExpression :: Assignment (Term Loc) conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (Statement.If <$> term (binaryExpression <|> unaryExpression) <*> (term expression <|> emptyTerm) <*> term expression) -list :: Assignment Term +list :: Assignment (Term Loc) list = makeTerm <$> symbol ListLiteral <*> children (Literal.Array <$> manyTerm (list <|> variable)) -exponentiationExpression :: Assignment Term +exponentiationExpression :: Assignment (Term Loc) exponentiationExpression = makeTerm <$> symbol ExponentiationExpression <*> children (Expression.Power <$> term (cloneExpression <|> primaryExpression) <*> term (primaryExpression <|> cloneExpression <|> exponentiationExpression)) -cloneExpression :: Assignment Term +cloneExpression :: Assignment (Term Loc) cloneExpression = makeTerm <$> symbol CloneExpression <*> children (Syntax.Clone <$> term primaryExpression) -primaryExpression :: Assignment Term +primaryExpression :: Assignment (Term Loc) primaryExpression = choice [ variable, classConstantAccessExpression, @@ -301,16 +173,16 @@ primaryExpression = choice [ parenthesizedExpression ] -parenthesizedExpression :: Assignment Term +parenthesizedExpression :: Assignment (Term Loc) parenthesizedExpression = symbol ParenthesizedExpression *> children (term expression) -classConstantAccessExpression :: Assignment Term +classConstantAccessExpression :: Assignment (Term Loc) classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> name) -variable :: Assignment Term +variable :: Assignment (Term Loc) variable = callableVariable <|> scopedPropertyAccessExpression <|> memberAccessExpression <|> castExpression -callableVariable :: Assignment Term +callableVariable :: Assignment (Term Loc) callableVariable = choice [ simpleVariable', subscriptExpression, @@ -319,18 +191,18 @@ callableVariable = choice [ functionCallExpression ] -memberCallExpression :: Assignment Term +memberCallExpression :: Assignment (Term Loc) memberCallExpression = makeTerm <$> symbol MemberCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term dereferencableExpression <*> memberName) <*> arguments <*> emptyTerm) where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName) -scopedCallExpression :: Assignment Term +scopedCallExpression :: Assignment (Term Loc) scopedCallExpression = makeTerm <$> symbol ScopedCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term scopeResolutionQualifier <*> memberName) <*> arguments <*> emptyTerm) where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName) -functionCallExpression :: Assignment Term +functionCallExpression :: Assignment (Term Loc) functionCallExpression = makeTerm <$> symbol FunctionCallExpression <*> children (Expression.Call [] <$> term (qualifiedName <|> callableExpression) <*> arguments <*> emptyTerm) -callableExpression :: Assignment Term +callableExpression :: Assignment (Term Loc) callableExpression = choice [ callableVariable, expression, @@ -338,29 +210,29 @@ callableExpression = choice [ string ] -subscriptExpression :: Assignment Term +subscriptExpression :: Assignment (Term Loc) subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term dereferencableExpression <*> (pure <$> (term expression <|> emptyTerm))) -memberAccessExpression :: Assignment Term +memberAccessExpression :: Assignment (Term Loc) memberAccessExpression = makeTerm <$> symbol MemberAccessExpression <*> children (Expression.MemberAccess <$> term dereferencableExpression <*> memberName) -dereferencableExpression :: Assignment Term +dereferencableExpression :: Assignment (Term Loc) dereferencableExpression = symbol DereferencableExpression *> children (term (variable <|> expression <|> arrayCreationExpression <|> string)) -scopedPropertyAccessExpression :: Assignment Term +scopedPropertyAccessExpression :: Assignment (Term Loc) scopedPropertyAccessExpression = makeTerm <$> symbol ScopedPropertyAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> simpleVariable') -scopeResolutionQualifier :: Assignment Term +scopeResolutionQualifier :: Assignment (Term Loc) scopeResolutionQualifier = choice [ relativeScope, qualifiedName, dereferencableExpression ] -arrayCreationExpression :: Assignment Term +arrayCreationExpression :: Assignment (Term Loc) arrayCreationExpression = makeTerm <$> symbol ArrayCreationExpression <*> children (Literal.Array <$> manyTerm arrayElementInitializer) -intrinsic :: Assignment Term +intrinsic :: Assignment (Term Loc) intrinsic = choice [ emptyIntrinsic, evalIntrinsic, @@ -369,68 +241,68 @@ intrinsic = choice [ printIntrinsic ] -emptyIntrinsic :: Assignment Term +emptyIntrinsic :: Assignment (Term Loc) emptyIntrinsic = makeTerm <$> symbol EmptyIntrinsic <*> children (Syntax.EmptyIntrinsic <$> term expression) -evalIntrinsic :: Assignment Term +evalIntrinsic :: Assignment (Term Loc) evalIntrinsic = makeTerm <$> symbol EvalIntrinsic <*> children (Syntax.EvalIntrinsic <$> term expression) -exitIntrinsic :: Assignment Term +exitIntrinsic :: Assignment (Term Loc) exitIntrinsic = makeTerm <$> symbol ExitIntrinsic <*> children (Syntax.ExitIntrinsic <$> (term expression <|> emptyTerm)) -issetIntrinsic :: Assignment Term +issetIntrinsic :: Assignment (Term Loc) issetIntrinsic = makeTerm <$> symbol IssetIntrinsic <*> children (Syntax.IssetIntrinsic <$> (makeTerm <$> location <*> someTerm variable)) -printIntrinsic :: Assignment Term +printIntrinsic :: Assignment (Term Loc) printIntrinsic = makeTerm <$> symbol PrintIntrinsic <*> children (Syntax.PrintIntrinsic <$> term expression) -anonymousFunctionCreationExpression :: Assignment Term +anonymousFunctionCreationExpression :: Assignment (Term Loc) anonymousFunctionCreationExpression = makeTerm <$> symbol AnonymousFunctionCreationExpression <*> children (makeFunction <$> emptyTerm <*> parameters <*> (term functionUseClause <|> emptyTerm) <*> (term returnType <|> emptyTerm) <*> term compoundStatement) where makeFunction identifier parameters functionUseClause returnType statement = Declaration.Function [functionUseClause, returnType] identifier parameters statement -parameters :: Assignment [Term] +parameters :: Assignment [Term Loc] parameters = symbol FormalParameters *> children (manyTerm (simpleParameter <|> variadicParameter)) -simpleParameter :: Assignment Term +simpleParameter :: Assignment (Term Loc) simpleParameter = makeTerm <$> symbol SimpleParameter <*> children (makeAnnotation <$> (term typeDeclaration <|> emptyTerm) <*> (makeAssignment <$> location <*> term variableName <*> (term defaultArgumentSpecifier <|> emptyTerm))) where makeAnnotation typeDecl assignment = Type.Annotation assignment typeDecl makeAssignment loc name argument = makeTerm loc (Statement.Assignment [] name argument) -defaultArgumentSpecifier :: Assignment Term +defaultArgumentSpecifier :: Assignment (Term Loc) defaultArgumentSpecifier = symbol DefaultArgumentSpecifier *> children (term expression) -variadicParameter :: Assignment Term +variadicParameter :: Assignment (Term Loc) variadicParameter = makeTerm <$> symbol VariadicParameter <*> children (makeTypeAnnotation <$> (term typeDeclaration <|> emptyTerm) <*> term variableName) where makeTypeAnnotation ty variableName = Type.Annotation variableName ty -functionUseClause :: Assignment Term +functionUseClause :: Assignment (Term Loc) functionUseClause = makeTerm <$> symbol AnonymousFunctionUseClause <*> children (Syntax.UseClause <$> someTerm variableName) -returnType :: Assignment Term +returnType :: Assignment (Term Loc) returnType = makeTerm <$> symbol ReturnType <*> children (Syntax.ReturnType <$> (term typeDeclaration <|> emptyTerm)) -typeDeclaration :: Assignment Term +typeDeclaration :: Assignment (Term Loc) typeDeclaration = makeTerm <$> symbol TypeDeclaration <*> children (Syntax.TypeDeclaration <$> term baseTypeDeclaration) -baseTypeDeclaration :: Assignment Term +baseTypeDeclaration :: Assignment (Term Loc) baseTypeDeclaration = makeTerm <$> symbol BaseTypeDeclaration <*> children (Syntax.BaseTypeDeclaration <$> term (scalarType <|> qualifiedName <|> emptyTerm)) -scalarType :: Assignment Term +scalarType :: Assignment (Term Loc) scalarType = makeTerm <$> symbol ScalarType <*> (Syntax.ScalarType <$> source) -compoundStatement :: Assignment Term +compoundStatement :: Assignment (Term Loc) compoundStatement = makeTerm <$> symbol CompoundStatement <*> children (manyTerm statement) -objectCreationExpression :: Assignment Term +objectCreationExpression :: Assignment (Term Loc) objectCreationExpression = makeTerm <$> symbol ObjectCreationExpression <*> children (Expression.New <$> term classTypeDesignator <*> emptyTerm <*> (arguments <|> pure [])) <|> (makeTerm <$> symbol ObjectCreationExpression <*> children (makeAnonClass <$ token AnonNew <* token AnonClass <*> emptyTerm <*> (arguments <|> pure []) <*> (term classBaseClause <|> emptyTerm) <*> (term classInterfaceClause <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm classMemberDeclaration))) where makeAnonClass identifier args baseClause interfaceClause declarations = Declaration.Class [] identifier (args <> [baseClause, interfaceClause]) declarations -classMemberDeclaration :: Assignment Term +classMemberDeclaration :: Assignment (Term Loc) classMemberDeclaration = choice [ classConstDeclaration, propertyDeclaration, @@ -444,7 +316,7 @@ publicAccessControl :: ScopeGraph.AccessControl publicAccessControl = ScopeGraph.Public -- TODO: Update to check for AccessControl. -methodDeclaration :: Assignment Term +methodDeclaration :: Assignment (Term Loc) methodDeclaration = (makeTerm <$> symbol MethodDeclaration <*> children (makeMethod1 publicAccessControl <$> manyTerm methodModifier <*> emptyTerm <*> functionDefinitionParts)) <|> makeTerm <$> symbol MethodDeclaration <*> children (makeMethod2 publicAccessControl <$> someTerm methodModifier <*> emptyTerm <*> term name <*> parameters <*> term (returnType <|> emptyTerm) <*> emptyTerm) where @@ -452,107 +324,107 @@ methodDeclaration = (makeTerm <$> symbol MethodDeclaration <*> children (makeMe makeMethod1 accessControl modifiers receiver (name, params, returnType, compoundStatement) = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement accessControl makeMethod2 accessControl modifiers receiver name params returnType compoundStatement = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement accessControl -classBaseClause :: Assignment Term +classBaseClause :: Assignment (Term Loc) classBaseClause = makeTerm <$> symbol ClassBaseClause <*> children (Syntax.ClassBaseClause <$> term qualifiedName) -classInterfaceClause :: Assignment Term +classInterfaceClause :: Assignment (Term Loc) classInterfaceClause = makeTerm <$> symbol ClassInterfaceClause <*> children (Syntax.ClassInterfaceClause <$> someTerm qualifiedName) -classConstDeclaration :: Assignment Term +classConstDeclaration :: Assignment (Term Loc) classConstDeclaration = makeTerm <$> symbol ClassConstDeclaration <*> children (Syntax.ClassConstDeclaration <$> (term accessControlModifier <|> emptyTerm) <*> manyTerm constElement) -- TODO: Update to ScopeGraph.AccessControl -accessControlModifier :: Assignment Term +accessControlModifier :: Assignment (Term Loc) accessControlModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . Name.name <$> source) -constElement :: Assignment Term +constElement :: Assignment (Term Loc) constElement = makeTerm <$> symbol ConstElement <*> children (Statement.Assignment [] <$> term name <*> term expression) -arguments :: Assignment [Term] +arguments :: Assignment [Term Loc] arguments = symbol Arguments *> children (manyTerm (variadicUnpacking <|> expression)) -variadicUnpacking :: Assignment Term +variadicUnpacking :: Assignment (Term Loc) variadicUnpacking = symbol VariadicUnpacking *> children (term expression) -classTypeDesignator :: Assignment Term +classTypeDesignator :: Assignment (Term Loc) classTypeDesignator = qualifiedName <|> newVariable -newVariable :: Assignment Term +newVariable :: Assignment (Term Loc) newVariable = makeTerm <$> symbol NewVariable <*> children (Syntax.NewVariable <$> ((pure <$> term simpleVariable') <|> ((\a b -> [a, b]) <$> term (newVariable <|> qualifiedName <|> relativeScope) <*> term (expression <|> memberName <|> emptyTerm)))) -memberName :: Assignment Term +memberName :: Assignment (Term Loc) memberName = name <|> simpleVariable' <|> expression -relativeScope :: Assignment Term +relativeScope :: Assignment (Term Loc) relativeScope = makeTerm <$> symbol RelativeScope <*> (Syntax.RelativeScope <$> source) -qualifiedName :: Assignment Term +qualifiedName :: Assignment (Term Loc) qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.QualifiedName <$> (term namespaceNameAsPrefix <|> emptyTerm) <*> term name) -namespaceNameAsPrefix :: Assignment Term +namespaceNameAsPrefix :: Assignment (Term Loc) namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (term namespaceName <|> emptyTerm) -namespaceName :: Assignment Term +namespaceName :: Assignment (Term Loc) namespaceName = makeTerm <$> symbol NamespaceName <*> children (Syntax.NamespaceName <$> someTerm' name) -namespaceName' :: Assignment (NonEmpty Term) +namespaceName' :: Assignment (NonEmpty (Term Loc)) namespaceName' = symbol NamespaceName *> children (someTerm' name) -updateExpression :: Assignment Term +updateExpression :: Assignment (Term Loc) updateExpression = makeTerm <$> symbol UpdateExpression <*> children (Syntax.Update <$> term expression) -shellCommandExpression :: Assignment Term +shellCommandExpression :: Assignment (Term Loc) shellCommandExpression = makeTerm <$> symbol ShellCommandExpression <*> (Syntax.ShellCommand <$> source) -literal :: Assignment Term +literal :: Assignment (Term Loc) literal = integer <|> float <|> string -float :: Assignment Term +float :: Assignment (Term Loc) float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) -integer :: Assignment Term +integer :: Assignment (Term Loc) integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) -unaryOpExpression :: Assignment Term +unaryOpExpression :: Assignment (Term Loc) unaryOpExpression = symbol UnaryOpExpression >>= \ loc -> makeTerm loc . Expression.Not <$> children ((symbol AnonTilde <|> symbol AnonBang) *> term expression) <|> makeTerm loc . Expression.Negate <$> children ((symbol AnonMinus <|> symbol AnonPlus) *> term expression) <|> makeTerm loc . Syntax.ErrorControl <$> children (symbol AnonAt *> term expression) -castExpression :: Assignment Term +castExpression :: Assignment (Term Loc) castExpression = makeTerm <$> (symbol CastExpression <|> symbol CastExpression') <*> children (flip Expression.Cast <$> term castType <*> term unaryExpression) -castType :: Assignment Term +castType :: Assignment (Term Loc) castType = makeTerm <$> symbol CastType <*> (Syntax.CastType <$> source) -expressionStatement :: Assignment Term +expressionStatement :: Assignment (Term Loc) expressionStatement = symbol ExpressionStatement *> children (term expression) -namedLabelStatement :: Assignment Term +namedLabelStatement :: Assignment (Term Loc) namedLabelStatement = makeTerm <$> symbol NamedLabelStatement <*> children (Syntax.LabeledStatement <$> term name) -selectionStatement :: Assignment Term +selectionStatement :: Assignment (Term Loc) selectionStatement = ifStatement <|> switchStatement -ifStatement :: Assignment Term +ifStatement :: Assignment (Term Loc) ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> (makeTerm <$> location <*> manyTerm statement) <*> (makeTerm <$> location <*> ((\as b -> as <> [b]) <$> manyTerm elseIfClause <*> (term elseClause <|> emptyTerm)))) -switchStatement :: Assignment Term +switchStatement :: Assignment (Term Loc) switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term expression <*> (makeTerm <$> location <*> manyTerm (caseStatement <|> defaultStatement))) -caseStatement :: Assignment Term +caseStatement :: Assignment (Term Loc) caseStatement = makeTerm <$> symbol CaseStatement <*> children (Statement.Pattern <$> term expression <*> (makeTerm <$> location <*> manyTerm statement)) -defaultStatement :: Assignment Term +defaultStatement :: Assignment (Term Loc) defaultStatement = makeTerm <$> symbol DefaultStatement <*> children (Statement.Pattern <$> emptyTerm <*> (makeTerm <$> location <*> manyTerm statement)) -elseIfClause :: Assignment Term +elseIfClause :: Assignment (Term Loc) elseIfClause = makeTerm <$> symbol ElseIfClause <*> children (Statement.Else <$> term expression <*> (makeTerm <$> location <*> manyTerm statement)) -elseClause :: Assignment Term +elseClause :: Assignment (Term Loc) elseClause = makeTerm <$> symbol ElseClause <*> children (Statement.Else <$> emptyTerm <*> (makeTerm <$> location <*> manyTerm statement)) -iterationStatement :: Assignment Term +iterationStatement :: Assignment (Term Loc) iterationStatement = choice [ whileStatement, doStatement, @@ -560,23 +432,23 @@ iterationStatement = choice [ foreachStatement ] -whileStatement :: Assignment Term +whileStatement :: Assignment (Term Loc) whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> expression <*> (term (statement <|> (makeTerm <$> location <*> manyTerm statement)) <|> emptyTerm)) -doStatement :: Assignment Term +doStatement :: Assignment (Term Loc) doStatement = makeTerm <$> symbol DoStatement <*> children (Statement.DoWhile <$> term statement <*> term expression) -forStatement :: Assignment Term +forStatement :: Assignment (Term Loc) forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> (term expressions <|> emptyTerm) <*> (term expressions <|> emptyTerm) <*> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) -foreachStatement :: Assignment Term +foreachStatement :: Assignment (Term Loc) foreachStatement = makeTerm <$> symbol ForeachStatement <*> children (forEachStatement' <$> term expression <*> term (pair <|> expression <|> list) <*> (makeTerm <$> location <*> manyTerm statement)) where forEachStatement' array value body = Statement.ForEach value array body -pair :: Assignment Term +pair :: Assignment (Term Loc) pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term expression <*> term (expression <|> list)) -jumpStatement :: Assignment Term +jumpStatement :: Assignment (Term Loc) jumpStatement = choice [ gotoStatement, continueStatement, @@ -585,81 +457,81 @@ jumpStatement = choice [ throwStatement ] -gotoStatement :: Assignment Term +gotoStatement :: Assignment (Term Loc) gotoStatement = makeTerm <$> symbol GotoStatement <*> children (Statement.Goto <$> term name) -continueStatement :: Assignment Term +continueStatement :: Assignment (Term Loc) continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (term breakoutLevel <|> emptyTerm)) -breakoutLevel :: Assignment Term +breakoutLevel :: Assignment (Term Loc) breakoutLevel = integer -breakStatement :: Assignment Term +breakStatement :: Assignment (Term Loc) breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (term breakoutLevel <|> emptyTerm)) -returnStatement :: Assignment Term +returnStatement :: Assignment (Term Loc) returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expression <|> emptyTerm)) -throwStatement :: Assignment Term +throwStatement :: Assignment (Term Loc) throwStatement = makeTerm <$> symbol ThrowStatement <*> children (Statement.Throw <$> term expression) -tryStatement :: Assignment Term +tryStatement :: Assignment (Term Loc) tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term compoundStatement <*> (((\as b -> as <> [b]) <$> someTerm catchClause <*> term finallyClause) <|> someTerm catchClause <|> someTerm finallyClause)) -catchClause :: Assignment Term +catchClause :: Assignment (Term Loc) catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (makeTerm <$> location <*> ((\a b -> [a, b]) <$> term qualifiedName <*> term variableName)) <*> term compoundStatement) -finallyClause :: Assignment Term +finallyClause :: Assignment (Term Loc) finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> term compoundStatement) -declareStatement :: Assignment Term +declareStatement :: Assignment (Term Loc) declareStatement = makeTerm <$> symbol DeclareStatement <*> children (Syntax.Declare <$> term declareDirective <*> (makeTerm <$> location <*> manyTerm statement)) -- | TODO: Figure out how to parse assignment token -declareDirective :: Assignment Term +declareDirective :: Assignment (Term Loc) declareDirective = makeTerm <$> symbol DeclareDirective <*> children (Syntax.DeclareDirective <$> literal) -echoStatement :: Assignment Term +echoStatement :: Assignment (Term Loc) echoStatement = makeTerm <$> symbol EchoStatement <*> children (Syntax.Echo <$> term expressions) -unsetStatement :: Assignment Term +unsetStatement :: Assignment (Term Loc) unsetStatement = makeTerm <$> symbol UnsetStatement <*> children (Syntax.Unset <$> (makeTerm <$> location <*> someTerm variable)) -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = expression <|> sequenceExpression -sequenceExpression :: Assignment Term +sequenceExpression :: Assignment (Term Loc) sequenceExpression = makeTerm <$> symbol SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) -constDeclaration :: Assignment Term +constDeclaration :: Assignment (Term Loc) constDeclaration = makeTerm <$> symbol ConstDeclaration <*> children (Syntax.ConstDeclaration <$> someTerm constElement) -functionDefinition :: Assignment Term +functionDefinition :: Assignment (Term Loc) functionDefinition = makeTerm <$> symbol FunctionDefinition <*> children (makeFunction <$> term name <*> parameters <*> (term returnType <|> emptyTerm) <*> term compoundStatement) where makeFunction identifier parameters returnType statement = Declaration.Function [returnType] identifier parameters statement -classDeclaration :: Assignment Term +classDeclaration :: Assignment (Term Loc) classDeclaration = makeTerm <$> symbol ClassDeclaration <*> children (makeClass <$> (term classModifier <|> emptyTerm) <*> term name <*> (term classBaseClause <|> emptyTerm) <*> (term classInterfaceClause <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm classMemberDeclaration)) where makeClass modifier name baseClause interfaceClause declarations = Declaration.Class [modifier] name [baseClause, interfaceClause] declarations -interfaceDeclaration :: Assignment Term +interfaceDeclaration :: Assignment (Term Loc) interfaceDeclaration = makeTerm <$> symbol InterfaceDeclaration <*> children (Syntax.InterfaceDeclaration <$> term name <*> (term interfaceBaseClause <|> emptyTerm) <*> manyTerm interfaceMemberDeclaration) -interfaceBaseClause :: Assignment Term +interfaceBaseClause :: Assignment (Term Loc) interfaceBaseClause = makeTerm <$> symbol InterfaceBaseClause <*> children (Syntax.InterfaceBaseClause <$> someTerm qualifiedName) -interfaceMemberDeclaration :: Assignment Term +interfaceMemberDeclaration :: Assignment (Term Loc) interfaceMemberDeclaration = methodDeclaration <|> classConstDeclaration -traitDeclaration :: Assignment Term +traitDeclaration :: Assignment (Term Loc) traitDeclaration = makeTerm <$> symbol TraitDeclaration <*> children (Syntax.TraitDeclaration <$> term name <*> manyTerm traitMemberDeclaration) -traitMemberDeclaration :: Assignment Term +traitMemberDeclaration :: Assignment (Term Loc) traitMemberDeclaration = choice [ propertyDeclaration, methodDeclaration, @@ -668,119 +540,119 @@ traitMemberDeclaration = choice [ traitUseClause ] -propertyDeclaration :: Assignment Term +propertyDeclaration :: Assignment (Term Loc) propertyDeclaration = makeTerm <$> symbol PropertyDeclaration <*> children (Syntax.PropertyDeclaration <$> term propertyModifier <*> someTerm propertyElement) -propertyModifier :: Assignment Term +propertyModifier :: Assignment (Term Loc) propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term accessControlModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . Name.name <$> source)) -propertyElement :: Assignment Term +propertyElement :: Assignment (Term Loc) propertyElement = makeTerm <$> symbol PropertyElement <*> children (Statement.Assignment [] <$> term variableName <*> term propertyInitializer) <|> (symbol PropertyElement *> children (term variableName)) where propertyInitializer = symbol PropertyInitializer *> children (term expression) -constructorDeclaration :: Assignment Term +constructorDeclaration :: Assignment (Term Loc) constructorDeclaration = makeTerm <$> symbol ConstructorDeclaration <*> children (Syntax.ConstructorDeclaration <$> someTerm methodModifier <*> parameters <*> term compoundStatement) -destructorDeclaration :: Assignment Term +destructorDeclaration :: Assignment (Term Loc) destructorDeclaration = makeTerm <$> symbol DestructorDeclaration <*> children (Syntax.DestructorDeclaration <$> someTerm methodModifier <*> term compoundStatement) -methodModifier :: Assignment Term +methodModifier :: Assignment (Term Loc) methodModifier = choice [ accessControlModifier, classModifier, staticModifier ] -staticModifier :: Assignment Term +staticModifier :: Assignment (Term Loc) staticModifier = makeTerm <$> symbol StaticModifier <*> (Syntax.Static <$> source) -classModifier :: Assignment Term +classModifier :: Assignment (Term Loc) classModifier = makeTerm <$> symbol ClassModifier <*> (Syntax.ClassModifier <$> source) -traitUseClause :: Assignment Term +traitUseClause :: Assignment (Term Loc) traitUseClause = makeTerm <$> symbol TraitUseClause <*> children (Syntax.TraitUseClause <$> someTerm qualifiedName <*> (term traitUseSpecification <|> emptyTerm)) -traitUseSpecification :: Assignment Term +traitUseSpecification :: Assignment (Term Loc) traitUseSpecification = makeTerm <$> symbol TraitUseSpecification <*> children (Syntax.TraitUseSpecification <$> manyTerm traitSelectAndAliasClause) -traitSelectAndAliasClause :: Assignment Term +traitSelectAndAliasClause :: Assignment (Term Loc) traitSelectAndAliasClause = traitSelectInsteadOfClause <|> traitAliasAsClause -traitSelectInsteadOfClause :: Assignment Term +traitSelectInsteadOfClause :: Assignment (Term Loc) traitSelectInsteadOfClause = makeTerm <$> symbol TraitSelectInsteadOfClause <*> children (Syntax.InsteadOf <$> term (classConstantAccessExpression <|> name) <*> term name) -traitAliasAsClause :: Assignment Term +traitAliasAsClause :: Assignment (Term Loc) traitAliasAsClause = makeTerm <$> symbol TraitAliasAsClause <*> children (Syntax.AliasAs <$> term (classConstantAccessExpression <|> name) <*> (term accessControlModifier <|> emptyTerm) <*> (term name <|> emptyTerm)) -namespaceDefinition :: Assignment Term +namespaceDefinition :: Assignment (Term Loc) namespaceDefinition = makeTerm <$> symbol NamespaceDefinition <*> children (Syntax.Namespace <$> (toList <$> namespaceName' <|> pure []) <*> (term compoundStatement <|> emptyTerm)) -namespaceUseDeclaration :: Assignment Term +namespaceUseDeclaration :: Assignment (Term Loc) namespaceUseDeclaration = makeTerm <$> symbol NamespaceUseDeclaration <*> children (Syntax.NamespaceUseDeclaration <$> ((mappend <$> (pure <$> (term namespaceFunctionOrConst <|> emptyTerm)) <*> someTerm namespaceUseClause) <|> ((\a b cs -> a : b : cs) <$> term namespaceFunctionOrConst <*> term namespaceName <*> someTerm namespaceUseGroupClause1) <|> ((:) <$> term namespaceName <*> someTerm namespaceUseGroupClause2))) -namespaceUseClause :: Assignment Term +namespaceUseClause :: Assignment (Term Loc) namespaceUseClause = makeTerm <$> symbol NamespaceUseClause <*> children (fmap Syntax.NamespaceUseClause $ (\a b -> [a, b]) <$> term qualifiedName <*> (term namespaceAliasingClause <|> emptyTerm)) -namespaceUseGroupClause1 :: Assignment Term +namespaceUseGroupClause1 :: Assignment (Term Loc) namespaceUseGroupClause1 = makeTerm <$> symbol NamespaceUseGroupClause_1 <*> children (fmap Syntax.NamespaceUseGroupClause $ (\a b -> [a, b]) <$> term namespaceName <*> (term namespaceAliasingClause <|> emptyTerm)) -namespaceUseGroupClause2 :: Assignment Term +namespaceUseGroupClause2 :: Assignment (Term Loc) namespaceUseGroupClause2 = makeTerm <$> symbol NamespaceUseGroupClause_2 <*> children (fmap Syntax.NamespaceUseGroupClause $ (\a b c -> [a, b, c]) <$> (term namespaceFunctionOrConst <|> emptyTerm) <*> term namespaceName <*> (term namespaceAliasingClause <|> emptyTerm)) -namespaceAliasingClause :: Assignment Term +namespaceAliasingClause :: Assignment (Term Loc) namespaceAliasingClause = makeTerm <$> symbol NamespaceAliasingClause <*> children (Syntax.NamespaceAliasingClause <$> term name) -- | TODO Do something better than Identifier -namespaceFunctionOrConst :: Assignment Term +namespaceFunctionOrConst :: Assignment (Term Loc) namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . Name.name <$> source) -globalDeclaration :: Assignment Term +globalDeclaration :: Assignment (Term Loc) globalDeclaration = makeTerm <$> symbol GlobalDeclaration <*> children (Syntax.GlobalDeclaration <$> manyTerm simpleVariable') -simpleVariable :: Assignment Term +simpleVariable :: Assignment (Term Loc) simpleVariable = makeTerm <$> symbol SimpleVariable <*> children (Syntax.SimpleVariable <$> term (simpleVariable' <|> expression)) -simpleVariable' :: Assignment Term +simpleVariable' :: Assignment (Term Loc) simpleVariable' = choice [simpleVariable, variableName] -yieldExpression :: Assignment Term +yieldExpression :: Assignment (Term Loc) yieldExpression = makeTerm <$> symbol YieldExpression <*> children (Statement.Yield <$> term (arrayElementInitializer <|> expression)) -arrayElementInitializer :: Assignment Term +arrayElementInitializer :: Assignment (Term Loc) arrayElementInitializer = makeTerm <$> symbol ArrayElementInitializer <*> children (Literal.KeyValue <$> term expression <*> term expression) <|> (symbol ArrayElementInitializer *> children (term expression)) -includeExpression :: Assignment Term +includeExpression :: Assignment (Term Loc) includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term expression) -includeOnceExpression :: Assignment Term +includeOnceExpression :: Assignment (Term Loc) includeOnceExpression = makeTerm <$> symbol IncludeOnceExpression <*> children (Syntax.IncludeOnce <$> term expression) -requireExpression :: Assignment Term +requireExpression :: Assignment (Term Loc) requireExpression = makeTerm <$> symbol RequireExpression <*> children (Syntax.Require <$> term expression) -requireOnceExpression :: Assignment Term +requireOnceExpression :: Assignment (Term Loc) requireOnceExpression = makeTerm <$> symbol RequireOnceExpression <*> children (Syntax.RequireOnce <$> term expression) -variableName :: Assignment Term +variableName :: Assignment (Term Loc) variableName = makeTerm <$> symbol VariableName <*> children (Syntax.VariableName <$> term name) -name :: Assignment Term +name :: Assignment (Term Loc) name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . Name.name <$> source) -functionStaticDeclaration :: Assignment Term +functionStaticDeclaration :: Assignment (Term Loc) functionStaticDeclaration = makeTerm <$> symbol FunctionStaticDeclaration <*> children (Declaration.VariableDeclaration <$> manyTerm staticVariableDeclaration) -staticVariableDeclaration :: Assignment Term +staticVariableDeclaration :: Assignment (Term Loc) staticVariableDeclaration = makeTerm <$> symbol StaticVariableDeclaration <*> children (Statement.Assignment [] <$> term variableName <*> (term expression <|> emptyTerm)) -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -string :: Assignment Term +string :: Assignment (Term Loc) string = makeTerm <$> (symbol Grammar.String <|> symbol Heredoc) <*> (Literal.TextElement <$> source) @@ -792,25 +664,25 @@ append x xs = xs <> [x] bookend :: a -> [a] -> a -> [a] bookend head_ list last_ = head_ : append last_ list -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term = contextualize (comment <|> textInterpolation) (postContextualize (comment <|> textInterpolation) term) -commentedTerm :: Assignment Term -> Assignment Term +commentedTerm :: Assignment (Term Loc) -> Assignment (Term Loc) commentedTerm term = contextualize (comment <|> textInterpolation) term <|> makeTerm1 <$> (Syntax.Context <$> some1 (comment <|> textInterpolation) <*> emptyTerm) -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment Term -> Assignment [Term] +manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] manyTerm = many . commentedTerm -someTerm :: Assignment Term -> Assignment [Term] +someTerm :: Assignment (Term Loc) -> Assignment [Term Loc] someTerm = fmap NonEmpty.toList . someTerm' -someTerm' :: Assignment Term -> Assignment (NonEmpty Term) +someTerm' :: Assignment (Term Loc) -> Assignment (NonEmpty (Term Loc)) someTerm' = NonEmpty.some1 . commentedTerm -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum PHP.Syntax (Term Loc))] + -> Assignment (Sum PHP.Syntax (Term Loc)) infixTerm = infixContext (comment <|> textInterpolation) diff --git a/src/Language/PHP/Term.hs b/src/Language/PHP/Term.hs new file mode 100644 index 000000000..4a0f8c114 --- /dev/null +++ b/src/Language/PHP/Term.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.PHP.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +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 qualified Data.Syntax.Type as Type +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import qualified Language.PHP.Syntax as Syntax +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Declaration.Class + , Declaration.Function + , Declaration.Method + , Declaration.VariableDeclaration + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.BAnd + , Expression.BOr + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Expression.Call + , Expression.Cast + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.InstanceOf + , Expression.MemberAccess + , Expression.New + , Expression.SequenceExpression + , Expression.Subscript + , Expression.Member + , Literal.Array + , Literal.Float + , Literal.Integer + , Literal.KeyValue + , Literal.TextElement + , Statement.Assignment + , Statement.Break + , Statement.Catch + , Statement.Continue + , Statement.DoWhile + , Statement.Else + , Statement.Finally + , Statement.For + , Statement.ForEach + , Statement.Goto + , Statement.If + , Statement.Match + , Statement.Pattern + , Statement.Return + , Statement.Statements + , Statement.Throw + , Statement.Try + , Statement.While + , Statement.Yield + , Syntax.AliasAs + , Syntax.ArrayElement + , Syntax.BaseTypeDeclaration + , Syntax.CastType + , Syntax.ClassBaseClause + , Syntax.ClassConstDeclaration + , Syntax.ClassInterfaceClause + , Syntax.ClassModifier + , Syntax.Clone + , Syntax.ConstDeclaration + , Syntax.ConstructorDeclaration + , Syntax.Context + , Syntax.Declare + , Syntax.DeclareDirective + , Syntax.DestructorDeclaration + , Syntax.Echo + , Syntax.Empty + , Syntax.EmptyIntrinsic + , Syntax.Error + , Syntax.ErrorControl + , Syntax.EvalIntrinsic + , Syntax.ExitIntrinsic + , Syntax.GlobalDeclaration + , Syntax.Identifier + , Syntax.Include + , Syntax.IncludeOnce + , Syntax.InsteadOf + , Syntax.InterfaceBaseClause + , Syntax.InterfaceDeclaration + , Syntax.IssetIntrinsic + , Syntax.LabeledStatement + , Syntax.Namespace + , Syntax.NamespaceAliasingClause + , Syntax.NamespaceName + , Syntax.NamespaceUseClause + , Syntax.NamespaceUseDeclaration + , Syntax.NamespaceUseGroupClause + , Syntax.NewVariable + , Syntax.PrintIntrinsic + , Syntax.PropertyDeclaration + , Syntax.PropertyModifier + , Syntax.QualifiedName + , Syntax.RelativeScope + , Syntax.Require + , Syntax.RequireOnce + , Syntax.ReturnType + , Syntax.ScalarType + , Syntax.ShellCommand + , Syntax.Concat + , Syntax.SimpleVariable + , Syntax.Static + , Syntax.Text + , Syntax.TraitDeclaration + , Syntax.TraitUseClause + , Syntax.TraitUseSpecification + , Syntax.TypeDeclaration + , Syntax.Unset + , Syntax.Update + , Syntax.UseClause + , Syntax.VariableName + , Type.Annotation + , [] + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index 51e358797..724166759 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.Python.Assignment ( assignment -, Syntax +, Python.Syntax , Grammar -, Term +, Python.Term(..) ) where import Assigning.Assignment hiding (Assignment, Error) @@ -31,104 +30,21 @@ import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term import Language.Python.Syntax as Python.Syntax +import Language.Python.Term as Python import Prologue import TreeSitter.Python as Grammar - --- | The type of Python syntax. -type Syntax = - '[ Comment.Comment - , Declaration.Class - , Declaration.Comprehension - , Declaration.Decorator - , Declaration.Function - , Declaration.RequiredParameter - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.Complement - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.ScopeResolution - , Expression.MemberAccess - , Expression.Subscript - , Expression.Member - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.Set - , Literal.String - , Literal.TextElement - , Literal.Tuple - , Python.Syntax.Alias - , Python.Syntax.Ellipsis - , Python.Syntax.FutureImport - , Python.Syntax.Import - , Python.Syntax.QualifiedImport - , Python.Syntax.QualifiedAliasedImport - , Python.Syntax.Redirect - , Statement.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.Else - , Statement.Finally - , Statement.ForEach - , Statement.If - , Statement.Let - , Statement.NoOp - , Statement.Return - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.Context - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Type.Annotation - , [] - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in Python's grammar onto a program in Python's syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError $ makeTerm <$> symbol Module <*> children (Statement.Statements <$> manyTerm expression) <|> parseError -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = handleError (choice expressionChoices) -expressionChoices :: [Assignment Term] +expressionChoices :: [Assignment (Term Loc)] expressionChoices = -- Long-term, can we de/serialize assignments and avoid paying the cost of construction altogether? [ argumentList @@ -196,34 +112,34 @@ expressionChoices = , yield ] -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = makeTerm'' <$> location <*> manyTerm expression -block :: Assignment Term +block :: Assignment (Term Loc) block = symbol Block *> children (makeTerm'' <$> location <*> manyTerm expression) -block' :: Assignment Term +block' :: Assignment (Term Loc) block' = symbol Block *> children (makeTerm <$> location <*> manyTerm expression) -expressionStatement :: Assignment Term +expressionStatement :: Assignment (Term Loc) expressionStatement = makeTerm'' <$> symbol ExpressionStatement <*> children (someTerm expression) -expressionList :: Assignment Term +expressionList :: Assignment (Term Loc) expressionList = makeTerm'' <$> symbol ExpressionList <*> children (someTerm expression) -listSplat :: Assignment Term +listSplat :: Assignment (Term Loc) listSplat = makeTerm <$> symbol ListSplat <*> (Syntax.Identifier . name <$> source) -dictionarySplat :: Assignment Term +dictionarySplat :: Assignment (Term Loc) dictionarySplat = makeTerm <$> symbol DictionarySplat <*> (Syntax.Identifier . name <$> source) -keywordArgument :: Assignment Term +keywordArgument :: Assignment (Term Loc) keywordArgument = makeTerm <$> symbol KeywordArgument <*> children (Statement.Assignment [] <$> term expression <*> term expression) -parenthesizedExpression :: Assignment Term +parenthesizedExpression :: Assignment (Term Loc) parenthesizedExpression = symbol ParenthesizedExpression *> children expressions -parameter :: Assignment Term +parameter :: Assignment (Term Loc) parameter = makeTerm <$> symbol DefaultParameter <*> children (Statement.Assignment [] <$> term expression <*> term expression) <|> makeTerm <$> symbol TypedParameter <*> children (Type.Annotation <$> term expression <*> term type') <|> makeAnnotation <$> symbol TypedDefaultParameter <*> children ((,,) <$> term expression <*> term expression <*> term expression) @@ -231,45 +147,45 @@ parameter = makeTerm <$> symbol DefaultParameter <*> children (Statement.Assign makeAnnotation loc (identifier', type', value') = makeTerm loc (Type.Annotation (makeAssignment loc identifier' value') type') makeAssignment loc identifier' value' = makeTerm loc (Statement.Assignment [] identifier' value') -decoratedDefinition :: Assignment Term +decoratedDefinition :: Assignment (Term Loc) decoratedDefinition = symbol DecoratedDefinition *> children (term decorator) where decorator = makeTerm <$> symbol Decorator <*> (children (Declaration.Decorator <$> term expression <*> manyTerm expression) <*> term (decorator <|> functionDefinition <|> classDefinition)) -argumentList :: Assignment Term +argumentList :: Assignment (Term Loc) argumentList = symbol ArgumentList *> children expressions -withStatement :: Assignment Term +withStatement :: Assignment (Term Loc) withStatement = symbol WithStatement *> children (flip (foldr make) <$> some withItem <*> term block') where make (val, name) = makeTerm1 . Statement.Let name val withItem = symbol WithItem *> children ((,) <$> term expression <*> term (expression <|> emptyTerm)) -forStatement :: Assignment Term +forStatement :: Assignment (Term Loc) forStatement = symbol ForStatement >>= \ loc -> children (make loc <$> (symbol Variables *> children expressions) <*> term expressionList <*> term block' <*> optional (symbol ElseClause *> children expressions)) where make loc binding subject body forElseClause = case forElseClause of Nothing -> makeTerm loc (Statement.ForEach binding subject body) Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.ForEach binding subject body) a) -whileStatement :: Assignment Term +whileStatement :: Assignment (Term Loc) whileStatement = symbol WhileStatement >>= \ loc -> children (make loc <$> term expression <*> term block <*> optional (symbol ElseClause *> children expressions)) where make loc whileCondition whileBody whileElseClause = case whileElseClause of Nothing -> makeTerm loc (Statement.While whileCondition whileBody) Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.While whileCondition whileBody) a) -tryStatement :: Assignment Term +tryStatement :: Assignment (Term Loc) tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term block <*> manyTerm (expression <|> elseClause)) where elseClause = makeTerm <$> symbol ElseClause <*> children (Statement.Else <$> emptyTerm <*> term block) -exceptClause :: Assignment Term +exceptClause :: Assignment (Term Loc) exceptClause = makeTerm <$> symbol ExceptClause <*> children (Statement.Catch <$> term ((makeTerm <$> location <*> (uncurry (flip Statement.Let) <$> ((,) <$> term expression <* symbol AnonAs <*> term expression) <*> emptyTerm)) <|> expressions) <*> expressions) -functionParam :: Assignment Term +functionParam :: Assignment (Term Loc) functionParam = (makeParameter <$> location <*> identifier) <|> tuple <|> parameter @@ -277,7 +193,7 @@ functionParam = (makeParameter <$> location <*> identifier) <|> dictionarySplat where makeParameter loc term = makeTerm loc (Declaration.RequiredParameter term) -functionDefinition :: Assignment Term +functionDefinition :: Assignment (Term Loc) functionDefinition = makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm functionParam) <*> optional (symbol Type *> children (term expression)) <*> term block') <|> makeFunctionDeclaration <$> (symbol Lambda' <|> symbol Lambda) <*> children ((,,,) <$ token AnonLambda <*> emptyTerm <*> (symbol LambdaParameters *> children (manyTerm expression) <|> pure []) <*> optional (symbol Type *> children (term expression)) <*> expressions') @@ -287,22 +203,22 @@ functionDefinition = = let fn = makeTerm loc (Declaration.Function [] functionName' functionParameters functionBody) in maybe fn (makeTerm loc . Type.Annotation fn) ty -classDefinition :: Assignment Term +classDefinition :: Assignment (Term Loc) classDefinition = makeTerm <$> symbol ClassDefinition <*> children (Declaration.Class [] <$> term expression <*> argumentList <*> term block') where argumentList = symbol ArgumentList *> children (manyTerm expression) <|> pure [] -type' :: Assignment Term +type' :: Assignment (Term Loc) type' = symbol Type *> children (term expression) -finallyClause :: Assignment Term +finallyClause :: Assignment (Term Loc) finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> expressions) -ellipsis :: Assignment Term +ellipsis :: Assignment (Term Loc) ellipsis = makeTerm <$> token Grammar.Ellipsis <*> pure Python.Syntax.Ellipsis -comparisonOperator :: Assignment Term +comparisonOperator :: Assignment (Term Loc) comparisonOperator = symbol ComparisonOperator *> children (expression `chainl1Term` choice [ (makeTerm1 .) . Expression.LessThan <$ token AnonLAngle , (makeTerm1 .) . Expression.LessThanEqual <$ token AnonLAngleEqual @@ -317,19 +233,19 @@ comparisonOperator = symbol ComparisonOperator *> children (expression `chainl1T ]) where invert cons a b = Expression.Not (makeTerm1 (cons a b)) -notOperator :: Assignment Term +notOperator :: Assignment (Term Loc) notOperator = makeTerm <$> symbol NotOperator <*> children (Expression.Not <$> term expression) -tuple :: Assignment Term +tuple :: Assignment (Term Loc) tuple = makeTerm <$> symbol Tuple <*> children (Literal.Tuple <$> manyTerm expression) -unaryOperator :: Assignment Term +unaryOperator :: Assignment (Term Loc) unaryOperator = symbol UnaryOperator >>= \ location -> arithmetic location <|> bitwise location <|> children ( symbol AnonPlus *> term expression ) where arithmetic location = makeTerm location . Expression.Negate <$> children ( symbol AnonMinus *> term expression ) bitwise location = makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> term expression ) -binaryOperator :: Assignment Term +binaryOperator :: Assignment (Term Loc) binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm expression (term expression) [ (inject .) . Expression.Plus <$ symbol AnonPlus , (inject .) . Expression.Minus <$ symbol AnonMinus @@ -346,13 +262,13 @@ binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm exp , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle ]) -booleanOperator :: Assignment Term +booleanOperator :: Assignment (Term Loc) booleanOperator = makeTerm' <$> symbol BooleanOperator <*> children (infixTerm expression (term expression) [ (inject .) . Expression.And <$ symbol AnonAnd , (inject .) . Expression.Or <$ symbol AnonOr ]) -assignment' :: Assignment Term +assignment' :: Assignment (Term Loc) assignment' = makeAssignment <$> symbol Assignment <*> children ((,,) <$> term expressionList <*> optional (symbol Type *> children (term expression)) <*> term rvalue) <|> makeTerm' <$> symbol AugmentedAssignment <*> children (infixTerm expressionList (term rvalue) [ assign Expression.Plus <$ symbol AnonPlusEqual @@ -371,43 +287,43 @@ assignment' = makeAssignment <$> symbol Assignment <*> children ((,,) <$> term ]) where rvalue = expressionList <|> assignment' <|> yield <|> emptyTerm makeAssignment loc (lhs, maybeType, rhs) = makeTerm loc (Statement.Assignment (maybeToList maybeType) lhs rhs) - assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term + assign :: (f :< Python.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Python.Syntax (Term Loc) assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r))) -yield :: Assignment Term +yield :: Assignment (Term Loc) yield = makeTerm <$> symbol Yield <*> (Statement.Yield <$> children (term ( expression <|> emptyTerm ))) -identifier :: Assignment Term +identifier :: Assignment (Term Loc) identifier = makeTerm <$> (symbol Identifier <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source) -set :: Assignment Term +set :: Assignment (Term Loc) set = makeTerm <$> symbol Set <*> children (Literal.Set <$> manyTerm expression) -dictionary :: Assignment Term +dictionary :: Assignment (Term Loc) dictionary = makeTerm <$> symbol Dictionary <*> children (Literal.Hash <$> manyTerm expression) -pair :: Assignment Term +pair :: Assignment (Term Loc) pair = makeTerm' <$> symbol Pair <*> children (infixTerm expression (term expression) [ (inject .) . Literal.KeyValue <$ symbol AnonColon ]) -list' :: Assignment Term +list' :: Assignment (Term Loc) list' = makeTerm <$> symbol List <*> children (Literal.Array <$> manyTerm expression) -string :: Assignment Term +string :: Assignment (Term Loc) string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) -concatenatedString :: Assignment Term +concatenatedString :: Assignment (Term Loc) concatenatedString = makeTerm <$> symbol ConcatenatedString <*> children (manyTerm string) -float :: Assignment Term +float :: Assignment (Term Loc) float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) -integer :: Assignment Term +integer :: Assignment (Term Loc) integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -import' :: Assignment Term +import' :: Assignment (Term Loc) import' = makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliasedImport <|> plainImport)) <|> makeTerm <$> symbol ImportFromStatement <*> children (Python.Syntax.Import <$> importPath <*> (wildcard <|> some (aliasImportSymbol <|> importSymbol))) <|> makeTerm <$> symbol FutureImportStatement <*> children (Python.Syntax.FutureImport <$> some (aliasImportSymbol <|> importSymbol)) @@ -432,10 +348,10 @@ import' = makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliase makeNameAliasPair location alias = makeTerm location (Python.Syntax.Alias alias alias) mkIdentifier location source = makeTerm location (Syntax.Identifier (name source)) -assertStatement :: Assignment Term +assertStatement :: Assignment (Term Loc) assertStatement = makeTerm <$> symbol AssertStatement <*> children (Expression.Call [] <$> (makeTerm <$> symbol AnonAssert <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) -printStatement :: Assignment Term +printStatement :: Assignment (Term Loc) printStatement = do location <- symbol PrintStatement children $ do @@ -446,26 +362,26 @@ printStatement = do redirectCallTerm location identifier = makeTerm location <$ symbol Chevron <*> (flip Python.Syntax.Redirect <$> children (term expression) <*> term (printCallTerm location identifier)) printCallTerm location identifier = makeTerm location <$> (Expression.Call [] identifier <$> manyTerm expression <*> emptyTerm) -nonlocalStatement :: Assignment Term +nonlocalStatement :: Assignment (Term Loc) nonlocalStatement = makeTerm <$> symbol NonlocalStatement <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonNonlocal <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) -globalStatement :: Assignment Term +globalStatement :: Assignment (Term Loc) globalStatement = makeTerm <$> symbol GlobalStatement <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonGlobal <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) -await :: Assignment Term +await :: Assignment (Term Loc) await = makeTerm <$> symbol Await <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonAwait <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) -returnStatement :: Assignment Term +returnStatement :: Assignment (Term Loc) returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> term (expressionList <|> emptyTerm)) -deleteStatement :: Assignment Term +deleteStatement :: Assignment (Term Loc) deleteStatement = makeTerm <$> symbol DeleteStatement <*> children (Expression.Call [] <$> term deleteIdentifier <* symbol ExpressionList <*> children (manyTerm expression) <*> emptyTerm) where deleteIdentifier = makeTerm <$> symbol AnonDel <*> (Syntax.Identifier . name <$> source) -raiseStatement :: Assignment Term +raiseStatement :: Assignment (Term Loc) raiseStatement = makeTerm <$> symbol RaiseStatement <*> children (Statement.Throw <$> expressions) -ifStatement :: Assignment Term +ifStatement :: Assignment (Term Loc) ifStatement = makeTerm <$> symbol IfStatement <*> children if' where if' = Statement.If <$> term expression <*> thenClause <*> (elseClause <|> emptyTerm) @@ -474,86 +390,86 @@ ifStatement = makeTerm <$> symbol IfStatement <*> children if' elif = makeTerm <$> symbol ElifClause <*> children if' else' = symbol ElseClause *> children expressions -execStatement :: Assignment Term +execStatement :: Assignment (Term Loc) execStatement = makeTerm <$> symbol ExecStatement <*> children (Expression.Call [] <$> term (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> manyTerm (string <|> expression) <*> emptyTerm) -passStatement :: Assignment Term +passStatement :: Assignment (Term Loc) passStatement = makeTerm <$> symbol PassStatement <*> (Statement.NoOp <$> emptyTerm <* advance) -breakStatement :: Assignment Term +breakStatement :: Assignment (Term Loc) breakStatement = makeTerm <$> symbol BreakStatement <*> (Statement.Break <$> emptyTerm <* advance) -continueStatement :: Assignment Term +continueStatement :: Assignment (Term Loc) continueStatement = makeTerm <$> symbol ContinueStatement <*> (Statement.Continue <$> emptyTerm <* advance) -memberAccess :: Assignment Term +memberAccess :: Assignment (Term Loc) memberAccess = makeTerm <$> symbol Attribute <*> children (Expression.MemberAccess <$> term expression <*> identifier) -subscript :: Assignment Term +subscript :: Assignment (Term Loc) subscript = makeTerm <$> symbol Subscript <*> children (Expression.Subscript <$> term expression <*> manyTerm expression) -slice :: Assignment Term +slice :: Assignment (Term Loc) slice = makeTerm <$> symbol Slice <*> children (Expression.Enumeration <$> ((emptyTerm <* token AnonColon) <|> (term expression <* token AnonColon)) <*> ((emptyTerm <* token AnonColon) <|> (term expression <* token AnonColon) <|> (term expression <|> emptyTerm)) <*> (term expression <|> emptyTerm)) -call :: Assignment Term +call :: Assignment (Term Loc) call = makeTerm <$> symbol Call <*> children (Expression.Call [] <$> term (identifier <|> expression) <*> (symbol ArgumentList *> children (manyTerm expression) <|> someTerm comprehension) <*> emptyTerm) -boolean :: Assignment Term +boolean :: Assignment (Term Loc) boolean = makeTerm <$> token Grammar.True <*> pure Literal.true <|> makeTerm <$> token Grammar.False <*> pure Literal.false -none :: Assignment Term +none :: Assignment (Term Loc) none = makeTerm <$> symbol None <*> (Literal.Null <$ rawSource) -comprehension :: Assignment Term +comprehension :: Assignment (Term Loc) comprehension = makeTerm <$> symbol ListComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) <|> makeTerm <$> symbol GeneratorExpression <*> children (Declaration.Comprehension <$> term expression <*> expressions) <|> makeTerm <$> symbol SetComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) <|> makeTerm <$> symbol DictionaryComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) -forInClause :: Assignment Term +forInClause :: Assignment (Term Loc) forInClause = symbol ForInClause *> children expressions -variables :: Assignment Term +variables :: Assignment (Term Loc) variables = symbol Variables *> children expressions -ifClause :: Assignment Term +ifClause :: Assignment (Term Loc) ifClause = symbol IfClause *> children expressions -conditionalExpression :: Assignment Term +conditionalExpression :: Assignment (Term Loc) conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (flip Statement.If <$> term expression <*> term expression <*> expressions) -- Helpers -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment Term -> Assignment [Term] +manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) -someTerm :: Assignment Term -> Assignment [Term] +someTerm :: Assignment (Term Loc) -> Assignment [Term Loc] someTerm term = some (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term = contextualize comment (postContextualize comment term) -term' :: Assignment Term -> Assignment Term +term' :: Assignment (Term Loc) -> Assignment (Term Loc) term' term = contextualize comment' (postContextualize comment' term) where comment' = choice [ comment, symbol AnonLambda *> empty ] -- | Match a left-associated infix chain of terms, optionally followed by comments. Like 'chainl1' but assigning comment nodes automatically. -chainl1Term :: Assignment Term -> Assignment (Term -> Term -> Term) -> Assignment Term +chainl1Term :: Assignment (Term Loc) -> Assignment (Term Loc -> Term Loc -> Term Loc) -> Assignment (Term Loc) chainl1Term expr op = term' expr `chainl1` op -- | Match a series of terms or comments until a delimiter is matched. -manyTermsTill :: Assignment Term -> Assignment b -> Assignment [Term] +manyTermsTill :: Assignment (Term Loc) -> Assignment b -> Assignment [Term Loc] manyTermsTill step end = manyTill (step <|> comment) end -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum Python.Syntax (Term Loc))] + -> Assignment (Sum Python.Syntax (Term Loc)) infixTerm = infixContext comment diff --git a/src/Language/Python/Term.hs b/src/Language/Python/Term.hs new file mode 100644 index 000000000..12e996eb9 --- /dev/null +++ b/src/Language/Python/Term.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.Python.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +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 qualified Data.Syntax.Type as Type +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import Language.Python.Syntax as Python.Syntax +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Declaration.Class + , Declaration.Comprehension + , Declaration.Decorator + , Declaration.Function + , Declaration.RequiredParameter + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Expression.BAnd + , Expression.BOr + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.Complement + , Expression.Call + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.Enumeration + , Expression.ScopeResolution + , Expression.MemberAccess + , Expression.Subscript + , Expression.Member + , Literal.Array + , Literal.Boolean + , Literal.Float + , Literal.Hash + , Literal.Integer + , Literal.KeyValue + , Literal.Null + , Literal.Set + , Literal.String + , Literal.TextElement + , Literal.Tuple + , Python.Syntax.Alias + , Python.Syntax.Ellipsis + , Python.Syntax.FutureImport + , Python.Syntax.Import + , Python.Syntax.QualifiedImport + , Python.Syntax.QualifiedAliasedImport + , Python.Syntax.Redirect + , Statement.Assignment + , Statement.Break + , Statement.Catch + , Statement.Continue + , Statement.Else + , Statement.Finally + , Statement.ForEach + , Statement.If + , Statement.Let + , Statement.NoOp + , Statement.Return + , Statement.Statements + , Statement.Throw + , Statement.Try + , Statement.While + , Statement.Yield + , Syntax.Context + , Syntax.Empty + , Syntax.Error + , Syntax.Identifier + , Type.Annotation + , [] + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 6b88f4f7f..a3a791d2a 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.Ruby.Assignment ( assignment -, Syntax +, Ruby.Syntax , Grammar -, Term +, Ruby.Term(..) ) where import Prologue hiding (for, unless) @@ -34,112 +33,20 @@ import qualified Data.Syntax.Directive as Directive import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement -import qualified Data.Term as Term import qualified Language.Ruby.Syntax as Ruby.Syntax +import Language.Ruby.Term as Ruby import TreeSitter.Ruby as Grammar --- | The type of Ruby syntax. -type Syntax = '[ - Comment.Comment - , Declaration.Function - , Declaration.Method - , Directive.File - , Directive.Line - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.Matches - , Expression.NotMatches - , Expression.MemberAccess - , Expression.ScopeResolution - , Expression.Subscript - , Expression.Member - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Character - , Literal.Complex - , Literal.EscapeSequence - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.InterpolationElement - , Literal.KeyValue - , Literal.Null - , Literal.Rational - , Literal.Regex - , Literal.String - , Literal.Symbol - , Literal.SymbolElement - , Literal.TextElement - , Ruby.Syntax.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.Else - , Statement.Finally - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.Context - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Ruby.Syntax.Class - , Ruby.Syntax.Load - , Ruby.Syntax.LowPrecedenceAnd - , Ruby.Syntax.LowPrecedenceOr - , Ruby.Syntax.Module - , Ruby.Syntax.Require - , Ruby.Syntax.Send - , Ruby.Syntax.ZSuper - , [] - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> many expression) <|> parseError -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = term (handleError (choice expressionChoices)) -expressionChoices :: [Assignment Term] +expressionChoices :: [Assignment (Term Loc)] expressionChoices = [ alias , assignment' @@ -187,10 +94,10 @@ expressionChoices = where mk s construct = makeTerm <$> symbol s <*> children ((construct .) . fromMaybe <$> emptyTerm <*> optional (symbol ArgumentList *> children expressions)) -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = makeTerm'' <$> location <*> many expression -parenthesizedExpressions :: Assignment Term +parenthesizedExpressions :: Assignment (Term Loc) parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (many expression) withExtendedScope :: Assignment a -> Assignment a @@ -206,7 +113,7 @@ withNewScope inner = withExtendedScope $ do inner -- Looks up identifiers in the list of locals to determine vcall vs. local identifier. -identifier :: Assignment Term +identifier :: Assignment (Term Loc) identifier = vcallOrLocal <|> zsuper @@ -234,11 +141,11 @@ identifier = then pure identTerm else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing) -self :: Assignment Term +self :: Assignment (Term Loc) self = makeTerm <$> symbol Self <*> (Expression.This <$ source) -- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc). -literal :: Assignment Term +literal :: Assignment (Term Loc) literal = makeTerm <$> token Grammar.True <*> pure Literal.true <|> makeTerm <$> token Grammar.False <*> pure Literal.false @@ -261,47 +168,47 @@ literal = <|> makeTerm <$> symbol Regex <*> (Literal.Regex <$> source) where - string :: Assignment Term + string :: Assignment (Term Loc) string = makeTerm' <$> (symbol String <|> symbol BareString) <*> (children (inject . Literal.String <$> some (interpolation <|> escapeSequence)) <|> inject . Literal.TextElement <$> source) - symbol' :: Assignment Term + symbol' :: Assignment (Term Loc) symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol BareSymbol) <*> (children (inject . Literal.Symbol <$> some interpolation) <|> inject . Literal.SymbolElement <$> source) -interpolation :: Assignment Term +interpolation :: Assignment (Term Loc) interpolation = makeTerm <$> symbol Interpolation <*> children (Literal.InterpolationElement <$> expression) -escapeSequence :: Assignment Term +escapeSequence :: Assignment (Term Loc) escapeSequence = makeTerm <$> symbol EscapeSequence <*> (Literal.EscapeSequence <$> source) -heredoc :: Assignment Term +heredoc :: Assignment (Term Loc) heredoc = makeTerm <$> symbol HeredocBeginning <*> (Literal.TextElement <$> source) <|> makeTerm <$> symbol HeredocBody <*> children (some (interpolation <|> escapeSequence <|> heredocEnd)) where heredocEnd = makeTerm <$> symbol HeredocEnd <*> (Literal.TextElement <$> source) -beginBlock :: Assignment Term +beginBlock :: Assignment (Term Loc) beginBlock = makeTerm <$> symbol BeginBlock <*> children (Statement.ScopeEntry <$> many expression) -endBlock :: Assignment Term +endBlock :: Assignment (Term Loc) endBlock = makeTerm <$> symbol EndBlock <*> children (Statement.ScopeExit <$> many expression) -class' :: Assignment Term +class' :: Assignment (Term Loc) class' = makeTerm <$> symbol Class <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> optional superclass <*> expressions) where - superclass :: Assignment Term + superclass :: Assignment (Term Loc) superclass = symbol Superclass *> children expression -singletonClass :: Assignment Term +singletonClass :: Assignment (Term Loc) singletonClass = makeTerm <$> symbol SingletonClass <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> pure Nothing <*> expressions) -module' :: Assignment Term +module' :: Assignment (Term Loc) module' = makeTerm <$> symbol Module <*> (withNewScope . children) (Ruby.Syntax.Module <$> expression <*> many expression) -scopeResolution :: Assignment Term +scopeResolution :: Assignment (Term Loc) scopeResolution = makeTerm <$> symbol ScopeResolution <*> children (Expression.ScopeResolution <$> NonEmpty.some1 expression) -parameter :: Assignment Term +parameter :: Assignment (Term Loc) parameter = postContextualize comment (term uncontextualizedParameter) where uncontextualizedParameter = @@ -328,40 +235,40 @@ parameter = postContextualize comment (term uncontextualizedParameter) publicAccessControl :: ScopeGraph.AccessControl publicAccessControl = ScopeGraph.Public -method :: Assignment Term +method :: Assignment (Term Loc) method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method [] <$> emptyTerm <*> methodSelector <*> params <*> expressions' <*> pure publicAccessControl) where params = symbol MethodParameters *> children (many parameter) <|> pure [] expressions' = makeTerm <$> location <*> many expression -singletonMethod :: Assignment Term +singletonMethod :: Assignment (Term Loc) singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withNewScope . children) (Declaration.Method [] <$> expression <*> methodSelector <*> params <*> expressions <*> pure publicAccessControl) where params = symbol MethodParameters *> children (many parameter) <|> pure [] -lambda :: Assignment Term +lambda :: Assignment (Term Loc) lambda = makeTerm <$> symbol Lambda <*> (withExtendedScope . children) ( Declaration.Function [] <$> emptyTerm <*> ((symbol BlockParameters <|> symbol LambdaParameters) *> children (many parameter) <|> pure []) <*> expressions) -block :: Assignment Term +block :: Assignment (Term Loc) block = makeTerm <$> symbol DoBlock <*> scopedBlockChildren <|> makeTerm <$> symbol Block <*> scopedBlockChildren where scopedBlockChildren = withExtendedScope blockChildren blockChildren = children (Declaration.Function [] <$> emptyTerm <*> params <*> expressions) params = symbol BlockParameters *> children (many parameter) <|> pure [] -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -alias :: Assignment Term +alias :: Assignment (Term Loc) alias = makeTerm <$> symbol Alias <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) -undef :: Assignment Term +undef :: Assignment (Term Loc) undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) -if' :: Assignment Term +if' :: Assignment (Term Loc) if' = ifElsif If <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> expression <*> expression <*> emptyTerm) where @@ -370,30 +277,30 @@ if' = ifElsif If expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof) else' = postContextualize comment (symbol Else *> children expressions) -then' :: Assignment Term +then' :: Assignment (Term Loc) then' = postContextualize comment (symbol Then *> children expressions) -unless :: Assignment Term +unless :: Assignment (Term Loc) unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert expression <*> expressions' <*> (else' <|> emptyTerm)) <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> expression <*> invert expression <*> emptyTerm) where expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> eof) else' = postContextualize comment (symbol Else *> children expressions) -while' :: Assignment Term +while' :: Assignment (Term Loc) while' = makeTerm <$> symbol While <*> children (Statement.While <$> expression <*> expressions) <|> makeTerm <$> symbol WhileModifier <*> children (flip Statement.While <$> expression <*> expression) -until' :: Assignment Term +until' :: Assignment (Term Loc) until' = makeTerm <$> symbol Until <*> children (Statement.While <$> invert expression <*> expressions) <|> makeTerm <$> symbol UntilModifier <*> children (flip Statement.While <$> expression <*> invert expression) -for :: Assignment Term +for :: Assignment (Term Loc) for = makeTerm <$> symbol For <*> children (Statement.ForEach <$> (makeTerm <$> location <*> manyTermsTill expression (symbol In)) <*> inClause <*> expressions) where inClause = symbol In *> children expression -case' :: Assignment Term +case' :: Assignment (Term Loc) case' = makeTerm <$> symbol Case <*> children (Statement.Match <$> (symbol When *> emptyTerm <|> expression) <*> whens) where whens = makeTerm <$> location <*> many (when' <|> else' <|> expression) @@ -401,16 +308,16 @@ case' = makeTerm <$> symbol Case <*> children (Statement.Match <$> (symbol When pattern' = postContextualize comment (symbol Pattern *> children ((symbol SplatArgument *> children expression) <|> expression)) else' = postContextualize comment (symbol Else *> children expressions) -subscript :: Assignment Term +subscript :: Assignment (Term Loc) subscript = makeTerm <$> symbol ElementReference <*> children (Expression.Subscript <$> expression <*> many expression) -pair :: Assignment Term +pair :: Assignment (Term Loc) pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> (expression <|> emptyTerm)) -args :: Assignment [Term] +args :: Assignment [Term Loc] args = (symbol ArgumentList <|> symbol ArgumentListWithParens) *> children (many expression) <|> many expression -methodCall :: Assignment Term +methodCall :: Assignment (Term Loc) methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|> send) where send = inject <$> ((regularCall <|> funcCall <|> scopeCall <|> dotCall) <*> optional block) @@ -431,7 +338,7 @@ methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|> (symbol ArgumentList <|> symbol ArgumentListWithParens) *> children (Ruby.Syntax.Load <$> expression <*> optional expression) nameExpression = (symbol ArgumentList <|> symbol ArgumentListWithParens) *> children expression -methodSelector :: Assignment Term +methodSelector :: Assignment (Term Loc) methodSelector = makeTerm <$> symbols <*> (Syntax.Identifier <$> (name <$> source)) where symbols = symbol Identifier @@ -440,12 +347,12 @@ methodSelector = makeTerm <$> symbols <*> (Syntax.Identifier <$> (name <$> sourc <|> symbol Setter <|> symbol Super -- TODO(@charliesome): super calls are *not* method calls and need to be assigned into their own syntax terms -call :: Assignment Term +call :: Assignment (Term Loc) call = makeTerm <$> symbol Call <*> children ( (Ruby.Syntax.Send <$> (Just <$> term expression) <*> (Just <$> methodSelector) <*> pure [] <*> pure Nothing) <|> (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args <*> pure Nothing)) -rescue :: Assignment Term +rescue :: Assignment (Term Loc) rescue = rescue' <|> makeTerm <$> symbol RescueModifier <*> children (Statement.Try <$> expression <*> many (makeTerm <$> location <*> (Statement.Catch <$> expression <*> emptyTerm))) <|> makeTerm <$> symbol Ensure <*> children (Statement.Finally <$> expressions) @@ -456,10 +363,10 @@ rescue = rescue' ex = makeTerm <$> symbol Exceptions <*> children (many expression) <|> makeTerm <$> symbol ExceptionVariable <*> children (many expression) -begin :: Assignment Term +begin :: Assignment (Term Loc) begin = makeTerm <$> symbol Begin <*> children (Statement.Try <$> expressions <*> many rescue) -assignment' :: Assignment Term +assignment' :: Assignment (Term Loc) assignment' = makeTerm <$> symbol Assignment <*> children (Ruby.Syntax.Assignment [] <$> lhs <*> rhs) <|> makeTerm' <$> symbol OperatorAssignment <*> children (infixTerm lhs expression [ assign Expression.Plus <$ symbol AnonPlusEqual @@ -477,7 +384,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Ruby.Syntax. , assign Expression.BXOr <$ symbol AnonCaretEqual ]) where - assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term + assign :: (f :< Ruby.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Ruby.Syntax (Term Loc) assign c l r = inject (Ruby.Syntax.Assignment [] l (makeTerm1 (c l r))) lhs = makeTerm <$> symbol LeftAssignmentList <*> children (many expr) <|> expr @@ -495,13 +402,13 @@ identWithLocals = do ident <- source pure (loc, ident, locals) -lhsIdent :: Assignment Term +lhsIdent :: Assignment (Term Loc) lhsIdent = do (loc, ident, locals) <- identWithLocals putLocals (ident : locals) pure $ makeTerm loc (Syntax.Identifier (name ident)) -unary :: Assignment Term +unary :: Assignment (Term Loc) unary = symbol Unary >>= \ location -> makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> expression ) <|> makeTerm location . Expression.Not <$> children ( symbol AnonBang *> expression ) @@ -511,7 +418,7 @@ unary = symbol Unary >>= \ location -> <|> children ( symbol AnonPlus *> expression ) -- TODO: Distinguish `===` from `==` ? -binary :: Assignment Term +binary :: Assignment (Term Loc) binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression [ (inject .) . Expression.Plus <$ symbol AnonPlus , (inject .) . Expression.Minus <$ (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') @@ -544,30 +451,30 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi ]) where invert cons a b = Expression.Not (makeTerm1 (cons a b)) -conditional :: Assignment Term +conditional :: Assignment (Term Loc) conditional = makeTerm <$> symbol Conditional <*> children (Statement.If <$> expression <*> expression <*> expression) -emptyStatement :: Assignment Term +emptyStatement :: Assignment (Term Loc) emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) -- Helpers -invert :: Assignment Term -> Assignment Term +invert :: Assignment (Term Loc) -> Assignment (Term Loc) invert term = makeTerm <$> location <*> fmap Expression.Not term -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term = contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 (comment <|> heredocEnd) <*> emptyTerm) where heredocEnd = makeTerm <$> symbol HeredocEnd <*> (Literal.TextElement <$> source) -- | Match a series of terms or comments until a delimiter is matched. -manyTermsTill :: Assignment Term -> Assignment b -> Assignment [Term] +manyTermsTill :: Assignment (Term Loc) -> Assignment b -> Assignment [Term Loc] manyTermsTill step end = manyTill (step <|> comment) end -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum Ruby.Syntax (Term Loc))] + -> Assignment (Sum Ruby.Syntax (Term Loc)) infixTerm = infixContext comment diff --git a/src/Language/Ruby/Term.hs b/src/Language/Ruby/Term.hs new file mode 100644 index 000000000..21dc713cb --- /dev/null +++ b/src/Language/Ruby/Term.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.Ruby.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +import qualified Data.Syntax.Declaration as Declaration +import qualified Data.Syntax.Directive as Directive +import qualified Data.Syntax.Expression as Expression +import qualified Data.Syntax.Literal as Literal +import qualified Data.Syntax.Statement as Statement +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import qualified Language.Ruby.Syntax as Ruby.Syntax +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Declaration.Function + , Declaration.Method + , Directive.File + , Directive.Line + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.BAnd + , Expression.BOr + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.Complement + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Expression.Call + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.Enumeration + , Expression.Matches + , Expression.NotMatches + , Expression.MemberAccess + , Expression.ScopeResolution + , Expression.Subscript + , Expression.Member + , Expression.This + , Literal.Array + , Literal.Boolean + , Literal.Character + , Literal.Complex + , Literal.EscapeSequence + , Literal.Float + , Literal.Hash + , Literal.Integer + , Literal.InterpolationElement + , Literal.KeyValue + , Literal.Null + , Literal.Rational + , Literal.Regex + , Literal.String + , Literal.Symbol + , Literal.SymbolElement + , Literal.TextElement + , Ruby.Syntax.Assignment + , Statement.Break + , Statement.Catch + , Statement.Continue + , Statement.Else + , Statement.Finally + , Statement.ForEach + , Statement.If + , Statement.Match + , Statement.Pattern + , Statement.Retry + , Statement.Return + , Statement.ScopeEntry + , Statement.ScopeExit + , Statement.Statements + , Statement.Try + , Statement.While + , Statement.Yield + , Syntax.Context + , Syntax.Empty + , Syntax.Error + , Syntax.Identifier + , Ruby.Syntax.Class + , Ruby.Syntax.Load + , Ruby.Syntax.LowPrecedenceAnd + , Ruby.Syntax.LowPrecedenceOr + , Ruby.Syntax.Module + , Ruby.Syntax.Require + , Ruby.Syntax.Send + , Ruby.Syntax.ZSuper + , [] + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/TSX/Assignment.hs b/src/Language/TSX/Assignment.hs index 88ada82b2..8a2ad7f7d 100644 --- a/src/Language/TSX/Assignment.hs +++ b/src/Language/TSX/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.TSX.Assignment ( assignment -, Syntax +, TSX.Syntax , Grammar -, Term +, TSX.Term(..) ) where import Assigning.Assignment hiding (Assignment, Error) @@ -31,191 +30,19 @@ import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term import qualified Language.TSX.Syntax as TSX.Syntax import qualified Language.TypeScript.Resolution as TypeScript.Resolution +import Language.TSX.Term as TSX import Prologue import TreeSitter.TSX as Grammar --- | The type of TSX syntax. -type Syntax = '[ - Comment.Comment - , Comment.HashBang - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.InterfaceDeclaration - , Declaration.PublicFieldDefinition - , Declaration.VariableDeclaration - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.MemberAccess - , Expression.NonNullExpression - , Expression.ScopeResolution - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Expression.Delete - , Expression.Void - , Expression.Typeof - , Expression.InstanceOf - , Expression.New - , Expression.Await - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.String - , Literal.TextElement - , Literal.Regex - , Statement.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AccessibilityModifier - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Syntax.Context - , Type.Readonly - , Type.TypeParameters - , TSX.Syntax.TypeParameter - , TSX.Syntax.Constraint - , TSX.Syntax.ParenthesizedType - , TSX.Syntax.DefaultType - , TSX.Syntax.PredefinedType - , TSX.Syntax.TypeIdentifier - , TSX.Syntax.NestedIdentifier - , TSX.Syntax.NestedTypeIdentifier - , TSX.Syntax.GenericType - , TSX.Syntax.TypeArguments - , TSX.Syntax.TypePredicate - , TSX.Syntax.CallSignature - , TSX.Syntax.ConstructSignature - , TSX.Syntax.ArrayType - , TSX.Syntax.LookupType - , TSX.Syntax.FlowMaybeType - , TSX.Syntax.TypeQuery - , TSX.Syntax.IndexTypeQuery - , TSX.Syntax.ThisType - , TSX.Syntax.ExistentialType - , TSX.Syntax.AbstractMethodSignature - , TSX.Syntax.IndexSignature - , TSX.Syntax.ObjectType - , TSX.Syntax.LiteralType - , TSX.Syntax.Union - , TSX.Syntax.Intersection - , TSX.Syntax.Module - , TSX.Syntax.InternalModule - , TSX.Syntax.FunctionType - , TSX.Syntax.Tuple - , TSX.Syntax.Constructor - , TSX.Syntax.TypeAssertion - , TSX.Syntax.ImportAlias - , TSX.Syntax.Debugger - , TSX.Syntax.ShorthandPropertyIdentifier - , TSX.Syntax.Super - , TSX.Syntax.Undefined - , TSX.Syntax.ClassHeritage - , TSX.Syntax.AbstractClass - , TSX.Syntax.ImplementsClause - , TSX.Syntax.JsxElement - , TSX.Syntax.JsxSelfClosingElement - , TSX.Syntax.JsxOpeningElement - , TSX.Syntax.JsxText - , TSX.Syntax.JsxClosingElement - , TSX.Syntax.JsxExpression - , TSX.Syntax.JsxAttribute - , TSX.Syntax.JsxFragment - , TSX.Syntax.JsxNamespaceName - , TSX.Syntax.OptionalParameter - , TSX.Syntax.RequiredParameter - , TSX.Syntax.RestParameter - , TSX.Syntax.PropertySignature - , TSX.Syntax.AmbientDeclaration - , TSX.Syntax.EnumDeclaration - , TSX.Syntax.ExtendsClause - , TSX.Syntax.AmbientFunction - , TSX.Syntax.ImportRequireClause - , TSX.Syntax.ImportClause - , TSX.Syntax.LabeledStatement - , TSX.Syntax.Annotation - , TSX.Syntax.With - , TSX.Syntax.ForOf - , TSX.Syntax.Update - , TSX.Syntax.ComputedPropertyName - , TSX.Syntax.Decorator - , TSX.Syntax.Import - , TSX.Syntax.QualifiedAliasedImport - , TSX.Syntax.SideEffectImport - , TSX.Syntax.DefaultExport - , TSX.Syntax.QualifiedExport - , TSX.Syntax.QualifiedExportFrom - , TSX.Syntax.JavaScriptRequire - , [] - , Statement.StatementBlock - , TSX.Syntax.MetaProperty - , TSX.Syntax.AnnotatedExpression - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = handleError everything where everything = choice [ @@ -256,13 +83,13 @@ expression = handleError everything identifier ] -undefined' :: Assignment Term +undefined' :: Assignment (Term Loc) undefined' = makeTerm <$> symbol Grammar.Undefined <*> (TSX.Syntax.Undefined <$ rawSource) -assignmentExpression :: Assignment Term +assignmentExpression :: Assignment (Term Loc) assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression) -augmentedAssignmentExpression :: Assignment Term +augmentedAssignmentExpression :: Assignment (Term Loc) augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [ assign Expression.Plus <$ symbol AnonPlusEqual , assign Expression.Minus <$ symbol AnonMinusEqual @@ -276,14 +103,14 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual , assign Expression.BOr <$ symbol AnonPipeEqual ]) - where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term + where assign :: (f :< TSX.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum TSX.Syntax (Term Loc) assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r))) -awaitExpression :: Assignment Term +awaitExpression :: Assignment (Term Loc) awaitExpression = makeTerm <$> symbol Grammar.AwaitExpression <*> children (Expression.Await <$> term expression) -unaryExpression :: Assignment Term +unaryExpression :: Assignment (Term Loc) unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> makeTerm loc . Expression.Not <$> children (symbol AnonBang *> term expression) <|> makeTerm loc . Expression.Complement <$> children (symbol AnonTilde *> term expression) @@ -292,16 +119,16 @@ unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> <|> makeTerm loc . Expression.Void <$> children (symbol AnonVoid *> term expression) <|> makeTerm loc . Expression.Delete <$> children (symbol AnonDelete *> term expression) -ternaryExpression :: Assignment Term +ternaryExpression :: Assignment (Term Loc) ternaryExpression = makeTerm <$> symbol Grammar.TernaryExpression <*> children (Statement.If <$> term expression <*> term expression <*> term expression) -memberExpression :: Assignment Term +memberExpression :: Assignment (Term Loc) memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier) -newExpression :: Assignment Term +newExpression :: Assignment (Term Loc) newExpression = makeTerm <$> symbol Grammar.NewExpression <*> children (Expression.New <$> term constructableExpression <*> (typeArguments' <|> emptyTerm) <*> (arguments <|> pure [])) -constructableExpression :: Assignment Term +constructableExpression :: Assignment (Term Loc) constructableExpression = choice [ this , identifier @@ -325,77 +152,77 @@ constructableExpression = choice [ , newExpression ] -metaProperty :: Assignment Term +metaProperty :: Assignment (Term Loc) metaProperty = makeTerm <$> symbol Grammar.MetaProperty <*> (TSX.Syntax.MetaProperty <$ rawSource) -updateExpression :: Assignment Term +updateExpression :: Assignment (Term Loc) updateExpression = makeTerm <$> symbol Grammar.UpdateExpression <*> children (TSX.Syntax.Update <$> term expression) -yieldExpression :: Assignment Term +yieldExpression :: Assignment (Term Loc) yieldExpression = makeTerm <$> symbol Grammar.YieldExpression <*> children (Statement.Yield <$> term (expression <|> emptyTerm)) -this :: Assignment Term +this :: Assignment (Term Loc) this = makeTerm <$> symbol Grammar.This <*> (Expression.This <$ rawSource) -regex :: Assignment Term +regex :: Assignment (Term Loc) regex = makeTerm <$> symbol Grammar.Regex <*> (Literal.Regex <$> source) -null' :: Assignment Term +null' :: Assignment (Term Loc) null' = makeTerm <$> symbol Null <*> (Literal.Null <$ rawSource) -abstractClass :: Assignment Term +abstractClass :: Assignment (Term Loc) abstractClass = makeTerm <$> symbol Grammar.AbstractClassDeclaration <*> children (TSX.Syntax.AbstractClass <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements) -abstractMethodSignature :: Assignment Term +abstractMethodSignature :: Assignment (Term Loc) abstractMethodSignature = makeSignature <$> symbol Grammar.AbstractMethodSignature <*> children ((,,) <$> accessibilityModifier' <*> term propertyName <*> callSignatureParts) where makeSignature loc (modifier, propertyName, (typeParams, params, annotation)) = makeTerm loc (TSX.Syntax.AbstractMethodSignature [typeParams, annotation] propertyName params modifier) -classHeritage' :: Assignment [Term] +classHeritage' :: Assignment [Term Loc] classHeritage' = symbol Grammar.ClassHeritage *> children ((mappend `on` toList) <$> optional (term extendsClause) <*> optional (term implementsClause')) -extendsClause :: Assignment Term +extendsClause :: Assignment (Term Loc) extendsClause = makeTerm <$> symbol Grammar.ExtendsClause <*> children (TSX.Syntax.ExtendsClause <$> manyTerm (typeReference <|> expression)) -typeReference :: Assignment Term +typeReference :: Assignment (Term Loc) typeReference = typeIdentifier <|> nestedTypeIdentifier <|> genericType -implementsClause' :: Assignment Term +implementsClause' :: Assignment (Term Loc) implementsClause' = makeTerm <$> symbol Grammar.ImplementsClause <*> children (TSX.Syntax.ImplementsClause <$> manyTerm ty) -super :: Assignment Term +super :: Assignment (Term Loc) super = makeTerm <$> symbol Grammar.Super <*> (TSX.Syntax.Super <$ rawSource) -asExpression :: Assignment Term +asExpression :: Assignment (Term Loc) asExpression = makeTerm <$> symbol AsExpression <*> children (Expression.Cast <$> term expression <*> term (ty <|> templateString)) -templateString :: Assignment Term +templateString :: Assignment (Term Loc) templateString = makeTerm <$> symbol TemplateString <*> children (Literal.String <$> manyTerm templateSubstitution) -templateSubstitution :: Assignment Term +templateSubstitution :: Assignment (Term Loc) templateSubstitution = symbol TemplateSubstitution *> children (term expressions) -nonNullExpression' :: Assignment Term +nonNullExpression' :: Assignment (Term Loc) nonNullExpression' = makeTerm <$> symbol Grammar.NonNullExpression <*> children (Expression.NonNullExpression <$> term expression) -importAlias' :: Assignment Term +importAlias' :: Assignment (Term Loc) importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TSX.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier)) -number :: Assignment Term +number :: Assignment (Term Loc) number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source) -string :: Assignment Term +string :: Assignment (Term Loc) string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source) -true :: Assignment Term +true :: Assignment (Term Loc) true = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ rawSource) -false :: Assignment Term +false :: Assignment (Term Loc) false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) -identifier :: Assignment Term +identifier :: Assignment (Term Loc) identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier . name <$> source) -class' :: Assignment Term +class' :: Assignment (Term Loc) class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ((,,,,) <$> manyTerm decorator <*> (term typeIdentifier <|> emptyTerm) <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) @@ -403,66 +230,66 @@ class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ( <*> classBodyStatements) where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators <> typeParams) expression classHeritage statements) -object :: Assignment Term +object :: Assignment (Term Loc) object = makeTerm <$> (symbol Object <|> symbol ObjectPattern) <*> children (Literal.Hash <$> manyTerm (pair <|> spreadElement <|> methodDefinition <|> assignmentPattern <|> shorthandPropertyIdentifier)) -array :: Assignment Term +array :: Assignment (Term Loc) array = makeTerm <$> (symbol Array <|> symbol ArrayPattern) <*> children (Literal.Array <$> manyTerm (expression <|> spreadElement)) -jsxElement' :: Assignment Term +jsxElement' :: Assignment (Term Loc) jsxElement' = choice [ jsxElement, jsxSelfClosingElement ] -jsxElement :: Assignment Term +jsxElement :: Assignment (Term Loc) jsxElement = makeTerm <$> symbol Grammar.JsxElement <*> children (TSX.Syntax.JsxElement <$> term jsxOpeningElement' <*> manyTerm jsxChild <*> term jsxClosingElement') -jsxFragment :: Assignment Term +jsxFragment :: Assignment (Term Loc) jsxFragment = makeTerm <$> symbol Grammar.JsxFragment <*> children (TSX.Syntax.JsxFragment <$> manyTerm jsxChild) -jsxChild :: Assignment Term +jsxChild :: Assignment (Term Loc) jsxChild = choice [ jsxElement', jsxExpression', jsxText ] -jsxSelfClosingElement :: Assignment Term +jsxSelfClosingElement :: Assignment (Term Loc) jsxSelfClosingElement = makeTerm <$> symbol Grammar.JsxSelfClosingElement <*> children (TSX.Syntax.JsxSelfClosingElement <$> term jsxElementName <*> manyTerm jsxAttribute') -jsxAttribute' :: Assignment Term +jsxAttribute' :: Assignment (Term Loc) jsxAttribute' = jsxAttribute <|> jsxExpression' -jsxOpeningElement' :: Assignment Term +jsxOpeningElement' :: Assignment (Term Loc) jsxOpeningElement' = makeTerm <$> symbol Grammar.JsxOpeningElement <*> children (TSX.Syntax.JsxOpeningElement <$> term jsxElementName <*> term (typeArguments' <|> emptyTerm) <*> manyTerm jsxAttribute') -jsxElementName :: Assignment Term +jsxElementName :: Assignment (Term Loc) jsxElementName = choice [ identifier, nestedIdentifier, jsxNamespaceName ] -jsxNamespaceName :: Assignment Term +jsxNamespaceName :: Assignment (Term Loc) jsxNamespaceName = makeTerm <$> symbol Grammar.JsxNamespaceName <*> children (TSX.Syntax.JsxNamespaceName <$> identifier <*> identifier) -jsxExpression' :: Assignment Term +jsxExpression' :: Assignment (Term Loc) jsxExpression' = makeTerm <$> symbol Grammar.JsxExpression <*> children (TSX.Syntax.JsxExpression <$> term (expressions <|> spreadElement <|> emptyTerm)) -jsxText :: Assignment Term +jsxText :: Assignment (Term Loc) jsxText = makeTerm <$> symbol Grammar.JsxText <*> (TSX.Syntax.JsxText <$> source) -jsxClosingElement' :: Assignment Term +jsxClosingElement' :: Assignment (Term Loc) jsxClosingElement' = makeTerm <$> symbol Grammar.JsxClosingElement <*> children (TSX.Syntax.JsxClosingElement <$> term jsxElementName) -jsxAttribute :: Assignment Term +jsxAttribute :: Assignment (Term Loc) jsxAttribute = makeTerm <$> symbol Grammar.JsxAttribute <*> children (TSX.Syntax.JsxAttribute <$> term (propertyIdentifier <|> jsxNamespaceName) <*> (term jsxAttributeValue <|> emptyTerm)) where jsxAttributeValue = choice [ string, jsxExpression', jsxElement', jsxFragment ] -propertyIdentifier :: Assignment Term +propertyIdentifier :: Assignment (Term Loc) propertyIdentifier = makeTerm <$> symbol PropertyIdentifier <*> (Syntax.Identifier . name <$> source) -sequenceExpression :: Assignment Term +sequenceExpression :: Assignment (Term Loc) sequenceExpression = makeTerm <$> symbol Grammar.SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = annotatedExpression <|> expression <|> sequenceExpression -annotatedExpression :: Assignment Term +annotatedExpression :: Assignment (Term Loc) annotatedExpression = mkAnnotated <$> location <*> expression <*> typeAnnotation' where mkAnnotated loc expr ann = makeTerm loc (TSX.Syntax.AnnotatedExpression expr ann) -parameter :: Assignment Term +parameter :: Assignment (Term Loc) parameter = requiredParameter <|> restParameter <|> optionalParameter @@ -475,23 +302,23 @@ accessibilityModifier' = (symbol AccessibilityModifier >> children (public <|> p default' = pure ScopeGraph.Public -destructuringPattern :: Assignment Term +destructuringPattern :: Assignment (Term Loc) destructuringPattern = object <|> array -spreadElement :: Assignment Term +spreadElement :: Assignment (Term Loc) spreadElement = symbol SpreadElement *> children (term expression) -readonly' :: Assignment Term +readonly' :: Assignment (Term Loc) readonly' = makeTerm <$> symbol Readonly <*> (Type.Readonly <$ rawSource) -methodDefinition :: Assignment Term +methodDefinition :: Assignment (Term Loc) methodDefinition = makeMethod <$> symbol MethodDefinition <*> children ((,,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> emptyTerm <*> term propertyName <*> callSignatureParts <*> term statementBlock) where makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [readonly, typeParameters', ty'] receiver propertyName' params statements modifier) -callSignatureParts :: Assignment (Term, [Term], Term) +callSignatureParts :: Assignment (Term Loc, [Term Loc], Term Loc) callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> callSignature' <*> many comment) where callSignature' = (,,) <$> (term typeParameters <|> emptyTerm) <*> formalParameters <*> (term typeAnnotation' <|> emptyTerm) @@ -502,20 +329,20 @@ callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postCont Just cs -> (typeParams, formalParams, makeTerm1 (Syntax.Context cs annotation)) Nothing -> (typeParams, formalParams, annotation) -callSignature :: Assignment Term +callSignature :: Assignment (Term Loc) callSignature = makeTerm <$> symbol Grammar.CallSignature <*> children (TSX.Syntax.CallSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) -constructSignature :: Assignment Term +constructSignature :: Assignment (Term Loc) constructSignature = makeTerm <$> symbol Grammar.ConstructSignature <*> children (TSX.Syntax.ConstructSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) -indexSignature :: Assignment Term +indexSignature :: Assignment (Term Loc) indexSignature = makeTerm <$> symbol Grammar.IndexSignature <*> children (TSX.Syntax.IndexSignature <$> term identifier <*> predefinedTy <*> term typeAnnotation') -methodSignature :: Assignment Term +methodSignature :: Assignment (Term Loc) methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> callSignatureParts) where makeMethodSignature loc (accessControl, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (Declaration.MethodSignature [readonly, typeParams, annotation] propertyName params accessControl) -formalParameters :: Assignment [Term] +formalParameters :: Assignment [Term Loc] formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of @@ -526,37 +353,37 @@ formalParameters = symbol FormalParameters *> children (contextualize' <$> Assig Nothing -> formalParams -decorator :: Assignment Term +decorator :: Assignment (Term Loc) decorator = makeTerm <$> symbol Grammar.Decorator <*> children (TSX.Syntax.Decorator <$> term (identifier <|> memberExpression <|> callExpression)) -typeParameters :: Assignment Term +typeParameters :: Assignment (Term Loc) typeParameters = makeTerm <$> symbol TypeParameters <*> children (Type.TypeParameters <$> manyTerm typeParameter') -typeAnnotation' :: Assignment Term +typeAnnotation' :: Assignment (Term Loc) typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TSX.Syntax.Annotation <$> term ty) -typeParameter' :: Assignment Term +typeParameter' :: Assignment (Term Loc) typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TSX.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) -defaultType :: Assignment Term +defaultType :: Assignment (Term Loc) defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TSX.Syntax.DefaultType <$> term ty) -constraint :: Assignment Term +constraint :: Assignment (Term Loc) constraint = makeTerm <$> symbol Grammar.Constraint <*> children (TSX.Syntax.Constraint <$> term ty) -function :: Assignment Term +function :: Assignment (Term Loc) function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.FunctionDeclaration <|> symbol Grammar.GeneratorFunction <|> symbol Grammar.GeneratorFunctionDeclaration) <*> children ((,,) <$> term (identifier <|> emptyTerm) <*> callSignatureParts <*> term statementBlock) where makeFunction loc (id, (typeParams, params, annotation), statements) = makeTerm loc (Declaration.Function [typeParams, annotation] id params statements) -- TODO: FunctionSignatures can, but don't have to be ambient functions. -ambientFunction :: Assignment Term +ambientFunction :: Assignment (Term Loc) ambientFunction = makeAmbientFunction <$> symbol Grammar.FunctionSignature <*> children ((,) <$> term identifier <*> callSignatureParts) where makeAmbientFunction loc (id, (typeParams, params, annotation)) = makeTerm loc (TSX.Syntax.AmbientFunction [typeParams, annotation] id params) -ty :: Assignment Term +ty :: Assignment (Term Loc) ty = primaryType <|> unionType <|> intersectionType <|> functionTy <|> constructorTy -primaryType :: Assignment Term +primaryType :: Assignment (Term Loc) primaryType = arrayTy <|> existentialType <|> flowMaybeTy @@ -574,76 +401,76 @@ primaryType = arrayTy <|> typePredicate <|> typeQuery -parenthesizedTy :: Assignment Term +parenthesizedTy :: Assignment (Term Loc) parenthesizedTy = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (TSX.Syntax.ParenthesizedType <$> term ty) -predefinedTy :: Assignment Term +predefinedTy :: Assignment (Term Loc) predefinedTy = makeTerm <$> symbol Grammar.PredefinedType <*> (TSX.Syntax.PredefinedType <$> source) -typeIdentifier :: Assignment Term +typeIdentifier :: Assignment (Term Loc) typeIdentifier = makeTerm <$> symbol Grammar.TypeIdentifier <*> (TSX.Syntax.TypeIdentifier <$> source) -nestedIdentifier :: Assignment Term +nestedIdentifier :: Assignment (Term Loc) nestedIdentifier = makeTerm <$> symbol Grammar.NestedIdentifier <*> children (TSX.Syntax.NestedIdentifier <$> term (identifier <|> nestedIdentifier) <*> term identifier) -nestedTypeIdentifier :: Assignment Term +nestedTypeIdentifier :: Assignment (Term Loc) nestedTypeIdentifier = makeTerm <$> symbol Grammar.NestedTypeIdentifier <*> children (TSX.Syntax.NestedTypeIdentifier <$> term (identifier <|> nestedIdentifier) <*> term typeIdentifier) -genericType :: Assignment Term +genericType :: Assignment (Term Loc) genericType = makeTerm <$> symbol Grammar.GenericType <*> children (TSX.Syntax.GenericType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term typeArguments') -typeArguments' :: Assignment Term +typeArguments' :: Assignment (Term Loc) typeArguments' = makeTerm <$> symbol Grammar.TypeArguments <*> children (TSX.Syntax.TypeArguments <$> some (term ty)) -typePredicate :: Assignment Term +typePredicate :: Assignment (Term Loc) typePredicate = makeTerm <$> symbol Grammar.TypePredicate <*> children (TSX.Syntax.TypePredicate <$> term identifier <*> term ty) -objectType :: Assignment Term +objectType :: Assignment (Term Loc) objectType = makeTerm <$> symbol Grammar.ObjectType <*> children (TSX.Syntax.ObjectType <$> manyTerm (exportStatement <|> propertySignature <|> callSignature <|> constructSignature <|> indexSignature <|> methodSignature)) -arrayTy :: Assignment Term +arrayTy :: Assignment (Term Loc) arrayTy = makeTerm <$> symbol Grammar.ArrayType <*> children (TSX.Syntax.ArrayType <$> term ty) -lookupType :: Assignment Term +lookupType :: Assignment (Term Loc) lookupType = makeTerm <$> symbol Grammar.LookupType <*> children (TSX.Syntax.LookupType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term ty) -flowMaybeTy :: Assignment Term +flowMaybeTy :: Assignment (Term Loc) flowMaybeTy = makeTerm <$> symbol Grammar.FlowMaybeType <*> children (TSX.Syntax.FlowMaybeType <$> term primaryType) -typeQuery :: Assignment Term +typeQuery :: Assignment (Term Loc) typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TSX.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) -indexTypeQuery :: Assignment Term +indexTypeQuery :: Assignment (Term Loc) indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TSX.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) -existentialType :: Assignment Term +existentialType :: Assignment (Term Loc) existentialType = makeTerm <$> symbol Grammar.ExistentialType <*> (TSX.Syntax.ExistentialType <$> source) -literalType :: Assignment Term +literalType :: Assignment (Term Loc) literalType = makeTerm <$> symbol Grammar.LiteralType <*> children (TSX.Syntax.LiteralType <$> term (number <|> string <|> true <|> false)) -unionType :: Assignment Term +unionType :: Assignment (Term Loc) unionType = makeTerm <$> symbol UnionType <*> children (TSX.Syntax.Union <$> (term ty <|> emptyTerm) <*> term ty) -intersectionType :: Assignment Term +intersectionType :: Assignment (Term Loc) intersectionType = makeTerm <$> symbol IntersectionType <*> children (TSX.Syntax.Intersection <$> term ty <*> term ty) -functionTy :: Assignment Term +functionTy :: Assignment (Term Loc) functionTy = makeTerm <$> symbol Grammar.FunctionType <*> children (TSX.Syntax.FunctionType <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) -tupleType :: Assignment Term +tupleType :: Assignment (Term Loc) tupleType = makeTerm <$> symbol TupleType <*> children (TSX.Syntax.Tuple <$> manyTerm ty) -constructorTy :: Assignment Term +constructorTy :: Assignment (Term Loc) constructorTy = makeTerm <$> symbol ConstructorType <*> children (TSX.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) -statementTerm :: Assignment Term +statementTerm :: Assignment (Term Loc) statementTerm = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement) -statementBlock :: Assignment Term +statementBlock :: Assignment (Term Loc) statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.StatementBlock <$> manyTerm statement) -classBodyStatements :: Assignment Term +classBodyStatements :: Assignment (Term Loc) classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of @@ -653,12 +480,12 @@ classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualiz Just cs -> formalParams <> toList cs Nothing -> formalParams -publicFieldDefinition :: Assignment Term +publicFieldDefinition :: Assignment (Term Loc) publicFieldDefinition = makeField <$> symbol Grammar.PublicFieldDefinition <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) where makeField loc (accessControl, readonly, propertyName, annotation, expression) = makeTerm loc (Declaration.PublicFieldDefinition [readonly, annotation] propertyName expression accessControl) -statement :: Assignment Term +statement :: Assignment (Term Loc) statement = handleError everything where everything = choice [ @@ -684,37 +511,37 @@ statement = handleError everything , emptyStatement , labeledStatement ] -forInStatement :: Assignment Term +forInStatement :: Assignment (Term Loc) forInStatement = makeTerm <$> symbol ForInStatement <*> children (Statement.ForEach <$> term expression <*> term expression <*> term statement) -doStatement :: Assignment Term +doStatement :: Assignment (Term Loc) doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression) -continueStatement :: Assignment Term +continueStatement :: Assignment (Term Loc) continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm)) -breakStatement :: Assignment Term +breakStatement :: Assignment (Term Loc) breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm)) -withStatement :: Assignment Term +withStatement :: Assignment (Term Loc) withStatement = makeTerm <$> symbol WithStatement <*> children (TSX.Syntax.With <$> term parenthesizedExpression <*> term statement) -returnStatement :: Assignment Term +returnStatement :: Assignment (Term Loc) returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm)) -throwStatement :: Assignment Term +throwStatement :: Assignment (Term Loc) throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions) -hashBang :: Assignment Term +hashBang :: Assignment (Term Loc) hashBang = makeTerm <$> symbol HashBangLine <*> (Comment.HashBang <$> source) -labeledStatement :: Assignment Term +labeledStatement :: Assignment (Term Loc) labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TSX.Syntax.LabeledStatement <$> statementIdentifier <*> term statement) -statementIdentifier :: Assignment Term +statementIdentifier :: Assignment (Term Loc) statementIdentifier = makeTerm <$> symbol StatementIdentifier <*> (Syntax.Identifier . name <$> source) -importStatement :: Assignment Term +importStatement :: Assignment (Term Loc) importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> children ((,) <$> importClause <*> fromClause) <|> makeTerm' <$> symbol Grammar.ImportStatement <*> children (requireImport <|> sideEffectImport) where @@ -746,16 +573,16 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr makeNameAliasPair from (Just alias) = (from, alias) makeNameAliasPair from Nothing = (from, from) - -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. + -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.Term (Sum TSX.Syntax). fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) -debuggerStatement :: Assignment Term +debuggerStatement :: Assignment (Term Loc) debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TSX.Syntax.Debugger <$ rawSource) -expressionStatement' :: Assignment Term +expressionStatement' :: Assignment (Term Loc) expressionStatement' = symbol ExpressionStatement *> children (term expressions) -declaration :: Assignment Term +declaration :: Assignment (Term Loc) declaration = everything where everything = choice [ @@ -774,24 +601,24 @@ declaration = everything ambientDeclaration ] -typeAliasDeclaration :: Assignment Term +typeAliasDeclaration :: Assignment (Term Loc) typeAliasDeclaration = makeTypeAliasDecl <$> symbol Grammar.TypeAliasDeclaration <*> children ((,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> term ty) where makeTypeAliasDecl loc (identifier, typeParams, body) = makeTerm loc (Declaration.TypeAlias [typeParams] identifier body) -enumDeclaration :: Assignment Term +enumDeclaration :: Assignment (Term Loc) enumDeclaration = makeTerm <$> symbol Grammar.EnumDeclaration <*> children (TSX.Syntax.EnumDeclaration <$> term identifier <*> (symbol EnumBody *> children (manyTerm (propertyName <|> enumAssignment)))) -enumAssignment :: Assignment Term +enumAssignment :: Assignment (Term Loc) enumAssignment = makeTerm <$> symbol Grammar.EnumAssignment <*> children (Statement.Assignment [] <$> term propertyName <*> term expression) -interfaceDeclaration :: Assignment Term +interfaceDeclaration :: Assignment (Term Loc) interfaceDeclaration = makeInterfaceDecl <$> symbol Grammar.InterfaceDeclaration <*> children ((,,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> optional (term extendsClause) <*> term objectType) where makeInterfaceDecl loc (identifier, typeParams, clause, objectType) = makeTerm loc (Declaration.InterfaceDeclaration [typeParams] identifier (toList clause) objectType) -ambientDeclaration :: Assignment Term +ambientDeclaration :: Assignment (Term Loc) ambientDeclaration = makeTerm <$> symbol Grammar.AmbientDeclaration <*> children (TSX.Syntax.AmbientDeclaration <$> term (choice [propertyIdentifier *> ty, declaration, statementBlock])) -exportStatement :: Assignment Term +exportStatement :: Assignment (Term Loc) exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip TSX.Syntax.QualifiedExportFrom <$> exportClause <*> fromClause) <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TSX.Syntax.QualifiedExport <$> exportClause) <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TSX.Syntax.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias'))) @@ -802,26 +629,26 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip makeNameAliasPair from (Just alias) = TSX.Syntax.Alias from alias makeNameAliasPair from Nothing = TSX.Syntax.Alias from from rawIdentifier = symbol Identifier *> (name <$> source) - -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. + -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.Term (Sum TSX.Syntax). fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) -propertySignature :: Assignment Term +propertySignature :: Assignment (Term Loc) propertySignature = makePropertySignature <$> symbol Grammar.PropertySignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm)) where makePropertySignature loc (modifier, readonly, propertyName, annotation) = makeTerm loc (TSX.Syntax.PropertySignature [readonly, annotation] propertyName modifier) -propertyName :: Assignment Term +propertyName :: Assignment (Term Loc) propertyName = term (propertyIdentifier <|> string <|> number <|> computedPropertyName) -computedPropertyName :: Assignment Term +computedPropertyName :: Assignment (Term Loc) computedPropertyName = makeTerm <$> symbol Grammar.ComputedPropertyName <*> children (TSX.Syntax.ComputedPropertyName <$> term expression) -assignmentPattern :: Assignment Term +assignmentPattern :: Assignment (Term Loc) assignmentPattern = makeTerm <$> symbol AssignmentPattern <*> children (Statement.Assignment [] <$> term shorthandPropertyIdentifier <*> term expression) -shorthandPropertyIdentifier :: Assignment Term +shorthandPropertyIdentifier :: Assignment (Term Loc) shorthandPropertyIdentifier = makeTerm <$> symbol Grammar.ShorthandPropertyIdentifier <*> (TSX.Syntax.ShorthandPropertyIdentifier <$> source) -requiredParameter :: Assignment Term +requiredParameter :: Assignment (Term Loc) requiredParameter = makeRequiredParameter <$> symbol Grammar.RequiredParameter <*> children ( (,,,,) @@ -833,44 +660,44 @@ requiredParameter = makeRequiredParameter where makeRequiredParameter loc (modifier, readonly, identifier, annotation, initializer) = makeTerm loc (TSX.Syntax.RequiredParameter [readonly, annotation] identifier initializer modifier) -restParameter :: Assignment Term +restParameter :: Assignment (Term Loc) restParameter = makeRestParameter <$> symbol Grammar.RestParameter <*> children ((,) <$> term identifier <*> (term typeAnnotation' <|> emptyTerm)) where makeRestParameter loc (identifier, annotation) = makeTerm loc (TSX.Syntax.RestParameter [annotation] identifier) -optionalParameter :: Assignment Term +optionalParameter :: Assignment (Term Loc) optionalParameter = makeOptionalParam <$> symbol Grammar.OptionalParameter <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> (term identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) where makeOptionalParam loc (modifier, readonly, subject, annotation, initializer) = makeTerm loc (TSX.Syntax.OptionalParameter [readonly, annotation] (makeTerm loc (Statement.Assignment [] subject initializer)) modifier) -internalModule :: Assignment Term +internalModule :: Assignment (Term Loc) internalModule = makeTerm <$> symbol Grammar.InternalModule <*> children (TSX.Syntax.InternalModule <$> term (string <|> identifier <|> nestedIdentifier) <*> statements) -module' :: Assignment Term +module' :: Assignment (Term Loc) module' = makeTerm <$> symbol Module <*> children (TSX.Syntax.Module <$> term (string <|> identifier <|> nestedIdentifier) <*> (statements <|> pure [])) -statements :: Assignment [Term] +statements :: Assignment [Term Loc] statements = symbol StatementBlock *> children (manyTerm statement) -arrowFunction :: Assignment Term +arrowFunction :: Assignment (Term Loc) arrowFunction = makeArrowFun <$> symbol ArrowFunction <*> children ((,,) <$> emptyTerm <*> (((\a b c -> (a, [b], c)) <$> emptyTerm <*> term identifier <*> emptyTerm) <|> callSignatureParts) <*> term (expression <|> statementBlock)) where makeArrowFun loc (identifier, (typeParams, params, returnTy), body) = makeTerm loc (Declaration.Function [ typeParams, returnTy ] identifier params body) -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -ifStatement :: Assignment Term +ifStatement :: Assignment (Term Loc) ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term parenthesizedExpression <*> term statement <*> (term statement <|> emptyTerm)) -whileStatement :: Assignment Term +whileStatement :: Assignment (Term Loc) whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> term expression <*> term statement) -forStatement :: Assignment Term +forStatement :: Assignment (Term Loc) forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> term (variableDeclaration <|> expressionStatement' <|> emptyStatement) <*> term (expressionStatement' <|> emptyStatement) <*> term (expressions <|> emptyTerm) <*> term statement) -variableDeclaration :: Assignment Term +variableDeclaration :: Assignment (Term Loc) variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator) -variableDeclarator :: Assignment Term +variableDeclarator :: Assignment (Term Loc) variableDeclarator = makeTerm <$> symbol VariableDeclarator <*> children (TSX.Syntax.JavaScriptRequire <$> identifier <*> requireCall) <|> makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) @@ -884,37 +711,37 @@ variableDeclarator = ) -parenthesizedExpression :: Assignment Term +parenthesizedExpression :: Assignment (Term Loc) parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions) -switchStatement :: Assignment Term +switchStatement :: Assignment (Term Loc) switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody) where switchBody = symbol SwitchBody *> children (makeTerm <$> location <*> manyTerm switchCase) switchCase = makeTerm <$> (symbol SwitchCase <|> symbol SwitchDefault) <*> children (Statement.Pattern <$> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) -subscriptExpression :: Assignment Term +subscriptExpression :: Assignment (Term Loc) subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term expression <*> (pure <$> term expressions)) -pair :: Assignment Term +pair :: Assignment (Term Loc) pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term propertyName <*> term expression) -callExpression :: Assignment Term +callExpression :: Assignment (Term Loc) callExpression = makeCall <$> (symbol CallExpression <|> symbol CallExpression') <*> children ((,,,) <$> term (expression <|> super <|> function) <*> (typeArguments <|> pure []) <*> (arguments <|> (pure <$> term templateString)) <*> emptyTerm) where makeCall loc (subject, typeArgs, args, body) = makeTerm loc (Expression.Call typeArgs subject args body) typeArguments = symbol Grammar.TypeArguments *> children (some (term ty)) -arguments :: Assignment [Term] +arguments :: Assignment [Term Loc] arguments = symbol Arguments *> children (manyTerm (expression <|> spreadElement)) -tryStatement :: Assignment Term +tryStatement :: Assignment (Term Loc) tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term statementTerm <*> optional (term catchClause) <*> optional (term finallyClause)) where makeTry loc (statementBlock', catch, finally) = makeTerm loc (Statement.Try statementBlock' (catMaybes [catch, finally])) catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (identifier <|> emptyTerm) <*> statementTerm) finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> statementTerm) -binaryExpression :: Assignment Term +binaryExpression :: Assignment (Term Loc) binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression) [ (inject .) . Expression.Plus <$ symbol AnonPlus , (inject .) . Expression.Minus <$ symbol AnonMinus @@ -946,18 +773,18 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm -- Helpers -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment Term -> Assignment [Term] +manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term = contextualize comment (postContextualize comment term) -emptyStatement :: Assignment Term +emptyStatement :: Assignment (Term Loc) emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum TSX.Syntax (Term Loc))] + -> Assignment (Sum TSX.Syntax (Term Loc)) infixTerm = infixContext comment diff --git a/src/Language/TSX/Term.hs b/src/Language/TSX/Term.hs new file mode 100644 index 000000000..9f51ed114 --- /dev/null +++ b/src/Language/TSX/Term.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.TSX.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +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 qualified Data.Syntax.Type as Type +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import qualified Language.TSX.Syntax as TSX.Syntax +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Comment.HashBang + , Declaration.Class + , Declaration.Function + , Declaration.Method + , Declaration.MethodSignature + , Declaration.InterfaceDeclaration + , Declaration.PublicFieldDefinition + , Declaration.VariableDeclaration + , Declaration.TypeAlias + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.BAnd + , Expression.BOr + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.UnsignedRShift + , Expression.Complement + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Expression.Call + , Expression.Cast + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.Enumeration + , Expression.MemberAccess + , Expression.NonNullExpression + , Expression.ScopeResolution + , Expression.SequenceExpression + , Expression.Subscript + , Expression.Member + , Expression.Delete + , Expression.Void + , Expression.Typeof + , Expression.InstanceOf + , Expression.New + , Expression.Await + , Expression.This + , Literal.Array + , Literal.Boolean + , Literal.Float + , Literal.Hash + , Literal.Integer + , Literal.KeyValue + , Literal.Null + , Literal.String + , Literal.TextElement + , Literal.Regex + , Statement.Assignment + , Statement.Break + , Statement.Catch + , Statement.Continue + , Statement.DoWhile + , Statement.Else + , Statement.Finally + , Statement.For + , Statement.ForEach + , Statement.If + , Statement.Match + , Statement.Pattern + , Statement.Retry + , Statement.Return + , Statement.ScopeEntry + , Statement.ScopeExit + , Statement.Statements + , Statement.Throw + , Statement.Try + , Statement.While + , Statement.Yield + , Syntax.AccessibilityModifier + , Syntax.Empty + , Syntax.Error + , Syntax.Identifier + , Syntax.Context + , Type.Readonly + , Type.TypeParameters + , TSX.Syntax.TypeParameter + , TSX.Syntax.Constraint + , TSX.Syntax.ParenthesizedType + , TSX.Syntax.DefaultType + , TSX.Syntax.PredefinedType + , TSX.Syntax.TypeIdentifier + , TSX.Syntax.NestedIdentifier + , TSX.Syntax.NestedTypeIdentifier + , TSX.Syntax.GenericType + , TSX.Syntax.TypeArguments + , TSX.Syntax.TypePredicate + , TSX.Syntax.CallSignature + , TSX.Syntax.ConstructSignature + , TSX.Syntax.ArrayType + , TSX.Syntax.LookupType + , TSX.Syntax.FlowMaybeType + , TSX.Syntax.TypeQuery + , TSX.Syntax.IndexTypeQuery + , TSX.Syntax.ThisType + , TSX.Syntax.ExistentialType + , TSX.Syntax.AbstractMethodSignature + , TSX.Syntax.IndexSignature + , TSX.Syntax.ObjectType + , TSX.Syntax.LiteralType + , TSX.Syntax.Union + , TSX.Syntax.Intersection + , TSX.Syntax.Module + , TSX.Syntax.InternalModule + , TSX.Syntax.FunctionType + , TSX.Syntax.Tuple + , TSX.Syntax.Constructor + , TSX.Syntax.TypeAssertion + , TSX.Syntax.ImportAlias + , TSX.Syntax.Debugger + , TSX.Syntax.ShorthandPropertyIdentifier + , TSX.Syntax.Super + , TSX.Syntax.Undefined + , TSX.Syntax.ClassHeritage + , TSX.Syntax.AbstractClass + , TSX.Syntax.ImplementsClause + , TSX.Syntax.JsxElement + , TSX.Syntax.JsxSelfClosingElement + , TSX.Syntax.JsxOpeningElement + , TSX.Syntax.JsxText + , TSX.Syntax.JsxClosingElement + , TSX.Syntax.JsxExpression + , TSX.Syntax.JsxAttribute + , TSX.Syntax.JsxFragment + , TSX.Syntax.JsxNamespaceName + , TSX.Syntax.OptionalParameter + , TSX.Syntax.RequiredParameter + , TSX.Syntax.RestParameter + , TSX.Syntax.PropertySignature + , TSX.Syntax.AmbientDeclaration + , TSX.Syntax.EnumDeclaration + , TSX.Syntax.ExtendsClause + , TSX.Syntax.AmbientFunction + , TSX.Syntax.ImportRequireClause + , TSX.Syntax.ImportClause + , TSX.Syntax.LabeledStatement + , TSX.Syntax.Annotation + , TSX.Syntax.With + , TSX.Syntax.ForOf + , TSX.Syntax.Update + , TSX.Syntax.ComputedPropertyName + , TSX.Syntax.Decorator + , TSX.Syntax.Import + , TSX.Syntax.QualifiedAliasedImport + , TSX.Syntax.SideEffectImport + , TSX.Syntax.DefaultExport + , TSX.Syntax.QualifiedExport + , TSX.Syntax.QualifiedExportFrom + , TSX.Syntax.JavaScriptRequire + , [] + , Statement.StatementBlock + , TSX.Syntax.MetaProperty + , TSX.Syntax.AnnotatedExpression + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index e790bef25..b0bb5c126 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME +{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-} module Language.TypeScript.Assignment ( assignment -, Syntax +, TypeScript.Syntax , Grammar -, Term +, TypeScript.Term(..) ) where import Assigning.Assignment hiding (Assignment, Error) @@ -31,182 +30,19 @@ import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term import qualified Language.TypeScript.Syntax as TypeScript.Syntax import qualified Language.TypeScript.Resolution as TypeScript.Resolution +import Language.TypeScript.Term as TypeScript import Prologue import TreeSitter.TypeScript as Grammar --- | The type of TypeScript syntax. -type Syntax = '[ - Comment.Comment - , Comment.HashBang - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.InterfaceDeclaration - , Declaration.PublicFieldDefinition - , Declaration.VariableDeclaration - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.MemberAccess - , Expression.NonNullExpression - , Expression.ScopeResolution - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Expression.Delete - , Expression.Void - , Expression.Typeof - , Expression.InstanceOf - , Expression.New - , Expression.Await - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.String - , Literal.TextElement - , Literal.Regex - , Statement.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AccessibilityModifier - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Syntax.Context - , Type.Readonly - , Type.TypeParameters - , TypeScript.Syntax.TypeParameter - , TypeScript.Syntax.Constraint - , TypeScript.Syntax.ParenthesizedType - , TypeScript.Syntax.DefaultType - , TypeScript.Syntax.PredefinedType - , TypeScript.Syntax.TypeIdentifier - , TypeScript.Syntax.NestedIdentifier - , TypeScript.Syntax.NestedTypeIdentifier - , TypeScript.Syntax.GenericType - , TypeScript.Syntax.TypeArguments - , TypeScript.Syntax.TypePredicate - , TypeScript.Syntax.CallSignature - , TypeScript.Syntax.ConstructSignature - , TypeScript.Syntax.ArrayType - , TypeScript.Syntax.LookupType - , TypeScript.Syntax.FlowMaybeType - , TypeScript.Syntax.TypeQuery - , TypeScript.Syntax.IndexTypeQuery - , TypeScript.Syntax.ThisType - , TypeScript.Syntax.ExistentialType - , TypeScript.Syntax.AbstractMethodSignature - , TypeScript.Syntax.IndexSignature - , TypeScript.Syntax.ObjectType - , TypeScript.Syntax.LiteralType - , TypeScript.Syntax.Union - , TypeScript.Syntax.Intersection - , TypeScript.Syntax.Module - , TypeScript.Syntax.InternalModule - , TypeScript.Syntax.FunctionType - , TypeScript.Syntax.Tuple - , TypeScript.Syntax.Constructor - , TypeScript.Syntax.TypeAssertion - , TypeScript.Syntax.ImportAlias - , TypeScript.Syntax.Debugger - , TypeScript.Syntax.ShorthandPropertyIdentifier - , TypeScript.Syntax.Super - , TypeScript.Syntax.Undefined - , TypeScript.Syntax.ClassHeritage - , TypeScript.Syntax.AbstractClass - , TypeScript.Syntax.ImplementsClause - , TypeScript.Syntax.OptionalParameter - , TypeScript.Syntax.RequiredParameter - , TypeScript.Syntax.RestParameter - , TypeScript.Syntax.PropertySignature - , TypeScript.Syntax.AmbientDeclaration - , TypeScript.Syntax.EnumDeclaration - , TypeScript.Syntax.ExtendsClause - , TypeScript.Syntax.AmbientFunction - , TypeScript.Syntax.ImportRequireClause - , TypeScript.Syntax.ImportClause - , TypeScript.Syntax.LabeledStatement - , TypeScript.Syntax.Annotation - , TypeScript.Syntax.With - , TypeScript.Syntax.ForOf - , TypeScript.Syntax.Update - , TypeScript.Syntax.ComputedPropertyName - , TypeScript.Syntax.Decorator - , TypeScript.Syntax.Import - , TypeScript.Syntax.QualifiedAliasedImport - , TypeScript.Syntax.SideEffectImport - , TypeScript.Syntax.DefaultExport - , TypeScript.Syntax.QualifiedExport - , TypeScript.Syntax.QualifiedExportFrom - , TypeScript.Syntax.JavaScriptRequire - , [] - , Statement.StatementBlock - , TypeScript.Syntax.MetaProperty - , TypeScript.Syntax.AnnotatedExpression - ] - -type Term = Term.Term (Sum Syntax) Loc type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax. -assignment :: Assignment Term +assignment :: Assignment (Term Loc) assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError -expression :: Assignment Term +expression :: Assignment (Term Loc) expression = handleError everything where everything = choice [ @@ -246,13 +82,13 @@ expression = handleError everything identifier ] -undefined' :: Assignment Term +undefined' :: Assignment (Term Loc) undefined' = makeTerm <$> symbol Grammar.Undefined <*> (TypeScript.Syntax.Undefined <$ rawSource) -assignmentExpression :: Assignment Term +assignmentExpression :: Assignment (Term Loc) assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression) -augmentedAssignmentExpression :: Assignment Term +augmentedAssignmentExpression :: Assignment (Term Loc) augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [ assign Expression.Plus <$ symbol AnonPlusEqual , assign Expression.Minus <$ symbol AnonMinusEqual @@ -266,14 +102,14 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual , assign Expression.BOr <$ symbol AnonPipeEqual ]) - where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Sum Syntax Term + where assign :: (f :< TypeScript.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum TypeScript.Syntax (Term Loc) assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r))) -awaitExpression :: Assignment Term +awaitExpression :: Assignment (Term Loc) awaitExpression = makeTerm <$> symbol Grammar.AwaitExpression <*> children (Expression.Await <$> term expression) -unaryExpression :: Assignment Term +unaryExpression :: Assignment (Term Loc) unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> makeTerm loc . Expression.Not <$> children (symbol AnonBang *> term expression) <|> makeTerm loc . Expression.Complement <$> children (symbol AnonTilde *> term expression) @@ -282,16 +118,16 @@ unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> <|> makeTerm loc . Expression.Void <$> children (symbol AnonVoid *> term expression) <|> makeTerm loc . Expression.Delete <$> children (symbol AnonDelete *> term expression) -ternaryExpression :: Assignment Term +ternaryExpression :: Assignment (Term Loc) ternaryExpression = makeTerm <$> symbol Grammar.TernaryExpression <*> children (Statement.If <$> term expression <*> term expression <*> term expression) -memberExpression :: Assignment Term +memberExpression :: Assignment (Term Loc) memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier) -newExpression :: Assignment Term +newExpression :: Assignment (Term Loc) newExpression = makeTerm <$> symbol Grammar.NewExpression <*> children (Expression.New <$> term constructableExpression <*> (typeArguments' <|> emptyTerm) <*> (arguments <|> pure [])) -constructableExpression :: Assignment Term +constructableExpression :: Assignment (Term Loc) constructableExpression = choice [ this , identifier @@ -315,80 +151,80 @@ constructableExpression = choice [ , newExpression ] -metaProperty :: Assignment Term +metaProperty :: Assignment (Term Loc) metaProperty = makeTerm <$> symbol Grammar.MetaProperty <*> (TypeScript.Syntax.MetaProperty <$ rawSource) -updateExpression :: Assignment Term +updateExpression :: Assignment (Term Loc) updateExpression = makeTerm <$> symbol Grammar.UpdateExpression <*> children (TypeScript.Syntax.Update <$> term expression) -yieldExpression :: Assignment Term +yieldExpression :: Assignment (Term Loc) yieldExpression = makeTerm <$> symbol Grammar.YieldExpression <*> children (Statement.Yield <$> term (expression <|> emptyTerm)) -this :: Assignment Term +this :: Assignment (Term Loc) this = makeTerm <$> symbol Grammar.This <*> (Expression.This <$ rawSource) -regex :: Assignment Term +regex :: Assignment (Term Loc) regex = makeTerm <$> symbol Grammar.Regex <*> (Literal.Regex <$> source) -null' :: Assignment Term +null' :: Assignment (Term Loc) null' = makeTerm <$> symbol Null <*> (Literal.Null <$ rawSource) -abstractClass :: Assignment Term +abstractClass :: Assignment (Term Loc) abstractClass = makeTerm <$> symbol Grammar.AbstractClassDeclaration <*> children (TypeScript.Syntax.AbstractClass <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements) -abstractMethodSignature :: Assignment Term +abstractMethodSignature :: Assignment (Term Loc) abstractMethodSignature = makeSignature <$> symbol Grammar.AbstractMethodSignature <*> children ((,,) <$> accessibilityModifier' <*> term propertyName <*> callSignatureParts) where makeSignature loc (modifier, propertyName, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.AbstractMethodSignature [typeParams, annotation] propertyName params modifier) -classHeritage' :: Assignment [Term] +classHeritage' :: Assignment [Term Loc] classHeritage' = symbol Grammar.ClassHeritage *> children ((mappend `on` toList) <$> optional (term extendsClause) <*> optional (term implementsClause')) -extendsClause :: Assignment Term +extendsClause :: Assignment (Term Loc) extendsClause = makeTerm <$> symbol Grammar.ExtendsClause <*> children (TypeScript.Syntax.ExtendsClause <$> manyTerm (typeReference <|> expression)) -typeReference :: Assignment Term +typeReference :: Assignment (Term Loc) typeReference = typeIdentifier <|> nestedTypeIdentifier <|> genericType -implementsClause' :: Assignment Term +implementsClause' :: Assignment (Term Loc) implementsClause' = makeTerm <$> symbol Grammar.ImplementsClause <*> children (TypeScript.Syntax.ImplementsClause <$> manyTerm ty) -super :: Assignment Term +super :: Assignment (Term Loc) super = makeTerm <$> symbol Grammar.Super <*> (TypeScript.Syntax.Super <$ rawSource) -typeAssertion :: Assignment Term +typeAssertion :: Assignment (Term Loc) typeAssertion = makeTerm <$> symbol Grammar.TypeAssertion <*> children (TypeScript.Syntax.TypeAssertion <$> term typeArguments' <*> term expression) -asExpression :: Assignment Term +asExpression :: Assignment (Term Loc) asExpression = makeTerm <$> symbol AsExpression <*> children (Expression.Cast <$> term expression <*> term (ty <|> templateString)) -templateString :: Assignment Term +templateString :: Assignment (Term Loc) templateString = makeTerm <$> symbol TemplateString <*> children (Literal.String <$> manyTerm templateSubstitution) -templateSubstitution :: Assignment Term +templateSubstitution :: Assignment (Term Loc) templateSubstitution = symbol TemplateSubstitution *> children (term expressions) -nonNullExpression' :: Assignment Term +nonNullExpression' :: Assignment (Term Loc) nonNullExpression' = makeTerm <$> symbol Grammar.NonNullExpression <*> children (Expression.NonNullExpression <$> term expression) -importAlias' :: Assignment Term +importAlias' :: Assignment (Term Loc) importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TypeScript.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier)) -number :: Assignment Term +number :: Assignment (Term Loc) number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source) -string :: Assignment Term +string :: Assignment (Term Loc) string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source) -true :: Assignment Term +true :: Assignment (Term Loc) true = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ rawSource) -false :: Assignment Term +false :: Assignment (Term Loc) false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) -identifier :: Assignment Term +identifier :: Assignment (Term Loc) identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier . name <$> source) -class' :: Assignment Term +class' :: Assignment (Term Loc) class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ((,,,,) <$> manyTerm decorator <*> (term typeIdentifier <|> emptyTerm) <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) @@ -396,26 +232,26 @@ class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ( <*> classBodyStatements) where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators <> typeParams) expression classHeritage statements) -object :: Assignment Term +object :: Assignment (Term Loc) object = makeTerm <$> (symbol Object <|> symbol ObjectPattern) <*> children (Literal.Hash <$> manyTerm (pair <|> spreadElement <|> methodDefinition <|> assignmentPattern <|> shorthandPropertyIdentifier)) -array :: Assignment Term +array :: Assignment (Term Loc) array = makeTerm <$> (symbol Array <|> symbol ArrayPattern) <*> children (Literal.Array <$> manyTerm (expression <|> spreadElement)) -propertyIdentifier :: Assignment Term +propertyIdentifier :: Assignment (Term Loc) propertyIdentifier = makeTerm <$> symbol PropertyIdentifier <*> (Syntax.Identifier . name <$> source) -sequenceExpression :: Assignment Term +sequenceExpression :: Assignment (Term Loc) sequenceExpression = makeTerm <$> symbol Grammar.SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) -expressions :: Assignment Term +expressions :: Assignment (Term Loc) expressions = annotatedExpression <|> expression <|> sequenceExpression -annotatedExpression :: Assignment Term +annotatedExpression :: Assignment (Term Loc) annotatedExpression = mkAnnotated <$> location <*> expression <*> typeAnnotation' where mkAnnotated loc expr ann = makeTerm loc (TypeScript.Syntax.AnnotatedExpression expr ann) -parameter :: Assignment Term +parameter :: Assignment (Term Loc) parameter = requiredParameter <|> restParameter <|> optionalParameter @@ -428,23 +264,23 @@ accessibilityModifier' = (symbol AccessibilityModifier >> children (public <|> p default' = pure ScopeGraph.Public -destructuringPattern :: Assignment Term +destructuringPattern :: Assignment (Term Loc) destructuringPattern = object <|> array -spreadElement :: Assignment Term +spreadElement :: Assignment (Term Loc) spreadElement = symbol SpreadElement *> children (term expression) -readonly' :: Assignment Term +readonly' :: Assignment (Term Loc) readonly' = makeTerm <$> symbol Readonly <*> (Type.Readonly <$ rawSource) -methodDefinition :: Assignment Term +methodDefinition :: Assignment (Term Loc) methodDefinition = makeMethod <$> symbol MethodDefinition <*> children ((,,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> emptyTerm <*> term propertyName <*> callSignatureParts <*> term statementBlock) where makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [readonly, typeParameters', ty'] receiver propertyName' params statements modifier) -callSignatureParts :: Assignment (Term, [Term], Term) +callSignatureParts :: Assignment (Term Loc, [Term Loc], Term Loc) callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> callSignature' <*> many comment) where callSignature' = (,,) <$> (term typeParameters <|> emptyTerm) <*> formalParameters <*> (term typeAnnotation' <|> emptyTerm) @@ -455,20 +291,20 @@ callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postCont Just cs -> (typeParams, formalParams, makeTerm1 (Syntax.Context cs annotation)) Nothing -> (typeParams, formalParams, annotation) -callSignature :: Assignment Term +callSignature :: Assignment (Term Loc) callSignature = makeTerm <$> symbol Grammar.CallSignature <*> children (TypeScript.Syntax.CallSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) -constructSignature :: Assignment Term +constructSignature :: Assignment (Term Loc) constructSignature = makeTerm <$> symbol Grammar.ConstructSignature <*> children (TypeScript.Syntax.ConstructSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) -indexSignature :: Assignment Term +indexSignature :: Assignment (Term Loc) indexSignature = makeTerm <$> symbol Grammar.IndexSignature <*> children (TypeScript.Syntax.IndexSignature <$> term identifier <*> predefinedTy <*> term typeAnnotation') -methodSignature :: Assignment Term +methodSignature :: Assignment (Term Loc) methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> callSignatureParts) where makeMethodSignature loc (accessControl, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (Declaration.MethodSignature [readonly, typeParams, annotation] propertyName params accessControl) -formalParameters :: Assignment [Term] +formalParameters :: Assignment [Term Loc] formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of @@ -479,37 +315,37 @@ formalParameters = symbol FormalParameters *> children (contextualize' <$> Assig Nothing -> formalParams -decorator :: Assignment Term +decorator :: Assignment (Term Loc) decorator = makeTerm <$> symbol Grammar.Decorator <*> children (TypeScript.Syntax.Decorator <$> term (identifier <|> memberExpression <|> callExpression)) -typeParameters :: Assignment Term +typeParameters :: Assignment (Term Loc) typeParameters = makeTerm <$> symbol TypeParameters <*> children (Type.TypeParameters <$> manyTerm typeParameter') -typeAnnotation' :: Assignment Term +typeAnnotation' :: Assignment (Term Loc) typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TypeScript.Syntax.Annotation <$> term ty) -typeParameter' :: Assignment Term +typeParameter' :: Assignment (Term Loc) typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) -defaultType :: Assignment Term +defaultType :: Assignment (Term Loc) defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TypeScript.Syntax.DefaultType <$> term ty) -constraint :: Assignment Term +constraint :: Assignment (Term Loc) constraint = makeTerm <$> symbol Grammar.Constraint <*> children (TypeScript.Syntax.Constraint <$> term ty) -function :: Assignment Term +function :: Assignment (Term Loc) function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.FunctionDeclaration <|> symbol Grammar.GeneratorFunction <|> symbol Grammar.GeneratorFunctionDeclaration) <*> children ((,,) <$> term (identifier <|> emptyTerm) <*> callSignatureParts <*> term statementBlock) where makeFunction loc (id, (typeParams, params, annotation), statements) = makeTerm loc (Declaration.Function [typeParams, annotation] id params statements) -- TODO: FunctionSignatures can, but don't have to be ambient functions. -ambientFunction :: Assignment Term +ambientFunction :: Assignment (Term Loc) ambientFunction = makeAmbientFunction <$> symbol Grammar.FunctionSignature <*> children ((,) <$> term identifier <*> callSignatureParts) where makeAmbientFunction loc (id, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.AmbientFunction [typeParams, annotation] id params) -ty :: Assignment Term +ty :: Assignment (Term Loc) ty = primaryType <|> unionType <|> intersectionType <|> functionTy <|> constructorTy -primaryType :: Assignment Term +primaryType :: Assignment (Term Loc) primaryType = arrayTy <|> existentialType <|> flowMaybeTy @@ -527,76 +363,76 @@ primaryType = arrayTy <|> typePredicate <|> typeQuery -parenthesizedTy :: Assignment Term +parenthesizedTy :: Assignment (Term Loc) parenthesizedTy = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (TypeScript.Syntax.ParenthesizedType <$> term ty) -predefinedTy :: Assignment Term +predefinedTy :: Assignment (Term Loc) predefinedTy = makeTerm <$> symbol Grammar.PredefinedType <*> (TypeScript.Syntax.PredefinedType <$> source) -typeIdentifier :: Assignment Term +typeIdentifier :: Assignment (Term Loc) typeIdentifier = makeTerm <$> symbol Grammar.TypeIdentifier <*> (TypeScript.Syntax.TypeIdentifier <$> source) -nestedIdentifier :: Assignment Term +nestedIdentifier :: Assignment (Term Loc) nestedIdentifier = makeTerm <$> symbol Grammar.NestedIdentifier <*> children (TypeScript.Syntax.NestedIdentifier <$> term (identifier <|> nestedIdentifier) <*> term identifier) -nestedTypeIdentifier :: Assignment Term +nestedTypeIdentifier :: Assignment (Term Loc) nestedTypeIdentifier = makeTerm <$> symbol Grammar.NestedTypeIdentifier <*> children (TypeScript.Syntax.NestedTypeIdentifier <$> term (identifier <|> nestedIdentifier) <*> term typeIdentifier) -genericType :: Assignment Term +genericType :: Assignment (Term Loc) genericType = makeTerm <$> symbol Grammar.GenericType <*> children (TypeScript.Syntax.GenericType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term typeArguments') -typeArguments' :: Assignment Term +typeArguments' :: Assignment (Term Loc) typeArguments' = makeTerm <$> symbol Grammar.TypeArguments <*> children (TypeScript.Syntax.TypeArguments <$> some (term ty)) -typePredicate :: Assignment Term +typePredicate :: Assignment (Term Loc) typePredicate = makeTerm <$> symbol Grammar.TypePredicate <*> children (TypeScript.Syntax.TypePredicate <$> term identifier <*> term ty) -objectType :: Assignment Term +objectType :: Assignment (Term Loc) objectType = makeTerm <$> symbol Grammar.ObjectType <*> children (TypeScript.Syntax.ObjectType <$> manyTerm (exportStatement <|> propertySignature <|> callSignature <|> constructSignature <|> indexSignature <|> methodSignature)) -arrayTy :: Assignment Term +arrayTy :: Assignment (Term Loc) arrayTy = makeTerm <$> symbol Grammar.ArrayType <*> children (TypeScript.Syntax.ArrayType <$> term ty) -lookupType :: Assignment Term +lookupType :: Assignment (Term Loc) lookupType = makeTerm <$> symbol Grammar.LookupType <*> children (TypeScript.Syntax.LookupType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term ty) -flowMaybeTy :: Assignment Term +flowMaybeTy :: Assignment (Term Loc) flowMaybeTy = makeTerm <$> symbol Grammar.FlowMaybeType <*> children (TypeScript.Syntax.FlowMaybeType <$> term primaryType) -typeQuery :: Assignment Term +typeQuery :: Assignment (Term Loc) typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TypeScript.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) -indexTypeQuery :: Assignment Term +indexTypeQuery :: Assignment (Term Loc) indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) -existentialType :: Assignment Term +existentialType :: Assignment (Term Loc) existentialType = makeTerm <$> symbol Grammar.ExistentialType <*> (TypeScript.Syntax.ExistentialType <$> source) -literalType :: Assignment Term +literalType :: Assignment (Term Loc) literalType = makeTerm <$> symbol Grammar.LiteralType <*> children (TypeScript.Syntax.LiteralType <$> term (number <|> string <|> true <|> false)) -unionType :: Assignment Term +unionType :: Assignment (Term Loc) unionType = makeTerm <$> symbol UnionType <*> children (TypeScript.Syntax.Union <$> (term ty <|> emptyTerm) <*> term ty) -intersectionType :: Assignment Term +intersectionType :: Assignment (Term Loc) intersectionType = makeTerm <$> symbol IntersectionType <*> children (TypeScript.Syntax.Intersection <$> term ty <*> term ty) -functionTy :: Assignment Term +functionTy :: Assignment (Term Loc) functionTy = makeTerm <$> symbol Grammar.FunctionType <*> children (TypeScript.Syntax.FunctionType <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) -tupleType :: Assignment Term +tupleType :: Assignment (Term Loc) tupleType = makeTerm <$> symbol TupleType <*> children (TypeScript.Syntax.Tuple <$> manyTerm ty) -constructorTy :: Assignment Term +constructorTy :: Assignment (Term Loc) constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) -statementTerm :: Assignment Term +statementTerm :: Assignment (Term Loc) statementTerm = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement) -statementBlock :: Assignment Term +statementBlock :: Assignment (Term Loc) statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.StatementBlock <$> manyTerm statement) -classBodyStatements :: Assignment Term +classBodyStatements :: Assignment (Term Loc) classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of @@ -606,12 +442,12 @@ classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualiz Just cs -> formalParams <> toList cs Nothing -> formalParams -publicFieldDefinition :: Assignment Term +publicFieldDefinition :: Assignment (Term Loc) publicFieldDefinition = makeField <$> symbol Grammar.PublicFieldDefinition <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) where makeField loc (accessControl, readonly, propertyName, annotation, expression) = makeTerm loc (Declaration.PublicFieldDefinition [readonly, annotation] propertyName expression accessControl) -statement :: Assignment Term +statement :: Assignment (Term Loc) statement = handleError everything where everything = choice [ @@ -637,37 +473,37 @@ statement = handleError everything , emptyStatement , labeledStatement ] -forInStatement :: Assignment Term +forInStatement :: Assignment (Term Loc) forInStatement = makeTerm <$> symbol ForInStatement <*> children (Statement.ForEach <$> term expression <*> term expression <*> term statement) -doStatement :: Assignment Term +doStatement :: Assignment (Term Loc) doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression) -continueStatement :: Assignment Term +continueStatement :: Assignment (Term Loc) continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm)) -breakStatement :: Assignment Term +breakStatement :: Assignment (Term Loc) breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm)) -withStatement :: Assignment Term +withStatement :: Assignment (Term Loc) withStatement = makeTerm <$> symbol WithStatement <*> children (TypeScript.Syntax.With <$> term parenthesizedExpression <*> term statement) -returnStatement :: Assignment Term +returnStatement :: Assignment (Term Loc) returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm)) -throwStatement :: Assignment Term +throwStatement :: Assignment (Term Loc) throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions) -hashBang :: Assignment Term +hashBang :: Assignment (Term Loc) hashBang = makeTerm <$> symbol HashBangLine <*> (Comment.HashBang <$> source) -labeledStatement :: Assignment Term +labeledStatement :: Assignment (Term Loc) labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TypeScript.Syntax.LabeledStatement <$> statementIdentifier <*> term statement) -statementIdentifier :: Assignment Term +statementIdentifier :: Assignment (Term Loc) statementIdentifier = makeTerm <$> symbol StatementIdentifier <*> (Syntax.Identifier . name <$> source) -importStatement :: Assignment Term +importStatement :: Assignment (Term Loc) importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> children ((,) <$> importClause <*> fromClause) <|> makeTerm' <$> symbol Grammar.ImportStatement <*> children (requireImport <|> sideEffectImport) where @@ -702,13 +538,13 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) -debuggerStatement :: Assignment Term +debuggerStatement :: Assignment (Term Loc) debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TypeScript.Syntax.Debugger <$ rawSource) -expressionStatement' :: Assignment Term +expressionStatement' :: Assignment (Term Loc) expressionStatement' = symbol ExpressionStatement *> children (term expressions) -declaration :: Assignment Term +declaration :: Assignment (Term Loc) declaration = everything where everything = choice [ @@ -727,24 +563,24 @@ declaration = everything ambientDeclaration ] -typeAliasDeclaration :: Assignment Term +typeAliasDeclaration :: Assignment (Term Loc) typeAliasDeclaration = makeTypeAliasDecl <$> symbol Grammar.TypeAliasDeclaration <*> children ((,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> term ty) where makeTypeAliasDecl loc (identifier, typeParams, body) = makeTerm loc (Declaration.TypeAlias [typeParams] identifier body) -enumDeclaration :: Assignment Term +enumDeclaration :: Assignment (Term Loc) enumDeclaration = makeTerm <$> symbol Grammar.EnumDeclaration <*> children (TypeScript.Syntax.EnumDeclaration <$> term identifier <*> (symbol EnumBody *> children (manyTerm (propertyName <|> enumAssignment)))) -enumAssignment :: Assignment Term +enumAssignment :: Assignment (Term Loc) enumAssignment = makeTerm <$> symbol Grammar.EnumAssignment <*> children (Statement.Assignment [] <$> term propertyName <*> term expression) -interfaceDeclaration :: Assignment Term +interfaceDeclaration :: Assignment (Term Loc) interfaceDeclaration = makeInterfaceDecl <$> symbol Grammar.InterfaceDeclaration <*> children ((,,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> optional (term extendsClause) <*> term objectType) where makeInterfaceDecl loc (identifier, typeParams, clause, objectType) = makeTerm loc (Declaration.InterfaceDeclaration [typeParams] identifier (toList clause) objectType) -ambientDeclaration :: Assignment Term +ambientDeclaration :: Assignment (Term Loc) ambientDeclaration = makeTerm <$> symbol Grammar.AmbientDeclaration <*> children (TypeScript.Syntax.AmbientDeclaration <$> term (choice [propertyIdentifier *> ty, declaration, statementBlock])) -exportStatement :: Assignment Term +exportStatement :: Assignment (Term Loc) exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip TypeScript.Syntax.QualifiedExportFrom <$> exportClause <*> fromClause) <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.QualifiedExport <$> exportClause) <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias'))) @@ -758,23 +594,23 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) -propertySignature :: Assignment Term +propertySignature :: Assignment (Term Loc) propertySignature = makePropertySignature <$> symbol Grammar.PropertySignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm)) where makePropertySignature loc (modifier, readonly, propertyName, annotation) = makeTerm loc (TypeScript.Syntax.PropertySignature [readonly, annotation] propertyName modifier) -propertyName :: Assignment Term +propertyName :: Assignment (Term Loc) propertyName = term (propertyIdentifier <|> string <|> number <|> computedPropertyName) -computedPropertyName :: Assignment Term +computedPropertyName :: Assignment (Term Loc) computedPropertyName = makeTerm <$> symbol Grammar.ComputedPropertyName <*> children (TypeScript.Syntax.ComputedPropertyName <$> term expression) -assignmentPattern :: Assignment Term +assignmentPattern :: Assignment (Term Loc) assignmentPattern = makeTerm <$> symbol AssignmentPattern <*> children (Statement.Assignment [] <$> term shorthandPropertyIdentifier <*> term expression) -shorthandPropertyIdentifier :: Assignment Term +shorthandPropertyIdentifier :: Assignment (Term Loc) shorthandPropertyIdentifier = makeTerm <$> symbol Grammar.ShorthandPropertyIdentifier <*> (TypeScript.Syntax.ShorthandPropertyIdentifier <$> source) -requiredParameter :: Assignment Term +requiredParameter :: Assignment (Term Loc) requiredParameter = makeRequiredParameter <$> symbol Grammar.RequiredParameter <*> children ( (,,,,) @@ -786,44 +622,44 @@ requiredParameter = makeRequiredParameter where makeRequiredParameter loc (modifier, readonly, identifier, annotation, initializer) = makeTerm loc (TypeScript.Syntax.RequiredParameter [readonly, annotation] identifier initializer modifier) -restParameter :: Assignment Term +restParameter :: Assignment (Term Loc) restParameter = makeRestParameter <$> symbol Grammar.RestParameter <*> children ((,) <$> term identifier <*> (term typeAnnotation' <|> emptyTerm)) where makeRestParameter loc (identifier, annotation) = makeTerm loc (TypeScript.Syntax.RestParameter [annotation] identifier) -optionalParameter :: Assignment Term +optionalParameter :: Assignment (Term Loc) optionalParameter = makeOptionalParam <$> symbol Grammar.OptionalParameter <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> (term identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) where makeOptionalParam loc (modifier, readonly, subject, annotation, initializer) = makeTerm loc (TypeScript.Syntax.OptionalParameter [readonly, annotation] (makeTerm loc (Statement.Assignment [] subject initializer)) modifier) -internalModule :: Assignment Term +internalModule :: Assignment (Term Loc) internalModule = makeTerm <$> symbol Grammar.InternalModule <*> children (TypeScript.Syntax.InternalModule <$> term (string <|> identifier <|> nestedIdentifier) <*> statements) -module' :: Assignment Term +module' :: Assignment (Term Loc) module' = makeTerm <$> symbol Module <*> children (TypeScript.Syntax.Module <$> term (string <|> identifier <|> nestedIdentifier) <*> (statements <|> pure [])) -statements :: Assignment [Term] +statements :: Assignment [Term Loc] statements = symbol StatementBlock *> children (manyTerm statement) -arrowFunction :: Assignment Term +arrowFunction :: Assignment (Term Loc) arrowFunction = makeArrowFun <$> symbol ArrowFunction <*> children ((,,) <$> emptyTerm <*> (((\a b c -> (a, [b], c)) <$> emptyTerm <*> term identifier <*> emptyTerm) <|> callSignatureParts) <*> term (expression <|> statementBlock)) where makeArrowFun loc (identifier, (typeParams, params, returnTy), body) = makeTerm loc (Declaration.Function [ typeParams, returnTy ] identifier params body) -comment :: Assignment Term +comment :: Assignment (Term Loc) comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) -ifStatement :: Assignment Term +ifStatement :: Assignment (Term Loc) ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term parenthesizedExpression <*> term statement <*> (term statement <|> emptyTerm)) -whileStatement :: Assignment Term +whileStatement :: Assignment (Term Loc) whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> term expression <*> term statement) -forStatement :: Assignment Term +forStatement :: Assignment (Term Loc) forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> term (variableDeclaration <|> expressionStatement' <|> emptyStatement) <*> term (expressionStatement' <|> emptyStatement) <*> term (expressions <|> emptyTerm) <*> term statement) -variableDeclaration :: Assignment Term +variableDeclaration :: Assignment (Term Loc) variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator) -variableDeclarator :: Assignment Term +variableDeclarator :: Assignment (Term Loc) variableDeclarator = makeTerm <$> symbol VariableDeclarator <*> children (TypeScript.Syntax.JavaScriptRequire <$> identifier <*> requireCall) <|> makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) @@ -837,37 +673,37 @@ variableDeclarator = ) -parenthesizedExpression :: Assignment Term +parenthesizedExpression :: Assignment (Term Loc) parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions) -switchStatement :: Assignment Term +switchStatement :: Assignment (Term Loc) switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody) where switchBody = symbol SwitchBody *> children (makeTerm <$> location <*> manyTerm switchCase) switchCase = makeTerm <$> (symbol SwitchCase <|> symbol SwitchDefault) <*> children (Statement.Pattern <$> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) -subscriptExpression :: Assignment Term +subscriptExpression :: Assignment (Term Loc) subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term expression <*> (pure <$> term expressions)) -pair :: Assignment Term +pair :: Assignment (Term Loc) pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term propertyName <*> term expression) -callExpression :: Assignment Term +callExpression :: Assignment (Term Loc) callExpression = makeCall <$> (symbol CallExpression <|> symbol CallExpression') <*> children ((,,,) <$> term (expression <|> super <|> function) <*> (typeArguments <|> pure []) <*> (arguments <|> (pure <$> term templateString)) <*> emptyTerm) where makeCall loc (subject, typeArgs, args, body) = makeTerm loc (Expression.Call typeArgs subject args body) typeArguments = symbol Grammar.TypeArguments *> children (some (term ty)) -arguments :: Assignment [Term] +arguments :: Assignment [Term Loc] arguments = symbol Arguments *> children (manyTerm (expression <|> spreadElement)) -tryStatement :: Assignment Term +tryStatement :: Assignment (Term Loc) tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term statementTerm <*> optional (term catchClause) <*> optional (term finallyClause)) where makeTry loc (statementBlock', catch, finally) = makeTerm loc (Statement.Try statementBlock' (catMaybes [catch, finally])) catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (identifier <|> emptyTerm) <*> statementTerm) finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> statementTerm) -binaryExpression :: Assignment Term +binaryExpression :: Assignment (Term Loc) binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression) [ (inject .) . Expression.Plus <$ symbol AnonPlus , (inject .) . Expression.Minus <$ symbol AnonMinus @@ -899,18 +735,18 @@ binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm -- Helpers -- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment Term -> Assignment [Term] +manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) -term :: Assignment Term -> Assignment Term +term :: Assignment (Term Loc) -> Assignment (Term Loc) term term = contextualize comment (postContextualize comment term) -emptyStatement :: Assignment Term +emptyStatement :: Assignment (Term Loc) emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment Term - -> Assignment Term - -> [Assignment (Term -> Term -> Sum Syntax Term)] - -> Assignment (Sum Syntax Term) +infixTerm :: Assignment (Term Loc) + -> Assignment (Term Loc) + -> [Assignment (Term Loc -> Term Loc -> Sum TypeScript.Syntax (Term Loc))] + -> Assignment (Sum TypeScript.Syntax (Term Loc)) infixTerm = infixContext comment diff --git a/src/Language/TypeScript/Term.hs b/src/Language/TypeScript/Term.hs new file mode 100644 index 000000000..096c37451 --- /dev/null +++ b/src/Language/TypeScript/Term.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +module Language.TypeScript.Term +( Syntax +, Term(..) +) where + +import Control.Lens.Lens +import Data.Abstract.Declarations +import Data.Abstract.FreeVariables +import Data.Aeson (ToJSON) +import Data.Bifunctor +import Data.Bitraversable +import Data.Coerce +import Data.Foldable (fold) +import Data.Functor.Foldable (Base, Recursive(..)) +import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) +import qualified Data.Sum as Sum +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +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 qualified Data.Syntax.Type as Type +import qualified Data.Term as Term +import Data.Traversable +import Diffing.Interpreter +import qualified Language.TypeScript.Syntax as TypeScript.Syntax +import Source.Loc +import Source.Span + +type Syntax = + [ Comment.Comment + , Comment.HashBang + , Declaration.Class + , Declaration.Function + , Declaration.Method + , Declaration.MethodSignature + , Declaration.InterfaceDeclaration + , Declaration.PublicFieldDefinition + , Declaration.VariableDeclaration + , Declaration.TypeAlias + , Expression.Plus + , Expression.Minus + , Expression.Times + , Expression.DividedBy + , Expression.Modulo + , Expression.Power + , Expression.Negate + , Expression.FloorDivision + , Expression.BAnd + , Expression.BOr + , Expression.BXOr + , Expression.LShift + , Expression.RShift + , Expression.UnsignedRShift + , Expression.Complement + , Expression.And + , Expression.Not + , Expression.Or + , Expression.XOr + , Expression.Call + , Expression.Cast + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual + , Expression.Comparison + , Expression.Enumeration + , Expression.MemberAccess + , Expression.NonNullExpression + , Expression.ScopeResolution + , Expression.SequenceExpression + , Expression.Subscript + , Expression.Member + , Expression.Delete + , Expression.Void + , Expression.Typeof + , Expression.InstanceOf + , Expression.New + , Expression.Await + , Expression.This + , Literal.Array + , Literal.Boolean + , Literal.Float + , Literal.Hash + , Literal.Integer + , Literal.KeyValue + , Literal.Null + , Literal.String + , Literal.TextElement + , Literal.Regex + , Statement.Assignment + , Statement.Break + , Statement.Catch + , Statement.Continue + , Statement.DoWhile + , Statement.Else + , Statement.Finally + , Statement.For + , Statement.ForEach + , Statement.If + , Statement.Match + , Statement.Pattern + , Statement.Retry + , Statement.Return + , Statement.ScopeEntry + , Statement.ScopeExit + , Statement.Statements + , Statement.Throw + , Statement.Try + , Statement.While + , Statement.Yield + , Syntax.AccessibilityModifier + , Syntax.Empty + , Syntax.Error + , Syntax.Identifier + , Syntax.Context + , Type.Readonly + , Type.TypeParameters + , TypeScript.Syntax.TypeParameter + , TypeScript.Syntax.Constraint + , TypeScript.Syntax.ParenthesizedType + , TypeScript.Syntax.DefaultType + , TypeScript.Syntax.PredefinedType + , TypeScript.Syntax.TypeIdentifier + , TypeScript.Syntax.NestedIdentifier + , TypeScript.Syntax.NestedTypeIdentifier + , TypeScript.Syntax.GenericType + , TypeScript.Syntax.TypeArguments + , TypeScript.Syntax.TypePredicate + , TypeScript.Syntax.CallSignature + , TypeScript.Syntax.ConstructSignature + , TypeScript.Syntax.ArrayType + , TypeScript.Syntax.LookupType + , TypeScript.Syntax.FlowMaybeType + , TypeScript.Syntax.TypeQuery + , TypeScript.Syntax.IndexTypeQuery + , TypeScript.Syntax.ThisType + , TypeScript.Syntax.ExistentialType + , TypeScript.Syntax.AbstractMethodSignature + , TypeScript.Syntax.IndexSignature + , TypeScript.Syntax.ObjectType + , TypeScript.Syntax.LiteralType + , TypeScript.Syntax.Union + , TypeScript.Syntax.Intersection + , TypeScript.Syntax.Module + , TypeScript.Syntax.InternalModule + , TypeScript.Syntax.FunctionType + , TypeScript.Syntax.Tuple + , TypeScript.Syntax.Constructor + , TypeScript.Syntax.TypeAssertion + , TypeScript.Syntax.ImportAlias + , TypeScript.Syntax.Debugger + , TypeScript.Syntax.ShorthandPropertyIdentifier + , TypeScript.Syntax.Super + , TypeScript.Syntax.Undefined + , TypeScript.Syntax.ClassHeritage + , TypeScript.Syntax.AbstractClass + , TypeScript.Syntax.ImplementsClause + , TypeScript.Syntax.OptionalParameter + , TypeScript.Syntax.RequiredParameter + , TypeScript.Syntax.RestParameter + , TypeScript.Syntax.PropertySignature + , TypeScript.Syntax.AmbientDeclaration + , TypeScript.Syntax.EnumDeclaration + , TypeScript.Syntax.ExtendsClause + , TypeScript.Syntax.AmbientFunction + , TypeScript.Syntax.ImportRequireClause + , TypeScript.Syntax.ImportClause + , TypeScript.Syntax.LabeledStatement + , TypeScript.Syntax.Annotation + , TypeScript.Syntax.With + , TypeScript.Syntax.ForOf + , TypeScript.Syntax.Update + , TypeScript.Syntax.ComputedPropertyName + , TypeScript.Syntax.Decorator + , TypeScript.Syntax.Import + , TypeScript.Syntax.QualifiedAliasedImport + , TypeScript.Syntax.SideEffectImport + , TypeScript.Syntax.DefaultExport + , TypeScript.Syntax.QualifiedExport + , TypeScript.Syntax.QualifiedExportFrom + , TypeScript.Syntax.JavaScriptRequire + , [] + , Statement.StatementBlock + , TypeScript.Syntax.MetaProperty + , TypeScript.Syntax.AnnotatedExpression + ] + + +newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } + deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON) + +instance Term.IsTerm Term where + type Syntax Term = Sum.Sum Syntax + toTermF = coerce + fromTermF = coerce + +instance Foldable Term where + foldMap = foldMapDefault + +instance Functor Term where + fmap = fmapDefault + +instance Traversable Term where + traverse f = go where go = fmap Term . bitraverse f go . getTerm + +instance VertexDeclaration Term where + toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax + +instance Syntax.HasErrors Term where + getErrors = cata $ \ (Term.In Loc{..} syntax) -> + maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) + + +instance DiffTerms Term where + diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term) + +type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann + +instance Recursive (Term ann) where + project = getTerm + +instance HasSpan ann => HasSpan (Term ann) where + span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) + {-# INLINE span_ #-} diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 4650c2e46..564923eb0 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, TypeFamilies #-} module Parsing.Parser ( Parser(..) -- * À la carte parsers @@ -26,6 +26,8 @@ module Parsing.Parser , rubyParser' , tsxParser' , typescriptParser' + -- * Modes by term type +, TermMode -- * Canonical sets of parsers , aLaCarteParsers , preciseParsers @@ -37,17 +39,16 @@ import qualified CMarkGFM import Data.AST import Data.Language import qualified Data.Map as Map -import Data.Sum import qualified Data.Syntax as Syntax import Data.Term import Foreign.Ptr import qualified Language.Go.Assignment as Go -import qualified Language.Java as PreciseJava -import qualified Language.JSON as PreciseJSON +import qualified Language.Java as Java +import qualified Language.JSON as JSON import qualified Language.Markdown.Assignment as Markdown import qualified Language.PHP.Assignment as PHP -import qualified Language.Python as PrecisePython -import qualified Language.Python.Assignment as Python +import qualified Language.Python as PythonPrecise +import qualified Language.Python.Assignment as PythonALaCarte import qualified Language.Ruby.Assignment as Ruby import qualified Language.TSX.Assignment as TSX import qualified Language.TypeScript.Assignment as TypeScript @@ -69,44 +70,44 @@ data Parser term where -- | A parser 'Unmarshal'ing to a precise AST type using a 'TS.Language'. UnmarshalParser :: Unmarshal t => Ptr TS.Language -> Parser (t Loc) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. - AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast) - => Parser (AST ast grammar) -- ^ A parser producing AST. - -> Assignment ast grammar (Term (Sum fs) Loc) -- ^ An assignment from AST onto 'Term's. - -> Parser (Term (Sum fs) Loc) -- ^ A parser producing 'Term's. + AssignmentParser :: (TS.Symbol grammar, Syntax.HasErrors term, Eq1 ast, Foldable term, Foldable ast, Functor ast) + => Parser (AST ast grammar) -- ^ A parser producing AST. + -> Assignment ast grammar (term Loc) -- ^ An assignment from AST onto 'Term's. + -> Parser (term Loc) -- ^ A parser producing 'Term's. -- | A parser for 'Markdown' using cmark. MarkdownParser :: Parser (AST (TermF [] CMarkGFM.NodeType) Markdown.Grammar) -goParser :: Parser Go.Term +goParser :: Parser (Go.Term Loc) goParser = AssignmentParser (ASTParser tree_sitter_go) Go.assignment -rubyParser :: Parser Ruby.Term +rubyParser :: Parser (Ruby.Term Loc) rubyParser = AssignmentParser (ASTParser tree_sitter_ruby) Ruby.assignment -phpParser :: Parser PHP.Term +phpParser :: Parser (PHP.Term Loc) phpParser = AssignmentParser (ASTParser tree_sitter_php) PHP.assignment -pythonParser :: Parser Python.Term -pythonParser = AssignmentParser (ASTParser tree_sitter_python) Python.assignment +pythonParser :: Parser (PythonALaCarte.Term Loc) +pythonParser = AssignmentParser (ASTParser tree_sitter_python) PythonALaCarte.assignment -typescriptParser :: Parser TypeScript.Term +typescriptParser :: Parser (TypeScript.Term Loc) typescriptParser = AssignmentParser (ASTParser tree_sitter_typescript) TypeScript.assignment -tsxParser :: Parser TSX.Term +tsxParser :: Parser (TSX.Term Loc) tsxParser = AssignmentParser (ASTParser tree_sitter_tsx) TSX.assignment -markdownParser :: Parser Markdown.Term +markdownParser :: Parser (Markdown.Term Loc) markdownParser = AssignmentParser MarkdownParser Markdown.assignment -javaParserPrecise :: Parser (PreciseJava.Term Loc) -javaParserPrecise = UnmarshalParser PreciseJava.tree_sitter_java +javaParserPrecise :: Parser (Java.Term Loc) +javaParserPrecise = UnmarshalParser Java.tree_sitter_java -jsonParserPrecise :: Parser (PreciseJSON.Term Loc) -jsonParserPrecise = UnmarshalParser PreciseJSON.tree_sitter_json +jsonParserPrecise :: Parser (JSON.Term Loc) +jsonParserPrecise = UnmarshalParser JSON.tree_sitter_json -pythonParserPrecise :: Parser (PrecisePython.Term Loc) -pythonParserPrecise = UnmarshalParser PrecisePython.tree_sitter_python +pythonParserPrecise :: Parser (PythonPrecise.Term Loc) +pythonParserPrecise = UnmarshalParser PythonPrecise.tree_sitter_python -- $abstract @@ -140,57 +141,65 @@ pythonParserPrecise = UnmarshalParser PrecisePython.tree_sitter_python data SomeParser c a where SomeParser :: c t => Parser (t a) -> SomeParser c a -goParser' :: c (Term (Sum Go.Syntax)) => (Language, SomeParser c Loc) +goParser' :: c Go.Term => (Language, SomeParser c Loc) goParser' = (Go, SomeParser goParser) -javaParser' :: c PreciseJava.Term => (Language, SomeParser c Loc) +javaParser' :: c Java.Term => (Language, SomeParser c Loc) javaParser' = (Java, SomeParser javaParserPrecise) -javascriptParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +javascriptParser' :: c TSX.Term => (Language, SomeParser c Loc) javascriptParser' = (JavaScript, SomeParser tsxParser) -jsonParserPrecise' :: c PreciseJSON.Term => (Language, SomeParser c Loc) +jsonParserPrecise' :: c JSON.Term => (Language, SomeParser c Loc) jsonParserPrecise' = (JSON, SomeParser jsonParserPrecise) -jsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +jsxParser' :: c TSX.Term => (Language, SomeParser c Loc) jsxParser' = (JSX, SomeParser tsxParser) -markdownParser' :: c (Term (Sum Markdown.Syntax)) => (Language, SomeParser c Loc) +markdownParser' :: c Markdown.Term => (Language, SomeParser c Loc) markdownParser' = (Markdown, SomeParser markdownParser) -phpParser' :: c (Term (Sum PHP.Syntax)) => (Language, SomeParser c Loc) +phpParser' :: c PHP.Term => (Language, SomeParser c Loc) phpParser' = (PHP, SomeParser phpParser) -pythonParserALaCarte' :: c (Term (Sum Python.Syntax)) => (Language, SomeParser c Loc) +pythonParserALaCarte' :: c PythonALaCarte.Term => (Language, SomeParser c Loc) pythonParserALaCarte' = (Python, SomeParser pythonParser) -pythonParserPrecise' :: c PrecisePython.Term => (Language, SomeParser c Loc) +pythonParserPrecise' :: c PythonPrecise.Term => (Language, SomeParser c Loc) pythonParserPrecise' = (Python, SomeParser pythonParserPrecise) -pythonParser' :: (c (Term (Sum Python.Syntax)), c PrecisePython.Term) => PerLanguageModes -> (Language, SomeParser c Loc) +pythonParser' :: (c PythonALaCarte.Term, c PythonPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) pythonParser' modes = case pythonMode modes of ALaCarte -> (Python, SomeParser pythonParser) Precise -> (Python, SomeParser pythonParserPrecise) -rubyParser' :: c (Term (Sum Ruby.Syntax)) => (Language, SomeParser c Loc) +rubyParser' :: c Ruby.Term => (Language, SomeParser c Loc) rubyParser' = (Ruby, SomeParser rubyParser) -tsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +tsxParser' :: c TSX.Term => (Language, SomeParser c Loc) tsxParser' = (TSX, SomeParser tsxParser) -typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc) +typescriptParser' :: c TypeScript.Term => (Language, SomeParser c Loc) typescriptParser' = (TypeScript, SomeParser typescriptParser) +-- | A type family selecting the language mode for a given term type. +type family TermMode term where + TermMode Java.Term = 'Precise + TermMode JSON.Term = 'Precise + TermMode PythonPrecise.Term = 'Precise + TermMode _ = 'ALaCarte + + -- | The canonical set of parsers producing à la carte terms. aLaCarteParsers - :: ( c (Term (Sum Go.Syntax)) - , c (Term (Sum Markdown.Syntax)) - , c (Term (Sum PHP.Syntax)) - , c (Term (Sum Python.Syntax)) - , c (Term (Sum Ruby.Syntax)) - , c (Term (Sum TSX.Syntax)) - , c (Term (Sum TypeScript.Syntax)) + :: ( c Go.Term + , c Markdown.Term + , c PHP.Term + , c PythonALaCarte.Term + , c Ruby.Term + , c TSX.Term + , c TypeScript.Term ) => Map Language (SomeParser c Loc) aLaCarteParsers = Map.fromList @@ -207,9 +216,9 @@ aLaCarteParsers = Map.fromList -- | The canonical set of parsers producing precise terms. preciseParsers - :: ( c PreciseJava.Term - , c PreciseJSON.Term - , c PrecisePython.Term + :: ( c Java.Term + , c JSON.Term + , c PythonPrecise.Term ) => Map Language (SomeParser c Loc) preciseParsers = Map.fromList @@ -220,16 +229,16 @@ preciseParsers = Map.fromList -- | The canonical set of all parsers for the passed per-language modes. allParsers - :: ( c (Term (Sum Go.Syntax)) - , c PreciseJava.Term - , c PreciseJSON.Term - , c (Term (Sum Markdown.Syntax)) - , c (Term (Sum PHP.Syntax)) - , c (Term (Sum Python.Syntax)) - , c PrecisePython.Term - , c (Term (Sum Ruby.Syntax)) - , c (Term (Sum TSX.Syntax)) - , c (Term (Sum TypeScript.Syntax)) + :: ( c Go.Term + , c Java.Term + , c JSON.Term + , c Markdown.Term + , c PHP.Term + , c PythonALaCarte.Term + , c PythonPrecise.Term + , c Ruby.Term + , c TSX.Term + , c TypeScript.Term ) => PerLanguageModes -> Map Language (SomeParser c Loc) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 582cd11c4..ae18a36ab 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, LambdaCase, MonoLocalBinds, QuantifiedConstraints, RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes, MonoLocalBinds, RankNTypes, UndecidableInstances #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) - , diffGraph - - , DiffEffects , diffTerms ) where @@ -18,14 +15,14 @@ import Control.Lens import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder +import Data.Diff import Data.Edit import Data.Graph -import Data.JSON.Fields +import Data.JSON.Fields (ToJSONFields1) import Data.Language import Data.ProtoLens (defMessage) -import Data.Term +import Data.Term (IsTerm(..)) import qualified Data.Text as T -import Diffing.Algorithm (Diffable) import Diffing.Interpreter (DiffTerms(..)) import Parsing.Parser import Prologue @@ -51,26 +48,26 @@ data DiffOutputFormat | DiffDotGraph deriving (Eq, Show) -parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder +parseDiffBuilder :: (Traversable t, Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m) => DiffOutputFormat -> t BlobPair -> m Builder parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON -parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith sexprDiffParsers sexprDiff) -parseDiffBuilder DiffShow = distributeFoldMap (diffWith showDiffParsers showDiff) -parseDiffBuilder DiffDotGraph = distributeFoldMap (diffWith dotGraphDiffParsers dotGraphDiff) +parseDiffBuilder DiffSExpression = distributeFoldMap (parsePairWith diffParsers sexprDiff) +parseDiffBuilder DiffShow = distributeFoldMap (parsePairWith diffParsers showDiff) +parseDiffBuilder DiffDotGraph = distributeFoldMap (parsePairWith diffParsers dotGraphDiff) -jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) -jsonDiff blobPair = diffWith jsonTreeDiffParsers (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair +jsonDiff :: (Member (Error SomeException) sig, Member Telemetry sig, Member Parse sig, Carrier sig m, MonadIO m) => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) +jsonDiff blobPair = parsePairWith diffParsers jsonTreeDiff blobPair `catchError` jsonError blobPair jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) -diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse +diffGraph :: (Traversable t, Member (Error SomeException) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m) => t BlobPair -> m DiffTreeGraphResponse diffGraph blobs = do graph <- distributeFor blobs go pure $ defMessage & P.files .~ toList graph where - go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph - go blobPair = diffWith jsonGraphDiffParsers (pure . jsonGraphDiff blobPair) blobPair + go :: (Member (Error SomeException) sig, Member Telemetry sig, Member Parse sig, Carrier sig m, MonadIO m) => BlobPair -> m DiffTreeFileGraph + go blobPair = parsePairWith diffParsers jsonGraphDiff blobPair `catchError` \(SomeException e) -> pure $ defMessage & P.path .~ path @@ -82,84 +79,78 @@ diffGraph blobs = do path = T.pack $ pathForBlobPair blobPair lang = bridging # languageForBlobPair blobPair -type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m) + +class DOTGraphDiff term where + dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder + +instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => DOTGraphDiff term where + dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph <=< diffTerms -dotGraphDiffParsers :: Map Language (SomeParser DOTGraphDiff Loc) -dotGraphDiffParsers = aLaCarteParsers +class JSONGraphDiff term where + jsonGraphDiff :: (Carrier sig m, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m DiffTreeFileGraph -class DiffTerms term => DOTGraphDiff term where - dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder - -instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DOTGraphDiff (Term syntax) where - dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph +instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => JSONGraphDiff term where + jsonGraphDiff terms = do + diff <- diffTerms terms + let blobPair = bimap fst fst terms + graph = renderTreeGraph diff + toEdge (Edge (a, b)) = defMessage & P.source .~ a^.diffVertexId & P.target .~ b^.diffVertexId + path = T.pack $ pathForBlobPair blobPair + lang = bridging # languageForBlobPair blobPair + pure $! defMessage + & P.path .~ path + & P.language .~ lang + & P.vertices .~ vertexList graph + & P.edges .~ fmap toEdge (edgeList graph) + & P.errors .~ mempty -jsonGraphDiffParsers :: Map Language (SomeParser JSONGraphDiff Loc) -jsonGraphDiffParsers = aLaCarteParsers +class JSONTreeDiff term where + jsonTreeDiff :: (Carrier sig m, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m (Rendering.JSON.JSON "diffs" SomeJSON) -class DiffTerms term => JSONGraphDiff term where - jsonGraphDiff :: BlobPair -> DiffFor term Loc Loc -> DiffTreeFileGraph - -instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => JSONGraphDiff (Term syntax) where - jsonGraphDiff blobPair diff - = let graph = renderTreeGraph diff - toEdge (Edge (a, b)) = defMessage & P.source .~ a^.diffVertexId & P.target .~ b^.diffVertexId - path = T.pack $ pathForBlobPair blobPair - lang = bridging # languageForBlobPair blobPair - in defMessage - & P.path .~ path - & P.language .~ lang - & P.vertices .~ vertexList graph - & P.edges .~ fmap toEdge (edgeList graph) - & P.errors .~ mempty +instance (DiffTerms term, Foldable (Syntax term), ToJSONFields1 (Syntax term)) => JSONTreeDiff term where + jsonTreeDiff terms = renderJSONDiff (bimap fst fst terms) <$> diffTerms terms -jsonTreeDiffParsers :: Map Language (SomeParser JSONTreeDiff Loc) -jsonTreeDiffParsers = aLaCarteParsers +class SExprDiff term where + sexprDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder -class DiffTerms term => JSONTreeDiff term where - jsonTreeDiff :: BlobPair -> DiffFor term Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON - -instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => JSONTreeDiff (Term syntax) where - jsonTreeDiff = renderJSONDiff +instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => SExprDiff term where + sexprDiff = serialize (SExpression ByConstructorName) <=< diffTerms -sexprDiffParsers :: Map Language (SomeParser SExprDiff Loc) -sexprDiffParsers = aLaCarteParsers +class ShowDiff term where + showDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder -class DiffTerms term => SExprDiff term where - sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder - -instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => SExprDiff (Term syntax) where - sexprDiff = serialize (SExpression ByConstructorName) +instance (DiffTerms term, Foldable (Syntax term), Show1 (Syntax term)) => ShowDiff term where + showDiff = serialize Show <=< diffTerms -showDiffParsers :: Map Language (SomeParser ShowDiff Loc) -showDiffParsers = aLaCarteParsers - -class DiffTerms term => ShowDiff term where - showDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder - -instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Show1 syntax, Traversable syntax) => ShowDiff (Term syntax) where - showDiff = serialize Show - - --- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff. --- --- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface. -diffWith - :: (forall term . c term => DiffTerms term, DiffEffects sig m) - => Map Language (SomeParser c Loc) -- ^ The set of parsers to select from. - -> (forall term . c term => DiffFor term Loc Loc -> m output) -- ^ A function to run on the computed diff. Note that the diff is abstract (it’s the diff type corresponding to an abstract term type), but the term type is constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. - -> BlobPair -- ^ The blob pair to parse. - -> m output -diffWith parsers render = parsePairWith parsers (render <=< diffTerms) - -diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) - => Edit (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann) +diffTerms :: (DiffTerms term, Foldable (Syntax term), Member Telemetry sig, Carrier sig m, MonadIO m) + => Edit (Blob, term ann) (Blob, term ann) -> m (Diff (Syntax term) ann ann) diffTerms terms = time "diff" languageTag $ do let diff = diffTermPair (bimap snd snd terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs blobs = bimap fst fst terms + +diffParsers :: Map Language (SomeParser Anything Loc) +diffParsers = aLaCarteParsers + +class + ( DiffTerms term + , ConstructorName (Syntax term) + , Foldable (Syntax term) + , Functor (Syntax term) + , Show1 (Syntax term) + , ToJSONFields1 (Syntax term) + ) => Anything term +instance + ( DiffTerms term + , ConstructorName (Syntax term) + , Foldable (Syntax term) + , Functor (Syntax term) + , Show1 (Syntax term) + , ToJSONFields1 (Syntax term) + ) => Anything term diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 7c585ddc2..6bc177afc 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, MonoLocalBinds, RankNTypes, StandaloneDeriving #-} +{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Semantic.Api.Symbols ( legacyParseSymbols , parseSymbols @@ -10,15 +10,13 @@ import Control.Effect.Parse import Control.Effect.Reader import Control.Exception import Control.Lens +import Data.Abstract.Declarations import Data.Blob hiding (File (..)) import Data.ByteString.Builder import Data.Language import Data.ProtoLens (defMessage) -import Data.Term +import Data.Term (IsTerm(..), TermF) import Data.Text (pack) -import qualified Language.Java as Java -import qualified Language.JSON as JSON -import qualified Language.Python as Python import qualified Parsing.Parser as Parser import Prologue import Proto.Semantic as P hiding (Blob, BlobPair) @@ -31,7 +29,6 @@ import Semantic.Task import Serializing.Format (Format) import Source.Loc as Loc import Source.Source -import Tags.Taggable import Tags.Tagging import qualified Tags.Tagging.Precise as Precise @@ -108,19 +105,17 @@ symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"] class ToTags t where tags :: Language -> [Text] -> Source -> t Loc -> [Tag] -instance IsTaggable syntax => ToTags (Term syntax) where - tags = runTagging +instance (Parser.TermMode term ~ strategy, ToTagsBy strategy term) => ToTags term where + tags = tagsBy @strategy +class ToTagsBy (strategy :: LanguageMode) term where + tagsBy :: Language -> [Text] -> Source -> term Loc -> [Tag] -deriving via (ViaPrecise Java.Term) instance ToTags Java.Term -deriving via (ViaPrecise JSON.Term) instance ToTags JSON.Term -deriving via (ViaPrecise Python.Term) instance ToTags Python.Term +instance (IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc)) => ToTagsBy 'ALaCarte term where + tagsBy = runTagging - -newtype ViaPrecise t a = ViaPrecise (t a) - -instance Precise.ToTags t => ToTags (ViaPrecise t) where - tags _ _ src (ViaPrecise t) = Precise.tags src t +instance Precise.ToTags term => ToTagsBy 'Precise term where + tagsBy _ _ = Precise.tags toTagsParsers :: PerLanguageModes -> Map Language (Parser.SomeParser ToTags Loc) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 484045c38..f9523eb5d 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DerivingVia, LambdaCase, MonoLocalBinds, StandaloneDeriving, TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes, DataKinds, LambdaCase, ScopedTypeVariables, TupleSections, TypeFamilies, UndecidableInstances #-} module Semantic.Api.TOCSummaries ( diffSummary , legacyDiffSummary , diffSummaryBuilder -, SummarizeDiff(..) -, summarizeDiffParsers +, SummarizeTerms(..) +, summarizeTermParsers ) where import Analysis.Decorator (decoratorWithAlgebra) @@ -21,22 +21,18 @@ import Data.ByteString.Builder import Data.Edit import Data.Either (partitionEithers) import Data.Function (on) -import Data.Functor.Classes -import Data.Hashable.Lifted -import Data.Language (Language, PerLanguageModes) +import Data.Functor.Foldable (Base, Recursive) +import Data.Language (Language, LanguageMode(..), PerLanguageModes) import Data.Map (Map) import qualified Data.Map.Monoidal as Map import Data.Maybe (mapMaybe) import Data.ProtoLens (defMessage) import Data.Semilattice.Lower -import Data.Term (Term) +import Data.Term (IsTerm(..), TermF) import qualified Data.Text as T -import Diffing.Algorithm (Diffable) import qualified Diffing.Algorithm.SES as SES -import qualified Language.Java as Java -import qualified Language.JSON as JSON -import qualified Language.Python as Python -import Parsing.Parser (SomeParser, allParsers) +import Diffing.Interpreter (DiffTerms) +import Parsing.Parser (SomeParser, TermMode, allParsers) import Proto.Semantic as P hiding (Blob, BlobPair) import Proto.Semantic_Fields as P import Rendering.TOC @@ -57,7 +53,7 @@ legacyDiffSummary :: (Carrier sig m, Member Distribute sig, Member (Error SomeEx legacyDiffSummary = distributeFoldMap go where go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m Summaries - go blobPair = asks summarizeDiffParsers >>= \ p -> parsePairWith p (fmap (uncurry (flip Summaries) . bimap toMap toMap . partitionEithers) . summarizeTerms) blobPair + go blobPair = asks summarizeTermParsers >>= \ p -> parsePairWith p (fmap (uncurry (flip Summaries) . bimap toMap toMap . partitionEithers) . summarizeTerms) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (toMap [ErrorSummary (T.pack (show e)) lowerBound lang]) where path = T.pack $ pathKeyForBlobPair blobPair @@ -74,7 +70,7 @@ diffSummary blobs = do pure $ defMessage & P.files .~ diff where go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m TOCSummaryFile - go blobPair = asks summarizeDiffParsers >>= \ p -> parsePairWith p (fmap (uncurry toFile . partitionEithers . map (bimap toError toChange)) . summarizeTerms) blobPair + go blobPair = asks summarizeTermParsers >>= \ p -> parsePairWith p (fmap (uncurry toFile . partitionEithers . map (bimap toError toChange)) . summarizeTerms) blobPair `catchError` \(SomeException e) -> pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] [] where toFile errors changes = defMessage @@ -103,28 +99,27 @@ toError ErrorSummary{..} = defMessage & P.maybe'span ?~ converting # span -summarizeDiffParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeDiff Loc) -summarizeDiffParsers = allParsers +summarizeTermParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeTerms Loc) +summarizeTermParsers = allParsers -class SummarizeDiff term where +class SummarizeTerms term where summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] -instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where - summarizeTerms = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where - decorateTerm :: (Foldable syntax, Functor syntax, HasDeclaration syntax) => (Blob, Term syntax Loc) -> (Blob, Term syntax (Maybe Declaration)) +instance (TermMode term ~ strategy, SummarizeTermsBy strategy term) => SummarizeTerms term where + summarizeTerms = summarizeTermsBy @strategy + +class SummarizeTermsBy (strategy :: LanguageMode) term where + summarizeTermsBy :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] + +instance (DiffTerms term, HasDeclaration (Syntax term), Traversable (Syntax term), Recursive (term Loc), Base (term Loc) ~ TermF (Syntax term) Loc) => SummarizeTermsBy 'ALaCarte term where + summarizeTermsBy = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where + decorateTerm :: (Blob, term Loc) -> (Blob, term (Maybe Declaration)) decorateTerm (blob, term) = (blob, decoratorWithAlgebra (declarationAlgebra blob) term) -deriving via (ViaTags Java.Term) instance SummarizeDiff Java.Term -deriving via (ViaTags JSON.Term) instance SummarizeDiff JSON.Term -deriving via (ViaTags Python.Term) instance SummarizeDiff Python.Term - - -newtype ViaTags t a = ViaTags (t a) - -instance Tagging.ToTags t => SummarizeDiff (ViaTags t) where - summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . edit (map Delete) (map Insert) (SES.ses compare) . bimap (uncurry go) (uncurry go) $ terms where - go blob (ViaTags t) = Tagging.tags (blobSource blob) t +instance Tagging.ToTags term => SummarizeTermsBy 'Precise term where + summarizeTermsBy terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . edit (map Delete) (map Insert) (SES.ses compare) . bimap (uncurry go) (uncurry go) $ terms where + go = Tagging.tags . blobSource lang = languageForBlobPair (bimap fst fst terms) (s1, s2) = edit (,mempty) (mempty,) (,) (bimap (blobSource . fst) (blobSource . fst) terms) compare = liftA2 (&&) <$> ((==) `on` Tag.kind) <*> ((==) `on` Tag.name) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 26fb91f1a..1ffad1003 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE ConstraintKinds, MonoLocalBinds, RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Semantic.Api.Terms ( termGraph , parseTermBuilder , TermOutputFormat(..) ) where -import Analysis.ConstructorName (ConstructorName) import Control.Effect.Error import Control.Effect.Parse import Control.Effect.Reader import Control.Lens import Control.Monad import Control.Monad.IO.Class +import Data.Aeson (ToJSON) import Data.Blob import Data.ByteString.Builder import Data.Either import Data.Graph -import Data.JSON.Fields import Data.Language import Data.ProtoLens (defMessage) import Data.Quieterm @@ -35,22 +34,22 @@ import Semantic.Config import Semantic.Task import Serializing.Format hiding (JSON) import qualified Serializing.Format as Format -import qualified Serializing.SExpression as SExpr (serializeSExpression) +import qualified Serializing.SExpression as SExpr import qualified Serializing.SExpression.Precise as SExpr.Precise (serializeSExpression) import Source.Loc import qualified Language.Java as Java import qualified Language.JSON as JSON -import qualified Language.Python as Python +import qualified Language.Python as PythonPrecise -termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse +termGraph :: (Traversable t, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => t Blob -> m ParseTreeGraphResponse termGraph blobs = do terms <- distributeFor blobs go pure $ defMessage & P.files .~ toList terms where - go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph + go :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Blob -> m ParseTreeFileGraph go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob `catchError` \(SomeException e) -> pure $ defMessage @@ -72,7 +71,7 @@ data TermOutputFormat | TermQuiet deriving (Eq, Show) -parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, MonadIO m) +parseTermBuilder :: (Traversable t, Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => TermOutputFormat -> t Blob -> m Builder parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs. parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON @@ -81,13 +80,13 @@ parseTermBuilder TermDotGraph = distributeFoldMap (parseWith dotGraphTermPars parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm -jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) +jsonTerm :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonTerm blob = parseWith jsonTreeTermParsers (pure . jsonTreeTerm blob) blob `catchError` jsonError blob jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) -quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder +quietTerm :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => Blob -> m Builder quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) where timingError (SomeException e) = pure (Left (show e)) @@ -96,26 +95,29 @@ quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers in stringUtf8 (status <> "\t" <> show (blobLanguage blob) <> "\t" <> blobPath blob <> "\t" <> show duration <> " ms\n") -type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m) - - showTermParsers :: PerLanguageModes -> Map Language (SomeParser ShowTerm Loc) showTermParsers = allParsers class ShowTerm term where showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder -instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where - showTerm = serialize Show . quieterm +instance (TermMode term ~ strategy, ShowTermBy strategy term) => ShowTerm term where + showTerm = showTermBy @strategy -instance ShowTerm Java.Term where - showTerm = serialize Show . void . Java.getTerm +class ShowTermBy (strategy :: LanguageMode) term where + showTermBy :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder -instance ShowTerm JSON.Term where - showTerm = serialize Show . void . JSON.getTerm +instance ShowTermBy 'Precise Java.Term where + showTermBy = serialize Show . void . Java.getTerm -instance ShowTerm Python.Term where - showTerm = serialize Show . void . Python.getTerm +instance ShowTermBy 'Precise JSON.Term where + showTermBy = serialize Show . void . JSON.getTerm + +instance ShowTermBy 'Precise PythonPrecise.Term where + showTermBy = serialize Show . void . PythonPrecise.getTerm + +instance (Recursive (term Loc), Show1 syntax, Base (term Loc) ~ TermF syntax Loc) => ShowTermBy 'ALaCarte term where + showTermBy = serialize Show . quieterm sexprTermParsers :: PerLanguageModes -> Map Language (SomeParser SExprTerm Loc) @@ -124,17 +126,23 @@ sexprTermParsers = allParsers class SExprTerm term where sexprTerm :: term Loc -> Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm (Term syntax) where - sexprTerm = SExpr.serializeSExpression ByConstructorName +instance (TermMode term ~ strategy, SExprTermBy strategy term) => SExprTerm term where + sexprTerm = sexprTermBy @strategy -instance SExprTerm Java.Term where - sexprTerm = SExpr.Precise.serializeSExpression . Java.getTerm +class SExprTermBy (strategy :: LanguageMode) term where + sexprTermBy :: term Loc -> Builder -instance SExprTerm JSON.Term where - sexprTerm = SExpr.Precise.serializeSExpression . JSON.getTerm +instance SExprTermBy 'Precise Java.Term where + sexprTermBy = SExpr.Precise.serializeSExpression . Java.getTerm -instance SExprTerm Python.Term where - sexprTerm = SExpr.Precise.serializeSExpression . Python.getTerm +instance SExprTermBy 'Precise JSON.Term where + sexprTermBy = SExpr.Precise.serializeSExpression . JSON.getTerm + +instance SExprTermBy 'Precise PythonPrecise.Term where + sexprTermBy = SExpr.Precise.serializeSExpression . PythonPrecise.getTerm + +instance (Recursive (term Loc), SExpr.ToSExpression (Base (term Loc))) => SExprTermBy 'ALaCarte term where + sexprTermBy = SExpr.serializeSExpression ByConstructorName dotGraphTermParsers :: Map Language (SomeParser DOTGraphTerm Loc) @@ -143,7 +151,7 @@ dotGraphTermParsers = aLaCarteParsers class DOTGraphTerm term where dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTerm (Term syntax) where +instance (Recursive (term Loc), ToTreeGraph TermVertex (Base (term Loc))) => DOTGraphTerm term where dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph @@ -153,7 +161,7 @@ jsonTreeTermParsers = aLaCarteParsers class JSONTreeTerm term where jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON -instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where +instance ToJSON (term Loc) => JSONTreeTerm term where jsonTreeTerm = renderJSONTerm @@ -163,15 +171,15 @@ jsonGraphTermParsers = aLaCarteParsers class JSONGraphTerm term where jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph -instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphTerm (Term syntax) where +instance (Recursive (term Loc), ToTreeGraph TermVertex (Base (term Loc))) => JSONGraphTerm term where jsonGraphTerm blob t = let graph = renderTreeGraph t toEdge (Edge (a, b)) = defMessage & P.source .~ a^.vertexId & P.target .~ b^.vertexId path = T.pack $ blobPath blob lang = bridging # blobLanguage blob in defMessage - & P.path .~ path + & P.path .~ path & P.language .~ lang & P.vertices .~ vertexList graph - & P.edges .~ fmap toEdge (edgeList graph) - & P.errors .~ mempty + & P.edges .~ fmap toEdge (edgeList graph) + & P.errors .~ mempty diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index b90174df2..833184583 100644 --- a/src/Tags/Taggable.hs +++ b/src/Tags/Taggable.hs @@ -63,29 +63,31 @@ emitIden loc docsLiteralRange name = yield (Iden (formatName name) loc docsLiter class Taggable constr where docsLiteral :: - ( Foldable syntax - , HasTextElement syntax + ( Foldable (Syntax term) + , IsTerm term + , HasTextElement (Syntax term) ) - => Language -> constr (Term syntax Loc) -> Maybe Range + => Language -> constr (term Loc) -> Maybe Range - snippet :: Foldable syntax => Loc -> constr (Term syntax Loc) -> Range + snippet :: (IsTerm term, Foldable (Syntax term)) => Loc -> constr (term Loc) -> Range - symbolName :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name + symbolName :: (IsTerm term, Declarations (term Loc)) => constr (term Loc) -> Maybe Name data Strategy = Default | Custom class TaggableBy (strategy :: Strategy) constr where docsLiteral' :: - ( Foldable syntax - , HasTextElement syntax + ( Foldable (Syntax term) + , IsTerm term + , HasTextElement (Syntax term) ) - => Language -> constr (Term syntax Loc) -> Maybe Range + => Language -> constr (term Loc) -> Maybe Range docsLiteral' _ _ = Nothing - snippet' :: (Foldable syntax) => Loc -> constr (Term syntax Loc) -> Range + snippet' :: (IsTerm term, Foldable (Syntax term)) => Loc -> constr (term Loc) -> Range snippet' ann _ = byteRange ann - symbolName' :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name + symbolName' :: (IsTerm term, Declarations (term Loc)) => constr (term Loc) -> Maybe Name symbolName' _ = Nothing type IsTaggable syntax = @@ -93,22 +95,23 @@ type IsTaggable syntax = , Foldable syntax , Taggable syntax , ConstructorName syntax - , Declarations1 syntax , HasTextElement syntax ) -tagging :: (Monad m, IsTaggable syntax) +tagging :: (Monad m, IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc)) => Language - -> Term syntax Loc + -> term Loc -> Stream (Of Token) m () tagging = foldSubterms . descend descend :: - ( ConstructorName (TermF syntax Loc) - , IsTaggable syntax + ( ConstructorName (TermF (Syntax term) Loc) + , Declarations (term Loc) + , IsTerm term + , IsTaggable (Syntax term) , Monad m ) - => Language -> SubtermAlgebra (TermF syntax Loc) (Term syntax Loc) (Tagger m ()) + => Language -> SubtermAlgebra (TermF (Syntax term) Loc) (term Loc) (Tagger m ()) descend lang t@(In loc _) = do let term = fmap subterm t let snippetRange = snippet loc term @@ -156,54 +159,60 @@ instance Taggable a => TaggableBy 'Custom (TermF a Loc) where symbolName' t = symbolName (termFOut t) instance TaggableBy 'Custom Syntax.Context where - snippet' ann (Syntax.Context _ (Term (In subj _))) = subtractLoc ann subj + snippet' ann (Syntax.Context _ subj) = subtractLoc ann (termAnnotation subj) instance TaggableBy 'Custom Declaration.Function where - docsLiteral' Python (Declaration.Function _ _ _ (Term (In _ bodyF))) - | (Term (In exprAnn exprF):_) <- toList bodyF + docsLiteral' Python (Declaration.Function _ _ _ body) + | bodyF <- termOut body + , expr:_ <- toList bodyF + , In exprAnn exprF <- toTermF expr , isTextElement exprF = Just (byteRange exprAnn) | otherwise = Nothing docsLiteral' _ _ = Nothing - snippet' ann (Declaration.Function _ _ _ (Term (In body _))) = subtractLoc ann body + snippet' ann (Declaration.Function _ _ _ body) = subtractLoc ann (termAnnotation body) symbolName' = declaredName . Declaration.functionName instance TaggableBy 'Custom Declaration.Method where - docsLiteral' Python (Declaration.Method _ _ _ _ (Term (In _ bodyF)) _) - | (Term (In exprAnn exprF):_) <- toList bodyF + docsLiteral' Python (Declaration.Method _ _ _ _ body _) + | bodyF <- termOut body + , expr:_ <- toList bodyF + , In exprAnn exprF <- toTermF expr , isTextElement exprF = Just (byteRange exprAnn) | otherwise = Nothing docsLiteral' _ _ = Nothing - snippet' ann (Declaration.Method _ _ _ _ (Term (In body _)) _) = subtractLoc ann body + snippet' ann (Declaration.Method _ _ _ _ body _) = subtractLoc ann (termAnnotation body) symbolName' = declaredName . Declaration.methodName instance TaggableBy 'Custom Declaration.Class where - docsLiteral' Python (Declaration.Class _ _ _ (Term (In _ bodyF))) - | (Term (In exprAnn exprF):_) <- toList bodyF + docsLiteral' Python (Declaration.Class _ _ _ body) + | bodyF <- termOut body + , expr:_ <- toList bodyF + , In exprAnn exprF <- toTermF expr , isTextElement exprF = Just (byteRange exprAnn) | otherwise = Nothing docsLiteral' _ _ = Nothing - snippet' ann (Declaration.Class _ _ _ (Term (In body _))) = subtractLoc ann body + snippet' ann (Declaration.Class _ _ _ body) = subtractLoc ann (termAnnotation body) symbolName' = declaredName . Declaration.classIdentifier instance TaggableBy 'Custom Ruby.Class where - snippet' ann (Ruby.Class _ _ (Term (In body _))) = subtractLoc ann body + snippet' ann (Ruby.Class _ _ body) = subtractLoc ann (termAnnotation body) symbolName' = declaredName . Ruby.classIdentifier instance TaggableBy 'Custom Ruby.Module where - snippet' ann (Ruby.Module _ (Term (In body _):_)) = subtractLoc ann body + snippet' ann (Ruby.Module _ (body:_)) = subtractLoc ann (termAnnotation body) snippet' ann (Ruby.Module _ _) = byteRange ann symbolName' = declaredName . Ruby.moduleIdentifier instance TaggableBy 'Custom TypeScript.Module where - snippet' ann (TypeScript.Module _ (Term (In body _):_)) = subtractLoc ann body + snippet' ann (TypeScript.Module _ (body:_)) = subtractLoc ann (termAnnotation body) snippet' ann (TypeScript.Module _ _ ) = byteRange ann symbolName' = declaredName . TypeScript.moduleIdentifier instance TaggableBy 'Custom Expression.Call where - snippet' ann (Expression.Call _ _ _ (Term (In body _))) = subtractLoc ann body + snippet' ann (Expression.Call _ _ _ body) = subtractLoc ann (termAnnotation body) symbolName' = declaredName . Expression.callFunction instance TaggableBy 'Custom Ruby.Send where - snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = subtractLoc ann body + snippet' ann (Ruby.Send _ _ _ (Just body)) = subtractLoc ann (termAnnotation body) snippet' ann _ = byteRange ann symbolName' Ruby.Send{..} = declaredName =<< sendSelector diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 4b06f0855..f9cf04f0a 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -3,6 +3,7 @@ module Tags.Tagging ( runTagging , Tag(..) , Kind(..) +, IsTaggable ) where @@ -10,6 +11,7 @@ import Prelude hiding (fail, filter, log) import Prologue hiding (Element, hash) import Control.Effect.State as Eff +import Data.Abstract.Declarations (Declarations) import Data.Text as T hiding (empty) import Streaming import qualified Streaming.Prelude as Streaming @@ -21,11 +23,11 @@ import qualified Source.Source as Source import Tags.Tag import Tags.Taggable -runTagging :: (IsTaggable syntax) +runTagging :: (IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc)) => Language -> [Text] -> Source.Source - -> Term syntax Loc + -> term Loc -> [Tag] runTagging lang symbolsToSummarize source = Eff.run diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 7e091df89..364786f25 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -4,6 +4,7 @@ module Rendering.TOC.Spec (spec) where import Analysis.TOCSummary import Control.Effect.Parse import Control.Effect.Reader +import Control.Monad.IO.Class import Data.Aeson hiding (defaultOptions) import Data.Bifunctor import Data.Diff @@ -16,7 +17,7 @@ import Prelude import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import Rendering.TOC -import Semantic.Api (DiffEffects, diffSummaryBuilder, summarizeTerms, summarizeDiffParsers) +import Semantic.Api (diffSummaryBuilder, summarizeTerms, summarizeTermParsers) import Serializing.Format as Format import Source.Loc import Source.Span @@ -216,7 +217,7 @@ blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject -- Diff helpers summarize - :: DiffEffects sig m + :: (Member (Error SomeException) sig, Member Parse sig, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> m [Either ErrorSummary TOCSummary] -summarize = parsePairWith (summarizeDiffParsers defaultLanguageModes) summarizeTerms +summarize = parsePairWith (summarizeTermParsers defaultLanguageModes) summarizeTerms