Merge branch 'master' into add-java-to-supported-langs

semantic-core/semantic-core.cabal

@@ -84,6 +84,7 @@ test-suite spec
   other-modules:       Generators
   build-depends:       base
                      , semantic-core
+                     , semantic-source ^>= 0
                      , fused-effects
                      , hedgehog ^>= 1
                      , tasty >= 1.2 && <2

semantic-core/src/Analysis/Concrete.hs

@@ -41,7 +41,7 @@ newtype FrameId = FrameId { unFrameId :: Precise }
   deriving (Eq, Ord, Show)
 
 data Concrete term
-  = Closure Loc Name term Env
+  = Closure Path Span Name term Env
   | Unit
   | Bool Bool
   | String Text
@@ -67,18 +67,18 @@ data Edge = Lexical | Import
 
 -- | Concrete evaluation of a term to a value.
 --
---   >>> map fileBody (snd (concrete eval [File (Loc "bool" (Span (Pos 1 1) (Pos 1 5))) (Core.bool True)]))
+--   >>> map fileBody (snd (concrete eval [File (Path "bool") (Span (Pos 1 1) (Pos 1 5)) (Core.bool True)]))
 --   [Right (Bool True)]
 concrete
   :: (Foldable term, Show (term Name))
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis (term Name) Precise (Concrete (term Name)) m
      -> (term Name -> m (Concrete (term Name)))
      -> (term Name -> m (Concrete (term Name)))
      )
   -> [File (term Name)]
-  -> (Heap (term Name), [File (Either (Loc, String) (Concrete (term Name)))])
+  -> (Heap (term Name), [File (Either (Path, Span, String) (Concrete (term Name)))])
 concrete eval
   = run
   . runFresh
@@ -94,15 +94,16 @@ runFile
      , Show (term Name)
      )
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis (term Name) Precise (Concrete (term Name)) m
      -> (term Name -> m (Concrete (term Name)))
      -> (term Name -> m (Concrete (term Name)))
      )
   -> File (term Name)
-  -> m (File (Either (Loc, String) (Concrete (term Name))))
+  -> m (File (Either (Path, Span, String) (Concrete (term Name))))
 runFile eval file = traverse run file
-  where run = runReader (fileLoc file)
+  where run = runReader (filePath file)
+            . runReader (fileSpan file)
             . runFail
             . runReader @Env mempty
             . fix (eval concreteAnalysis)
@@ -111,7 +112,8 @@ concreteAnalysis :: ( Carrier sig m
                     , Foldable term
                     , Member Fresh sig
                     , Member (Reader Env) sig
-                    , Member (Reader Loc) sig
+                    , Member (Reader Path) sig
+                    , Member (Reader Span) sig
                     , Member (State (Heap (term Name))) sig
                     , MonadFail m
                     , Show (term Name)
@@ -124,11 +126,12 @@ concreteAnalysis = Analysis{..}
         deref = gets . IntMap.lookup
         assign addr value = modify (IntMap.insert addr value)
         abstract _ name body = do
-          loc <- ask
+          path <- ask
+          span <- ask
           env <- asks (flip Map.restrictKeys (Set.delete name (foldMap Set.singleton body)))
-          pure (Closure loc name body env)
+          pure (Closure path span name body env)
-        apply eval (Closure loc name body env) a = do
+        apply eval (Closure path span name body env) a = do
-          local (const loc) $ do
+          local (const path) . local (const span) $ do
             addr <- alloc name
             assign addr a
             local (const (Map.insert name addr env)) (eval body)
@@ -185,7 +188,7 @@ heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
           Unit -> G.empty
           Bool _ -> G.empty
           String _ -> G.empty
-          Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
+          Closure _ _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
           Record frame -> Map.foldrWithKey (\ k -> G.overlay . edge (Right k)) G.empty frame
 
 heapValueGraph :: Heap term -> G.Graph (Concrete term)
@@ -206,7 +209,7 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
           Unit ->  "()"
           Bool b -> pack $ show b
           String s -> pack $ show s
-          Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> unName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
+          Closure p (Span s e) n _ _ -> "\\\\ " <> unName n <> " [" <> getPath p <> ":" <> showPos s <> "-" <> showPos e <> "]"
           Record _ -> "{}"
         showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
 

semantic-core/src/Analysis/Eval.hs

@@ -27,15 +27,16 @@ import Data.Term
 import Data.Text (Text)
 import GHC.Stack
 import Prelude hiding (fail)
+import Source.Span
 
 eval :: ( Carrier sig m
-        , Member (Reader Loc) sig
+        , Member (Reader Span) sig
         , MonadFail m
         , Semigroup value
         )
-     => Analysis (Term (Ann :+: Core) Name) address value m
+     => Analysis (Term (Ann Span :+: Core) Name) address value m
-     -> (Term (Ann :+: Core) Name -> m value)
+     -> (Term (Ann Span :+: Core) Name -> m value)
-     -> (Term (Ann :+: Core) Name -> m value)
+     -> (Term (Ann Span :+: Core) Name -> m value)
 eval Analysis{..} eval = \case
   Var n -> lookupEnv' n >>= deref' n
   Term (R c) -> case c of
@@ -72,7 +73,7 @@ eval Analysis{..} eval = \case
       b' <- eval b
       addr <- ref a
       b' <$ assign addr b'
-  Term (L (Ann loc c)) -> local (const loc) (eval c)
+  Term (L (Ann span c)) -> local (const span) (eval c)
   where freeVariable s = fail ("free variable: " <> s)
         uninitialized s = fail ("uninitialized variable: " <> s)
         invalidRef s = fail ("invalid ref: " <> s)
@@ -90,7 +91,7 @@ eval Analysis{..} eval = \case
               a' <- ref a
               a' ... b >>= maybe (freeVariable (show b)) pure
             c -> invalidRef (show c)
-          Term (L (Ann loc c)) -> local (const loc) (ref c)
+          Term (L (Ann span c)) -> local (const span) (ref c)
 
 
 prog1 :: (Carrier sig t, Member Core sig) => File (t Name)
@@ -116,7 +117,7 @@ prog4 = fromBody
     (Core.bool True)
     (Core.bool False))
 
-prog5 :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
+prog5 :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name)
 prog5 = fromBody $ ann (do'
   [ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record
     [ ("x", ann (pure "_x"))
@@ -129,15 +130,15 @@ prog5 = fromBody $ ann (do'
 
 prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)]
 prog6 =
-  [ File (Loc "dep"  (locSpan (fromJust here))) $ Core.record
+  [ File (Path "dep")  (snd (fromJust here)) $ Core.record
     [ ("dep", Core.record [ ("var", Core.bool True) ]) ]
-  , File (Loc "main" (locSpan (fromJust here))) $ do' (map (Nothing :<-)
+  , File (Path "main") (snd (fromJust here)) $ do' (map (Nothing :<-)
     [ load (Core.string "dep")
     , Core.record [ ("thing", pure "dep" Core.... "var") ]
     ])
   ]
 
-ruby :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t Name)
+ruby :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name)
 ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements))
   where statements =
           [ Just "Class" :<- record

semantic-core/src/Analysis/ImportGraph.hs

@@ -25,6 +25,7 @@ import           Data.Proxy
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import           Prelude hiding (fail)
+import           Source.Span
 
 type ImportGraph = Map.Map Text (Set.Set Text)
 
@@ -41,7 +42,7 @@ instance Monoid (Value term) where
   mempty = Value Abstract mempty
 
 data Semi term
-  = Closure Loc Name term
+  = Closure Path Span Name term
   -- FIXME: Bound String values.
   | String Text
   | Abstract
@@ -51,14 +52,14 @@ data Semi term
 importGraph
   :: (Ord term, Show term)
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name (Value term) m
      -> (term -> m (Value term))
      -> (term -> m (Value term))
      )
   -> [File term]
   -> ( Heap Name (Value term)
-     , [File (Either (Loc, String) (Value term))]
+     , [File (Either (Path, Span, String) (Value term))]
      )
 importGraph eval
   = run
@@ -75,15 +76,16 @@ runFile
      , Show term
      )
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name (Value term) m
      -> (term -> m (Value term))
      -> (term -> m (Value term))
      )
   -> File term
-  -> m (File (Either (Loc, String) (Value term)))
+  -> m (File (Either (Path, Span, String) (Value term)))
 runFile eval file = traverse run file
-  where run = runReader (fileLoc file)
+  where run = runReader (filePath file)
+            . runReader (fileSpan file)
             . runFail
             . fmap fold
             . convergeTerm (Proxy @Name) (fix (cacheTerm . eval importGraphAnalysis))
@@ -91,7 +93,8 @@ runFile eval file = traverse run file
 -- FIXME: decompose into a product domain and two atomic domains
 importGraphAnalysis :: ( Alternative m
                        , Carrier sig m
-                       , Member (Reader Loc) sig
+                       , Member (Reader Path) sig
+                       , Member (Reader Span) sig
                        , Member (State (Heap Name (Value term))) sig
                        , MonadFail m
                        , Ord  term
@@ -105,9 +108,10 @@ importGraphAnalysis = Analysis{..}
         deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
         assign addr v = modify (Map.insertWith (<>) addr (Set.singleton v))
         abstract _ name body = do
-          loc <- ask
+          path <- ask
-          pure (Value (Closure loc name body) mempty)
+          span <- ask
-        apply eval (Value (Closure loc name body) _) a = local (const loc) $ do
+          pure (Value (Closure path span name body) mempty)
+        apply eval (Value (Closure path span name body) _) a = local (const path) . local (const span) $ do
           addr <- alloc name
           assign addr a
           bind name addr (eval body)

semantic-core/src/Analysis/ScopeGraph.hs

@@ -27,14 +27,19 @@ import           Data.Proxy
 import qualified Data.Set as Set
 import           Data.Traversable (for)
 import           Prelude hiding (fail)
+import           Source.Span
 
 data Decl = Decl
   { declSymbol :: Name
-  , declLoc    :: Loc
+  , declPath   :: Path
+  , declSpan   :: Span
   }
   deriving (Eq, Ord, Show)
 
-newtype Ref = Ref Loc
+data Ref = Ref
+  { refPath :: Path
+  , refSpan :: Span
+  }
   deriving (Eq, Ord, Show)
 
 newtype ScopeGraph = ScopeGraph { unScopeGraph :: Map.Map Decl (Set.Set Ref) }
@@ -49,13 +54,13 @@ instance Monoid ScopeGraph where
 scopeGraph
   :: Ord term
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name ScopeGraph m
      -> (term -> m ScopeGraph)
      -> (term -> m ScopeGraph)
      )
   -> [File term]
-  -> (Heap Name ScopeGraph, [File (Either (Loc, String) ScopeGraph)])
+  -> (Heap Name ScopeGraph, [File (Either (Path, Span, String) ScopeGraph)])
 scopeGraph eval
   = run
   . runFresh
@@ -70,16 +75,17 @@ runFile
      , Ord term
      )
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name ScopeGraph m
      -> (term -> m ScopeGraph)
      -> (term -> m ScopeGraph)
      )
   -> File term
-  -> m (File (Either (Loc, String) ScopeGraph))
+  -> m (File (Either (Path, Span, String) ScopeGraph))
 runFile eval file = traverse run file
-  where run = runReader (fileLoc file)
+  where run = runReader (filePath file)
-            . runReader (Map.empty @Name @Loc)
+            . runReader (fileSpan file)
+            . runReader (Map.empty @Name @Ref)
             . runFail
             . fmap fold
             . convergeTerm (Proxy @Name) (fix (cacheTerm . eval scopeGraphAnalysis))
@@ -87,27 +93,28 @@ runFile eval file = traverse run file
 scopeGraphAnalysis
   :: ( Alternative m
      , Carrier sig m
-     , Member (Reader Loc) sig
+     , Member (Reader Path) sig
-     , Member (Reader (Map.Map Name Loc)) sig
+     , Member (Reader Span) sig
+     , Member (Reader (Map.Map Name Ref)) sig
      , Member (State (Heap Name ScopeGraph)) sig
      )
   => Analysis term Name ScopeGraph m
 scopeGraphAnalysis = Analysis{..}
   where alloc = pure
         bind name _ m = do
-          loc <- ask @Loc
+          ref <- askRef
-          local (Map.insert name loc) m
+          local (Map.insert name ref) m
         lookupEnv = pure . Just
         deref addr = do
-          ref <- asks Ref
+          ref <- askRef
-          bindLoc <- asks (Map.lookup addr)
+          bindRef <- asks (Map.lookup addr)
           cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
-          let extending = mappend (extendBinding addr ref bindLoc)
+          let extending = mappend (extendBinding addr ref bindRef)
           maybe (pure Nothing) (foldMapA (pure . Just . extending)) cell
         assign addr v = do
-          ref <- asks Ref
+          ref <- askRef
-          bindLoc <- asks (Map.lookup addr)
+          bindRef <- asks (Map.lookup addr)
-          modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindLoc <> v)))
+          modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindRef <> v)))
         abstract eval name body = do
           addr <- alloc name
           assign name (mempty @ScopeGraph)
@@ -121,10 +128,13 @@ scopeGraphAnalysis = Analysis{..}
         record fields = do
           fields' <- for fields $ \ (k, v) -> do
             addr <- alloc k
-            loc <- ask @Loc
+            path <- ask
-            let v' = ScopeGraph (Map.singleton (Decl k loc) mempty) <> v
+            span <- ask
+            let v' = ScopeGraph (Map.singleton (Decl k path span) mempty) <> v
             (k, v') <$ assign addr v'
           pure (foldMap snd fields')
         _ ... m = pure (Just m)
 
-        extendBinding addr ref bindLoc = ScopeGraph (maybe Map.empty (\ bindLoc -> Map.singleton (Decl addr bindLoc) (Set.singleton ref)) bindLoc)
+        askRef = Ref <$> ask <*> ask
+
+        extendBinding addr ref bindRef = ScopeGraph (maybe Map.empty (\ (Ref path span) -> Map.singleton (Decl addr path span) (Set.singleton ref)) bindRef)

semantic-core/src/Analysis/Typecheck.hs

@@ -37,6 +37,7 @@ import           Data.Traversable (for)
 import           Data.Void
 import           GHC.Generics (Generic1)
 import           Prelude hiding (fail)
+import           Source.Span
 
 data Monotype f a
   = Bool
@@ -94,14 +95,14 @@ generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R
 typecheckingFlowInsensitive
   :: Ord term
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name Type m
      -> (term -> m Type)
      -> (term -> m Type)
      )
   -> [File term]
   -> ( Heap Name Type
-     , [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))]
+     , [File (Either (Path, Span, String) (Term (Polytype :+: Monotype) Void))]
      )
 typecheckingFlowInsensitive eval
   = run
@@ -118,13 +119,13 @@ runFile
      , Ord term
      )
   => (forall sig m
-     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     .  (Carrier sig m, Member (Reader Path) sig, Member (Reader Span) sig, MonadFail m)
      => Analysis term Name Type m
      -> (term -> m Type)
      -> (term -> m Type)
      )
   -> File term
-  -> m (File (Either (Loc, String) Type))
+  -> m (File (Either (Path, Span, String) Type))
 runFile eval file = traverse run file
   where run
           = (\ m -> do
@@ -132,7 +133,8 @@ runFile eval file = traverse run file
               modify @(Heap Name Type) (fmap (Set.map (substAll subst)))
               pure (substAll subst <$> t))
           . runState (mempty :: Substitution)
-          . runReader (fileLoc file)
+          . runReader (filePath file)
+          . runReader (fileSpan file)
           . runFail
           . (\ m -> do
             (cs, t) <- m

semantic-core/src/Control/Carrier/Fail/WithLoc.hs

@@ -14,18 +14,20 @@ import Control.Effect.Fail (Fail(..), MonadFail(..))
 import Control.Effect.Reader
 import Data.Loc
 import Prelude hiding (fail)
+import Source.Span
 
-runFail :: FailC m a -> m (Either (Loc, String) a)
+runFail :: FailC m a -> m (Either (Path, Span, String) a)
 runFail = runError . runFailC
 
-newtype FailC m a = FailC { runFailC :: ErrorC (Loc, String) m a }
+newtype FailC m a = FailC { runFailC :: ErrorC (Path, Span, String) m a }
   deriving (Alternative, Applicative, Functor, Monad)
 
-instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailC m) where
+instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => MonadFail (FailC m) where
   fail s = do
-    loc <- ask
+    path <- ask
-    FailC (throwError (loc :: Loc, s))
+    span <- ask
+    FailC (throwError (path :: Path, span :: Span, s))
 
-instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailC m) where
+instance (Carrier sig m, Effect sig, Member (Reader Path) sig, Member (Reader Span) sig) => Carrier (Fail :+: sig) (FailC m) where
   eff (L (Fail s)) = fail s
   eff (R other)    = FailC (eff (R (handleCoercible other)))

semantic-core/src/Data/Core.hs

@@ -50,6 +50,7 @@ import Data.Term
 import Data.Text (Text)
 import GHC.Generics (Generic1)
 import GHC.Stack
+import Source.Span
 
 data Core f a
   -- | Recursive local binding of a name in a scope; strict evaluation of the name in the body will diverge.
@@ -215,27 +216,27 @@ a .= b = send (a := b)
 infix 3 .=
 
 
-data Ann f a
+data Ann ann f a
-  = Ann Loc (f a)
+  = Ann ann (f a)
   deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
 
-instance HFunctor Ann
+instance HFunctor (Ann ann)
 
-instance RightModule Ann where
+instance RightModule (Ann ann) where
   Ann l b >>=* f = Ann l (b >>= f)
 
 
-ann :: (Carrier sig m, Member Ann sig) => HasCallStack => m a -> m a
+ann :: (Carrier sig m, Member (Ann Span) sig) => HasCallStack => m a -> m a
 ann = annWith callStack
 
-annAt :: (Carrier sig m, Member Ann sig) => Loc -> m a -> m a
+annAt :: (Carrier sig m, Member (Ann ann) sig) => ann -> m a -> m a
-annAt loc = send . Ann loc
+annAt ann = send . Ann ann
 
-annWith :: (Carrier sig m, Member Ann sig) => CallStack -> m a -> m a
+annWith :: (Carrier sig m, Member (Ann Span) sig) => CallStack -> m a -> m a
-annWith callStack = maybe id annAt (stackLoc callStack)
+annWith callStack = maybe id (annAt . snd) (stackLoc callStack)
 
 
-stripAnnotations :: (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann :+: sig) a -> Term sig a
+stripAnnotations :: forall ann a sig . (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann ann :+: sig) a -> Term sig a
 stripAnnotations (Var v)              = Var v
 stripAnnotations (Term (L (Ann _ b))) = stripAnnotations b
 stripAnnotations (Term (R        b))  = Term (hmap stripAnnotations b)

semantic-core/src/Data/Core/Parser.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE FlexibleContexts, TypeOperators #-}
 module Data.Core.Parser
-  ( module Text.Trifecta
+  ( core
-  , core
   , lit
   , expr
   , record

semantic-core/src/Data/File.hs

@@ -7,12 +7,15 @@ module Data.File
 import Data.Loc
 import Data.Maybe (fromJust)
 import GHC.Stack
+import Source.Span
 
 data File a = File
-  { fileLoc  :: !Loc
+  { filePath :: !Path
+  , fileSpan :: {-# UNPACK #-} !Span
   , fileBody :: !a
   }
   deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
 
 fromBody :: HasCallStack => a -> File a
-fromBody body = File (fromJust (stackLoc callStack)) body
+fromBody body = File path span body where
+  (path, span) = fromJust (stackLoc callStack)

semantic-core/src/Data/Loc.hs

@@ -1,7 +1,6 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
 module Data.Loc
-( Loc(..)
+( Path(..)
-, interactive
 , here
 , stackLoc
 ) where
@@ -10,23 +9,17 @@ import Data.Text (Text, pack)
 import GHC.Stack
 import Source.Span
 
-data Loc = Loc
+newtype Path = Path { getPath :: Text }
-  { locPath :: !Text
-  , locSpan :: {-# UNPACK #-} !Span
-  }
   deriving (Eq, Ord, Show)
 
-interactive :: Loc
-interactive = Loc "<interactive>" (Span (Pos 1 1) (Pos 1 1))
 
-
+here :: HasCallStack => Maybe (Path, Span)
-here :: HasCallStack => Maybe Loc
 here = stackLoc callStack
 
-stackLoc :: CallStack -> Maybe Loc
+stackLoc :: CallStack -> Maybe (Path, Span)
 stackLoc cs = case getCallStack cs of
   (_, srcLoc):_ -> Just (fromGHCSrcLoc srcLoc)
   _             -> Nothing
 
-fromGHCSrcLoc :: SrcLoc -> Loc
+fromGHCSrcLoc :: SrcLoc -> (Path, Span)
-fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
+fromGHCSrcLoc SrcLoc{..} = (Path (pack srcLocFile), Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))

semantic-core/test/Spec.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, TypeOperators #-}
+{-# LANGUAGE OverloadedStrings, TypeApplications, TypeOperators #-}
 module Main (main) where
 
 import           Data.String
@@ -11,6 +11,7 @@ import           Test.Tasty.HUnit
 
 import           Control.Effect.Sum
 import           Data.File
+import           Data.Loc (Path)
 import qualified Generators as Gen
 import qualified Analysis.Eval as Eval
 import           Data.Core
@@ -18,10 +19,11 @@ import           Data.Core.Pretty
 import           Data.Core.Parser as Parse
 import           Data.Name
 import           Data.Term
+import           Source.Span
 
 -- * Helpers
 
-true, false :: Term (Ann :+: Core) Name
+true, false :: Term Core Name
 true  = bool True
 false = bool False
 
@@ -31,10 +33,10 @@ parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Tri
 -- * Parser roundtripping properties. Note that parsing and prettyprinting is generally
 -- not a roundtrip, because the parser inserts 'Ann' nodes itself.
 
-prop_roundtrips :: Gen (Term (Ann :+: Core) Name) -> Property
+prop_roundtrips :: Gen (Term Core Name) -> Property
 prop_roundtrips gen = property $ do
   input <- forAll gen
-  tripping input (showCore . stripAnnotations) (parseEither (Parse.core <* Trifecta.eof))
+  tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
 
 parserProps :: TestTree
 parserProps = testGroup "Parsing: roundtripping"
@@ -47,7 +49,7 @@ parserProps = testGroup "Parsing: roundtripping"
 
 -- * Parser specs
 
-parsesInto :: String -> Term (Ann :+: Core) Name -> Assertion
+parsesInto :: String -> Term Core Name -> Assertion
 parsesInto str res = case parseEither Parse.core str of
   Right x -> x @?= res
   Left m  -> assertFailure m
@@ -57,7 +59,7 @@ assert_booleans_parse = do
   parseEither Parse.core "#true"  @?= Right true
   parseEither Parse.core "#false" @?= Right false
 
-a, f, g, h :: Term (Ann :+: Core) Name
+a, f, g, h :: Term Core Name
 (a, f, g, h) = (pure "a", pure "f", pure "g", pure "h")
 
 assert_ifthen_parse :: Assertion
@@ -93,10 +95,10 @@ parserSpecs = testGroup "Parsing: simple specs"
   , testCase "quoted names" assert_quoted_name_parse
   ]
 
-assert_roundtrips :: File (Term (Ann :+: Core) Name) -> Assertion
+assert_roundtrips :: File (Term Core Name) -> Assertion
-assert_roundtrips (File _ core) = case parseEither Parse.core (showCore (stripAnnotations core)) of
+assert_roundtrips (File _ _ core) = case parseEither Parse.core (showCore core) of
-  Right v -> stripAnnotations v @?= stripAnnotations core
+  Right v -> v @?= core
-  Left e -> assertFailure e
+  Left  e -> assertFailure e
 
 parserExamples :: TestTree
 parserExamples = testGroup "Parsing: Eval.hs examples"
@@ -106,7 +108,7 @@ parserExamples = testGroup "Parsing: Eval.hs examples"
   , testCase "prog4" (assert_roundtrips Eval.prog4)
   , testCase "prog6.1" (assert_roundtrips (head Eval.prog6))
   , testCase "prog6.2" (assert_roundtrips (last Eval.prog6))
-  , testCase "ruby" (assert_roundtrips Eval.ruby)
+  , testCase "ruby" (assert_roundtrips (stripAnnotations @Span <$> Eval.ruby))
   ]
 
 tests :: TestTree

semantic-python/src/Language/Python/Core.hs

@@ -5,7 +5,6 @@
 module Language.Python.Core
 ( toplevelCompile
 , Bindings
-, SourcePath
 ) where
 
 import Prelude hiding (fail)
@@ -18,21 +17,13 @@ import           Control.Monad ((>=>))
 import           Data.Coerce
 import           Data.Core as Core
 import           Data.Foldable
-import           Data.Loc (Loc)
-import qualified Data.Loc
 import           Data.Name as Name
 import           Data.Stack (Stack)
 import qualified Data.Stack as Stack
-import           Data.String (IsString)
-import           Data.Text (Text)
 import           GHC.Records
 import           Source.Span (Span)
 import qualified TreeSitter.Python.AST as Py
 
--- | Access to the current filename as Text to stick into location annotations.
-newtype SourcePath = SourcePath { rawPath :: Text }
-  deriving (Eq, IsString, Show)
-
 -- | Keeps track of the current scope's bindings (so that we can, when
 -- compiling a class or module, return the list of bound variables as
 -- a Core record so that all immediate definitions are exposed)
@@ -57,7 +48,7 @@ pattern SingleIdentifier name <- Py.ExpressionList
 -- possible for us to 'cheat' by pattern-matching on or eliminating a
 -- compiled term.
 type CoreSyntax sig t = ( Member Core sig
-                        , Member Ann sig
+                        , Member (Ann Span) sig
                         , Carrier sig t
                         , Foldable t
                         )
@@ -66,7 +57,6 @@ class Compile (py :: * -> *) where
   -- FIXME: rather than failing the compilation process entirely
   -- with MonadFail, we should emit core that represents failure
   compile :: ( CoreSyntax syn t
-             , Member (Reader SourcePath) sig
              , Member (Reader Bindings) sig
              , Carrier sig m
              , MonadFail m
@@ -79,7 +69,6 @@ class Compile (py :: * -> *) where
   compile a _ _ = defaultCompile a
 
 toplevelCompile :: ( CoreSyntax syn t
-                   , Member (Reader SourcePath) sig
                    , Member (Reader Bindings) sig
                    , Carrier sig m
                    , MonadFail m
@@ -93,20 +82,14 @@ toplevelCompile py = compile py pure none
 none :: (Member Core sig, Carrier sig t) => t Name
 none = unit
 
-locFromTSSpan :: SourcePath -> Span -> Loc
-locFromTSSpan fp = Data.Loc.Loc (rawPath fp)
-
 locate :: ( HasField "ann" syntax Span
           , CoreSyntax syn t
-          , Member (Reader SourcePath) sig
+          , Applicative m
-          , Carrier sig m
           )
        => syntax
        -> t a
        -> m (t a)
-locate syn item = do
+locate syn item = pure (Core.annAt (getField @"ann" syn) item)
-  fp <- ask @SourcePath
-  pure (Core.annAt (locFromTSSpan fp (getField @"ann" syn)) item)
 
 defaultCompile :: (MonadFail m, Show py) => py -> m (t Name)
 defaultCompile t = fail $ "compilation unimplemented for " <> show t
@@ -140,20 +123,18 @@ type Desugared = Py.ExpressionList :+: Py.Yield
 
 -- We have to pair locations and names, and tuple syntax is harder to
 -- read in this case than a happy little constructor.
-data Located a = Located Loc a
+data Located a = Located Span a
 
 -- Desugaring an RHS involves walking as deeply as possible into an
 -- assignment, storing the names we encounter as we go and eventually
 -- returning a terminal expression. We have to keep track of which
-desugar :: (Member (Reader SourcePath) sig, Carrier sig m, MonadFail m)
+desugar :: MonadFail m
         => [Located Name]
         -> RHS Span
         -> m ([Located Name], Desugared Span)
 desugar acc = \case
-  Prj Py.Assignment { left = SingleIdentifier name, right = Just rhs, ann} -> do
+  Prj Py.Assignment { left = SingleIdentifier name, right = Just rhs, ann} ->
-    loc <- locFromTSSpan <$> ask <*> pure ann
+    desugar (Located ann name : acc) rhs
-    let cons = (Located loc name :)
-    desugar (cons acc) rhs
   R1 any -> pure (acc, any)
   other -> fail ("desugar: couldn't desugar RHS " <> show other)
 
@@ -179,8 +160,7 @@ instance Compile Py.Assignment where
     , right = Just rhs
     , ann
     } cc next = do
-    p <- ask @SourcePath
+    (names, val) <- desugar [Located ann name] rhs
-    (names, val) <- desugar [Located (locFromTSSpan p ann) name] rhs
     compile val pure next >>= foldr collapseDesugared cc names >>= locate it
 
   compile other _ _ = fail ("Unhandled assignment case: " <> show other)

semantic-python/test/Instances.hs

@@ -19,27 +19,27 @@ deriving newtype instance ToJSON Name
 deriving newtype instance ToJSONKey Name
 
 instance ToJSON a => ToJSON (File a) where
-  toJSON File{fileLoc, fileBody} = object
+  toJSON File{filePath, fileSpan, fileBody} = object
-    [ "location" .= fileLoc
+    [ "path" .= filePath
+    , "span" .= fileSpan
     , "body" .= fileBody
     ]
 
-instance ToJSON Loc where
+deriving newtype instance ToJSON Path
-  toJSON Loc{locPath, locSpan} = object
-    [ "kind" .= ("loc" :: Text)
-    , "path" .= locPath
-    , "span" .= locSpan
-    ]
 
 instance ToJSON Ref where
-  toJSON (Ref loc) = object [ "kind" .= ("ref" :: Text)
+  toJSON (Ref path span) = object
-                            , "location" .= loc]
+    [ "kind" .= ("ref" :: Text)
+    , "path" .= path
+    , "span" .= span
+    ]
 
 instance ToJSON Decl where
-  toJSON Decl{declSymbol, declLoc} = object
+  toJSON Decl{declSymbol, declPath, declSpan} = object
     [ "kind"   .= ("decl" :: Text)
     , "symbol" .= declSymbol
-    , "location" .= declLoc
+    , "path" .= declPath
+    , "span" .= declSpan
     ]
 
 instance ToJSON ScopeGraph where

semantic-python/test/Test.hs

@@ -25,10 +25,10 @@ import           Data.Loc
 import           Data.Maybe
 import           Data.Name
 import           Data.Term
-import           Data.String (fromString)
 import           GHC.Stack
 import qualified Language.Python.Core as Py
 import           Prelude hiding (fail)
+import           Source.Span
 import           Streaming
 import qualified Streaming.Prelude as Stream
 import qualified Streaming.Process
@@ -49,10 +49,10 @@ import qualified Directive
 import           Instances ()
 
 
-assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann :+: Core) Name -> HUnit.Assertion
+assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann Span :+: Core) Name -> HUnit.Assertion
 assertJQExpressionSucceeds directive tree core = do
-  bod <- case scopeGraph Eval.eval [File interactive core] of
+  bod <- case scopeGraph Eval.eval [File (Path "<interactive>") (Span (Pos 1 1) (Pos 1 1)) core] of
-    (heap, [File _ (Right result)]) -> pure $ Aeson.object
+    (heap, [File _ _ (Right result)]) -> pure $ Aeson.object
       [ "scope" Aeson..= heap
       , "heap"  Aeson..= result
       ]
@@ -95,7 +95,6 @@ fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> wi
   result <- ByteString.readFile (Path.toString fullPath) >>= TS.parseByteString TSP.tree_sitter_python
   let coreResult = Control.Effect.run
                    . runFail
-                   . runReader (fromString @Py.SourcePath . Path.toString $ fp)
                    . runReader @Py.Bindings mempty
                    . Py.toplevelCompile
                    <$> result