Corral orphan instances.

semantic-core/src/Analysis/ScopeGraph.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, RecordWildCards, TypeApplications, TypeOperators #-}
 module Analysis.ScopeGraph
 ( ScopeGraph(..)
+, Ref (..)
 , Decl(..)
 , scopeGraph
 , scopeGraphAnalysis

semantic-python/semantic-python.cabal

@@ -66,6 +66,7 @@ test-suite test
   ghc-options: -threaded
 
   other-modules: Directive
+               , Instances
 
   build-depends: semantic-python == 0.0.0.0
                , aeson ^>= 1.4.4.0
@@ -81,5 +82,6 @@ test-suite test
                , streaming-bytestring ^>= 0.1.6
                , tasty ^>= 1.2.3
                , tasty-hunit ^>= 0.10.0.2
+               , text ^>= 1.2.3
                , trifecta >= 2 && <3
                , unordered-containers ^>= 0.2.10

semantic-python/test/Instances.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Instances where
+
+-- Testing code depends on certain instances that we don't want to
+-- expose in semantic-core proper, yet are important enough that
+-- we should keep track of them in a dedicated file.
+
+import           Analysis.ScopeGraph
+import           Control.Monad.Fail
+import           Data.Aeson
+import           Data.Loc
+import qualified Data.Map as Map
+import           Data.Text (Text)
+
+instance MonadFail (Either String) where fail = Left
+
+instance ToJSON Span where
+  toJSON Span{spanStart, spanEnd} = object
+    [ "kind"  .= ("span" :: Text)
+    , "start" .= spanStart
+    , "end"   .= spanEnd
+    ]
+
+instance ToJSON Pos where
+  toJSON Pos{posLine, posCol} = object
+    [ "kind" .= ("pos" :: Text)
+    , "line" .= posLine
+    , "column"  .= posCol
+    ]
+
+instance ToJSON Loc where
+  toJSON Loc{locPath, locSpan} = object
+    [ "kind" .= ("loc" :: Text)
+    , "path" .= locPath
+    , "span" .= locSpan
+    ]
+
+instance ToJSON Ref where
+  toJSON (Ref loc) = object [ "kind" .= ("ref" :: Text)
+                            , "location" .= loc]
+
+instance ToJSON Decl where
+  toJSON Decl{declSymbol, declLoc} = object
+    [ "kind"   .= ("decl" :: Text)
+    , "symbol" .= declSymbol
+    , "location" .= declLoc
+    ]
+
+instance ToJSON ScopeGraph where
+  toJSON (ScopeGraph sc) = toJSON . Map.mapKeys declSymbol $ sc

semantic-python/test/Test.hs

@@ -3,6 +3,7 @@
 module Main (main) where
 
 import qualified Analysis.Eval as Eval
+import           Analysis.FlowInsensitive
 import           Control.Effect
 import           Control.Effect.Fail
 import           Control.Effect.Fresh
@@ -46,20 +47,19 @@ import qualified Test.Tasty.HUnit as HUnit
 
 import qualified Directive
 import           Analysis.ScopeGraph
+import Instances ()
 
-instance MonadFail (Either String) where fail = Left
-
-dumpScopeGraph :: ScopeGraph -> Aeson.Value
-dumpScopeGraph (ScopeGraph sg) = Aeson.object
-  [ "scope" Aeson..= scopeJSON
-  ] where
-  scopeJSON = Aeson.toJSON . Map.mapKeys declSymbol . fmap (const ()) $ sg
+dumpScopeGraph :: Heap Name ScopeGraph -> ScopeGraph -> Aeson.Value
+dumpScopeGraph h sg = Aeson.object $
+  [ "scope" Aeson..= h
+  , "heap"  Aeson..= sg
+  ]
 
 
 assertJQExpressionSucceeds :: Directive.Directive -> Term (Ann :+: Core) Name -> HUnit.Assertion
 assertJQExpressionSucceeds directive core = do
   bod <- case scopeGraph Eval.eval [File interactive core] of
-    (_heap, [File _ (Right bod)]) -> pure $ dumpScopeGraph bod
+    (heap, [File _ (Right bod)]) -> pure $ dumpScopeGraph heap bod
     other -> HUnit.assertFailure "Couldn't run scope dumping mechanism; this shouldn't happen"
 
   let ignore = ByteStream.effects . hoist ByteStream.effects