Merge branch 'master' into bump-fused-effects-03-03-2019

semantic.cabal

@@ -239,7 +239,7 @@ library
                      -- API
                      , Semantic.Api
                      , Semantic.Api.Diffs
-                     , Semantic.Api.Helpers
+                     , Semantic.Api.Bridge
                      , Semantic.Api.LegacyTypes
                      , Semantic.Api.Symbols
                      , Semantic.Api.Terms

src/Rendering/Graph.hs

@@ -18,7 +18,7 @@ import Data.Patch
 import Data.String (IsString (..))
 import Data.Term
 import Prologue
-import Semantic.Api.Helpers
+import Semantic.Api.Bridge
 import Semantic.Api.V1.CodeAnalysisPB
 
 import qualified Data.Text as T
@@ -70,7 +70,7 @@ instance (ConstructorName syntax, Foldable syntax) =>
     termAlgebra (In ann syntax) = do
       i <- fresh
       parent <- ask
-      let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (spanToSpan (locationSpan ann)))
+      let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locationSpan ann)
       subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
       pure (parent `connect` root `overlay` subGraph)
 
@@ -89,7 +89,7 @@ instance (ConstructorName syntax, Foldable syntax) =>
       graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
       pure (parent `connect` replace `overlay` graph)
     where
-      ann a = spanToSpan (locationSpan a)
+      ann a = converting #? locationSpan a
       diffAlgebra ::
         ( Foldable f
         , Member Fresh sig

src/Semantic/Api/Bridge.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE FunctionalDependencies, LambdaCase #-}
+module Semantic.Api.Bridge
+  ( APIBridge (..)
+  , APIConvert (..)
+  , (#?)
+  ) where
+
+import           Control.Lens
+import qualified Data.Blob as Data
+import qualified Data.Language as Data
+import           Data.Source (fromText, toText)
+import qualified Data.Span as Data
+import qualified Data.Text as T
+import qualified Semantic.Api.LegacyTypes as Legacy
+import qualified Semantic.Api.V1.CodeAnalysisPB as API
+
+-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
+-- This is suitable for types such as 'Pos' which are representationally equivalent
+-- in their API, legacy, and native forms. All 'Lens' laws apply.
+--
+-- Foreign to native: @x^.bridging@
+-- Native to foreign: @bridging # x@
+-- Native to 'Just' foreign: @bridging #? x@.
+-- 'Maybe' foreign to 'Maybe' native: @x >>= preview bridging@
+class APIBridge api native | api -> native where
+  bridging :: Iso' api native
+
+-- | An @APIConvert x y@ instance describes a partial isomorphism between @x@ and @y@.
+-- This is suitable for types containing nested records therein, such as 'Span'.
+-- (The isomorphism must be partial, given that a protobuf record can have Nothing
+-- for all its fields, which means we cannot convert to a native format.)
+--
+-- Foreign to native: this is a type error, unless the native is a Monoid
+-- Foreign to 'Maybe' native: @x^?converting@
+-- Native to foreign: @converting # x@
+-- Native to 'Just' foreign: @converting #? x@
+class APIConvert api native | api -> native where
+  converting :: Prism' api native
+
+-- | A helper function for turning 'bridging' around and
+-- extracting 'Just' values from it.
+(#?) :: AReview t s -> s -> Maybe t
+rev #? item = item ^? re rev
+infixr 8 #?
+
+instance APIBridge Legacy.Position Data.Pos where
+  bridging = iso fromAPI toAPI where
+    toAPI Data.Pos{..}          = Legacy.Position posLine posColumn
+    fromAPI Legacy.Position{..} = Data.Pos line column
+
+instance APIBridge API.Position Data.Pos where
+  bridging = iso fromAPI toAPI where
+    toAPI Data.Pos{..}          = API.Position (fromIntegral posLine) (fromIntegral posColumn)
+    fromAPI API.Position{..}    = Data.Pos (fromIntegral line) (fromIntegral column)
+
+instance APIConvert API.Span Data.Span where
+  converting = prism' toAPI fromAPI where
+    toAPI Data.Span{..} = API.Span (bridging #? spanStart) (bridging #? spanEnd)
+    fromAPI API.Span{..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
+
+instance APIConvert Legacy.Span Data.Span where
+  converting = prism' toAPI fromAPI where
+    toAPI Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd)
+    fromAPI Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
+
+instance APIBridge API.Language Data.Language where
+  bridging = iso apiLanguageToLanguage languageToApiLanguage where
+    languageToApiLanguage :: Data.Language -> API.Language
+    languageToApiLanguage = \case
+      Data.Unknown -> API.Unknown
+      Data.Go -> API.Go
+      Data.Haskell -> API.Haskell
+      Data.Java -> API.Java
+      Data.JavaScript -> API.Javascript
+      Data.JSON -> API.Json
+      Data.JSX -> API.Jsx
+      Data.Markdown -> API.Markdown
+      Data.Python -> API.Python
+      Data.Ruby -> API.Ruby
+      Data.TypeScript -> API.Typescript
+      Data.PHP -> API.Php
+
+    apiLanguageToLanguage :: API.Language -> Data.Language
+    apiLanguageToLanguage = \case
+      API.Unknown -> Data.Unknown
+      API.Go -> Data.Go
+      API.Haskell -> Data.Haskell
+      API.Java -> Data.Java
+      API.Javascript -> Data.JavaScript
+      API.Json -> Data.JSON
+      API.Jsx -> Data.JSX
+      API.Markdown -> Data.Markdown
+      API.Python -> Data.Python
+      API.Ruby -> Data.Ruby
+      API.Typescript -> Data.TypeScript
+      API.Php -> Data.PHP
+
+instance APIBridge API.Blob Data.Blob where
+  bridging = iso apiBlobToBlob blobToApiBlob where
+    blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage)
+    apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging)
+
+
+instance APIConvert API.BlobPair Data.BlobPair where
+  converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where
+
+    apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Just $ Data.Diffing (before^.bridging) (after^.bridging)
+    apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Just $ Data.Deleting (before^.bridging)
+    apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Just $ Data.Inserting (after^.bridging)
+    apiBlobPairToBlobPair _ = Nothing
+
+    blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (bridging #? before) (bridging #? after)
+    blobPairToApiBlobPair (Data.Inserting after)      = API.BlobPair Nothing (bridging #? after)
+    blobPairToApiBlobPair (Data.Deleting before)      = API.BlobPair (bridging #? before) Nothing

src/Semantic/Api/Diffs.hs

@@ -16,6 +16,7 @@ import           Analysis.TOCSummary (HasDeclaration)
 import           Control.Effect
 import           Control.Effect.Error
 import           Control.Exception
+import           Control.Lens
 import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.ByteString.Builder
@@ -33,7 +34,7 @@ import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair, Language(..))
 import           Semantic.Task as Task
 import           Semantic.Telemetry as Stat
@@ -75,7 +76,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor
         pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ pathForBlobPair blobPair
-        lang = languageToApiLanguage $ languageForBlobPair blobPair
+        lang = bridging # languageForBlobPair blobPair
 
         render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph
         render _ diff =

src/Semantic/Api/Helpers.hs

@@ -1,88 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Semantic.Api.Helpers
-  ( spanToSpan
-  , spanToLegacySpan
-  , toChangeType
-  , languageToApiLanguage
-  , apiSpanToSpan
-  , apiLanguageToLanguage
-  , apiBlobsToBlobs
-  , apiBlobToBlob
-  , apiBlobPairsToBlobPairs
-  , apiBlobPairToBlobPair
-  ) where
-
-import qualified Data.Blob as Data
-import qualified Data.Language as Data
-import           Data.Source (fromText)
-import qualified Data.Span as Data
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import qualified Semantic.Api.LegacyTypes as Legacy
-import qualified Semantic.Api.V1.CodeAnalysisPB as API
-
-spanToSpan :: Data.Span -> Maybe API.Span
-spanToSpan Data.Span{..} = Just $ API.Span (toPos spanStart) (toPos spanEnd)
-  where toPos Data.Pos{..} = Just $ API.Position (fromIntegral posLine) (fromIntegral posColumn)
-
-spanToLegacySpan :: Data.Span -> Maybe Legacy.Span
-spanToLegacySpan Data.Span{..} = Just $ Legacy.Span (toPos spanStart) (toPos spanEnd)
-  where toPos Data.Pos{..} = Just $ Legacy.Position posLine posColumn
-
-apiSpanToSpan :: Maybe API.Span -> Data.Span
-apiSpanToSpan (Just API.Span{..}) = Data.Span (toPos start) (toPos end)
-  where toPos (Just API.Position{..}) = Data.Pos (fromIntegral line) (fromIntegral column)
-        toPos Nothing = Data.Pos 1 1
-apiSpanToSpan Nothing = Data.emptySpan
-
-toChangeType :: T.Text -> API.ChangeType
-toChangeType = \case
-  "added" -> API.Added
-  "modified" -> API.Modified
-  "removed" -> API.Removed
-  _ -> API.None
-
-languageToApiLanguage :: Data.Language -> API.Language
-languageToApiLanguage = \case
-  Data.Unknown -> API.Unknown
-  Data.Go -> API.Go
-  Data.Haskell -> API.Haskell
-  Data.Java -> API.Java
-  Data.JavaScript -> API.Javascript
-  Data.JSON -> API.Json
-  Data.JSX -> API.Jsx
-  Data.Markdown -> API.Markdown
-  Data.Python -> API.Python
-  Data.Ruby -> API.Ruby
-  Data.TypeScript -> API.Typescript
-  Data.PHP -> API.Php
-
-apiLanguageToLanguage :: API.Language -> Data.Language
-apiLanguageToLanguage = \case
-  API.Unknown -> Data.Unknown
-  API.Go -> Data.Go
-  API.Haskell -> Data.Haskell
-  API.Java -> Data.Java
-  API.Javascript -> Data.JavaScript
-  API.Json -> Data.JSON
-  API.Jsx -> Data.JSX
-  API.Markdown -> Data.Markdown
-  API.Python -> Data.Python
-  API.Ruby -> Data.Ruby
-  API.Typescript -> Data.TypeScript
-  API.Php -> Data.PHP
-
-apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob]
-apiBlobsToBlobs = V.toList . fmap apiBlobToBlob
-
-apiBlobToBlob :: API.Blob -> Data.Blob
-apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language)
-
-apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair]
-apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair
-
-apiBlobPairToBlobPair :: API.BlobPair -> Data.BlobPair
-apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Data.Diffing (apiBlobToBlob before) (apiBlobToBlob after)
-apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Data.Deleting (apiBlobToBlob before)
-apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Data.Inserting (apiBlobToBlob after)
-apiBlobPairToBlobPair _ = Prelude.error "Expected BlobPair to have either 'before' and/or 'after'."

src/Semantic/Api/Symbols.hs

@@ -10,6 +10,7 @@ import Prelude hiding (span)
 import           Control.Effect
 import           Control.Effect.Error
 import           Control.Exception
+import           Control.Lens
 import           Data.Blob
 import           Data.ByteString.Builder
 import           Data.Location
@@ -20,7 +21,7 @@ import qualified Data.Vector as V
 import           Data.Text (pack)
 import           Parsing.Parser
 import           Prologue
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import qualified Semantic.Api.LegacyTypes as Legacy
 import           Semantic.Api.Terms (ParseEffects, doParse)
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob)
@@ -48,7 +49,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
       { symbolName = name
       , symbolKind = kind
       , symbolLine = fromMaybe mempty line
-      , symbolSpan = spanToLegacySpan span
+      , symbolSpan = converting #? span
       }
 
 parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Builder
@@ -60,13 +61,13 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
     go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m File
     go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
       where
-        errorFile e = File (pack blobPath) (languageToApiLanguage blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
+        errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
 
         renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File
         renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term)
 
         tagsToFile :: Blob -> [Tag] -> File
-        tagsToFile Blob{..} tags = File (pack blobPath) (languageToApiLanguage blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty
+        tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty
 
         tagToSymbol :: Tag -> Symbol
         tagToSymbol Tag{..}
@@ -74,6 +75,6 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
           { symbol = name
           , kind = kind
           , line = fromMaybe mempty line
-          , span = spanToSpan span
+          , span = converting #? span
           , docs = fmap Docstring docs
           }

src/Semantic/Api/TOCSummaries.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
+{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-}
 module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
 
 import           Analysis.TOCSummary (Declaration, declarationAlgebra)
 import           Control.Effect.Error
+import           Control.Lens
 import           Data.Aeson
 import           Data.Blob
 import           Data.ByteString.Builder
@@ -13,7 +14,7 @@ import qualified Data.Text as T
 import qualified Data.Vector as V
 import           Rendering.TOC
 import           Semantic.Api.Diffs
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair)
 import           Semantic.Task as Task
 import           Serializing.Format
@@ -42,16 +43,22 @@ diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
       `catchError` \(SomeException e) ->
         pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
       where path = T.pack $ pathKeyForBlobPair blobPair
-            lang = languageToApiLanguage $ languageForBlobPair blobPair
+            lang = bridging # languageForBlobPair blobPair
 
     render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile
     render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
       where
         path = T.pack $ pathKeyForBlobPair blobPair
-        lang = languageToApiLanguage $ languageForBlobPair blobPair
+        lang = bridging # languageForBlobPair blobPair
+
+        toChangeType = \case
+          "added" -> Added
+          "modified" -> Modified
+          "removed" -> Removed
+          _ -> None
 
         go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
         go TOCSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (spanToSpan summarySpan) (toChangeType summaryChangeType)) changes) errors
+          = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
         go ErrorSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (spanToSpan errorSpan)) errors)
+          = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)

src/Semantic/Api/Terms.hs

@@ -17,6 +17,7 @@ module Semantic.Api.Terms
 import           Analysis.ConstructorName (ConstructorName)
 import           Control.Effect
 import           Control.Effect.Error
+import           Control.Lens
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Abstract.Declarations
@@ -36,7 +37,7 @@ import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, Language (..))
 import           Semantic.Task
 import           Serializing.Format hiding (JSON)
@@ -52,7 +53,7 @@ termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor
         pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ blobPath blob
-        lang = languageToApiLanguage $ blobLanguage blob
+        lang = bridging # blobLanguage blob
 
         render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph
         render t = let graph = renderTreeGraph t