Basic plumbing for import rendering

semantic-diff.cabal

@@ -108,6 +108,7 @@ library
                      , Paths_semantic_diff
                      -- Rendering formats
                      , Rendering.DOT
+                     , Rendering.Imports
                      , Rendering.JSON
                      , Rendering.Renderer
                      , Rendering.SExpression

src/Rendering/Imports.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Rendering.Imports
+( renderModuleTerms
+, renderToImports
+) where
+
+import Analysis.Declaration
+import Data.Aeson
+import Data.Blob
+import Data.Maybe (mapMaybe)
+import Data.Record
+import Data.Span
+import Data.Term
+import GHC.Generics
+import System.FilePath.Posix (takeBaseName)
+import qualified Data.Text as T
+import qualified Data.Map as Map
+import Rendering.TOC (termTableOfContentsBy, declaration, getDeclaration, toCategoryName)
+
+
+-- | Render terms to final JSON structure.
+renderModuleTerms :: [Value] -> Map.Map T.Text Value
+renderModuleTerms = Map.singleton "modules" . toJSON
+
+-- | Render a 'Term' to a list of symbols (See 'Symbol').
+renderToImports :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> [Value]
+renderToImports Blob{..} term = [toJSON (termToC blobPath term)]
+  where
+    termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => FilePath -> Term f (Record fields) -> Module
+    termToC path = Module (T.pack (takeBaseName path)) (T.pack path) (T.pack . show <$> blobLanguage) . mapMaybe declarationSummary . termTableOfContentsBy declaration
+
+-- | Construct a 'Symbol' from a node annotation and a change type label.
+declarationSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Record fields -> Maybe SymbolDeclaration
+declarationSummary record = case getDeclaration record of
+  Just ErrorDeclaration{} -> Nothing
+  Just declaration -> Just SymbolDeclaration
+    { declarationName = declarationIdentifier declaration
+    , declarationKind = toCategoryName declaration
+    , declarationSpan = getField record
+    }
+  _ -> Nothing
+
+data Module = Module
+  { moduleName :: T.Text
+  , modulePath :: T.Text
+  , moduleLanguage :: Maybe T.Text
+  -- , moduleImports :: [SymbolImports]
+  , moduleDeclarations :: [SymbolDeclaration]
+  -- , moduleReferences :: [SymbolReferences]
+  } deriving (Generic, Eq, Show)
+
+instance ToJSON Module where
+  toJSON Module{..} = object [ "name" .= moduleName
+                             , "path" .= modulePath
+                             , "langauge" .= moduleLanguage
+                             , "declarations" .= moduleDeclarations
+                             ]
+
+data SymbolDeclaration = SymbolDeclaration
+  { declarationName :: T.Text
+  , declarationKind :: T.Text
+  , declarationSpan :: Span
+  } deriving (Generic, Eq, Show)
+
+instance ToJSON SymbolDeclaration where
+  toJSON SymbolDeclaration{..} = object [ "name" .= declarationName
+                                        , "kind" .= declarationKind
+                                        , "span" .= declarationSpan
+                                        ]

src/Rendering/Renderer.hs

@@ -13,6 +13,8 @@ module Rendering.Renderer
 , renderToCTerm
 , renderSymbolTerms
 , renderToSymbols
+, renderModuleTerms
+, renderToImports
 , renderToTags
 , renderDOTDiff
 , renderDOTTerm
@@ -28,6 +30,7 @@ import Rendering.DOT as R
 import Rendering.JSON as R
 import Rendering.SExpression as R
 import Rendering.Symbol as R
+import Rendering.Imports as R
 import Rendering.TOC as R
 
 -- | Specification of renderers for diffs, producing output in the parameter type.
@@ -54,6 +57,8 @@ data TermRenderer output where
   TagsTermRenderer :: TermRenderer [Value]
   -- | Render to a list of symbols.
   SymbolsTermRenderer :: SymbolFields -> TermRenderer [Value]
+  -- | Render to a list of modules that represent the import graph.
+  ImportsTermRenderer :: TermRenderer [Value]
   -- | Render to a 'ByteString' formatted as a DOT description of the term.
   DOTTermRenderer :: TermRenderer ByteString
 

src/Semantic.hs

@@ -45,6 +45,7 @@ parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
 parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (parseBlob renderer) blobs
   where toOutput' = case renderer of
           JSONTermRenderer -> toOutput . renderJSONTerms
+          ImportsTermRenderer -> toOutput . renderModuleTerms
           SymbolsTermRenderer _ -> toOutput . renderSymbolTerms
           _ -> toOutput
 
@@ -56,6 +57,7 @@ parseBlob renderer blob@Blob{..}
     JSONTermRenderer           -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
     SExpressionTermRenderer    -> decorate constructorLabel . (Nil <$)                   >=> render renderSExpressionTerm
     TagsTermRenderer           -> decorate (declarationAlgebra blob)                     >=> render (renderToTags blob)
+    ImportsTermRenderer        -> decorate (declarationAlgebra blob)                     >=> render (renderToImports blob)
     SymbolsTermRenderer fields -> decorate (declarationAlgebra blob)                     >=> render (renderToSymbols fields blob)
     DOTTermRenderer            ->                                                            render (renderDOTTerm blob)
   | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))

src/Semantic/CLI.hs

@@ -82,6 +82,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
                                              <> help "Comma delimited list of specific fields to return (symbols output only)."
                                              <> metavar "FIELDS")
                   <|> pure defaultSymbolFields)
+          <|> flag'                                        (SomeRenderer ImportsTermRenderer)     (long "import-graph" <> help "Output JSON import graph")
           <|> flag'                                        (SomeRenderer DOTTermRenderer)         (long "dot" <> help "Output DOT graph parse trees"))
       <*> (   Right <$> some (argument filePathReader (metavar "FILES..."))
           <|> pure (Left stdin) )