From e637d195b942b74fefb56b26b182f62db2ce594b Mon Sep 17 00:00:00 2001
From: joshvera <josh@joshvera.com>
Date: Wed, 19 Jul 2017 15:26:00 -0400
Subject: [PATCH] Add remaining json syntax

---
 src/Language/JSON/Syntax.hs | 26 ++++++++++++++++++++++++--
 src/Parser.hs               |  5 +++++
 src/Semantic.hs             |  3 +++
 3 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/src/Language/JSON/Syntax.hs b/src/Language/JSON/Syntax.hs
index ef952df65..b51bbf4a9 100644
--- a/src/Language/JSON/Syntax.hs
+++ b/src/Language/JSON/Syntax.hs
@@ -19,7 +19,15 @@ import Prologue hiding (Location)
 
 type Syntax =
   '[ Literal.Hash
+   , Literal.KeyValue
+   , Literal.Null
+   , Literal.String
+   , Literal.TextElement
    , Syntax.Error
+   , Literal.Array
+   , Literal.Boolean
+   , Literal.Float
+   , []
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
@@ -35,12 +43,26 @@ parseError = makeTerm <$> symbol ParseError <*> (Syntax.Error [] <$ source)
 assignment :: Assignment
 assignment = object <|> array <|> parseError
 
+value :: Assignment
+value = object <|> array <|> number <|> string <|> boolean <|> none
+
 object :: Assignment
 object = makeTerm <$> symbol Object <*> children (Literal.Hash <$> many pairs)
-  where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> expression)
+  where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> (number <|> string) <*> value)
 
 array :: Assignment
-array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many expression)
+array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many value)
 
+number :: Assignment
+number = makeTerm <$> symbol Number <*> (Literal.Float <$> source)
 
+string :: Assignment
+string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source)
+
+boolean :: Assignment
+boolean =  makeTerm <$> symbol Grammar.True  <*> (Literal.true <$ source)
+       <|> makeTerm <$> symbol Grammar.False <*> (Literal.false <$ source)
+
+none :: Assignment
+none = makeTerm <$> symbol Null <*> (Literal.Null <$ source)
 
diff --git a/src/Parser.hs b/src/Parser.hs
index c469ebafa..2813a78d1 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -5,6 +5,7 @@ module Parser
 -- Syntax parsers
 , parserForLanguage
 -- À la carte parsers
+, jsonParser
 , markdownParser
 , pythonParser
 , rubyParser
@@ -20,6 +21,7 @@ import Data.Union
 import Info hiding (Empty, Go)
 import Language
 import Language.Markdown
+import qualified Language.JSON.Syntax as JSON
 import qualified Language.Markdown.Syntax as Markdown
 import qualified Language.Python.Syntax as Python
 import qualified Language.Ruby.Syntax as Ruby
@@ -71,6 +73,9 @@ rubyParser = AssignmentParser (ASTParser tree_sitter_ruby) headF Ruby.assignment
 pythonParser :: Parser Python.Term
 pythonParser = AssignmentParser (ASTParser tree_sitter_python) headF Python.assignment
 
+jsonParser :: Parser JSON.Term
+jsonParser = AssignmentParser (ASTParser tree_sitter_json) headF JSON.assignment
+
 markdownParser :: Parser Markdown.Term
 markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment
 
diff --git a/src/Semantic.hs b/src/Semantic.hs
index 25eb0641c..711cea500 100644
--- a/src/Semantic.hs
+++ b/src/Semantic.hs
@@ -70,12 +70,15 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
   (ToCDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms (renderToCDiff blobs)
   (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs)
   (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs)
+  (JSONDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderJSONDiff blobs)
   (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs)
   (PatchDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderPatch blobs)
   (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderPatch blobs)
+  (PatchDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderPatch blobs)
   (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs)
   (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse markdownParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel)
   (SExpressionDiffRenderer, Just Language.Python) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel)
+  (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse jsonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel)
   (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory)
   (IdentityDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms Just
   where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs)