github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-03 04:51:57 +03:00
Code Issues Projects Releases Wiki Activity

Move decoration of terms out of the JSON renderer.

Browse Source
This commit is contained in:
Rob Rix 2017-04-27 19:36:35 -04:00
parent 013d998ef3
commit 4975dc61fe
2 changed files with 15 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Renderer.hs
View File

@ -18,7 +18,7 @@ import Data.Map as Map hiding (null)
import Data.Record import Data.Record
import Diff import Diff
import Info import Info
import Language.Ruby.Syntax (decoratorWithAlgebra) import Language.Ruby.Syntax (decoratorWithAlgebra, fToR)
import Prologue import Prologue
import Renderer.JSON as R import Renderer.JSON as R
import Renderer.Patch as R import Renderer.Patch as R
@ -58,14 +58,14 @@ data ParseTreeRenderer fields output where
JSONIndexParseTreeRenderer :: (ToJSONFields (Record fields), HasField fields Range) => Bool -> ParseTreeRenderer fields Value JSONIndexParseTreeRenderer :: (ToJSONFields (Record fields), HasField fields Range) => Bool -> ParseTreeRenderer fields Value
resolveParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> SourceBlob -> Term (Syntax Text) (Record fields) -> output resolveParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> SourceBlob -> Term (Syntax Text) (Record fields) -> output
resolveParseTreeRenderer renderer = case renderer of resolveParseTreeRenderer renderer blob = case renderer of
SExpressionParseTreeRenderer format -> R.sExpressionParseTree format SExpressionParseTreeRenderer format -> R.sExpressionParseTree format blob
JSONParseTreeRenderer True -> (uncurry R.jsonParseTree .) . decorateWithSource JSONParseTreeRenderer True -> R.jsonParseTree blob . decoratorWithAlgebra (fToR identifierAlg) . decoratorWithAlgebra (sourceDecorator (source blob))
JSONParseTreeRenderer False -> R.jsonParseTree JSONParseTreeRenderer False -> R.jsonParseTree blob . decoratorWithAlgebra (fToR identifierAlg)
JSONIndexParseTreeRenderer True -> (uncurry R.jsonIndexParseTree .) . decorateWithSource JSONIndexParseTreeRenderer True -> R.jsonIndexParseTree blob . decoratorWithAlgebra (fToR identifierAlg) . decoratorWithAlgebra (sourceDecorator (source blob))
JSONIndexParseTreeRenderer False -> R.jsonIndexParseTree JSONIndexParseTreeRenderer False -> R.jsonIndexParseTree blob . decoratorWithAlgebra (fToR identifierAlg)
where decorateWithSource blob = (,) blob . decoratorWithAlgebra (sourceDecorator (source blob)) where sourceDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source)))
sourceDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source))) identifierAlg = fmap R.Identifier . maybeIdentifier . fmap (fmap unIdentifier)
runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> output runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> output
runParseTreeRenderer = foldMap . uncurry . resolveParseTreeRenderer runParseTreeRenderer = foldMap . uncurry . resolveParseTreeRenderer

17
src/Renderer/JSON.hs
View File

@ -3,9 +3,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Renderer.JSON module Renderer.JSON
( json ( json
, jsonFile
, jsonParseTree , jsonParseTree
, jsonIndexParseTree , jsonIndexParseTree
, ToJSONFields(..) , ToJSONFields(..)
, Identifier(..)
) where ) where
import Alignment import Alignment
@ -19,7 +21,6 @@ import Data.These
import Data.Vector as Vector hiding (toList) import Data.Vector as Vector hiding (toList)
import Diff import Diff
import Info import Info
import Language.Ruby.Syntax (decoratorWithAlgebra, fToR, FAlgebra)
import Prologue import Prologue
import qualified Data.Map as Map import qualified Data.Map as Map
import Source import Source
@ -197,9 +198,6 @@ instance Monoid Value where
instance StringConv Value ByteString where instance StringConv Value ByteString where
strConv _ = toS . (<> "\n") . encode strConv _ = toS . (<> "\n") . encode
ala :: Functor f => (a -> b) -> (b -> a) -> FAlgebra f a -> FAlgebra f b
ala into outof f = into . f . fmap outof
newtype Identifier = Identifier { unIdentifier :: Text } newtype Identifier = Identifier { unIdentifier :: Text }
deriving (Eq, Show) deriving (Eq, Show)
@ -210,13 +208,10 @@ jsonFile :: ToJSON a => SourceBlob -> a -> Value
jsonFile SourceBlob{..} = toJSON . File path jsonFile SourceBlob{..} = toJSON . File path
jsonParseTree :: ToJSONFields (Record fields) => SourceBlob -> Term (Syntax Text) (Record fields) -> Value jsonParseTree :: ToJSONFields (Record fields) => SourceBlob -> Term (Syntax Text) (Record fields) -> Value
jsonParseTree blob = jsonFile blob . decoratorWithAlgebra (fToR identifierAlg) jsonParseTree = jsonFile
jsonIndexParseTree :: ToJSONFields (Record fields) => SourceBlob -> Term (Syntax Text) (Record fields) -> Value jsonIndexParseTree :: (ToJSONFields (Record fields), HasField fields (Maybe Identifier)) => SourceBlob -> Term (Syntax Text) (Record fields) -> Value
jsonIndexParseTree blob = jsonFile blob . fmap (object . toJSONFields) . cata combine . decoratorWithAlgebra (fToR identifierAlg) jsonIndexParseTree blob = jsonFile blob . fmap (object . toJSONFields) . cata combine
where combine (a :< f) | Nothing <- rhead a = Prologue.concat f where combine (a :< f) | Nothing <- getField a :: Maybe Identifier = Prologue.concat f
| Leaf _ <- f = Prologue.concat f | Leaf _ <- f = Prologue.concat f
| otherwise = a : Prologue.concat f | otherwise = a : Prologue.concat f
identifierAlg :: FAlgebra (SyntaxTermF Text a) (Maybe Identifier)
identifierAlg = ala (fmap Renderer.JSON.Identifier) (fmap unIdentifier) maybeIdentifier