Re-enable semantic parse --json output.

When we switched away from alacarte syntax, we lost the `--json`
option for AST output. However, the majority of the needed code was
already implemented by @aymannadeem, so all we had to do was have the
syntax types opt into the `MarshalJSON` API, and to define the
boilerplate needed to plug it into the `Serialize` interface.

Fixes #471.

semantic-codeql/src/Language/CodeQL.hs

@@ -1,9 +1,12 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -freduction-depth=0 #-}
 -- | Semantic functionality for CodeQL programs.
 module Language.CodeQL
 ( Term(..)
 , TreeSitter.QL.tree_sitter_ql
 ) where
 
+import           AST.Marshal.JSON
 import qualified AST.Unmarshal as TS
 import           Data.Proxy
 import qualified Language.CodeQL.AST as CodeQL
@@ -12,6 +15,7 @@ import qualified Tags.Tagging.Precise as Tags
 import qualified TreeSitter.QL (tree_sitter_ql)
 
 newtype Term a = Term { getTerm :: CodeQL.Ql a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy CodeQL.Ql)

semantic-go/src/Language/Go.hs

@@ -1,10 +1,11 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Semantic functionality for Go programs.
 module Language.Go
 ( Term(..)
 , Language.Go.Grammar.tree_sitter_go
 ) where
 
-
+import           AST.Marshal.JSON
 import           Data.Proxy
 import qualified Language.Go.AST as Go
 import qualified Language.Go.Tags as GoTags
@@ -13,6 +14,7 @@ import qualified Language.Go.Grammar (tree_sitter_go)
 import qualified AST.Unmarshal as TS
 
 newtype Term a = Term { getTerm :: Go.SourceFile a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy Go.SourceFile)

semantic-java/src/Language/Java.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Semantic functionality for Java programs.
 module Language.Java
 ( Term(..)
 , Language.Java.Grammar.tree_sitter_java
 ) where
 
+import           AST.Marshal.JSON
 import           Data.Proxy
 import qualified Language.Java.AST as Java
 import qualified Language.Java.Tags as JavaTags
@@ -12,6 +14,7 @@ import qualified Language.Java.Grammar (tree_sitter_java)
 import qualified AST.Unmarshal as TS
 
 newtype Term a = Term { getTerm :: Java.Program a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy Java.Program)

semantic-json/src/Language/JSON.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Semantic functionality for JSON programs.
 module Language.JSON
 ( Term(..)
 , TreeSitter.JSON.tree_sitter_json
 ) where
 
+import           AST.Marshal.JSON
 import           Data.Proxy
 import qualified Language.JSON.AST as JSON
 import qualified Tags.Tagging.Precise as Tags
@@ -11,6 +13,7 @@ import qualified TreeSitter.JSON (tree_sitter_json)
 import qualified AST.Unmarshal as TS
 
 newtype Term a = Term { getTerm :: JSON.Document a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy JSON.Document)

semantic-php/src/Language/PHP.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Semantic functionality for PHP programs.
 module Language.PHP
 ( Term(..)
 , TreeSitter.PHP.tree_sitter_php
 ) where
 
+import           AST.Marshal.JSON
 import qualified AST.Unmarshal as TS
 import           Data.Proxy
 import qualified Language.PHP.AST as PHP
@@ -12,6 +14,7 @@ import qualified Tags.Tagging.Precise as Tags
 import qualified TreeSitter.PHP (tree_sitter_php)
 
 newtype Term a = Term { getTerm :: PHP.Program a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy PHP.Program)

semantic-python/src/Language/Python.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Semantic functionality for Python programs.
 module Language.Python
 ( Term(..)
 , Language.Python.Grammar.tree_sitter_python
 ) where
 
+import           AST.Marshal.JSON
 import qualified AST.Unmarshal as TS
 import           Data.Proxy
 import qualified Language.Python.AST as Py
@@ -14,6 +16,7 @@ import qualified Language.Python.Tags as PyTags
 import qualified Tags.Tagging.Precise as Tags
 
 newtype Term a = Term { getTerm :: Py.Module a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy Py.Module)

semantic-ruby/src/Language/Ruby.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- | Semantic functionality for Ruby programs.
@@ -6,6 +7,7 @@ module Language.Ruby
 , Language.Ruby.Grammar.tree_sitter_ruby
 ) where
 
+import           AST.Marshal.JSON
 import qualified AST.Unmarshal as TS
 import           Control.Carrier.State.Strict
 import           Data.Proxy
@@ -16,6 +18,7 @@ import qualified Language.Ruby.Tags as RbTags
 import qualified Tags.Tagging.Precise as Tags
 
 newtype Term a = Term { getTerm :: Rb.Program a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy Rb.Program)

semantic-tsx/src/Language/TSX.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -freduction-depth=0 #-}
 -- | Semantic functionality for TSX programs.
 module Language.TSX
@@ -5,6 +6,7 @@ module Language.TSX
 , Language.TSX.Grammar.tree_sitter_tsx
 ) where
 
+import           AST.Marshal.JSON
 import           Data.Proxy
 import qualified Language.TSX.AST as TSX
 import qualified Language.TSX.Tags as TsxTags
@@ -13,6 +15,7 @@ import qualified Language.TSX.Grammar (tree_sitter_tsx)
 import qualified AST.Unmarshal as TS
 
 newtype Term a = Term { getTerm :: TSX.Program a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy TSX.Program)

semantic-typescript/src/Language/TypeScript.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -freduction-depth=0 #-}
 -- | Semantic functionality for TypeScript programs.
 module Language.TypeScript
@@ -5,6 +6,7 @@ module Language.TypeScript
 , Language.TypeScript.Grammar.tree_sitter_typescript
 ) where
 
+import           AST.Marshal.JSON
 import           Data.Proxy
 import qualified Language.TypeScript.AST as TypeScript
 import qualified Language.TypeScript.Tags as TsTags
@@ -13,6 +15,7 @@ import qualified Language.TypeScript.Grammar (tree_sitter_typescript)
 import qualified AST.Unmarshal as TS
 
 newtype Term a = Term { getTerm :: TypeScript.Program a }
+  deriving MarshalJSON
 
 instance TS.SymbolMatching Term where
   matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy TypeScript.Program)

semantic/src/Semantic/Api/Terms.hs

@@ -45,6 +45,7 @@ import           Source.Loc
 data TermOutputFormat
   = TermSExpression
   | TermShow
+  | TermJSON
   | TermQuiet
   deriving (Eq, Show)
 
@@ -52,6 +53,7 @@ parseTermBuilder :: (Traversable t, Has Distribute sig m, Has (Error SomeExcepti
   => TermOutputFormat -> t Blob -> m Builder
 parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers (pure . sexprTerm))
 parseTermBuilder TermShow        = distributeFoldMap (parseWith showTermParsers showTerm)
+parseTermBuilder TermJSON        = distributeFoldMap (parseWith jsonTermParsers jsonTerm)
 parseTermBuilder TermQuiet       = distributeFoldMap quietTerm
 
 quietTerm :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m) => Blob -> m Builder
@@ -96,6 +98,39 @@ instance ShowTerm TSX.Term where
 instance ShowTerm TypeScript.Term where
   showTerm = serialize Show . void . TypeScript.getTerm
 
+jsonTermParsers :: Map Language (SomeParser JSONTerm Loc)
+jsonTermParsers = preciseParsers
+
+class JSONTerm term where
+  jsonTerm :: (Has (Reader Config) sig m) => term Loc -> m Builder
+
+instance JSONTerm Go.Term where
+  jsonTerm = serialize Marshal . Go.getTerm
+
+instance JSONTerm Java.Term where
+  jsonTerm = serialize Marshal . Java.getTerm
+
+instance JSONTerm JSON.Term where
+  jsonTerm = serialize Marshal . JSON.getTerm
+
+instance JSONTerm PHP.Term where
+  jsonTerm = serialize Marshal . PHP.getTerm
+
+instance JSONTerm Python.Term where
+  jsonTerm = serialize Marshal . Python.getTerm
+
+instance JSONTerm CodeQL.Term where
+  jsonTerm = serialize Marshal . CodeQL.getTerm
+
+instance JSONTerm Ruby.Term where
+  jsonTerm = serialize Marshal . Ruby.getTerm
+
+instance JSONTerm TSX.Term where
+  jsonTerm = serialize Marshal . TSX.getTerm
+
+instance JSONTerm TypeScript.Term where
+  jsonTerm = serialize Marshal . TypeScript.getTerm
+
 sexprTermParsers :: Map Language (SomeParser SExprTerm Loc)
 sexprTermParsers = preciseParsers
 

semantic/src/Semantic/CLI.hs

@@ -96,6 +96,9 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
         <|> flag' (parseSymbolsBuilder Proto)
                   (  long "proto-symbols"
                   <> help "Output protobufs symbol list")
+        <|> flag' (parseTermBuilder TermJSON)
+                  (  long "json"
+                  <> help "Output JSON AST dump")
         <|> flag' (parseTermBuilder TermShow)
                   (  long "show"
                   <> help "Output using the Show instance (debug only, format subject to change without notice)")

semantic/src/Serializing/Format.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Serializing.Format
-( Format(..)
-, FormatStyle(..)
-, Builder
-, runSerialize
-) where
 
+module Serializing.Format
+  ( Format (..),
+    FormatStyle (..),
+    Builder,
+    runSerialize,
+  )
+where
+
+import AST.Marshal.JSON
 import Algebra.Graph.Export.Dot
 import Algebra.Graph.ToGraph
 import Data.Aeson (ToJSON (..), fromEncoding)
@@ -16,19 +19,22 @@ import Data.ProtoLens.Encoding as Proto
 import Data.ProtoLens.Message (Message)
 import Language.Haskell.HsColour
 import Language.Haskell.HsColour.Colourise
+import Source.Loc
 import Text.Show.Pretty
 
 data Format input where
-  DOT         :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph
-  JSON        :: ToJSON input                                         =>                         Format input
-  Show        :: Show input                                           =>                         Format input
-  Proto       :: Message input                                        =>                         Format input
+  DOT :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph
+  JSON :: ToJSON input => Format input
+  Marshal :: MarshalJSON input => Format (input Loc)
+  Show :: Show input => Format input
+  Proto :: Message input => Format input
 
 data FormatStyle = Colourful | Plain
 
 runSerialize :: FormatStyle -> Format input -> input -> Builder
-runSerialize _         (DOT style)        = export style
-runSerialize _         JSON               = (<> "\n") . fromEncoding . toEncoding
-runSerialize Colourful Show               = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow
-runSerialize Plain     Show               = (<> "\n") . stringUtf8 . show
-runSerialize _         Proto              = Proto.buildMessage
+runSerialize _ (DOT style) = export style
+runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding
+runSerialize _ Marshal = fromEncoding . toEncoding . marshal
+runSerialize Colourful Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow
+runSerialize Plain Show = (<> "\n") . stringUtf8 . show
+runSerialize _ Proto = Proto.buildMessage