Merge branch 'master' into precise-json

README.md

@@ -83,7 +83,7 @@ Available options:
 | 4        | Python         | ✅     | ✅     | ✅    | ✅  | ✅      | ✅           | 🚧 | |
 | 5        | Go             | ✅     | ✅     | ✅    | ✅  | ✅      | ✅           | 🚧 | |
 |          | PHP            | ✅     | ✅     | ✅    | ✅  | ✅      | | | |
-|          | Java           | ✅     | ✅     | ✅    | 🔶  | ✅      |               | | |
+|          | Java           | 🚧     | 🚧     | 🚧    | 🔶  | ✅      |               | | |
 |          | JSON           | ✅     | ✅     | ✅    | N/A | N/A     | N/A          | N/A| |
 |          | JSX            | ✅     | ✅     | ✅    | 🔶  |         |              | | |
 |          | Haskell        | 🚧     | 🚧     | 🚧    | 🔶  | 🚧       |              | | |

semantic-core/semantic-core.cabal

@@ -25,6 +25,7 @@ library
                      , Analysis.ImportGraph
                      , Analysis.ScopeGraph
                      , Analysis.Typecheck
+                     , Control.Carrier.Fail.WithLoc
                      , Control.Effect.Readline
                      , Control.Monad.Module
                      , Data.Core
@@ -36,8 +37,6 @@ library
                      , Data.Scope
                      , Data.Stack
                      , Data.Term
-  -- other-modules:
-  -- other-extensions:
   build-depends:       algebraic-graphs            ^>= 0.3
                      , base                         >= 4.12 && < 5
                      , containers                  ^>= 0.6
@@ -48,6 +47,7 @@ library
                      , parsers                     ^>= 0.12.10
                      , prettyprinter               ^>= 1.2.1
                      , prettyprinter-ansi-terminal ^>= 1.1.1
+                     , semantic-source             ^>= 0
                      , semigroupoids               ^>= 5.3
                      , text                        ^>= 1.2.3.1
                      , transformers                ^>= 0.5.6

semantic-core/src/Analysis/Concrete.hs

@@ -13,8 +13,8 @@ import qualified Algebra.Graph as G
 import qualified Algebra.Graph.Export.Dot as G
 import           Analysis.Eval
 import           Control.Applicative (Alternative (..))
+import           Control.Carrier.Fail.WithLoc
 import           Control.Effect
-import           Control.Effect.Fail
 import           Control.Effect.Fresh
 import           Control.Effect.NonDet
 import           Control.Effect.Reader hiding (Local)
@@ -32,6 +32,7 @@ import qualified Data.Set as Set
 import           Data.Text (Text, pack)
 import           Data.Traversable (for)
 import           Prelude hiding (fail)
+import           Source.Span
 
 type Precise = Int
 type Env = Map.Map Name Precise
@@ -66,7 +67,7 @@ data Edge = Lexical | Import
 
 -- | Concrete evaluation of a term to a value.
 --
---   >>> map fileBody (snd (concrete eval [File (Loc "bool" emptySpan) (Core.bool True)]))
+--   >>> map fileBody (snd (concrete eval [File (Loc "bool" (Span (Pos 1 1) (Pos 1 5))) (Core.bool True)]))
 --   [Right (Bool True)]
 concrete
   :: (Foldable term, Show (term Name))
@@ -102,7 +103,7 @@ runFile
   -> m (File (Either (Loc, String) (Concrete (term Name))))
 runFile eval file = traverse run file
   where run = runReader (fileLoc file)
-            . runFailWithLoc
+            . runFail
             . runReader @Env mempty
             . fix (eval concreteAnalysis)
 
@@ -197,7 +198,7 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,)
 addressStyle :: Heap term -> G.Style (EdgeType term, Precise) Text
 addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
   where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
-        edgeAttributes _ (Slot name,    _) = ["label" G.:= name]
+        edgeAttributes _ (Slot name,    _) = ["label" G.:= unName name]
         edgeAttributes _ (Edge Import,  _) = ["color" G.:= "blue"]
         edgeAttributes _ (Edge Lexical, _) = ["color" G.:= "green"]
         edgeAttributes _ _                 = []
@@ -205,7 +206,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 _ _ -> "\\\\ " <> n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
+          Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> unName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
           Record _ -> "{}"
         showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
 

semantic-core/src/Analysis/ImportGraph.hs

@@ -8,8 +8,8 @@ module Analysis.ImportGraph
 import           Analysis.Eval
 import           Analysis.FlowInsensitive
 import           Control.Applicative (Alternative(..))
+import           Control.Carrier.Fail.WithLoc
 import           Control.Effect
-import           Control.Effect.Fail
 import           Control.Effect.Fresh
 import           Control.Effect.Reader
 import           Control.Effect.State
@@ -84,7 +84,7 @@ runFile
   -> m (File (Either (Loc, String) (Value term)))
 runFile eval file = traverse run file
   where run = runReader (fileLoc file)
-            . runFailWithLoc
+            . runFail
             . fmap fold
             . convergeTerm (Proxy @Name) (fix (cacheTerm . eval importGraphAnalysis))
 

semantic-core/src/Analysis/ScopeGraph.hs

@@ -10,8 +10,8 @@ module Analysis.ScopeGraph
 import           Analysis.Eval
 import           Analysis.FlowInsensitive
 import           Control.Applicative (Alternative (..))
+import           Control.Carrier.Fail.WithLoc
 import           Control.Effect.Carrier
-import           Control.Effect.Fail
 import           Control.Effect.Fresh
 import           Control.Effect.Reader
 import           Control.Effect.State
@@ -25,12 +25,11 @@ import qualified Data.Map as Map
 import           Data.Name
 import           Data.Proxy
 import qualified Data.Set as Set
-import           Data.Text (Text)
 import           Data.Traversable (for)
 import           Prelude hiding (fail)
 
 data Decl = Decl
-  { declSymbol :: Text
+  { declSymbol :: Name
   , declLoc    :: Loc
   }
   deriving (Eq, Ord, Show)
@@ -81,7 +80,7 @@ runFile
 runFile eval file = traverse run file
   where run = runReader (fileLoc file)
             . runReader (Map.empty @Name @Loc)
-            . runFailWithLoc
+            . runFail
             . fmap fold
             . convergeTerm (Proxy @Name) (fix (cacheTerm . eval scopeGraphAnalysis))
 

semantic-core/src/Analysis/Typecheck.hs

@@ -10,8 +10,8 @@ module Analysis.Typecheck
 import           Analysis.Eval
 import           Analysis.FlowInsensitive
 import           Control.Applicative (Alternative (..))
+import           Control.Carrier.Fail.WithLoc
 import           Control.Effect.Carrier
-import           Control.Effect.Fail
 import           Control.Effect.Fresh as Fresh
 import           Control.Effect.Reader hiding (Local)
 import           Control.Effect.State
@@ -133,7 +133,7 @@ runFile eval file = traverse run file
               pure (substAll subst <$> t))
           . runState (mempty :: Substitution)
           . runReader (fileLoc file)
-          . runFailWithLoc
+          . runFail
           . (\ m -> do
             (cs, t) <- m
             t <$ solve cs)

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

@@ -0,0 +1,31 @@
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+module Control.Carrier.Fail.WithLoc
+( -- * Fail effect
+  module Control.Effect.Fail
+  -- * Fail carrier
+, runFail
+, FailC(..)
+) where
+
+import Control.Applicative
+import Control.Effect.Carrier
+import Control.Effect.Error
+import Control.Effect.Fail (Fail(..), MonadFail(..))
+import Control.Effect.Reader
+import Data.Loc
+import Prelude hiding (fail)
+
+runFail :: FailC m a -> m (Either (Loc, String) a)
+runFail = runError . runFailC
+
+newtype FailC m a = FailC { runFailC :: ErrorC (Loc, String) m a }
+  deriving (Alternative, Applicative, Functor, Monad)
+
+instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailC m) where
+  fail s = do
+    loc <- ask
+    FailC (throwError (loc :: Loc, s))
+
+instance (Carrier sig m, Effect sig, Member (Reader Loc) 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/Loc.hs

@@ -1,25 +1,14 @@
-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
 module Data.Loc
 ( Loc(..)
 , interactive
-, Span(..)
-, emptySpan
-, Pos(..)
 , here
 , stackLoc
-, FailWithLocC(..)
-, runFailWithLoc
 ) where
 
-import Control.Applicative
-import Control.Effect.Carrier
-import Control.Effect.Error
-import Control.Effect.Fail
-import Control.Effect.Reader
 import Data.Text (Text, pack)
-import Data.Text.Prettyprint.Doc (Pretty (..))
 import GHC.Stack
-import Prelude hiding (fail)
+import Source.Span
 
 data Loc = Loc
   { locPath :: !Text
@@ -28,28 +17,7 @@ data Loc = Loc
   deriving (Eq, Ord, Show)
 
 interactive :: Loc
-interactive = Loc "<interactive>" emptySpan
+interactive = Loc "<interactive>" (Span (Pos 1 1) (Pos 1 1))
-
-data Span = Span
-  { spanStart :: {-# UNPACK #-} !Pos
-  , spanEnd   :: {-# UNPACK #-} !Pos
-  }
-  deriving (Eq, Ord, Show)
-
-instance Pretty Span where
-  pretty (Span s e) = pretty s <> "-" <> pretty e
-
-emptySpan :: Span
-emptySpan = Span (Pos 1 1) (Pos 1 1)
-
-data Pos = Pos
-  { posLine :: {-# UNPACK #-} !Int
-  , posCol  :: {-# UNPACK #-} !Int
-  }
-  deriving (Eq, Ord, Show)
-
-instance Pretty Pos where
-  pretty (Pos l c) = pretty l <> ":" <> pretty c
 
 
 here :: HasCallStack => Maybe Loc
@@ -62,19 +30,3 @@ stackLoc cs = case getCallStack cs of
 
 fromGHCSrcLoc :: SrcLoc -> Loc
 fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
-
-
-runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)
-runFailWithLoc = runError . runFailWithLocC
-
-newtype FailWithLocC m a = FailWithLocC { runFailWithLocC :: ErrorC (Loc, String) m a }
-  deriving (Alternative, Applicative, Functor, Monad)
-
-instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailWithLocC m) where
-  fail s = do
-    loc <- ask
-    FailWithLocC (throwError (loc :: Loc, s))
-
-instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailWithLocC m) where
-  eff (L (Fail s)) = fail s
-  eff (R other)    = FailWithLocC (eff (R (handleCoercible other)))

semantic-core/src/Data/Name.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE DeriveTraversable, LambdaCase, OverloadedLists #-}
+{-# LANGUAGE DeriveGeneric, DeriveTraversable, GeneralizedNewtypeDeriving, LambdaCase, OverloadedLists #-}
 module Data.Name
-( Name
+( Name (..)
 , Named(..)
 , named
 , named'
@@ -15,10 +15,14 @@ module Data.Name
 import qualified Data.Char as Char
 import           Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
+import           Data.String (IsString)
 import           Data.Text as Text (Text, any, unpack)
+import           Data.Text.Prettyprint.Doc (Pretty)
+import           GHC.Generics (Generic)
 
 -- | User-specified and -relevant names.
-type Name = Text
+newtype Name = Name { unName :: Text }
+  deriving (Eq, Generic, IsString, Ord, Pretty, Show)
 
 -- | Annotates an @a@ with a 'Name'-provided name, which is ignored for '==' and 'compare'.
 data Named a = Named (Ignored Name) a
@@ -50,7 +54,7 @@ reservedNames = [ "#true", "#false", "if", "then", "else"
 -- | Returns true if any character would require quotation or if the
 -- name conflicts with a Core primitive.
 needsQuotation :: Name -> Bool
-needsQuotation u = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
+needsQuotation (Name u) = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
 
 -- | A ‘simple’ character is, loosely defined, a character that is compatible
 -- with identifiers in most ASCII-oriented programming languages. This is defined

semantic-core/test/Generators.hs

@@ -26,7 +26,7 @@ import Data.Term
 -- interesting property as they parse regardless.
 name :: MonadGen m => m (Named Name)
 name = Gen.prune (named' <$> names) where
-  names = Gen.text (Range.linear 1 10) Gen.lower
+  names = Name <$> Gen.text (Range.linear 1 10) Gen.lower
 
 boolean :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name)
 boolean = Core.bool <$> Gen.bool

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

@@ -1,7 +1,8 @@
 {-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, DeriveAnyClass, DeriveGeneric, DerivingStrategies,
              DerivingVia, DisambiguateRecordFields, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
              KindSignatures, LambdaCase, NamedFieldPuns, OverloadedLists, OverloadedStrings, PatternSynonyms,
-             ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
+             ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances,
+             ViewPatterns #-}
 
 module Language.Python.Core
 ( compile
@@ -27,7 +28,6 @@ import           Data.Text (Text)
 import           GHC.Generics
 import           GHC.Records
 import           Source.Span (Span)
-import qualified Source.Span as Source
 import qualified TreeSitter.Python.AST as Py
 
 -- | Access to the current filename as Text to stick into location annotations.
@@ -52,7 +52,7 @@ def n = coerce (Stack.:> n)
 pattern SingleIdentifier :: Name -> Py.ExpressionList a
 pattern SingleIdentifier name <- Py.ExpressionList
   { Py.extraChildren =
-    [ Py.PrimaryExpressionExpression (Py.IdentifierPrimaryExpression (Py.Identifier { bytes = name }))
+    [ Py.PrimaryExpressionExpression (Py.IdentifierPrimaryExpression (Py.Identifier { bytes = Name -> name }))
     ]
   }
 
@@ -97,9 +97,8 @@ compile :: ( Compile py
         -> m (t Name)
 compile t = compileCC t (pure none)
 
-locFromTSSpan :: SourcePath -> Source.Span -> Loc
+locFromTSSpan :: SourcePath -> Span -> Loc
-locFromTSSpan fp (Source.Span (Source.Pos a b) (Source.Pos c d))
+locFromTSSpan fp = Data.Loc.Loc (rawPath fp)
-  = Data.Loc.Loc (rawPath fp) (Data.Loc.Span (Data.Loc.Pos a b) (Data.Loc.Pos c d))
 
 locate :: ( HasField "ann" syntax Span
           , CoreSyntax syn t
@@ -254,18 +253,18 @@ instance Compile Py.FunctionDefinition where
       -- 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.
-      assigning located <$> local (def name) cc
+      assigning located <$> local (def (Name name)) cc
-    where param (Py.IdentifierParameter (Py.Identifier _pann pname)) = pure (named' pname)
+    where param (Py.IdentifierParameter (Py.Identifier _pann pname)) = pure . named' . Name $ pname
           param x                                                    = unimplemented x
           unimplemented x = fail $ "unimplemented: " <> show x
-          assigning item f = (Name.named' name :<- item) >>>= f
+          assigning item f = (Name.named' (Name name) :<- item) >>>= f
 
 instance Compile Py.FutureImportStatement
 instance Compile Py.GeneratorExpression
 instance Compile Py.GlobalStatement
 
 instance Compile Py.Identifier where
-  compileCC Py.Identifier { bytes } _ = pure (pure bytes)
+  compileCC Py.Identifier { bytes } _ = pure . pure . Name $ bytes
 
 instance Compile Py.IfStatement where
   compileCC it@Py.IfStatement{ condition, consequence, alternative} cc =

semantic-python/test/Instances.hs

@@ -8,18 +8,15 @@ module Instances () where
 -- we should keep track of them in a dedicated file.
 
 import           Analysis.ScopeGraph
-import           Control.Effect.Sum
 import           Data.Aeson
-import qualified Data.HashMap.Strict as HashMap
-import           Data.Loc
-import           Data.Core (Core, Ann (..))
-import qualified Data.Map as Map
 import           Data.File
-import           Data.Term
+import           Data.Loc
+import qualified Data.Map as Map
+import           Data.Name (Name (..))
 import           Data.Text (Text)
-import           Data.Scope (Scope, Incr)
+
-import qualified Data.Scope as Scope
+deriving newtype instance ToJSON Name
-import           Data.Name
+deriving newtype instance ToJSONKey Name
 
 instance ToJSON a => ToJSON (File a) where
   toJSON File{fileLoc, fileBody} = object
@@ -27,20 +24,6 @@ instance ToJSON a => ToJSON (File a) where
     , "body" .= fileBody
     ]
 
-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)