From 96d2ccf92e583a1858063c463be577717c85a7a7 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 27 Apr 2017 16:57:47 -0400
Subject: [PATCH] Decorate the term with the identifier algebraically.

---
 src/Renderer/JSON.hs | 11 ++++-------
 src/Syntax.hs        | 33 ++++++++++++++++-----------------
 2 files changed, 20 insertions(+), 24 deletions(-)

diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs
index 39c3e5c83..8a01f0521 100644
--- a/src/Renderer/JSON.hs
+++ b/src/Renderer/JSON.hs
@@ -20,6 +20,7 @@ import Data.These
 import Data.Vector as Vector hiding (toList)
 import Diff
 import Info
+import Language.Ruby.Syntax (decoratorWithAlgebra, fToR)
 import Prologue
 import qualified Data.Map as Map
 import qualified Data.Text as T
@@ -224,15 +225,11 @@ jsonIndexParseTree = jsonParseTree' IndexFile combine
 jsonParseTree' :: (ToJSON root, HasDefaultFields fields) => (FilePath -> a -> root) -> (ParseNode -> [a] -> a) -> Bool -> SourceBlob -> Term (Syntax Text) (Record fields) -> Value
 jsonParseTree' constructor combine debug SourceBlob{..} term = toJSON $ constructor path (para algebra term')
   where
-    term' = decorateTerm (if debug then termSourceTextDecorator source else const Nothing) term
+    term' = decorateTerm (if debug then termSourceTextDecorator source else const Nothing) (decoratorWithAlgebra (fToR maybeIdentifier) term)
     algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
 
-    makeNode :: HasDefaultFields fields => Record (Maybe SourceText ': fields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': fields))) -> ParseNode
-    makeNode (sourceText :. record) syntax = ParseNode (getField record) (getField record) sourceText (getField record) (identifierFor syntax)
-
-    -- | Returns a Just identifier text if the given Syntax term contains an identifier (leaf) syntax. Otherwise returns Nothing.
-    identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
-    identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier
+    makeNode :: HasDefaultFields fields => Record (Maybe SourceText ': Maybe Text ': fields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': Maybe Text ': fields))) -> ParseNode
+    makeNode (sourceText :. record) _ = ParseNode (getField record) (getField record) sourceText (getField record) (getField record)
 
     -- | Decorate a 'Term' using a function to compute the annotation values at every node.
     decorateTerm :: (Functor f, HasDefaultFields fields) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 071fd14f3..8751b6210 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -1,8 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 module Syntax where
 
-import Data.Record
-import qualified Info
 import Data.Aeson
 import Data.Functor.Classes
 import Data.Functor.Classes.Eq.Generic
@@ -119,21 +117,22 @@ extractLeafValue syntax = case syntax of
   Leaf a -> Just a
   _ -> Nothing
 
-maybeIdentifier :: HasField fields Info.Category => Syntax leaf (Cofree (Syntax leaf) (Record fields)) -> Maybe (Cofree (Syntax leaf) (Record fields))
-maybeIdentifier syntax = case syntax of
-  Assignment f _ -> Just f
-  Class f _ _ -> Just f
-  Export f _ -> f
-  Function f _ _ -> Just f
-  FunctionCall f _ _ -> Just f
-  Import f _ -> Just f
-  Method _ f _ _ _ -> Just f
-  MethodCall _ f _ _ -> Just f
-  Module f _ -> Just f
-  OperatorAssignment f _ -> Just f
-  SubscriptAccess f _  -> Just f
-  TypeDecl f _ -> Just f
-  VarAssignment f _ -> find ((== Info.Identifier) . Info.category . extract) f
+maybeIdentifier :: CofreeF (Syntax leaf) a (Maybe leaf) -> Maybe leaf
+maybeIdentifier (_ :< syntax) = case syntax of
+  Leaf f -> Just f
+  Assignment f _ -> f
+  Class f _ _ -> f
+  Export f _ -> join f
+  Function f _ _ -> f
+  FunctionCall f _ _ -> f
+  Import f _ -> f
+  Method _ f _ _ _ -> f
+  MethodCall _ f _ _ -> f
+  Module f _ -> f
+  OperatorAssignment f _ -> f
+  SubscriptAccess f _  -> f
+  TypeDecl f _ -> f
+  VarAssignment f _ -> asum f
   _ -> Nothing
 
 -- Instances