Merge remote-tracking branch 'origin/master' into proto-lens

2024-12-27 00:44:57 +03:00 · 2019-10-03 09:48:06 -07:00 · 2019-10-03 09:48:06 -07:00 · f8c76b2329
commit f8c76b2329
parent c537122987 b9cc7763ec
17 changed files with 425 additions and 281 deletions
--- a/semantic-python/test/Instances.hs
+++ b/semantic-python/test/Instances.hs
@ -21,68 +21,6 @@ import           Data.Scope (Scope, Incr)
 import qualified Data.Scope as Scope
 import           Data.Name

-instance ToJSON a => ToJSON (Named a) where
-  toJSON _ = object []
-
-instance ToJSON1 Named where
-  liftToJSON f _ (Named i a) = object
-    [ "name" .= i
-    , "value" .= f a
-    ]
-
-  -- Loses information compared to the toJSON instance
-  -- due to an infelicity in how Aeson's toJSON1 is implemented.
-  -- The correct thing to do here is to manually munge the bytestring
-  -- together as a builder, but we don't even hit this code path,
-  -- so it will do for now.
-  liftToEncoding f _ (Named _ a) = f a
-
-instance ToJSON2 Incr where
-  liftToJSON2 f _ g _ = \case
-    Scope.Z a -> f a
-    Scope.S b -> g b
-  liftToEncoding2 f _ g _ = \case
-    Scope.Z a -> f a
-    Scope.S b -> g b
-
-deriving newtype instance (ToJSON a) => ToJSON (Ignored a)
-
-instance (Functor f, ToJSON1 f, ToJSON a) => ToJSON1 (Scope a f) where
-  liftToJSON f g (Scope.Scope a) = toJSON1 (fmap (toJSON2 . fmap (liftToJSON f g)) a)
-  liftToEncoding f g (Scope.Scope a) = liftToEncoding inner outer a where
-    inner = liftToEncoding2 toEncoding toEncodingList hoist loist
-    outer = liftToEncodingList2 toEncoding toEncodingList hoist loist
-    hoist = liftToEncoding f g
-    loist = liftToEncodingList f g
-
-deriving anyclass instance (Functor f, ToJSON1 f) => ToJSON1 (Core f)
-
-instance (ToJSON1 (sig (Term sig))) => ToJSON1 (Term sig) where
-  liftToJSON f _ (Var a) = f a
-  liftToJSON f g (Term s) = liftToJSON f g s
-
-  liftToEncoding f _ (Var a) = f a
-  liftToEncoding f g (Term s) = liftToEncoding f g s
-
-instance (ToJSON1 (f k), ToJSON1 (g k)) => ToJSON1 ((:+:) f g k) where
-  liftToJSON f g (L h) = liftToJSON f g h
-  liftToJSON f g (R h) = liftToJSON f g h
-
-  liftToEncoding f g (L h) = liftToEncoding f g h
-  liftToEncoding f g (R h) = liftToEncoding f g h
-
-instance (ToJSON1 f) => ToJSON1 (Ann f) where
-  liftToJSON f g (Ann loc term) =
-    let
-      rest = case liftToJSON f g term of
-        Object os -> HashMap.toList os
-        other     -> ["value" .= other]
-    in object (["location" .= loc] <> rest)
-
-- We default to deriving the default toEncoding definition (that piggybacks
-- off of toJSON) so that we never hit the problematic code paths associated
-- with toEncoding above.
-
 instance ToJSON a => ToJSON (File a) where
  toJSON File{fileLoc, fileBody} = object
    [ "location" .= fileLoc
--- a/semantic-python/test/Test.hs
+++ b/semantic-python/test/Test.hs
@ -56,7 +56,6 @@ assertJQExpressionSucceeds directive tree core = do
    (heap, [File _ (Right result)]) -> pure $ Aeson.object
      [ "scope" Aeson..= heap
      , "heap"  Aeson..= result
-      , "tree"  Aeson..= Aeson.toJSON1 core
      ]
    _other                       -> HUnit.assertFailure "Couldn't run scope dumping mechanism; this shouldn't happen"

--- a/semantic-source/CHANGELOG.md
+++ b/semantic-source/CHANGELOG.md
@ -0,0 +1,9 @@
+# 0.0.0.1
+
+- Loosens the upper bound on `hashable`.
+- Adds support for GHC 8.8.1.
+
+
+# 0.0.0.0
+
+Initial release
--- a/semantic-source/semantic-source.cabal
+++ b/semantic-source/semantic-source.cabal
@ -1,7 +1,7 @@
 cabal-version:       2.4

 name:                semantic-source
-version:             0.0.0.0
+version:             0.0.0.1
 synopsis:            Types and functionality for working with source code
 description:         Types and functionality for working with source code (program text).
 homepage:            https://github.com/github/semantic/tree/master/semantic-source#readme
@ -15,11 +15,12 @@ category:            Data
 build-type:          Simple
 stability:           alpha
 extra-source-files:
+  CHANGELOG.md
  README.md

-
 tested-with:
  GHC == 8.6.5
+  GHC == 8.8.1

 common common
  default-language: Haskell2010
@ -35,6 +36,8 @@ common common
    -Wno-missed-specialisations
    -Wno-all-missed-specialisations
    -Wno-star-is-type
+  if (impl(ghc >= 8.8))
+    ghc-options: -Wno-missing-deriving-strategies

 library
  import: common
@ -43,15 +46,13 @@ library
    Source.Range
    Source.Source
    Source.Span
-  -- other-modules:
-  -- other-extensions:
  build-depends:
      aeson          ^>= 1.4.2.0
    , base            >= 4.12 && < 5
    , bytestring     ^>= 0.10.8.2
    , deepseq        ^>= 1.4.4.0
    , generic-monoid ^>= 0.1.0.0
-    , hashable       ^>= 1.2.7.0
+    , hashable        >= 1.2.7 && < 1.4
    , semilattices   ^>= 0.0.0.3
    , text           ^>= 1.2.3.1
  hs-source-dirs: src
--- a/src/Control/Carrier/Parse/Measured.hs
+++ b/src/Control/Carrier/Parse/Measured.hs
@ -60,13 +60,13 @@ runParser blob@Blob{..} parser = case parser of
    time "parse.tree_sitter_ast_parse" languageTag $ do
      config <- asks config
      parseToAST (configTreeSitterParseTimeout config) language blob
-        >>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
+        >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure

  UnmarshalParser language ->
    time "parse.tree_sitter_ast_parse" languageTag $ do
      config <- asks config
      parseToPreciseAST (configTreeSitterParseTimeout config) language blob
-        >>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
+        >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure

  AssignmentParser    parser assignment -> runAssignment Assignment.assign    parser blob assignment
  DeterministicParser parser assignment -> runAssignment Deterministic.assign parser blob assignment
--- a/src/Control/Carrier/Parse/Simple.hs
+++ b/src/Control/Carrier/Parse/Simple.hs
@ -51,11 +51,11 @@ runParser
 runParser timeout blob@Blob{..} parser = case parser of
  ASTParser language ->
    parseToAST timeout language blob
-      >>= either (throwError . SomeException . ParseFailure) pure
+      >>= either (throwError . SomeException) pure

  UnmarshalParser language ->
    parseToPreciseAST timeout language blob
-      >>= either (throwError . SomeException . ParseFailure) pure
+      >>= either (throwError . SomeException) pure

  AssignmentParser    parser assignment ->
    runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign    blobSource assignment
--- a/src/Control/Effect/Parse.hs
+++ b/src/Control/Effect/Parse.hs
@ -1,12 +1,20 @@
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, RankNTypes #-}
 module Control.Effect.Parse
 ( -- * Parse effect
  Parse(..)
 , parse
+, parseWith
+, parsePairWith
 ) where

 import Control.Effect.Carrier
+import Control.Effect.Error
+import Control.Exception (SomeException)
+import Data.Bifunctor.Join
 import Data.Blob
+import Data.Language
+import qualified Data.Map as Map
+import Data.These
 import Parsing.Parser

 data Parse m k
@ -27,3 +35,26 @@ parse :: (Member Parse sig, Carrier sig m)
      -> Blob
      -> m term
 parse parser blob = send (Parse parser blob pure)
+
+
+-- | Parse a 'Blob' with one of the provided parsers, and run an action on the abstracted term.
+parseWith
+  :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig)
+  => Map.Map Language (SomeParser c ann)       -- ^ The set of parsers to select from.
+  -> (forall term . c term => term ann -> m a) -- ^ A function to run on the parsed term. Note that the term is abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
+  -> Blob                                      -- ^ The blob to parse.
+  -> m a
+parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of
+  Just (SomeParser parser) -> parse parser blob >>= with
+  _                        -> noLanguageForBlob (blobPath blob)
+
+-- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair.
+parsePairWith
+  :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig)
+  => Map.Map Language (SomeParser c ann)                          -- ^ The set of parsers to select from.
+  -> (forall term . c term => These (term ann) (term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but 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 a
+parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of
+  Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin
+  _                        -> noLanguageForBlob (pathForBlobPair blobPair)
--- a/src/Diffing/Interpreter.hs
+++ b/src/Diffing/Interpreter.hs
@ -1,4 +1,4 @@
-{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-}
 module Diffing.Interpreter
 ( diffTerms
 , DiffTerms(..)
@ -29,11 +29,18 @@ stripDiff :: Functor syntax
          -> Diff.Diff syntax ann1 ann2
 stripDiff = bimap snd snd

-class DiffTerms term diff | diff -> term, term -> diff where
-  -- | Diff a 'These' of terms.
-  diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2
+-- | 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

-instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where
+  -- | Diff a 'These' of terms.
+  diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2
+
+instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where
+  type DiffFor (Term syntax) = Diff.Diff syntax
  diffTermPair = these Diff.deleting Diff.inserting diffTerms


--- a/src/Parsing/Parser.hs
+++ b/src/Parsing/Parser.hs
@ -1,12 +1,11 @@
-{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
 module Parsing.Parser
 ( Parser(..)
 , SomeAnalysisParser(..)
 , SomeASTParser(..)
 , someASTParser
 , someAnalysisParser
-, ApplyAll
-- À la carte parsers
+-- * À la carte parsers
 , goParser
 , goASTParser
 , jsonParser
@ -21,8 +20,27 @@ module Parsing.Parser
 , phpParser
 , phpASTParser
 , haskellParser
-  -- Precise parsers
-, precisePythonParser
+  -- * Abstract parsers
+
+  -- $abstract
+, SomeParser(..)
+, goParser'
+, haskellParser'
+, javascriptParser'
+, jsonParser'
+, jsxParser'
+, markdownParser'
+, phpParser'
+, pythonParserALaCarte'
+, pythonParserPrecise'
+, pythonParser'
+, rubyParser'
+, tsxParser'
+, typescriptParser'
+  -- * Canonical sets of parsers
+, aLaCarteParsers
+, preciseParsers
+, allParsers
 ) where

 import           Assigning.Assignment
@ -31,8 +49,9 @@ import qualified CMarkGFM
 import           Data.Abstract.Evaluatable (HasPrelude)
 import           Data.AST
 import           Data.Graph.ControlFlowVertex (VertexDeclaration')
-import           Data.Kind
 import           Data.Language
+import           Data.Kind (Constraint)
+import qualified Data.Map as Map
 import           Data.Sum
 import qualified Data.Syntax as Syntax
 import           Data.Term
@ -62,26 +81,26 @@ import           TreeSitter.Unmarshal


 -- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
-data SomeAnalysisParser typeclasses ann where
-  SomeAnalysisParser :: ( ApplyAll typeclasses (Sum fs)
+data SomeAnalysisParser (constraint :: (* -> *) -> Constraint) ann where
+  SomeAnalysisParser :: ( constraint (Sum fs)
                        , Apply (VertexDeclaration' (Sum fs)) fs
                        , HasPrelude lang
                        )
                     => Parser (Term (Sum fs) ann)
                     -> Proxy lang
-                     -> SomeAnalysisParser typeclasses ann
+                     -> SomeAnalysisParser constraint ann

 -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
-someAnalysisParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
-                      , ApplyAll typeclasses (Sum PHP.Syntax)
-                      , ApplyAll typeclasses (Sum Python.Syntax)
-                      , ApplyAll typeclasses (Sum Ruby.Syntax)
-                      , ApplyAll typeclasses (Sum TypeScript.Syntax)
-                      , ApplyAll typeclasses (Sum Haskell.Syntax)
+someAnalysisParser :: ( constraint (Sum Go.Syntax)
+                      , constraint (Sum PHP.Syntax)
+                      , constraint (Sum Python.Syntax)
+                      , constraint (Sum Ruby.Syntax)
+                      , constraint (Sum TypeScript.Syntax)
+                      , constraint (Sum Haskell.Syntax)
                      )
-                   => proxy typeclasses                  -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-                   -> Language                           -- ^ The 'Language' to select.
-                   -> SomeAnalysisParser typeclasses Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced.
+                   => proxy constraint                  -- ^ A proxy for the constraint required, e.g. @(Proxy \@Show1)@.
+                   -> Language                          -- ^ The 'Language' to select.
+                   -> SomeAnalysisParser constraint Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced.
 someAnalysisParser _ Go         = SomeAnalysisParser goParser         (Proxy @'Go)
 someAnalysisParser _ Haskell    = SomeAnalysisParser haskellParser    (Proxy @'Haskell)
 someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy @'JavaScript)
@ -112,12 +131,6 @@ data Parser term where
  MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))


-- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
-type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
-  ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax)
-  ApplyAll '[] syntax = ()
-
-
 goParser :: Parser Go.Term
 goParser = AssignmentParser (ASTParser tree_sitter_go) Go.assignment

@ -161,8 +174,8 @@ markdownParser :: Parser Markdown.Term
 markdownParser = AssignmentParser MarkdownParser Markdown.assignment


-precisePythonParser :: Parser (Py.Term Loc)
-precisePythonParser = UnmarshalParser tree_sitter_python
+pythonParserPrecise :: Parser (Py.Term Loc)
+pythonParserPrecise = UnmarshalParser tree_sitter_python


 -- | A parser for producing specialized (tree-sitter) ASTs.
@ -189,3 +202,139 @@ someASTParser PHP        = Just (SomeASTParser (ASTParser tree_sitter_php :: Par
 someASTParser Java       = Nothing
 someASTParser Markdown   = Nothing
 someASTParser Unknown    = Nothing
+
+
+-- $abstract
+-- Most of our features are intended to operate over multiple languages, each represented by disjoint term types. Thus, we typically implement them using typeclasses, allowing us to share a single interface to invoke the feature, while specializing the implementation(s) as appropriate for each distinct term type.
+--
+-- In order to accomplish this, we employ 'SomeParser', which abstracts over parsers of various term types, while ensuring that some desired constraint holds. Constructing a @'SomeParser' c@ requires satisfiyng the constraint @c@ against the underlying 'Parser'’s term type, and so it can be used to parse with any of a map of parsers whose terms support @c@.
+--
+-- In practice, this means using 'Control.Effect.Parse.parseWith', and passing in a map of parsers to select from for your feature. It is recommended to define the map as a concrete top-level binding using the abstract parsers or ideally the canonical maps of parsers, below; using the abstracted parsers or canonical maps directly with 'Control.Effect.Parse.parseWith' will lead to significantly slower compiles.
+--
+-- Bad:
+--
+-- @
+-- isFancy :: (Carrier sig m, Member Parse sig) => Blob -> m Bool
+-- isFancy = parseWith (preciseParsers @Fancy) (pure . isTermFancy) -- slow compiles!
+-- @
+--
+-- Good:
+--
+-- @
+-- fancyParsers :: 'Map' 'Language' ('SomeParser' Fancy 'Loc')
+-- fancyParsers = preciseParsers
+--
+-- isFancy :: (Carrier sig m, Member Parse sig) => Blob -> m Bool
+-- isFancy = parseWith fancyParsers (pure . isTermFancy) -- much faster compiles
+-- @
+
+
+-- | A parser producing terms of existentially-quantified type under some constraint @c@.
+--
+--   This can be used to perform actions on terms supporting some feature abstracted using a typeclass, without knowing (or caring) what the specific term types are.
+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' = (Go, SomeParser goParser)
+
+haskellParser' :: c (Term (Sum Haskell.Syntax)) => (Language, SomeParser c Loc)
+haskellParser' = (Haskell, SomeParser haskellParser)
+
+javascriptParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc)
+javascriptParser' = (JavaScript, SomeParser tsxParser)
+
+jsonParser' :: c (Term (Sum JSON.Syntax)) => (Language, SomeParser c Loc)
+jsonParser' = (JSON, SomeParser jsonParser)
+
+jsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc)
+jsxParser' = (JSX, SomeParser tsxParser)
+
+markdownParser' :: c (Term (Sum Markdown.Syntax)) => (Language, SomeParser c Loc)
+markdownParser' = (Markdown, SomeParser markdownParser)
+
+phpParser' :: c (Term (Sum PHP.Syntax)) => (Language, SomeParser c Loc)
+phpParser' = (PHP, SomeParser phpParser)
+
+pythonParserALaCarte' :: c (Term (Sum Python.Syntax)) => (Language, SomeParser c Loc)
+pythonParserALaCarte' = (Python, SomeParser pythonParser)
+
+pythonParserPrecise' :: c Py.Term => (Language, SomeParser c Loc)
+pythonParserPrecise' = (Python, SomeParser pythonParserPrecise)
+
+pythonParser' :: (c (Term (Sum Python.Syntax)), c Py.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' = (Ruby, SomeParser rubyParser)
+
+tsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc)
+tsxParser' = (TSX, SomeParser tsxParser)
+
+typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc)
+typescriptParser' = (TypeScript, SomeParser typescriptParser)
+
+
+-- | The canonical set of parsers producing à la carte terms.
+aLaCarteParsers
+  :: ( c (Term (Sum Go.Syntax))
+     , c (Term (Sum Haskell.Syntax))
+     , c (Term (Sum JSON.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))
+     )
+  => Map Language (SomeParser c Loc)
+aLaCarteParsers = Map.fromList
+  [ goParser'
+  , haskellParser'
+  , javascriptParser'
+  , jsonParser'
+  , jsxParser'
+  , markdownParser'
+  , phpParser'
+  , pythonParserALaCarte'
+  , rubyParser'
+  , typescriptParser'
+  , tsxParser'
+  ]
+
+-- | The canonical set of parsers producing precise terms.
+preciseParsers :: c Py.Term => Map Language (SomeParser c Loc)
+preciseParsers = Map.fromList
+  [ pythonParserPrecise'
+  ]
+
+-- | The canonical set of all parsers for the passed per-language modes.
+allParsers
+  :: ( c (Term (Sum Go.Syntax))
+     , c (Term (Sum Haskell.Syntax))
+     , c (Term (Sum JSON.Syntax))
+     , c (Term (Sum Markdown.Syntax))
+     , c (Term (Sum PHP.Syntax))
+     , c (Term (Sum Python.Syntax))
+     , c Py.Term
+     , c (Term (Sum Ruby.Syntax))
+     , c (Term (Sum TSX.Syntax))
+     , c (Term (Sum TypeScript.Syntax))
+     )
+  => PerLanguageModes
+  -> Map Language (SomeParser c Loc)
+allParsers modes = Map.fromList
+  [ goParser'
+  , haskellParser'
+  , javascriptParser'
+  , jsonParser'
+  , jsxParser'
+  , markdownParser'
+  , phpParser'
+  , pythonParser' modes
+  , rubyParser'
+  , typescriptParser'
+  , tsxParser'
+  ]
--- a/src/Parsing/TreeSitter.hs
+++ b/src/Parsing/TreeSitter.hs
@ -1,6 +1,7 @@
-{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE DataKinds, GADTs, LambdaCase, ScopedTypeVariables, TypeOperators #-}
 module Parsing.TreeSitter
-( Duration(..)
+( TSParseException (..)
+, Duration(..)
 , parseToAST
 , parseToPreciseAST
 ) where
@ -10,6 +11,7 @@ import Prologue
 import           Control.Effect.Fail
 import           Control.Effect.Lift
 import           Control.Effect.Reader
+import qualified Control.Exception as Exc
 import           Foreign
 import           Foreign.C.Types (CBool (..))
 import           Foreign.Marshal.Array (allocaArray)
@ -29,6 +31,12 @@ import qualified TreeSitter.Parser as TS
 import qualified TreeSitter.Tree as TS
 import qualified TreeSitter.Unmarshal as TS

+data TSParseException
+  = ParserTimedOut
+  | IncompatibleVersions
+  | UnmarshalFailure String
+    deriving (Eq, Show, Generic)
+
 -- | Parse a 'Blob' with the given 'TS.Language' and return its AST.
 -- Returns 'Nothing' if the operation timed out.
 parseToAST :: ( Bounded grammar
@ -38,8 +46,8 @@ parseToAST :: ( Bounded grammar
           => Duration
           -> Ptr TS.Language
           -> Blob
-           -> m (Either String (AST [] grammar))
-parseToAST parseTimeout language blob = runParse parseTimeout language blob (fmap Right . anaM toAST <=< peek)
+           -> m (Either TSParseException  (AST [] grammar))
+parseToAST parseTimeout language blob = runParse parseTimeout language blob (anaM toAST <=< peek)

 parseToPreciseAST
  :: ( MonadIO m
@ -48,20 +56,27 @@ parseToPreciseAST
  => Duration
  -> Ptr TS.Language
  -> Blob
-  -> m (Either String (t Loc))
+  -> m (Either TSParseException (t Loc))
 parseToPreciseAST parseTimeout language blob = runParse parseTimeout language blob $ \ rootPtr ->
  TS.withCursor (castPtr rootPtr) $ \ cursor ->
    runM (runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode))))
+      >>= either (Exc.throw . UnmarshalFailure) pure
+
+instance Exception TSParseException where
+  displayException = \case
+    ParserTimedOut -> "tree-sitter: parser timed out"
+    IncompatibleVersions -> "tree-sitter: incompatible versions"
+    UnmarshalFailure s -> "tree-sitter: unmarshal failure - " <> show s

 runParse
  :: MonadIO m
  => Duration
  -> Ptr TS.Language
  -> Blob
-  -> (Ptr TS.Node -> IO (Either String a))
-  -> m (Either String a)
+  -> (Ptr TS.Node -> IO a)
+  -> m (Either TSParseException a)
 runParse parseTimeout language Blob{..} action =
-  liftIO . TS.withParser language $ \ parser -> do
+  liftIO . Exc.tryJust fromException . TS.withParser language $ \ parser -> do
    let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
    TS.ts_parser_set_timeout_micros parser timeoutMicros
    TS.ts_parser_halt_on_error parser (CBool 1)
@ -69,11 +84,11 @@ runParse parseTimeout language Blob{..} action =
    if compatible then
      TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do
        if treePtr == nullPtr then
-          pure (Left "tree-sitter: null root node")
+          Exc.throw ParserTimedOut
        else
          TS.withRootNode treePtr action
    else
-      pure (Left "tree-sitter: incompatible versions")
+      Exc.throw IncompatibleVersions

 toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
 toAST node@TS.Node{..} = do
--- a/src/Semantic/Api/Diffs.hs
+++ b/src/Semantic/Api/Diffs.hs
@ -1,15 +1,15 @@
-{-# LANGUAGE GADTs, ConstraintKinds, FunctionalDependencies, LambdaCase, RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, LambdaCase, MonoLocalBinds, QuantifiedConstraints, RankNTypes #-}
 module Semantic.Api.Diffs
  ( parseDiffBuilder
  , DiffOutputFormat(..)
  , diffGraph

-  , doDiff
+  , decoratingDiffWith
  , DiffEffects

-  , SomeTermPair(..)
-
+  , legacySummarizeDiffParsers
  , LegacySummarizeDiff(..)
+  , summarizeDiffParsers
  , SummarizeDiff(..)
  ) where

@ -24,13 +24,13 @@ import           Control.Lens
 import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.ByteString.Builder
-import           Data.Diff
 import           Data.Graph
 import           Data.JSON.Fields
 import           Data.Language
 import           Data.ProtoLens (defMessage)
 import           Data.Term
 import qualified Data.Text as T
+import           Diffing.Algorithm (Diffable)
 import           Diffing.Interpreter (DiffTerms(..))
 import           Parsing.Parser
 import           Prologue
@ -60,12 +60,12 @@ data DiffOutputFormat
 parseDiffBuilder :: (Traversable t, DiffEffects sig 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 (doDiff (const id) sexprDiff)
-parseDiffBuilder DiffShow        = distributeFoldMap (doDiff (const id) showDiff)
-parseDiffBuilder DiffDotGraph    = distributeFoldMap (doDiff (const id) dotGraphDiff)
+parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith sexprDiffParsers sexprDiff)
+parseDiffBuilder DiffShow        = distributeFoldMap (diffWith showDiffParsers showDiff)
+parseDiffBuilder DiffDotGraph    = distributeFoldMap (diffWith dotGraphDiffParsers dotGraphDiff)

 jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
-jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair
+jsonDiff blobPair = diffWith jsonTreeDiffParsers (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair

 jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
 jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
@ -76,7 +76,7 @@ diffGraph blobs = do
  pure $ defMessage & P.files .~ toList graph
  where
    go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph
-    go blobPair = doDiff (const id) (pure . jsonGraphDiff blobPair) blobPair
+    go blobPair = diffWith jsonGraphDiffParsers (pure . jsonGraphDiff blobPair) blobPair
      `catchError` \(SomeException e) ->
        pure $ defMessage
          & P.path .~ path
@ -90,20 +90,24 @@ diffGraph blobs = do

 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)

-type Decorate a b = forall term diff . DiffActions term diff => Blob -> term a -> term b

+dotGraphDiffParsers :: Map Language (SomeParser DOTGraphDiff Loc)
+dotGraphDiffParsers = aLaCarteParsers

-class DOTGraphDiff diff where
-  dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
+class DiffTerms term => DOTGraphDiff term where
+  dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder

-instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Diff syntax) where
+instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DOTGraphDiff (Term syntax) where
  dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph


-class JSONGraphDiff diff where
-  jsonGraphDiff :: BlobPair -> diff Loc Loc -> DiffTreeFileGraph
+jsonGraphDiffParsers :: Map Language (SomeParser JSONGraphDiff Loc)
+jsonGraphDiffParsers = aLaCarteParsers

-instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Diff syntax) where
+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
@ -117,41 +121,56 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphD
           & P.errors .~ mempty


-class JSONTreeDiff diff where
-  jsonTreeDiff :: BlobPair -> diff Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON
+jsonTreeDiffParsers :: Map Language (SomeParser JSONTreeDiff Loc)
+jsonTreeDiffParsers = aLaCarteParsers

-instance ToJSONFields1 syntax => JSONTreeDiff (Diff syntax) where
+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


-class SExprDiff diff where
-  sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
+sexprDiffParsers :: Map Language (SomeParser SExprDiff Loc)
+sexprDiffParsers = aLaCarteParsers

-instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Diff syntax) where
+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)


-class ShowDiff diff where
-  showDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
+showDiffParsers :: Map Language (SomeParser ShowDiff Loc)
+showDiffParsers = aLaCarteParsers

-instance Show1 syntax => ShowDiff (Diff syntax) where
+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


-class LegacySummarizeDiff term diff | diff -> term, term -> diff where
-  legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
-  legacySummarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> Summaries
+legacySummarizeDiffParsers :: Map Language (SomeParser LegacySummarizeDiff Loc)
+legacySummarizeDiffParsers = aLaCarteParsers

-instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) (Diff syntax) where
+class DiffTerms term => LegacySummarizeDiff term where
+  legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
+  legacySummarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> Summaries
+
+instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => LegacySummarizeDiff (Term syntax) where
  legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra
  legacySummarizeDiff = renderToCDiff


-class SummarizeDiff term diff | diff -> term, term -> diff where
-  decorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
-  summarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile
+summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc)
+summarizeDiffParsers = aLaCarteParsers

-instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) (Diff syntax) where
+class DiffTerms term => SummarizeDiff term where
+  decorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
+  summarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile
+
+instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where
  decorateTerm = decoratorWithAlgebra . declarationAlgebra
  summarizeDiff blobPair diff = foldr go (defMessage & P.path .~ path & P.language .~ lang) (diffTOC diff)
    where
@ -178,51 +197,35 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi
        & P.errors .~ (defMessage & P.error .~ errorText & P.maybe'span .~ converting #? errorSpan) : file^.P.errors


-type DiffActions term diff =
-  ( Bifoldable diff
-  , DiffTerms term diff
-  , DOTGraphDiff diff
-  , JSONGraphDiff diff
-  , JSONTreeDiff diff
-  , SExprDiff diff
-  , ShowDiff diff
-  , LegacySummarizeDiff term diff
-  , SummarizeDiff term diff
-  )
-
-doDiff
-  :: DiffEffects sig m
-  => Decorate Loc ann
-  -> (forall term diff . DiffActions term diff => diff ann ann -> m output)
-  -> BlobPair
+-- | 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
-doDiff decorate render blobPair = do
-  SomeTermPair terms <- doParse blobPair decorate
-  diff <- diffTerms blobPair terms
-  render diff
+diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms blobPair) blobPair

-diffTerms :: (DiffActions term diff, Member Telemetry sig, Carrier sig m, MonadIO m)
-  => BlobPair -> Join These (term ann) -> m (diff ann ann)
+-- | Parse a 'BlobPair' using one of the provided parsers, decorate the resulting terms, diff them, 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.
+decoratingDiffWith
+  :: forall ann c output m sig
+  .  (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 => Blob -> term Loc -> term ann)     -- ^ A function to decorate the terms, replacing their annotations and thus the annotations in the resulting diff.
+  -> (forall term . c term => DiffFor term ann ann -> 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
+decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . bimap (decorate blobL) (decorate blobR)) blobPair where
+  (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair)
+  errorBlob = Prelude.error "evaluating blob on absent side"
+
+diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m)
+  => BlobPair -> These (term ann) (term ann) -> m (DiffFor term ann ann)
 diffTerms blobs terms = time "diff" languageTag $ do
-  let diff = diffTermPair (runJoin terms)
+  let diff = diffTermPair terms
  diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
  where languageTag = languageTagForBlobPair blobs
-
-doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Carrier sig m)
-  => BlobPair -> Decorate Loc ann -> m (SomeTermPair ann)
-doParse blobPair decorate = case languageForBlobPair blobPair of
-  Go         -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse goParser blob)
-  Haskell    -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse haskellParser blob)
-  JavaScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
-  JSON       -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse jsonParser blob)
-  JSX        -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
-  Markdown   -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse markdownParser blob)
-  Python     -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse pythonParser blob)
-  Ruby       -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse rubyParser blob)
-  TypeScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse typescriptParser blob)
-  TSX        -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
-  PHP        -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse phpParser blob)
-  _          -> noLanguageForBlob (pathForBlobPair blobPair)
-
-data SomeTermPair ann where
-  SomeTermPair :: DiffActions term diff => Join These (term ann) -> SomeTermPair ann
--- a/src/Semantic/Api/Symbols.hs
+++ b/src/Semantic/Api/Symbols.hs
@ -17,6 +17,7 @@ import           Data.ProtoLens (defMessage)
 import           Data.Term
 import           Data.Text (pack)
 import qualified Data.Text as T
+import qualified Language.Python as Python
 import qualified Parsing.Parser as Parser
 import           Prologue
 import           Proto.Semantic as P hiding (Blob, BlobPair)
@ -28,6 +29,7 @@ import           Semantic.Config
 import           Semantic.Task
 import           Serializing.Format (Format)
 import           Source.Loc
+import           Source.Source
 import           Tags.Taggable
 import           Tags.Tagging
 import qualified Tags.Tagging.Precise as Precise
@ -36,7 +38,7 @@ legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig,
 legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
  where
    go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File]
-    go blob@Blob{..} = doParse (pure . renderToSymbols) symbolsToSummarize blob `catchError` (\(SomeException _) -> pure (pure emptyFile))
+    go blob@Blob{..} = asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile))
      where
        emptyFile = tagsToFile []

@ -44,8 +46,8 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
        symbolsToSummarize :: [Text]
        symbolsToSummarize = ["Function", "Method", "Class", "Module"]

-        renderToSymbols :: Precise.ToTags t => t Loc -> [Legacy.File]
-        renderToSymbols = pure . tagsToFile . Precise.tags blobSource
+        renderToSymbols :: ToTags t => t Loc -> [Legacy.File]
+        renderToSymbols = pure . tagsToFile . tags (blobLanguage blob) symbolsToSummarize blobSource

        tagsToFile :: [Tag] -> Legacy.File
        tagsToFile tags = Legacy.File (pack (blobPath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags)
@ -68,7 +70,7 @@ parseSymbols blobs = do
  pure $ defMessage & P.files .~ toList terms
  where
    go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File
-    go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) symbolsToSummarize blob
+    go blob@Blob{..} = catching $ asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob
      where
        catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e))
        blobLanguage' = blobLanguage blob
@ -80,8 +82,8 @@ parseSymbols blobs = do
          & P.errors .~ [defMessage & P.error .~ T.pack e]
          & P.blobOid .~ blobOid

-        renderToSymbols :: Precise.ToTags t => t Loc -> File
-        renderToSymbols term = tagsToFile (Precise.tags blobSource term)
+        renderToSymbols :: ToTags t => t Loc -> File
+        renderToSymbols term = tagsToFile (tags (blobLanguage blob) symbolsToSummarize blobSource term)

        tagsToFile :: [Tag] -> File
        tagsToFile tags = defMessage
@ -102,38 +104,15 @@ parseSymbols blobs = do
 symbolsToSummarize :: [Text]
 symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]

-data ALaCarteTerm syntax ann = ALaCarteTerm Language [Text] (Term syntax ann)
+class ToTags t where
+  tags :: Language -> [Text] -> Source -> t Loc -> [Tag]

-instance IsTaggable syntax => Precise.ToTags (ALaCarteTerm syntax) where
-  tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang source symbolsToSummarize term
+instance IsTaggable syntax => ToTags (Term syntax) where
+  tags = runTagging
+
+instance ToTags Python.Term where
+  tags _ _ = Precise.tags


-doParse
-  :: ( Carrier sig m
-     , Member (Error SomeException) sig
-     , Member Parse sig
-     , Member (Reader PerLanguageModes) sig
-     )
-  => (forall t . Precise.ToTags t => t Loc -> m a)
-  -> [Text]
-  -> Blob
-  -> m a
-doParse with symbolsToSummarize blob = do
-  modes <- ask @PerLanguageModes
-  case blobLanguage blob of
-    Go         -> parse Parser.goParser         blob >>= with . mkTerm
-    Haskell    -> parse Parser.haskellParser    blob >>= with . mkTerm
-    JavaScript -> parse Parser.tsxParser        blob >>= with . mkTerm
-    JSON       -> parse Parser.jsonParser       blob >>= with . mkTerm
-    JSX        -> parse Parser.tsxParser        blob >>= with . mkTerm
-    Markdown   -> parse Parser.markdownParser   blob >>= with . mkTerm
-    Python
-      | Precise <- pythonMode modes -> parse Parser.precisePythonParser blob >>= with
-      | otherwise                   -> parse Parser.pythonParser        blob >>= with . mkTerm
-    Ruby       -> parse Parser.rubyParser       blob >>= with . mkTerm
-    TypeScript -> parse Parser.typescriptParser blob >>= with . mkTerm
-    TSX        -> parse Parser.tsxParser        blob >>= with . mkTerm
-    PHP        -> parse Parser.phpParser        blob >>= with . mkTerm
-    _          -> noLanguageForBlob (blobPath blob)
-    where mkTerm :: Term syntax Loc -> ALaCarteTerm syntax Loc
-          mkTerm = ALaCarteTerm (blobLanguage blob) symbolsToSummarize
+toTagsParsers :: PerLanguageModes -> Map Language (Parser.SomeParser ToTags Loc)
+toTagsParsers = Parser.allParsers
--- a/src/Semantic/Api/TOCSummaries.hs
+++ b/src/Semantic/Api/TOCSummaries.hs
@ -24,7 +24,7 @@ legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries
 legacyDiffSummary = distributeFoldMap go
  where
    go :: DiffEffects sig m => BlobPair -> m Summaries
-    go blobPair = doDiff legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair
+    go blobPair = decoratingDiffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair
      `catchError` \(SomeException e) ->
        pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)])
      where path = T.pack $ pathKeyForBlobPair blobPair
@ -37,7 +37,7 @@ diffSummary blobs = do
  pure $ defMessage & P.files .~ diff
  where
    go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile
-    go blobPair = doDiff decorateTerm (pure . summarizeDiff blobPair) blobPair
+    go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair
      `catchError` \(SomeException e) ->
        pure $ defMessage
          & P.path .~ path
--- a/src/Semantic/Api/Terms.hs
+++ b/src/Semantic/Api/Terms.hs
@ -47,7 +47,7 @@ termGraph blobs = do
    & P.files .~ toList terms
  where
    go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph
-    go blob = doParse (pure . jsonGraphTerm blob) blob
+    go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob
      `catchError` \(SomeException e) ->
        pure $ defMessage
          & P.path .~ path
@ -72,19 +72,19 @@ parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, 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
-parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm)
-parseTermBuilder TermDotGraph    = distributeFoldMap (doParse dotGraphTerm)
-parseTermBuilder TermShow        = distributeFoldMap (doParse showTerm)
+parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers sexprTerm)
+parseTermBuilder TermDotGraph    = distributeFoldMap (parseWith dotGraphTermParsers dotGraphTerm)
+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 blob = doParse (pure . jsonTreeTerm blob) blob `catchError` jsonError blob
+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 blob = showTiming blob <$> time' ( doParse (fmap (const (Right ())) . showTerm) blob `catchError` timingError )
+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))
    showTiming Blob{..} (res, duration) =
@ -95,6 +95,9 @@ quietTerm blob = showTiming blob <$> time' ( doParse (fmap (const (Right ())) .
 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

@ -102,9 +105,12 @@ instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where
  showTerm = serialize Show . quieterm

 instance ShowTerm Py.Term where
-  showTerm = serialize Show . Py.getTerm
+  showTerm = serialize Show . void . Py.getTerm


+sexprTermParsers :: Map Language (SomeParser SExprTerm Loc)
+sexprTermParsers = aLaCarteParsers
+
 class SExprTerm term where
  sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder

@ -112,6 +118,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm
  sexprTerm = serialize (SExpression ByConstructorName)


+dotGraphTermParsers :: Map Language (SomeParser DOTGraphTerm Loc)
+dotGraphTermParsers = aLaCarteParsers
+
 class DOTGraphTerm term where
  dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder

@ -119,6 +128,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTe
  dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph


+jsonTreeTermParsers :: Map Language (SomeParser JSONTreeTerm Loc)
+jsonTreeTermParsers = aLaCarteParsers
+
 class JSONTreeTerm term where
  jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON

@ -126,6 +138,9 @@ instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where
  jsonTreeTerm = renderJSONTerm


+jsonGraphTermParsers :: Map Language (SomeParser JSONGraphTerm Loc)
+jsonGraphTermParsers = aLaCarteParsers
+
 class JSONGraphTerm term where
  jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph

@ -141,27 +156,3 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT
          & P.vertices .~ vertexList graph
          & P.edges .~ fmap toEdge (edgeList graph)
          & P.errors .~ mempty
-
-type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t, ShowTerm t)
-
-doParse
-  :: ( Carrier sig m
-     , Member (Error SomeException) sig
-     , Member Parse sig
-     )
-  => (forall term . TermActions term => term Loc -> m a)
-  -> Blob
-  -> m a
-doParse with blob = case blobLanguage blob of
-  Go         -> parse goParser         blob >>= with
-  Haskell    -> parse haskellParser    blob >>= with
-  JavaScript -> parse tsxParser        blob >>= with
-  JSON       -> parse jsonParser       blob >>= with
-  JSX        -> parse tsxParser        blob >>= with
-  Markdown   -> parse markdownParser   blob >>= with
-  Python     -> parse pythonParser     blob >>= with
-  Ruby       -> parse rubyParser       blob >>= with
-  TypeScript -> parse typescriptParser blob >>= with
-  TSX        -> parse tsxParser        blob >>= with
-  PHP        -> parse phpParser        blob >>= with
-  _          -> noLanguageForBlob (blobPath blob)
--- a/src/Semantic/Graph.hs
+++ b/src/Semantic/Graph.hs
@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Graph
 ( runGraph
 , runCallGraph
@ -71,7 +71,29 @@ import           Text.Show.Pretty (ppShow)

 data GraphType = ImportGraph | CallGraph

-type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, AccessControls1, Foldable, Functor, Ord1, Show1 ]
+-- | Constraints we require for a term’s syntax in order to analyze it.
+class
+  ( Declarations1 syntax
+  , Eq1 syntax
+  , Evaluatable syntax
+  , FreeVariables1 syntax
+  , AccessControls1 syntax
+  , Foldable syntax
+  , Functor syntax
+  , Ord1 syntax
+  , Show1 syntax
+  ) => AnalysisClasses syntax
+instance
+  ( Declarations1 syntax
+  , Eq1 syntax
+  , Evaluatable syntax
+  , FreeVariables1 syntax
+  , AccessControls1 syntax
+  , Foldable syntax
+  , Functor syntax
+  , Ord1 syntax
+  , Show1 syntax
+  ) => AnalysisClasses syntax

 runGraph :: ( Member Distribute sig
            , Member Parse sig
--- a/src/Tags/Tagging.hs
+++ b/src/Tags/Tagging.hs
@ -23,11 +23,11 @@ import           Tags.Taggable

 runTagging :: (IsTaggable syntax)
           => Language
-           -> Source.Source
           -> [Text]
+           -> Source.Source
           -> Term syntax Loc
           -> [Tag]
-runTagging lang source symbolsToSummarize
+runTagging lang symbolsToSummarize source
  = Eff.run
  . evalState @[ContextToken] []
  . Streaming.toList_
--- a/test/Tags/Spec.hs
+++ b/test/Tags/Spec.hs
@ -10,40 +10,40 @@ spec = do
  describe "go" $ do
    it "produces tags for functions with docs" $ do
      (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "TestFromBits" Function (Span (Pos 6 1) (Pos 8 2)) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...")
        , Tag "Hi" Function (Span (Pos 10 1) (Pos 11 2)) "func Hi()" Nothing ]

    it "produces tags for methods" $ do
      (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/method.go")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "CheckAuth" Method (Span (Pos 3 1) (Pos 3 100)) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing]

    it "produces tags for calls" $ do
      (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
-      runTagging (blobLanguage blob) (blobSource blob) ["Call"] tree `shouldBe`
+      runTagging (blobLanguage blob) ["Call"] (blobSource blob) tree `shouldBe`
        [ Tag "Hi" Call (Span (Pos 7 2) (Pos 7 6)) "Hi()" Nothing]

  describe "javascript and typescript" $ do
    it "produces tags for functions with docs" $ do
      (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/javascript/tags/simple_function_with_docs.js")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "myFunction" Function (Span (Pos 2 1) (Pos 4 2)) "function myFunction()" (Just "// This is myFunction") ]

    it "produces tags for classes" $ do
      (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/class.ts")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "FooBar" Class (Span (Pos 1 1) (Pos 1 16)) "class FooBar" Nothing ]

    it "produces tags for modules" $ do
      (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/module.ts")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "APromise" Tags.Module (Span (Pos 1 1) (Pos 1 20)) "module APromise { }" Nothing ]

  describe "python" $ do
    it "produces tags for functions" $ do
      (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_functions.py")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "Foo" Function (Span (Pos 1 1) (Pos 5 17)) "def Foo(x):" Nothing
        , Tag "Bar" Function (Span (Pos 7 1) (Pos 11 13)) "def Bar():" Nothing
        , Tag "local" Function (Span (Pos 8 5) (Pos 9 17)) "def local():" Nothing
@ -51,30 +51,30 @@ spec = do

    it "produces tags for functions with docs" $ do
      (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_function_with_docs.py")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ]

    it "produces tags for classes" $ do
      (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/class.py")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "Foo" Class (Span (Pos 1 1) (Pos 5 17)) "class Foo:" (Just "\"\"\"The Foo class\"\"\"")
        , Tag "f" Function (Span (Pos 3 5) (Pos 5 17)) "def f(self):" (Just "\"\"\"The f method\"\"\"")
        ]

    it "produces tags for multi-line functions" $ do
      (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/multiline.py")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x," Nothing ]

  describe "ruby" $ do
    it "produces tags for methods" $ do
      (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "foo" Method (Span (Pos 1 1) (Pos 4 4)) "def foo" Nothing ]

    it "produces tags for sends" $ do
      (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
-      runTagging (blobLanguage blob) (blobSource blob) ["Send"] tree `shouldBe`
+      runTagging (blobLanguage blob) ["Send"] (blobSource blob) tree `shouldBe`
        [ Tag "puts" Call (Span (Pos 2 3) (Pos 2 12)) "puts \"hi\"" Nothing
        , Tag "bar" Call (Span (Pos 3 3) (Pos 3 8)) "a.bar" Nothing
        , Tag "a" Call (Span (Pos 3 3) (Pos 3 4)) "a" Nothing
@ -82,17 +82,17 @@ spec = do

    it "produces tags for methods with docs" $ do
      (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method_with_docs.rb")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "foo" Method (Span (Pos 2 1) (Pos 3 4)) "def foo" (Just "# Public: foo") ]

    it "correctly tags files containing multibyte UTF-8 characters" $ do
      (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/unicode_identifiers.rb")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "日本語" Method (Span (Pos 2 1) (Pos 4 4)) "def 日本語" (Just "# coding: utf-8")]

    it "produces tags for methods and classes with docs" $ do
      (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/class_module.rb")
-      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe`
        [ Tag "Foo" Tags.Module (Span (Pos 2 1 ) (Pos 12 4)) "module Foo" (Just "# Public: Foo")
        , Tag "Bar" Class  (Span (Pos 5 3 ) (Pos 11 6)) "class Bar" (Just "# Public: Bar")
        , Tag "baz" Method (Span (Pos 8 5 ) (Pos 10 8)) "def baz(a)" (Just "# Public: baz")