Merge branch 'typescript-graphs' into fix-graph-errors

semantic.cabal

@@ -71,6 +71,7 @@ library
                      , Data.AST
                      , Data.Blob
                      , Data.Diff
+                     , Data.Empty
                      , Data.Error
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic
@@ -238,6 +239,7 @@ test-suite test
                      , Analysis.Ruby.Spec
                      , Analysis.TypeScript.Spec
                      , Data.Diff.Spec
+                     , Data.Abstract.Path.Spec
                      , Data.Functor.Classes.Generic.Spec
                      , Data.Functor.Listable
                      , Data.Mergeable.Spec

src/Analysis/Abstract/Evaluating.hs

@@ -2,6 +2,7 @@
 module Analysis.Abstract.Evaluating
 ( Evaluating
 , EvaluatingState(..)
+, State
 ) where
 
 import           Control.Abstract.Analysis
@@ -15,6 +16,7 @@ import           Data.Abstract.Heap
 import           Data.Abstract.Module
 import           Data.Abstract.ModuleTable
 import           Data.Abstract.Origin
+import           Data.Empty
 import qualified Data.IntMap as IntMap
 import           Lens.Micro
 import           Prelude hiding (fail)
@@ -60,9 +62,8 @@ deriving instance (Show (Cell location value), Show location, Show term, Show va
 instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
   EvaluatingState e1 h1 m1 l1 x1 j1 o1 <> EvaluatingState e2 h2 m2 l2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
 
-instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
-  mempty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty
-  mappend = (<>)
+instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatingState location term value) where
+  empty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty
 
 _environment :: Lens' (EvaluatingState location term value) (Environment location value)
 _environment = lens environment (\ s e -> s {environment = e})

src/Control/Effect.hs

@@ -15,6 +15,7 @@ import Control.Monad.Effect.Reader
 import Control.Monad.Effect.Resumable
 import Control.Monad.Effect.State
 import Control.Monad.Effect.Writer
+import Data.Empty as E
 import Data.Semigroup.Reducer
 import Prologue
 
@@ -47,9 +48,9 @@ class RunEffect f a where
   runEffect :: Eff (f ': fs) a -> Eff fs (Result f a)
 
 -- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state.
-instance Monoid b => RunEffect (State b) a where
+instance E.Empty b => RunEffect (State b) a where
   type Result (State b) a = (a, b)
-  runEffect = flip runState mempty
+  runEffect = flip runState E.empty
 
 -- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value.
 instance Monoid b => RunEffect (Reader b) a where

src/Data/Abstract/Path.hs

@@ -3,17 +3,24 @@ module Data.Abstract.Path where
 import Prologue
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString as B
+import System.FilePath.Posix
 
-splitOnPathSeparator :: ByteString -> [ByteString]
-splitOnPathSeparator = BC.split '/'
+-- | Join two paths a and b. Handles walking up relative directories in b. e.g.
+--
+--     joinPaths "a/b" "../c" == "a/c"
+--     joinPaths "a/b" "./c" == "a/b/c"
+--
+-- Walking beyond the beginning of a just stops when you get to the root of a.
+joinPaths :: FilePath -> FilePath -> FilePath
+joinPaths a b = let bs = splitPath (normalise b)
+                    n = length (filter (== "../") bs)
+                in normalise $ walkup n a </> joinPath (drop n bs)
+  where
+    walkup 0 str = str
+    walkup n str = walkup (pred n) (takeDirectory str)
 
 stripQuotes :: ByteString -> ByteString
 stripQuotes = B.filter (`B.notElem` "\'\"")
 
 dropRelativePrefix :: ByteString -> ByteString
 dropRelativePrefix = BC.dropWhile (== '/') . BC.dropWhile (== '.')
-
-dropExtension :: ByteString -> ByteString
-dropExtension path = case BC.split '.' path of
-  [] -> path
-  xs -> BC.intercalate "." (Prelude.init xs)

src/Data/Empty.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Empty ( Empty (..) ) where
+
+-- | A typeclass for values that have a sensible notion of an empty value.
+-- This is used in Control.Effect to provide a useful default for running
+-- a State computation without providing it an explicit starting value.
+-- This is very useful if a type has no coherent Monoid instance but
+-- needs a value analogous to 'mempty'. It is not recommended to use this
+-- for other purposes, as there are no laws by which 'empty' is required
+-- to abide.
+class Empty a where
+  empty :: a
+
+-- | Every Monoid has an Empty instance.
+instance {-# OVERLAPS #-} Monoid a => Empty a where
+  empty = mempty

src/Language/Go/Syntax.hs

@@ -3,6 +3,7 @@ module Language.Go.Syntax where
 
 import Data.Abstract.Evaluatable hiding (Label)
 import Data.Abstract.Module
+import Data.Abstract.Path
 import Data.Abstract.FreeVariables (name)
 import Diffing.Algorithm
 import qualified Data.ByteString.Char8 as BC
@@ -25,7 +26,7 @@ resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [Modu
 resolveGoImport relImportPath = do
   ModuleInfo{..} <- currentModule
   let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
-  listModulesInDir $ normalise (relRootDir </> normalise relImportPath)
+  listModulesInDir (joinPaths relRootDir relImportPath)
 
 -- | Import declarations (symbols are added directly to the calling environment).
 --

src/Language/TypeScript/Syntax.hs

@@ -4,6 +4,7 @@ module Language.TypeScript.Syntax where
 import qualified Data.Abstract.Environment as Env
 import qualified Data.Abstract.FreeVariables as FV
 import           Data.Abstract.Evaluatable
+import           Data.Abstract.Path
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString as B
 import           Data.Abstract.Module (ModulePath, ModuleInfo(..))
@@ -45,7 +46,8 @@ resolveRelativePath :: forall value term location m. MonadEvaluatable location t
 resolveRelativePath relImportPath exts = do
   ModuleInfo{..} <- currentModule
   let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
-  let path = normalise (relRootDir </> normalise relImportPath)
+  let path = joinPaths relRootDir relImportPath
+  traceM $ show relImportPath <> " -> " <> show path
   resolveTSModule path exts >>= either notFound pure
   where
     notFound _ = throwException @(ResolutionError value) $ TypeScriptError relImportPath
@@ -76,7 +78,7 @@ resolveNonRelativePath name exts = do
     notFound _ = throwException @(ResolutionError value) $ TypeScriptError name
 
 resolveTSModule :: MonadEvaluatable location term value m => FilePath -> [String] -> m (Either [FilePath] ModulePath)
-resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths
+resolveTSModule path exts = trace ("typescript (resolve): " <> show path) $ maybe (Left searchPaths) Right <$> resolve searchPaths
   where searchPaths =
           ((path <.>) <$> exts)
           -- TODO: Requires parsing package.json, getting the path of the

test/Data/Abstract/Path/Spec.hs

@@ -0,0 +1,20 @@
+module Data.Abstract.Path.Spec(spec) where
+
+import Data.Abstract.Path
+import SpecHelpers
+
+spec :: Spec
+spec = parallel $
+  describe "joinPaths" $ do
+    it "joins empty paths" $
+      joinPaths "" "" `shouldBe` "."
+    it "joins relative paths" $
+      joinPaths "a/b" "./c" `shouldBe` "a/b/c"
+    it "joins absolute paths" $
+      joinPaths "/a/b" "c" `shouldBe` "/a/b/c"
+    it "walks up directories for ../" $
+      joinPaths "a/b" "../c" `shouldBe` "a/c"
+    it "walks up directories for multiple ../" $
+      joinPaths "a/b" "../../c" `shouldBe` "c"
+    it "stops walking at top directory" $
+      joinPaths "a/b" "../../../c" `shouldBe` "c"

test/Spec.hs

@@ -7,6 +7,7 @@ import qualified Analysis.Ruby.Spec
 import qualified Analysis.TypeScript.Spec
 import qualified Assigning.Assignment.Spec
 import qualified Data.Diff.Spec
+import qualified Data.Abstract.Path.Spec
 import qualified Data.Functor.Classes.Generic.Spec
 import qualified Data.Mergeable.Spec
 import qualified Data.Scientific.Spec
@@ -35,6 +36,7 @@ main = hspec $ do
     describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
     describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
     describe "Data.Diff" Data.Diff.Spec.spec
+    describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
     describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
     describe "Data.Mergeable" Data.Mergeable.Spec.spec
     describe "Data.Scientific" Data.Scientific.Spec.spec