Merge remote-tracking branch 'origin/master' into compile-python-calls

Dockerfile

@@ -1,7 +1,7 @@
 # Put protoc and twirp tooling in its own image
 FROM haskell:8.6 as haskell
-RUN cabal new-update hackage.haskell.org,HEAD
-RUN cabal new-install proto-lens-protoc
+RUN cabal v2-update && \
+    cabal v2-install proto-lens-protoc
 RUN which proto-lens-protoc
 
 FROM golang:1.13-stretch AS protoc
@@ -22,18 +22,23 @@ ENTRYPOINT ["/protobuf/bin/protoc", "-I/protobuf", "--plugin=protoc-gen-haskell=
 FROM haskell:8.6 as build
 WORKDIR /build
 
-# Build and cache the dependencies first so we can cache these layers.
+# Build just the dependencies so that this layer can be cached
 COPY semantic.cabal .
-COPY semantic-core semantic-core
-RUN cabal new-update hackage.haskell.org,HEAD
-RUN cabal new-configure semantic semantic-core
-RUN cabal new-build --only-dependencies
+COPY semantic-core semantic-core/
+COPY semantic-java semantic-java/
+COPY semantic-json semantic-json/
+COPY semantic-python semantic-python/
+COPY semantic-source semantic-source/
+COPY semantic-tags semantic-tags/
+COPY cabal.project .
+RUN cabal v2-update && \
+    cabal v2-build --flags="release" --only-dependencies
 
-# Copy in and build the entire project
+# Build all of semantic
 COPY . .
-RUN cabal new-build --flags="release" semantic:exe:semantic
+RUN cabal v2-build --flags="release" semantic:exe:semantic
 
-# A fake `install` target until we can get `cabal new-install` to work
+# A fake `install` target until we can get `cabal v2-install` to work
 RUN cp $(find dist-newstyle/build/x86_64-linux -name semantic -type f -perm -u=x) /usr/local/bin/semantic
 
 # Create a fresh image containing only the compiled CLI program, so that the

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)
-        apply eval (Closure loc name body env) a = do
-          local (const loc) $ do
+          pure (Closure path span name body env)
+        apply eval (Closure path span name body env) a = 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
-     -> (Term (Ann :+: Core) Name -> m value)
-     -> (Term (Ann :+: Core) Name -> m value)
+     => Analysis (Term (Ann Span :+: Core) Name) address value m
+     -> (Term (Ann Span :+: 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
-          pure (Value (Closure loc name body) mempty)
-        apply eval (Value (Closure loc name body) _) a = local (const loc) $ do
+          path <- ask
+          span <- ask
+          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)
-            . runReader (Map.empty @Name @Loc)
+  where run = runReader (filePath file)
+            . 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 (Map.Map Name Loc)) sig
+     , Member (Reader Path) 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
-          local (Map.insert name loc) m
+          ref <- askRef
+          local (Map.insert name ref) m
         lookupEnv = pure . Just
         deref addr = do
-          ref <- asks Ref
-          bindLoc <- asks (Map.lookup addr)
+          ref <- askRef
+          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
-          bindLoc <- asks (Map.lookup addr)
-          modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindLoc <> v)))
+          ref <- askRef
+          bindRef <- asks (Map.lookup addr)
+          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
-            let v' = ScopeGraph (Map.singleton (Decl k loc) mempty) <> v
+            path <- ask
+            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
-    FailC (throwError (loc :: Loc, s))
+    path <- ask
+    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
-  = Ann Loc (f a)
+data Ann ann 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 loc = send . Ann loc
+annAt :: (Carrier sig m, Member (Ann ann) sig) => ann -> m a -> m a
+annAt ann = send . Ann ann
 
-annWith :: (Carrier sig m, Member Ann sig) => CallStack -> m a -> m a
-annWith callStack = maybe id annAt (stackLoc callStack)
+annWith :: (Carrier sig m, Member (Ann Span) sig) => CallStack -> m a -> m a
+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(..)
-, interactive
+( Path(..)
 , here
 , stackLoc
 ) where
@@ -10,23 +9,17 @@ import Data.Text (Text, pack)
 import GHC.Stack
 import Source.Span
 
-data Loc = Loc
-  { locPath :: !Text
-  , locSpan :: {-# UNPACK #-} !Span
-  }
+newtype Path = Path { getPath :: Text }
   deriving (Eq, Ord, Show)
 
-interactive :: Loc
-interactive = Loc "<interactive>" (Span (Pos 1 1) (Pos 1 1))
 
-
-here :: HasCallStack => Maybe Loc
+here :: HasCallStack => Maybe (Path, Span)
 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{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
+fromGHCSrcLoc :: SrcLoc -> (Path, Span)
+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 _ core) = case parseEither Parse.core (showCore (stripAnnotations core)) of
-  Right v -> stripAnnotations v @?= stripAnnotations core
-  Left e -> assertFailure e
+assert_roundtrips :: File (Term Core Name) -> Assertion
+assert_roundtrips (File _ _ core) = case parseEither Parse.core (showCore core) of
+  Right v -> v @?= core
+  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)
@@ -14,25 +13,16 @@ import           AST.Element
 import           Control.Effect hiding ((:+:))
 import           Control.Effect.Reader
 import           Control.Monad.Fail
-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 +47,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 +56,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 +68,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 +81,13 @@ 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
-          , Carrier sig m
           )
        => syntax
        -> t a
-       -> m (t a)
-locate syn item = do
-  fp <- ask @SourcePath
-  pure (Core.annAt (locFromTSSpan fp (getField @"ann" syn)) item)
+       -> t a
+locate syn  = Core.annAt (getField @"ann" syn)
 
 defaultCompile :: (MonadFail m, Show py) => py -> m (t Name)
 defaultCompile t = fail $ "compilation unimplemented for " <> show t
@@ -140,20 +121,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
-    loc <- locFromTSSpan <$> ask <*> pure ann
-    let cons = (Located loc name :)
-    desugar (cons acc) rhs
+  Prj Py.Assignment { left = SingleIdentifier name, right = Just rhs, ann} ->
+    desugar (Located ann name : acc) rhs
   R1 any -> pure (acc, any)
   other -> fail ("desugar: couldn't desugar RHS " <> show other)
 
@@ -179,9 +158,8 @@ instance Compile Py.Assignment where
     , right = Just rhs
     , ann
     } cc next = do
-    p <- ask @SourcePath
-    (names, val) <- desugar [Located (locFromTSSpan p ann) name] rhs
-    compile val pure next >>= foldr collapseDesugared cc names >>= locate it
+    (names, val) <- desugar [Located ann name] rhs
+    compile val pure next >>= foldr collapseDesugared cc names >>= pure . locate it
 
   compile other _ _ = fail ("Unhandled assignment case: " <> show other)
 
@@ -192,7 +170,9 @@ instance Compile Py.Await
 instance Compile Py.BinaryOperator
 
 instance Compile Py.Block where
-  compile it@Py.Block{ Py.extraChildren = body} cc next = foldr compile cc body next >>= locate it
+  compile it@Py.Block{ Py.extraChildren = body} cc
+    = fmap (locate it)
+    . foldr compile cc body
 
 instance Compile Py.BooleanOperator
 instance Compile Py.BreakStatement
@@ -230,20 +210,20 @@ instance Compile Py.ExecStatement
 deriving instance Compile Py.Expression
 
 instance Compile Py.ExpressionStatement where
-  compile it@Py.ExpressionStatement
-    { Py.extraChildren = children
-    } cc = do
-    foldr compile cc children >=> locate it
+  compile it@Py.ExpressionStatement { Py.extraChildren = children } cc
+    = fmap (locate it)
+    . foldr compile cc children
 
 instance Compile Py.ExpressionList where
   compile it@Py.ExpressionList { Py.extraChildren = [child] } cc
-    = compile child cc >=> locate it
+    = fmap (locate it)
+    . compile child cc
   compile Py.ExpressionList { Py.extraChildren = items } _
     = const (fail ("unimplemented: ExpressionList of length " <> show items))
 
 
 instance Compile Py.False where
-  compile it cc _ = locate it (bool False) >>= cc
+  compile it cc _ = cc $ locate it (bool False)
 
 instance Compile Py.Float
 instance Compile Py.ForStatement
@@ -256,10 +236,9 @@ instance Compile Py.FunctionDefinition where
     } cc next = do
       -- Compile each of the parameters, then the body.
       parameters' <- traverse param parameters
-      -- BUG: ignoring the continuation here
       body' <- compile body pure next
       -- Build a lambda.
-      located <- locate it (lams parameters' body')
+      let located = locate it (lams parameters' body')
       -- Give it a name (below), then augment the current continuation
       -- with the new name (with 'def'), so that calling contexts know
       -- that we have built an exportable definition.
@@ -274,15 +253,13 @@ instance Compile Py.GeneratorExpression
 instance Compile Py.GlobalStatement
 
 instance Compile Py.Identifier where
-  compile Py.Identifier { text } cc _next = cc . pure . Name $ text
+  compile Py.Identifier { text } cc _ = cc . pure . Name $ text
 
 instance Compile Py.IfStatement where
   compile it@Py.IfStatement{ condition, consequence, alternative} cc next =
-    locate it =<< (if'
-                    <$> compile condition pure next
-                    <*> compile consequence cc next
-                    <*> foldr clause (cc next) alternative
-                  )
+    locate it <$> (if' <$> compile condition pure next
+                       <*> compile consequence cc next
+                       <*> foldr clause (cc next) alternative)
     where clause (R1 Py.ElseClause{ body }) _ = compile body cc next
           clause (L1 Py.ElifClause{ condition, consequence }) rest  =
             if' <$> compile condition pure next <*> compile consequence cc next <*> rest
@@ -307,7 +284,7 @@ instance Compile Py.Module where
           bindings <- asks @Bindings (toList . unBindings)
           let buildName n = (n, pure n)
           pure . record . fmap buildName $ bindings
-    in foldr compile buildRecord stmts >=> locate it
+    in fmap (locate it) . foldr compile buildRecord stmts
 
 instance Compile Py.NamedExpression
 instance Compile Py.None
@@ -319,16 +296,16 @@ instance Compile Py.ParenthesizedExpression where
     = compile extraChildren cc >=> locate it
 
 instance Compile Py.PassStatement where
-  compile it@Py.PassStatement {} cc _ = locate it Core.unit >>= cc
+  compile it@Py.PassStatement {} cc _ = cc $ locate it Core.unit
 
 deriving instance Compile Py.PrimaryExpression
 
 instance Compile Py.PrintStatement
 
 instance Compile Py.ReturnStatement where
-  compile it@Py.ReturnStatement { Py.extraChildren = vals } _ next = case vals of
-    Nothing -> locate it $ none
-    Just Py.ExpressionList { extraChildren = [val] } -> compile val pure next >>= locate it
+  compile it@Py.ReturnStatement { Py.extraChildren = vals } _ next = locate it <$> case vals of
+    Nothing -> pure none
+    Just Py.ExpressionList { extraChildren = [val] } -> compile val pure next
     Just Py.ExpressionList { extraChildren = vals  } -> fail ("unimplemented: return statement returning " <> show (length vals) <> " values")
 
 
@@ -342,12 +319,12 @@ instance Compile Py.String
 instance Compile Py.Subscript
 
 instance Compile Py.True where
-  compile it cc _next = locate it (bool True) >>= cc
+  compile it cc _next = cc $ locate it (bool True)
 
 instance Compile Py.TryStatement
 
 instance Compile Py.Tuple where
-  compile it@Py.Tuple { Py.extraChildren = [] } cc _ = locate it unit >>= cc
+  compile it@Py.Tuple { Py.extraChildren = [] } cc _ = cc $ locate it unit
 
   compile it _ _
     = fail ("Unimplemented: non-empty tuple " <> show it)

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
-    [ "location" .= fileLoc
+  toJSON File{filePath, fileSpan, fileBody} = object
+    [ "path" .= filePath
+    , "span" .= fileSpan
     , "body" .= fileBody
     ]
 
-instance ToJSON Loc where
-  toJSON Loc{locPath, locSpan} = object
-    [ "kind" .= ("loc" :: Text)
-    , "path" .= locPath
-    , "span" .= locSpan
-    ]
+deriving newtype instance ToJSON Path
 
 instance ToJSON Ref where
-  toJSON (Ref loc) = object [ "kind" .= ("ref" :: Text)
-                            , "location" .= loc]
+  toJSON (Ref path span) = object
+    [ "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
-    (heap, [File _ (Right result)]) -> pure $ Aeson.object
+  bod <- case scopeGraph Eval.eval [File (Path "<interactive>") (Span (Pos 1 1) (Pos 1 1)) core] of
+    (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

src/Data/Language.hs

@@ -104,7 +104,7 @@ supportedExts = foldr append mempty supportedLanguages
     lookup k = Map.lookup k Lingo.languages
 
 codeNavLanguages :: [Language]
-codeNavLanguages = [Go, Ruby, Python, JavaScript, TypeScript, PHP]
+codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
 
 pathIsMinified :: FilePath -> Bool
 pathIsMinified = isExtensionOf ".min.js"

src/Parsing/Parser.hs

@@ -180,7 +180,7 @@ goParser' :: c (Term (Sum Go.Syntax)) => (Language, SomeParser c Loc)
 goParser' = (Go, SomeParser goParser)
 
 javaParser' :: c PreciseJava.Term => (Language, SomeParser c Loc)
-javaParser' = (Python, SomeParser javaParserPrecise)
+javaParser' = (Java, SomeParser javaParserPrecise)
 
 javascriptParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc)
 javascriptParser' = (JavaScript, SomeParser tsxParser)

test/Data/Language/Spec.hs

@@ -7,7 +7,7 @@ import Test.Tasty.HUnit
 testTree :: TestTree
 testTree = testGroup "Data.Language"
   [ testCase "supportedExts returns expected list" $
-      supportedExts @=? [".go",".rb",".builder",".eye",".fcgi",".gemspec",".god",".jbuilder",".mspec",".pluginspec",".podspec",".rabl",".rake",".rbuild",".rbw",".rbx",".ru",".ruby",".spec",".thor",".watchr",".py",".bzl",".cgi",".fcgi",".gyp",".gypi",".lmi",".py3",".pyde",".pyi",".pyp",".pyt",".pyw",".rpy",".spec",".tac",".wsgi",".xpy",".js","._js",".bones",".es",".es6",".frag",".gs",".jake",".jsb",".jscad",".jsfl",".jsm",".jss",".mjs",".njs",".pac",".sjs",".ssjs",".xsjs",".xsjslib",".ts",".php",".aw",".ctp",".fcgi",".inc",".php3",".php4",".php5",".phps",".phpt"]
+      supportedExts @=? [".go",".java",".rb",".builder",".eye",".fcgi",".gemspec",".god",".jbuilder",".mspec",".pluginspec",".podspec",".rabl",".rake",".rbuild",".rbw",".rbx",".ru",".ruby",".spec",".thor",".watchr",".py",".bzl",".cgi",".fcgi",".gyp",".gypi",".lmi",".py3",".pyde",".pyi",".pyp",".pyt",".pyw",".rpy",".spec",".tac",".wsgi",".xpy",".js","._js",".bones",".es",".es6",".frag",".gs",".jake",".jsb",".jscad",".jsfl",".jsm",".jss",".mjs",".njs",".pac",".sjs",".ssjs",".xsjs",".xsjslib",".ts",".php",".aw",".ctp",".fcgi",".inc",".php3",".php4",".php5",".phps",".phpt"]
   , testCase "codeNavLanguages returns expected list" $
-      codeNavLanguages @=? [Go, Ruby, Python, JavaScript, TypeScript, PHP]
+      codeNavLanguages @=? [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
   ]