Merge branch 'master' into function-scopes

.github/workflows/haskell.yml

@@ -27,11 +27,17 @@ jobs:
         ghc-version: ${{ matrix.ghc }}
         cabal-version: ${{ matrix.cabal }}
 
+    - uses: actions/cache@v1
+      name: Cache ~/.cabal/packages
+      with:
+        path: ~/.cabal/packages
+        key: ${{ runner.os }}-${{ matrix.ghc }}-cabal-packages
+
     - uses: actions/cache@v1
       name: Cache ~/.cabal/store
       with:
         path: ~/.cabal/store
-        key: ${{ runner.os }}-${{ matrix.ghc }}-v1-cabal-store
+        key: ${{ runner.os }}-${{ matrix.ghc }}-v5-cabal-store
 
     - uses: actions/cache@v1
       name: Cache dist-newstyle
@@ -39,17 +45,17 @@ jobs:
         path: dist-newstyle
         key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-semantic-dist
 
+    # - name: hlint
+    #   run: |
+    #     test -f dist-newstyle/hlint || cabal install hlint --installdir=dist-newstyle
+    #     dist-newstyle/hlint src semantic-python
+
     - name: Install dependencies
       run: |
         cabal v2-update
         cabal v2-configure --project-file=cabal.project.ci --disable-optimization --enable-benchmarks --enable-tests --write-ghc-environment-files=always -j2
         cabal v2-build     --project-file=cabal.project.ci all --only-dependencies
 
-    - name: hlint
-      run: |
-        test -f dist-newstyle/hlint || cabal install hlint --installdir=dist-newstyle
-        dist-newstyle/hlint src semantic-python
-
     - name: Build & test
       run: |
         cabal v2-build --project-file=cabal.project.ci

.hlint.yaml

@@ -12,6 +12,7 @@
   - {name: init, within: []}
   - {name: last, within: []}
   - {name: fromJust, within: []}
+  - {name: decodeUtf8, within: [], message: "Use decodeUtf8' or decodeUtf8With lenientDecode"}
 
 # Replace a $ b $ c with a . b $ c
 - group: {name: dollar, enabled: true}

bench/Evaluation.hs

@@ -1,13 +1,17 @@
-{-# LANGUAGE DataKinds, FlexibleContexts, PackageImports, PartialTypeSignatures, TypeApplications, TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Evaluation (benchmarks) where
 
 import           Control.Carrier.Parse.Simple
-import qualified Data.Duration as Duration
 import           Data.Abstract.Evaluatable
-import           Data.Blob
-import           Data.Blob.IO (readBlobFromFile')
 import           Data.Bifunctor
+import           Data.Blob.IO (readBlobFromPath)
+import qualified Data.Duration as Duration
 import           "semantic" Data.Graph (topologicalSort)
 import qualified Data.Language as Language
 import           Data.Project
@@ -18,21 +22,23 @@ import           Semantic.Config (defaultOptions)
 import           Semantic.Graph
 import           Semantic.Task (TaskSession (..), runTask, withOptions)
 import           Semantic.Util
-import qualified System.Path as Path
 import           System.Path ((</>))
+import qualified System.Path as Path
+import qualified System.Path.PartClass as Path.PartClass
 
 -- Duplicating this stuff from Util to shut off the logging
 
 callGraphProject' :: ( Language.SLanguage lang
                      , HasPrelude lang
+                     , Path.PartClass.AbsRel ar
                      )
                   => TaskSession
                   -> Proxy lang
-                  -> Path.RelFile
+                  -> Path.File ar
                   -> IO (Either String ())
 callGraphProject' session proxy path
   | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do
-  blob <- readBlobFromFile' (fileForTypedPath path)
+  blob <- readBlobFromPath (Path.toAbsRel path)
   package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang []))
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   runCallGraph proxy False modules package

bench/Tagging.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Tagging (benchmarks) where
 
@@ -8,19 +8,19 @@ import           Control.Carrier.Parse.Measured
 import           Control.Carrier.Reader
 import           Control.Exception (throwIO)
 import           Control.Monad
-import           Data.Blob
 import           Data.Foldable
 import           Data.Language (LanguageMode (..), PerLanguageModes (..))
 import           Gauge
 import           System.FilePath.Glob
 import qualified System.Path as Path
 
-import Data.Flag
-import Proto.Semantic as P hiding (Blob, BlobPair)
-import Semantic.Api.Symbols (parseSymbols)
-import Semantic.Config as Config
-import Semantic.Task
-import Semantic.Task.Files
+import qualified Analysis.File as File
+import           Data.Flag
+import           Proto.Semantic as P hiding (Blob, BlobPair)
+import           Semantic.Api.Symbols (parseSymbols)
+import           Semantic.Config as Config
+import           Semantic.Task
+import           Semantic.Task.Files
 
 benchmarks :: Benchmark
 benchmarks = bgroup "tagging"
@@ -66,7 +66,7 @@ parseSymbolsFilePath ::
   => PerLanguageModes
   -> Path.RelFile
   -> m ParseTreeSymbolResponse
-parseSymbolsFilePath languageModes path = readBlob (fileForTypedPath path) >>= runReader languageModes . parseSymbols . pure @[]
+parseSymbolsFilePath languageModes path = readBlob (File.fromPath path) >>= runReader languageModes . parseSymbols . pure @[]
 
 aLaCarteLanguageModes :: PerLanguageModes
 aLaCarteLanguageModes = PerLanguageModes

script/ghci-flags

@@ -10,7 +10,8 @@ ghc_version="$(ghc --numeric-version)"
 # recent hie-bios requires us to output to the file at $HIE_BIOS_OUTPUT, but older builds & script/repl don’t set that var, so we default it to stdout
 output_file="${HIE_BIOS_OUTPUT:-/dev/stdout}"
 
-build_products_dir="dist-newstyle/build/x86_64-osx/ghc-$ghc_version/build-repl"
+build_dir="dist-newstyle/build/x86_64-osx/ghc-$ghc_version"
+build_products_dir="$build_dir/build-repl"
 
 function flags {
   # disable optimizations for faster loading
@@ -26,11 +27,11 @@ function flags {
 
   # preprocessor options, for -XCPP
   echo "-optP-include"
-  echo "-optP$build_products_dir/autogen/cabal_macros.h"
+  echo "-optP$build_dir/semantic-0.10.0.0/build/autogen/cabal_macros.h"
 
   # autogenerated sources, both .hs and .h (e.g. Foo_paths.hs)
-  echo "-i$build_products_dir/autogen"
-  echo "-I$build_products_dir/autogen"
+  echo "-i$build_dir/semantic-0.10.0.0/build/autogen"
+  echo "-I$build_dir/semantic-0.10.0.0/build/autogen"
 
   # .hs source dirs
   # TODO: would be nice to figure this out from cabal.project & the .cabal files

semantic-analysis/semantic-analysis.cabal

@@ -56,17 +56,22 @@ library
     Analysis.Typecheck
     Control.Carrier.Fail.WithLoc
   build-depends:
-      algebraic-graphs            ^>= 0.3
+    , aeson                       ^>= 1.4
+    , algebraic-graphs            ^>= 0.3
     , base                         >= 4.13 && < 5
     , containers                  ^>= 0.6
+    , filepath
     , fused-effects               ^>= 1.0
     , fused-effects-readline
     , fused-syntax
+    , hashable
     , haskeline                   ^>= 0.7.5
+    , lingo                       ^>= 0.3
     , pathtype                    ^>= 0.8.1
     , prettyprinter                >= 1.2 && < 2
     , prettyprinter-ansi-terminal ^>= 1.1.1
-    , semantic-source             ^>= 0.0.1
+    , semantic-source             ^>= 0.0.2
+    , semilattices
     , terminal-size               ^>= 0.3
     , text                        ^>= 1.2.3.1
     , transformers                ^>= 0.5

semantic-analysis/src/Analysis/File.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE DeriveTraversable #-}
 module Analysis.File
 ( File(..)
+, fileLanguage
 , fromBody
+, fromPath
 ) where
 
-import Data.Maybe (fromJust, listToMaybe)
-import GHC.Stack
-import Source.Span
+import           Data.Maybe (fromJust, listToMaybe)
+import           Data.Semilattice.Lower
+import           GHC.Stack
+import           Source.Language as Language
+import           Source.Span
 import qualified System.Path as Path
+import qualified System.Path.PartClass as Path.PartClass
 
 data File a = File
   { filePath :: !Path.AbsRelFile
@@ -19,3 +24,10 @@ data File a = File
 fromBody :: HasCallStack => a -> File a
 fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where
   srcLoc = snd (fromJust (listToMaybe (getCallStack callStack)))
+
+-- | The language of the provided file, as inferred by 'Language.forPath'.
+fileLanguage :: File a -> Language
+fileLanguage = Language.forPath . filePath
+
+fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language
+fromPath p = File (Path.toAbsRel p) lowerBound (Language.forPath p)

semantic-ast/app/Main.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Main (main) where
 
@@ -8,17 +7,21 @@ import qualified TreeSitter.Python.AST as AST
 import qualified TreeSitter.Python as Python
 import Source.Range
 import Source.Span
+import Data.Aeson (toJSON)
 import Data.ByteString.Char8
 import Data.ByteString (readFile)
 import Options.Applicative hiding (style)
 import Text.Pretty.Simple (pPrint, pPrintNoColor)
 import Data.Foldable (traverse_)
 import Control.Monad ((>=>))
+import Marshal.JSON (marshal)
+import Data.ByteString.Lazy.Char8 (putStrLn)
+import Data.Aeson.Encode.Pretty (encodePretty)
 
 data SemanticAST = SemanticAST
-  { format :: Format
-  , noColor  :: Bool
-  , source :: Either [FilePath] String
+  { _format :: Format
+  , _noColor  :: Bool
+  , _source :: Either [FilePath] String
   }
 
 -- Usage: semantic-ast --format ARG [--no-color] (--sourceString STRING | FILEPATHS…)
@@ -51,13 +54,13 @@ generateAST (SemanticAST format noColor source) =
           Left filePaths -> traverse Data.ByteString.readFile filePaths
           Right source   -> pure [Data.ByteString.Char8.pack source]
         go = ast >=> display
-        ast = parseByteString @AST.Module @(Range, Span) Python.tree_sitter_python
+        ast = parseByteString @AST.Module @(Range, Span) Python.tree_sitter_python -- TODO: generalize for all languages
         display = case format of
+          Json -> Data.ByteString.Lazy.Char8.putStrLn . encodePretty . either toJSON (marshal . fmap (const ())) -- TODO: replacing range and span annotations with () for which there is a ToJSON instance for now, deal with this later
           Show -> print
           Pretty | noColor -> pPrintNoColor
                  | otherwise -> pPrint
 
--- need AST in scope for case format and ..
 
 opts :: ParserInfo SemanticAST
 opts = info (parseAST <**> helper)
@@ -68,6 +71,5 @@ opts = info (parseAST <**> helper)
 -- TODO: Define formats for json, sexpression, etc.
 data Format = Show
             | Pretty
+            | Json
   deriving (Read)
-
--- bool field would break Read

semantic-ast/semantic-ast.cabal

@@ -37,19 +37,25 @@ common haskell
 
 library
   import:              haskell
-  exposed-modules:
+  exposed-modules:     Marshal.JSON
+
   -- other-modules:
   -- other-extensions:
   build-depends:       base ^>= 4.13
                      , tree-sitter ^>= 0.8
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , tree-sitter-python ^>= 0.8.1
                      , bytestring ^>= 0.10.8.2
                      , optparse-applicative >= 0.14.3 && < 0.16
                      , pretty-simple ^>= 3.1.0.0
+                     , aeson                ^>= 1.4.2.0
+                     , text                 ^>= 1.2.3.1
+                     , bytestring           ^>= 0.10.8.2
+                     , aeson-pretty         ^>= 0.8.8
   hs-source-dirs:      src
   default-language:    Haskell2010
 
+
 executable semantic-ast
   import:              haskell
   main-is:             Main.hs
@@ -63,5 +69,8 @@ executable semantic-ast
                      , bytestring
                      , optparse-applicative
                      , pretty-simple
-  hs-source-dirs:      src
+                     , aeson
+                     , bytestring
+                     , aeson-pretty
+  hs-source-dirs:      app
   default-language:    Haskell2010

semantic-ast/src/Marshal/JSON.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Marshal.JSON
+( MarshalJSON(..)
+) where
+
+import           Data.Aeson as Aeson
+import           Data.List.NonEmpty (NonEmpty)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           GHC.Generics
+
+-- TODO: use toEncoding -- direct serialization to ByteString
+
+-- Serialize unmarshaled ASTs into JSON representation by auto-deriving Aeson instances generically
+class MarshalJSON t where
+  marshal :: (ToJSON a) => t a -> Value
+  marshal = object . fields []
+  fields :: (ToJSON a) => [(Text, Value)] -> t a -> [(Text, Value)]
+  default fields :: ( Generic1 t, GFields (Rep1 t), ToJSON a) => [(Text, Value)] -> t a -> [(Text, Value)]
+  fields acc = gfields acc . from1
+
+-- Implement the sum case
+instance {-# OVERLAPPING #-} (MarshalJSON f, MarshalJSON g) => MarshalJSON (f :+: g) where
+  fields acc (L1 f) = fields acc f
+  fields acc (R1 g) = fields acc g
+
+-- Create MarshalJSON instances for each type constructor
+instance (GFields (Rep1 t), Generic1 t) => MarshalJSON t
+
+-- Stores meta-data for datatypes
+instance (GFields f, Datatype c) => GFields (M1 D c f) where
+   gfields acc x = gfields ((Text.pack "type", String (Text.pack (datatypeName x))): acc) $ unM1 x
+
+-- Fold over S1 product types and pass the result to Aeson objects
+instance GFields fields => GFields (C1 c fields) where
+  gfields acc x = gfields acc (unM1 x)
+
+-- Implement base case for products
+-- To get a value out of this datum, we define another typeclass: @GValue@ with the method @gvalue@.
+instance (GValue p, Selector s) => GFields (S1 s p) where
+  gfields acc x = (Text.pack (selName x), gvalue (unM1 x)) : acc
+
+-- Implement inductive case for product case
+-- Product datatypes are marshalled to an object with a type field holding the constructor name and a separate field for each selector in the datatype.
+instance (GFields f, GFields g) => GFields (f :*: g) where
+  gfields acc (f :*: g) = gfields (gfields acc g) f
+
+-- GValue for leaves
+instance ToJSON a => GValue (K1 i a) where
+  gvalue = toJSON . unK1
+
+-- Par1 instance
+instance GValue Par1 where
+  gvalue = toJSON . unPar1
+
+instance (MarshalJSON t) => GValue (Rec1 t) where
+  gvalue (Rec1 f) = marshal f
+
+instance (GValue t) => GValue (Maybe :.: t) where
+  gvalue (Comp1 (Just t)) = gvalue t
+  gvalue (Comp1 Nothing)  = Null
+
+instance (GValue t) => GValue ([] :.: t) where
+  gvalue (Comp1 ts) = toJSON $ map gvalue ts
+
+instance (GValue t) => GValue (NonEmpty :.: t) where
+  gvalue (Comp1 ts) = toJSON $ fmap gvalue ts
+
+-- GFields operates on product field types: it takes an accumulator, a datatype, and returns a new accumulator value.
+class GFields f where
+  gfields :: ToJSON a => [(Text, Value)] -> f a -> [(Text, Value)]
+
+-- gvalue is a wrapper that calls to @toJSON@ (for leaf nodes such as @Text@) or recurses via @marshal@
+class GValue f where
+  gvalue :: (ToJSON a) => f a -> Value

semantic-core/semantic-core.cabal

@@ -54,7 +54,7 @@ library
     , prettyprinter                >= 1.2.1 && < 2
     , prettyprinter-ansi-terminal ^>= 1.1.1
     , semantic-analysis           ^>= 0
-    , semantic-source             ^>= 0.0.1
+    , semantic-source             ^>= 0.0.2
     , text                        ^>= 1.2.3.1
     , trifecta                     >= 2 && < 2.2
     , unordered-containers        ^>= 0.2.10
@@ -69,7 +69,7 @@ test-suite test
       base
     , semantic-analysis
     , semantic-core
-    , semantic-source ^>= 0.0.1
+    , semantic-source
     , fused-effects
     , fused-syntax
     , hedgehog ^>= 1

semantic-go/semantic-go.cabal

@@ -25,7 +25,7 @@ common haskell
                      , fused-syntax
                      , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , semantic-tags ^>= 0.0
                      , text ^>= 1.2.3
                      , tree-sitter ^>= 0.8

semantic-go/src/Language/Go/Tags.hs

@@ -47,7 +47,7 @@ instance ToTags Go.MethodDeclaration where
   tags t@Go.MethodDeclaration
     { ann = loc@Loc { byteRange }
     , name = Go.FieldIdentifier { text }
-    } = yieldTag text Function loc byteRange >> gtags t
+    } = yieldTag text Method loc byteRange >> gtags t
 
 instance ToTags Go.CallExpression where
   tags t@Go.CallExpression

semantic-java/semantic-java.cabal

@@ -25,7 +25,7 @@ library
   build-depends:
       base              >= 4.13 && < 5
     , fused-effects    ^>= 1.0
-    , semantic-source  ^>= 0.0.1
+    , semantic-source  ^>= 0.0.2
     , semantic-tags    ^>= 0.0
     , tree-sitter      ^>= 0.8
     , tree-sitter-java ^>= 0.6.1

semantic-python/semantic-python.cabal

@@ -25,7 +25,7 @@ common haskell
                      , fused-syntax
                      , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , semantic-tags ^>= 0.0
                      , semantic-scope-graph ^>= 0.0
                      , semilattices ^>= 0

semantic-ruby/semantic-ruby.cabal

@@ -25,7 +25,7 @@ common haskell
                      , fused-syntax
                      , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , semantic-tags ^>= 0.0
                      , text ^>= 1.2.3
                      , tree-sitter ^>= 0.8

semantic-ruby/src/Language/Ruby/Tags.hs

@@ -147,7 +147,7 @@ yieldMethodNameTag t loc range (Rb.MethodName expr) = enterScope True $ case exp
   -- Prj Rb.Symbol { extraChildren = [Prj Rb.EscapeSequence { text = name }] } -> yield name
   _                                                               -> gtags t
   where
-    yield name = yieldTag name Function loc range >> gtags t
+    yield name = yieldTag name Method loc range >> gtags t
 
 enterScope :: (Has (State [Text]) sig m) => Bool -> m () -> m ()
 enterScope createNew m = do

semantic-scope-graph/semantic-scope-graph.cabal

@@ -38,7 +38,7 @@ library
     , semilattices
     , generic-monoid
     , pathtype
-    , semantic-source    ^>= 0.0
+    , semantic-source    ^>= 0.0.2
     , text               ^>= 1.2.3.1
   hs-source-dirs:      src
   default-language:    Haskell2010

semantic-scope-graph/src/Data/ScopeGraph.hs

@@ -163,22 +163,21 @@ data Kind = AbstractClass
 instance Lower Kind where
   lowerBound = Unknown
 
--- Offsets and frame addresses in the heap should be addresses?
-data Scope address =
-    Scope {
-      edges        :: Map EdgeLabel [address]
-    , references   :: Map Reference ([ReferenceInfo], Path address)
-    , declarations :: Seq (Info address)
-    }
-  | PreludeScope {
-      edges        :: Map EdgeLabel [address]
-    , references   :: Map Reference ([ReferenceInfo], Path address)
-    , declarations :: Seq (Info address)
-    }
+data Domain
+  = Standard
+  | Preluded
   deriving (Eq, Show, Ord)
 
+-- Offsets and frame addresses in the heap should be addresses?
+data Scope address = Scope
+  { edges        :: Map EdgeLabel [address]
+  , references   :: Map Reference ([ReferenceInfo], Path address)
+  , declarations :: Seq (Info address)
+  , domain       :: Domain
+  } deriving (Eq, Show, Ord)
+
 instance Lower (Scope scopeAddress) where
-  lowerBound = Scope mempty mempty mempty
+  lowerBound = Scope mempty mempty mempty Standard
 
 instance AbstractHole (Scope scopeAddress) where
   hole = lowerBound
@@ -373,11 +372,11 @@ insertDeclarationSpan decl@Declaration{..} span g = fromMaybe g $ do
 
 -- | Insert a new scope with the given address and edges into the scope graph.
 newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
-newScope address edges = insertScope address (Scope edges mempty mempty)
+newScope address edges = insertScope address (Scope edges mempty mempty Standard)
 
 -- | Insert a new scope with the given address and edges into the scope graph.
 newPreludeScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
-newPreludeScope address edges = insertScope address (PreludeScope edges mempty mempty)
+newPreludeScope address edges = insertScope address (Scope edges mempty mempty Preluded)
 
 insertScope :: Ord address => address -> Scope address -> ScopeGraph address -> ScopeGraph address
 insertScope address scope = ScopeGraph . Map.insert address scope . unScopeGraph

semantic-source/CHANGELOG.md

@@ -1,3 +1,8 @@
+# 0.0.2.0
+
+- Adds `Source.Language`.
+- Adds `ToJSON` instances for `Range` and `Loc`.
+
 # 0.0.1.0
 
 - Adds an `NFData` instance for `Source`.

semantic-source/semantic-source.cabal

@@ -1,7 +1,7 @@
 cabal-version:       2.4
 
 name:                semantic-source
-version:             0.0.1.0
+version:             0.0.2.0
 synopsis:            Types and functionality for working with source code
 description:         Types and functionality for working with source code (program text).
 homepage:            https://github.com/github/semantic/tree/master/semantic-source#readme
@@ -42,6 +42,7 @@ common haskell
 library
   import: haskell
   exposed-modules:
+    Source.Language
     Source.Loc
     Source.Range
     Source.Source
@@ -51,8 +52,11 @@ library
     , base            >= 4.12 && < 5
     , bytestring     ^>= 0.10.8.2
     , deepseq        ^>= 1.4.4.0
+    , containers     ^>= 0.6.2
     , generic-monoid ^>= 0.1.0.0
     , hashable        >= 1.2.7 && < 1.4
+    , lingo          ^>= 0.3
+    , pathtype       ^>= 0.8.1
     , semilattices   ^>= 0.0.0.3
     , text           ^>= 1.2.3.1
   hs-source-dirs: src

semantic-source/src/Source/Language.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Source.Language
+  ( Language (..)
+  , SLanguage (..)
+  , extensionsForLanguage
+  , knownLanguage
+  , forPath
+  , textToLanguage
+  , languageToText
+  ) where
+
+import           Data.Aeson
+import           Data.Hashable (Hashable)
+import qualified Data.Languages as Lingo
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import           GHC.Generics (Generic)
+import qualified System.Path as Path
+import qualified System.Path.PartClass as Path.PartClass
+
+-- | The various languages we support.
+data Language
+    = Unknown
+    | Go
+    | Haskell
+    | Java
+    | JavaScript
+    | JSON
+    | JSX
+    | Markdown
+    | Python
+    | Ruby
+    | TypeScript
+    | PHP
+    | TSX
+    deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Enum)
+
+-- | Reifies a proxied type-level 'Language' to a value.
+class SLanguage (lang :: Language) where
+  reflect :: proxy lang -> Language
+
+instance SLanguage 'Unknown where
+  reflect _ = Unknown
+
+instance SLanguage 'Go where
+  reflect _ = Go
+
+instance SLanguage 'Haskell where
+  reflect _ = Haskell
+
+instance SLanguage 'Java where
+  reflect _ = Java
+
+instance SLanguage 'JavaScript where
+  reflect _ = JavaScript
+
+instance SLanguage 'JSON where
+  reflect _ = JSON
+
+instance SLanguage 'JSX where
+  reflect _ = JSX
+
+instance SLanguage 'Markdown where
+  reflect _ = Markdown
+
+instance SLanguage 'Python where
+  reflect _ = Python
+
+instance SLanguage 'Ruby where
+  reflect _ = Ruby
+
+instance SLanguage 'TypeScript where
+  reflect _ = TypeScript
+
+instance SLanguage 'PHP where
+  reflect _ = PHP
+
+instance FromJSON Language where
+  parseJSON = withText "Language" $ \l ->
+    pure $ textToLanguage l
+
+
+-- | Predicate failing on 'Unknown' and passing in all other cases.
+knownLanguage :: Language -> Bool
+knownLanguage = (/= Unknown)
+
+extensionsForLanguage :: Language -> [String]
+extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages)
+
+forPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language
+forPath path =
+  let spurious lang = lang `elem` [ "Hack" -- .php files
+                                  , "GCC Machine Description" -- .md files
+                                  , "XML" -- .tsx files
+                                  ]
+      allResults = Lingo.languageName <$> Lingo.languagesForPath (Path.toString path)
+  in case filter (not . spurious) allResults of
+    [result] -> textToLanguage result
+    _        -> Unknown
+
+languageToText :: Language -> T.Text
+languageToText = \case
+  Unknown -> "Unknown"
+  Go -> "Go"
+  Haskell -> "Haskell"
+  Java -> "Java"
+  JavaScript -> "JavaScript"
+  JSON -> "JSON"
+  JSX -> "JSX"
+  Markdown -> "Markdown"
+  Python -> "Python"
+  Ruby -> "Ruby"
+  TypeScript -> "TypeScript"
+  TSX -> "TSX"
+  PHP -> "PHP"
+
+textToLanguage :: T.Text -> Language
+textToLanguage = \case
+  "Go" -> Go
+  "Haskell" -> Haskell
+  "Java" -> Java
+  "JavaScript" -> JavaScript
+  "JSON" -> JSON
+  "JSX" -> JSX
+  "Markdown" -> Markdown
+  "Python" -> Python
+  "Ruby" -> Ruby
+  "TypeScript" -> TypeScript
+  "TSX" -> TSX
+  "PHP" -> PHP
+  _ -> Unknown

semantic-source/src/Source/Loc.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes #-}
+{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes, NamedFieldPuns, OverloadedStrings #-}
 module Source.Loc
 ( Loc(..)
 , byteRange_
@@ -7,6 +7,7 @@ module Source.Loc
 ) where
 
 import Control.DeepSeq (NFData)
+import Data.Aeson (ToJSON(..), object, (.=))
 import Data.Hashable (Hashable)
 import Data.Monoid.Generic
 import GHC.Generics (Generic)
@@ -28,6 +29,9 @@ instance HasSpan Loc where
   span_ = lens span (\l s -> l { span = s })
   {-# INLINE span_ #-}
 
+instance ToJSON Loc where
+  toJSON Loc{byteRange, span} = object ["sourceRange" .= byteRange
+                                      , "sourceSpan" .= span]
 
 byteRange_ :: Lens' Loc Range
 byteRange_ = lens byteRange (\l r -> l { byteRange = r })
@@ -38,3 +42,4 @@ type Lens' s a = forall f . Functor f => (a -> f a) -> (s -> f s)
 lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
 lens get put afa s = fmap (put s) (afa (get s))
 {-# INLINE lens #-}
+

semantic-source/src/Source/Range.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, RankNTypes #-}
+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RankNTypes, NamedFieldPuns #-}
 module Source.Range
 ( Range(..)
 , point
@@ -10,6 +10,7 @@ module Source.Range
 ) where
 
 import Control.DeepSeq (NFData)
+import Data.Aeson (ToJSON(..))
 import Data.Hashable (Hashable)
 import Data.Semilattice.Lower (Lower(..))
 import GHC.Generics (Generic)
@@ -24,6 +25,8 @@ data Range = Range
 instance Hashable Range
 instance NFData   Range
 
+
+
 -- $
 -- prop> a <> (b <> c) === (a <> b) <> (c :: Range)
 instance Semigroup Range where
@@ -32,6 +35,8 @@ instance Semigroup Range where
 instance Lower Range where
   lowerBound = Range 0 0
 
+instance ToJSON Range where
+  toJSON Range { start, end } = toJSON [ start, end ]
 
 -- | Construct a 'Range' with a given value for both its start and end indices.
 point :: Int -> Range
@@ -60,3 +65,4 @@ lens get put afa s = fmap (put s) (afa (get s))
 -- $setup
 -- >>> import Test.QuickCheck
 -- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary ; shrink (Range s e) = Range <$> shrink s <*> shrink e
+

semantic-tags/semantic-tags.cabal

@@ -26,7 +26,7 @@ library
   build-depends:
       base                >= 4.13 && < 5
     , fused-effects      ^>= 1.0
-    , semantic-source    ^>= 0.0.1
+    , semantic-source    ^>= 0.0.2
     , text               ^>= 1.2.3.1
   hs-source-dirs:      src
   default-language:    Haskell2010

semantic-tsx/semantic-tsx.cabal

@@ -25,11 +25,11 @@ common haskell
                      , fused-syntax
                      , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , semantic-tags ^>= 0.0
                      , text ^>= 1.2.3
                      , tree-sitter ^>= 0.8
-                     , tree-sitter-tsx ^>= 0.4.1
+                     , tree-sitter-tsx ^>= 0.4.2
 
   ghc-options:
     -Weverything

semantic-tsx/src/Language/TSX/Tags.hs

@@ -67,7 +67,7 @@ instance ToTags Tsx.MethodDefinition where
       -- TODO: There are more here
       _                                   -> gtags t
       where
-        yield name = yieldTag name Call loc byteRange >> gtags t
+        yield name = yieldTag name Method loc byteRange >> gtags t
 
 instance ToTags Tsx.ClassDeclaration where
   tags t@Tsx.ClassDeclaration
@@ -100,6 +100,19 @@ instance ToTags Tsx.Class where
     } = yieldTag text Class loc byteRange >> gtags t
   tags t = gtags t
 
+instance ToTags Tsx.Module where
+  tags t@Tsx.Module
+    { ann = loc@Loc { byteRange }
+    , name
+    } = match name
+    where
+      match expr = case expr of
+        Prj Tsx.Identifier { text } -> yield text
+        -- TODO: Handle NestedIdentifiers and Strings
+        -- Prj Tsx.NestedIdentifier { extraChildren } -> match
+        _ -> gtags t
+      yield text = yieldTag text Module loc byteRange >> gtags t
+
 instance (ToTags l, ToTags r) => ToTags (l :+: r) where
   tags (L1 l) = tags l
   tags (R1 r) = tags r
@@ -222,7 +235,7 @@ instance ToTags Tsx.MemberExpression
 instance ToTags Tsx.MetaProperty
 -- instance ToTags Tsx.MethodDefinition
 instance ToTags Tsx.MethodSignature
-instance ToTags Tsx.Module
+-- instance ToTags Tsx.Module
 instance ToTags Tsx.NamedImports
 instance ToTags Tsx.NamespaceImport
 instance ToTags Tsx.NestedIdentifier

semantic-typescript/semantic-typescript.cabal

@@ -25,11 +25,11 @@ common haskell
                      , fused-syntax
                      , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-source ^>= 0.0.2
                      , semantic-tags ^>= 0.0
                      , text ^>= 1.2.3
                      , tree-sitter ^>= 0.8
-                     , tree-sitter-typescript ^>= 0.4.1
+                     , tree-sitter-typescript ^>= 0.4.2
 
   ghc-options:
     -Weverything

semantic-typescript/src/Language/TypeScript/Tags.hs

@@ -67,7 +67,7 @@ instance ToTags Ts.MethodDefinition where
       -- TODO: There are more here
       _                                  -> gtags t
       where
-        yield name = yieldTag name Call loc byteRange >> gtags t
+        yield name = yieldTag name Method loc byteRange >> gtags t
 
 instance ToTags Ts.ClassDeclaration where
   tags t@Ts.ClassDeclaration
@@ -93,6 +93,19 @@ instance ToTags Ts.CallExpression where
         _ -> gtags t
       yield name = yieldTag name Call loc byteRange >> gtags t
 
+instance ToTags Ts.Module where
+  tags t@Ts.Module
+    { ann = loc@Loc { byteRange }
+    , name
+    } = match name
+    where
+      match expr = case expr of
+        Prj Ts.Identifier { text } -> yield text
+        -- TODO: Handle NestedIdentifiers and Strings
+        -- Prj Tsx.NestedIdentifier { extraChildren } -> match
+        _ -> gtags t
+      yield text = yieldTag text Module loc byteRange >> gtags t
+
 instance (ToTags l, ToTags r) => ToTags (l :+: r) where
   tags (L1 l) = tags l
   tags (R1 r) = tags r
@@ -215,7 +228,7 @@ instance ToTags Ts.MemberExpression
 instance ToTags Ts.MetaProperty
 -- instance ToTags Ts.MethodDefinition
 instance ToTags Ts.MethodSignature
-instance ToTags Ts.Module
+-- instance ToTags Ts.Module
 instance ToTags Ts.NamedImports
 instance ToTags Ts.NamespaceImport
 instance ToTags Ts.NestedIdentifier

semantic.cabal

@@ -59,7 +59,7 @@ common dependencies
                      , fused-effects-exceptions ^>= 1
                      , fused-effects-resumable ^>= 0.1
                      , hashable >= 1.2.7 && < 1.4
-                     , tree-sitter ^>= 0.8
+                     , tree-sitter ^>= 0.8.0.2
                      , mtl ^>= 2.2.2
                      , network ^>= 2.8.0.0
                      , pathtype ^>= 0.8.1
@@ -67,7 +67,8 @@ common dependencies
                      , recursion-schemes ^>= 5.1
                      , scientific ^>= 0.3.6.2
                      , safe-exceptions ^>= 0.1.7.0
-                     , semantic-source ^>= 0.0.1
+                     , semantic-analysis
+                     , semantic-source ^>= 0.0.2
                      , semilattices ^>= 0.0.0.3
                      , streaming ^>= 0.2.2.0
                      , text ^>= 1.2.3.1
@@ -303,12 +304,12 @@ library
                      , unliftio-core ^>= 0.1.2.0
                      , unordered-containers ^>= 0.2.9.0
                      , vector ^>= 0.12.0.2
-                     , tree-sitter-go ^>= 0.4.1
+                     , tree-sitter-go ^>= 0.4.1.1
                      , tree-sitter-php ^>= 0.2
                      , tree-sitter-python ^>= 0.8.1
                      , tree-sitter-ruby ^>= 0.4.1
-                     , tree-sitter-typescript ^>= 0.4.1
-                     , tree-sitter-tsx ^>= 0.4.1
+                     , tree-sitter-typescript ^>= 0.4.2
+                     , tree-sitter-tsx ^>= 0.4.2
 
 executable semantic
   import:              haskell, dependencies, executable-flags

src/Control/Carrier/Parse/Measured.hs

@@ -58,9 +58,9 @@ runParser blob@Blob{..} parser = case parser of
         >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure
 
   UnmarshalParser language ->
-    time "parse.tree_sitter_ast_parse" languageTag $ do
+    time "parse.tree_sitter_precise_ast_parse" languageTag $ do
       config <- asks config
-      parseToPreciseAST (configTreeSitterParseTimeout config) language blob
+      parseToPreciseAST (configTreeSitterParseTimeout config) (configTreeSitterUnmarshalTimeout config) language blob
         >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure
 
   AssignmentParser    parser assignment -> runAssignment Assignment.assign    parser blob assignment

src/Control/Carrier/Parse/Simple.hs

@@ -51,7 +51,7 @@ runParser timeout blob@Blob{..} parser = case parser of
       >>= either (throwError . SomeException) pure
 
   UnmarshalParser language ->
-    parseToPreciseAST timeout language blob
+    parseToPreciseAST timeout timeout language blob
       >>= either (throwError . SomeException) pure
 
   AssignmentParser    parser assignment ->

src/Data/Blob.hs

@@ -6,18 +6,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 module Data.Blob
-( File(..)
-, fileForPath
-, fileForTypedPath
-, Blob(..)
+( Blob(..)
 , Blobs(..)
 , blobLanguage
 , NoLanguageForBlob (..)
 , blobPath
-, makeBlob
 , decodeBlobs
 , nullBlob
-, sourceBlob
+, fromSource
 , moduleForBlob
 , noLanguageForBlob
 , BlobPair
@@ -31,69 +27,51 @@ module Data.Blob
 
 import Prologue
 
+import           Analysis.File (File (..))
 import           Control.Effect.Error
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import           Data.Edit
 import           Data.JSON.Fields
-import           Data.Language
 import           Data.Module
-import           Source.Source (Source)
+import           Source.Language as Language
+import           Source.Source (Source, totalSpan)
 import qualified Source.Source as Source
 import qualified System.FilePath as FP
 import qualified System.Path as Path
 import qualified System.Path.PartClass as Path.PartClass
 
--- | A 'FilePath' paired with its corresponding 'Language'.
--- Unpacked to have the same size overhead as (FilePath, Language).
-data File = File
-  { filePath     :: FilePath
-  , fileLanguage :: Language
-  } deriving (Show, Eq)
-
--- | Prefer 'fileForTypedPath' if at all possible.
-fileForPath :: FilePath  -> File
-fileForPath p = File p (languageForFilePath p)
-
-fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File
-fileForTypedPath = fileForPath . Path.toString
-
 -- | The source, path information, and language of a file read from disk.
 data Blob = Blob
-  { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
-  , blobFile   :: File   -- ^ Path/language information for this blob.
-  , blobOid    :: Text   -- ^ Git OID for this blob, mempty if blob is not from a git db.
+  { blobSource :: Source         -- ^ The UTF-8 encoded source text of the blob.
+  , blobFile   :: File Language  -- ^ Path/language information for this blob.
   } deriving (Show, Eq)
 
 blobLanguage :: Blob -> Language
-blobLanguage = fileLanguage . blobFile
+blobLanguage = Analysis.File.fileBody . blobFile
 
 blobPath :: Blob -> FilePath
-blobPath = filePath . blobFile
-
-makeBlob :: Source -> FilePath -> Language -> Text -> Blob
-makeBlob s p l = Blob s (File p l)
-{-# INLINE makeBlob #-}
+blobPath = Path.toString . Analysis.File.filePath . blobFile
 
 newtype Blobs a = Blobs { blobs :: [a] }
   deriving (Generic, FromJSON)
 
 instance FromJSON Blob where
-  parseJSON = withObject "Blob" $ \b -> inferringLanguage
-    <$> b .: "content"
-    <*> b .: "path"
-    <*> b .: "language"
+  parseJSON = withObject "Blob" $ \b -> do
+    src <- b .: "content"
+    Right pth <- fmap Path.parse (b .: "path")
+    lang <- b .: "language"
+    let lang' = if knownLanguage lang then lang else Language.forPath pth
+    pure (fromSource (pth :: Path.AbsRelFile) lang' src)
 
 nullBlob :: Blob -> Bool
 nullBlob Blob{..} = Source.null blobSource
 
-sourceBlob :: FilePath -> Language -> Source -> Blob
-sourceBlob filepath language source = makeBlob source filepath language mempty
-
-inferringLanguage :: Source -> FilePath -> Language -> Blob
-inferringLanguage src pth lang
-  | knownLanguage lang = makeBlob src pth lang mempty
-  | otherwise = makeBlob src pth (languageForFilePath pth) mempty
+-- | Create a Blob from a provided path, language, and UTF-8 source.
+-- The resulting Blob's span is taken from the 'totalSpan' of the source.
+fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob
+fromSource filepath language source
+  = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language)
 
 decodeBlobs :: BL.ByteString -> Either String [Blob]
 decodeBlobs = fmap blobs <$> eitherDecode
@@ -112,7 +90,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
               -> Module term    -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
 moduleForBlob rootDir b = Module info
   where root = fromMaybe (FP.takeDirectory (blobPath b)) rootDir
-        info = ModuleInfo (FP.makeRelative root (blobPath b)) (languageToText (blobLanguage b)) (blobOid b)
+        info = ModuleInfo (FP.makeRelative root (blobPath b)) (languageToText (blobLanguage b)) mempty
 
 -- | Represents a blobs suitable for diffing which can be either a blob to
 -- delete, a blob to insert, or a pair of blobs to diff.

src/Data/Blob/IO.hs

@@ -1,14 +1,17 @@
+{-# LANGUAGE ViewPatterns #-}
 -- | These are primitive file IO methods for use in ghci and as internal functions.
 -- Instead of using these, consider if you can use the Files DSL instead.
 module Data.Blob.IO
   ( readBlobFromFile
   , readBlobFromFile'
+  , readBlobFromPath
   , readBlobsFromDir
   , readFilePair
   ) where
 
 import Prologue
 
+import           Analysis.File as File
 import qualified Control.Concurrent.Async as Async
 import           Data.Blob
 import qualified Data.ByteString as B
@@ -18,24 +21,29 @@ import qualified Source.Source as Source
 import qualified System.Path as Path
 
 -- | Read a utf8-encoded file to a 'Blob'.
-readBlobFromFile :: MonadIO m => File -> m (Maybe Blob)
-readBlobFromFile (File "/dev/null" _) = pure Nothing
-readBlobFromFile (File path language) = do
-  raw <- liftIO $ B.readFile path
-  pure . Just . sourceBlob path language . Source.fromUTF8 $ raw
+readBlobFromFile :: MonadIO m => File Language -> m (Maybe Blob)
+readBlobFromFile (File (Path.toString -> "/dev/null") _ _) = pure Nothing
+readBlobFromFile file@(File path _ _language) = do
+  raw <- liftIO $ B.readFile (Path.toString path)
+  let newblob = Blob (Source.fromUTF8 raw) file
+  pure . Just $ newblob
 
--- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found.
-readBlobFromFile' :: (MonadFail m, MonadIO m) => File -> m Blob
+-- | Read a utf8-encoded file to a 'Blob', failing if it can't be found.
+readBlobFromFile' :: (MonadFail m, MonadIO m) => File Language -> m Blob
 readBlobFromFile' file = do
   maybeFile <- readBlobFromFile file
   maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
 
+-- | Read a blob from the provided absolute or relative path , failing if it can't be found.
+readBlobFromPath :: (MonadFail m, MonadIO m) => Path.AbsRelFile -> m Blob
+readBlobFromPath = readBlobFromFile' . File.fromPath
+
 -- | Read all blobs in the directory with Language.supportedExts.
 readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob]
 readBlobsFromDir path = liftIO . fmap catMaybes $
-  findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForTypedPath)
+  findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . File.fromPath)
 
-readFilePair :: MonadIO m => File -> File -> m BlobPair
+readFilePair :: MonadIO m => File Language -> File Language -> m BlobPair
 readFilePair a b = do
   before <- readBlobFromFile a
   after  <- readBlobFromFile b

src/Data/Language.hs

@@ -1,107 +1,19 @@
-{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, KindSignatures, LambdaCase, OverloadedStrings #-}
 module Data.Language
-  ( Language (..)
-  , SLanguage (..)
-  , extensionsForLanguage
-  , knownLanguage
-  , languageForFilePath
-  , pathIsMinified
-  , supportedExts
-  , codeNavLanguages
-  , textToLanguage
-  , languageToText
+  ( module Source.Language
+  , LanguageMode(..)
   , PerLanguageModes(..)
   , defaultLanguageModes
-  , LanguageMode(..)
+  , codeNavLanguages
+  , supportedExts
   ) where
 
-import           Data.Aeson
 import qualified Data.Languages as Lingo
-import qualified Data.Text as T
 import qualified Data.Map.Strict as Map
-import           Prologue
-import           System.FilePath.Posix
+import qualified Data.Text as T
+import           Source.Language
 
--- | The various languages we support.
--- Please do not reorder any of the field names: the current implementation of 'Primitive'
--- delegates to the auto-generated 'Enum' instance.
-data Language
-    = Unknown
-    | Go
-    | Haskell
-    | Java
-    | JavaScript
-    | JSON
-    | JSX
-    | Markdown
-    | Python
-    | Ruby
-    | TypeScript
-    | PHP
-    | TSX
-    deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Enum)
-
-class SLanguage (lang :: Language) where
-  reflect :: proxy lang -> Language
-
-instance SLanguage 'Unknown where
-  reflect _ = Unknown
-
-instance SLanguage 'Go where
-  reflect _ = Go
-
-instance SLanguage 'Haskell where
-  reflect _ = Haskell
-
-instance SLanguage 'Java where
-  reflect _ = Java
-
-instance SLanguage 'JavaScript where
-  reflect _ = JavaScript
-
-instance SLanguage 'JSON where
-  reflect _ = JSON
-
-instance SLanguage 'JSX where
-  reflect _ = JSX
-
-instance SLanguage 'Markdown where
-  reflect _ = Markdown
-
-instance SLanguage 'Python where
-  reflect _ = Python
-
-instance SLanguage 'Ruby where
-  reflect _ = Ruby
-
-instance SLanguage 'TypeScript where
-  reflect _ = TypeScript
-
-instance SLanguage 'PHP where
-  reflect _ = PHP
-
-instance FromJSON Language where
-  parseJSON = withText "Language" $ \l ->
-    pure $ textToLanguage l
-
--- | Predicate failing on 'Unknown' and passing in all other cases.
-knownLanguage :: Language -> Bool
-knownLanguage = (/= Unknown)
-
-extensionsForLanguage :: Language -> [String]
-extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages)
-
--- | Return a language based on a FilePath's extension.
-languageForFilePath :: FilePath -> Language
-languageForFilePath path =
-  let spurious lang = lang `elem` [ "Hack" -- .php files
-                                  , "GCC Machine Description" -- .md files
-                                  , "XML" -- .tsx files
-                                  ]
-      allResults = Lingo.languageName <$> Lingo.languagesForPath path
-  in case filter (not . spurious) allResults of
-    [result] -> textToLanguage result
-    _        -> Unknown
+codeNavLanguages :: [Language]
+codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
 
 supportedExts :: [String]
 supportedExts = foldr append mempty supportedLanguages
@@ -111,53 +23,15 @@ supportedExts = foldr append mempty supportedLanguages
     supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages)
     lookup k = Map.lookup k Lingo.languages
 
-codeNavLanguages :: [Language]
-codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
-
-pathIsMinified :: FilePath -> Bool
-pathIsMinified = isExtensionOf ".min.js"
-
-languageToText :: Language -> T.Text
-languageToText = \case
-  Unknown -> "Unknown"
-  Go -> "Go"
-  Haskell -> "Haskell"
-  Java -> "Java"
-  JavaScript -> "JavaScript"
-  JSON -> "JSON"
-  JSX -> "JSX"
-  Markdown -> "Markdown"
-  Python -> "Python"
-  Ruby -> "Ruby"
-  TypeScript -> "TypeScript"
-  TSX -> "TSX"
-  PHP -> "PHP"
-
-textToLanguage :: T.Text -> Language
-textToLanguage = \case
-  "Go" -> Go
-  "Haskell" -> Haskell
-  "Java" -> Java
-  "JavaScript" -> JavaScript
-  "JSON" -> JSON
-  "JSX" -> JSX
-  "Markdown" -> Markdown
-  "Python" -> Python
-  "Ruby" -> Ruby
-  "TypeScript" -> TypeScript
-  "TSX" -> TSX
-  "PHP" -> PHP
-  _ -> Unknown
-
 
 data PerLanguageModes = PerLanguageModes
-  { pythonMode :: LanguageMode
-  , rubyMode   :: LanguageMode
-  , goMode     :: LanguageMode
+  { pythonMode     :: LanguageMode
+  , rubyMode       :: LanguageMode
+  , goMode         :: LanguageMode
   , typescriptMode :: LanguageMode
-  , tsxMode :: LanguageMode
+  , tsxMode        :: LanguageMode
   , javascriptMode :: LanguageMode
-  , jsxMode :: LanguageMode
+  , jsxMode        :: LanguageMode
   }
   deriving (Eq, Ord, Show)
 

src/Data/Project.hs

@@ -9,12 +9,13 @@ module Data.Project
 import Prelude hiding (readFile)
 import Prologue
 
+import           Analysis.File
 import           Data.Blob
 import           Data.Blob.IO
 import           Data.Language
 import qualified Data.Text as T
-import           System.FilePath.Posix
 import           Semantic.IO
+import           System.FilePath.Posix
 import qualified System.Path as Path
 
 -- | A 'Project' contains all the information that semantic needs
@@ -32,7 +33,7 @@ projectName = T.pack . dropExtensions . takeFileName . projectRootDir
 projectExtensions :: Project -> [String]
 projectExtensions = extensionsForLanguage . projectLanguage
 
-projectFiles :: Project -> [File]
+projectFiles :: Project -> [File Language]
 projectFiles = fmap blobFile . projectBlobs
 
 readProjectFromPaths :: MonadIO m
@@ -56,5 +57,5 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do
   blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
   pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs)
   where
-    toFile path = File (Path.toString path) lang
+    toFile path = File path lowerBound lang
     exts = extensionsForLanguage lang

src/Parsing/TreeSitter.hs

@@ -12,7 +12,6 @@ import Prologue
 import           Control.Carrier.Reader
 import qualified Control.Exception as Exc
 import           Foreign
-import           Foreign.C.Types (CBool (..))
 
 import           Data.AST (AST, Node (Node))
 import           Data.Blob
@@ -21,6 +20,7 @@ import           Data.Term
 import           Source.Loc
 import qualified Source.Source as Source
 import           Source.Span
+import qualified System.Timeout as System
 
 import qualified TreeSitter.Cursor as TS
 import qualified TreeSitter.Language as TS
@@ -32,6 +32,7 @@ import qualified TreeSitter.Unmarshal as TS
 data TSParseException
   = ParserTimedOut
   | IncompatibleVersions
+  | UnmarshalTimedOut
   | UnmarshalFailure String
     deriving (Eq, Show, Generic)
 
@@ -52,18 +53,24 @@ parseToPreciseAST
      , TS.Unmarshal t
      )
   => Duration
+  -> Duration
   -> Ptr TS.Language
   -> Blob
   -> m (Either TSParseException (t Loc))
-parseToPreciseAST parseTimeout language blob = runParse parseTimeout language blob $ \ rootPtr ->
-  TS.withCursor (castPtr rootPtr) $ \ cursor ->
-    runReader (TS.UnmarshalState (Source.bytes (blobSource blob)) cursor) (liftIO (peek rootPtr) >>= TS.unmarshalNode)
-    `Exc.catch` (Exc.throw . UnmarshalFailure . TS.getUnmarshalError)
+parseToPreciseAST parseTimeout unmarshalTimeout language blob = runParse parseTimeout language blob $ \ rootPtr ->
+  withTimeout $
+    TS.withCursor (castPtr rootPtr) $ \ cursor ->
+      runReader (TS.UnmarshalState (Source.bytes (blobSource blob)) cursor) (liftIO (peek rootPtr) >>= TS.unmarshalNode)
+        `Exc.catch` (Exc.throw . UnmarshalFailure . TS.getUnmarshalError)
+  where
+    withTimeout :: IO a -> IO a
+    withTimeout action = System.timeout (toMicroseconds unmarshalTimeout) action >>= maybeM (Exc.throw UnmarshalTimedOut)
 
 instance Exception TSParseException where
   displayException = \case
     ParserTimedOut -> "tree-sitter: parser timed out"
     IncompatibleVersions -> "tree-sitter: incompatible versions"
+    UnmarshalTimedOut -> "tree-sitter: unmarshal timed out"
     UnmarshalFailure s -> "tree-sitter: unmarshal failure - " <> show s
 
 runParse
@@ -77,7 +84,6 @@ runParse parseTimeout language Blob{..} action =
   liftIO . Exc.tryJust fromException . TS.withParser language $ \ parser -> do
     let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
     TS.ts_parser_set_timeout_micros parser timeoutMicros
-    TS.ts_parser_halt_on_error parser (CBool 1)
     compatible <- TS.ts_parser_set_language parser language
     if compatible then
       TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do

src/Semantic/Api/Bridge.hs

@@ -1,21 +1,28 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RecordWildCards #-}
 module Semantic.Api.Bridge
   ( APIBridge (..)
   , APIConvert (..)
   , (#?)
   ) where
 
+import           Analysis.File
 import           Control.Lens
 import qualified Data.Blob as Data
 import qualified Data.Edit as Data
+import           Data.Either
 import qualified Data.Language as Data
 import           Data.ProtoLens (defMessage)
 import qualified Data.Text as T
-import qualified Semantic.Api.LegacyTypes as Legacy
+import           Data.Text.Lens
 import qualified Proto.Semantic as API
 import           Proto.Semantic_Fields as P
-import           Source.Source (fromText, toText)
+import qualified Semantic.Api.LegacyTypes as Legacy
+import qualified Source.Source as Source (fromText, toText, totalSpan)
 import qualified Source.Span as Source
+import qualified System.Path as Path
 
 -- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
 -- This is suitable for types such as 'Pos' which are representationally equivalent
@@ -71,8 +78,18 @@ instance APIBridge T.Text Data.Language where
 
 instance APIBridge API.Blob Data.Blob where
   bridging = iso apiBlobToBlob blobToApiBlob where
-    blobToApiBlob b = defMessage & P.content .~ toText (Data.blobSource b) & P.path .~ T.pack (Data.blobPath b) & P.language .~ (bridging # Data.blobLanguage b)
-    apiBlobToBlob blob = Data.makeBlob (fromText (blob^.content)) (T.unpack (blob^.path)) (blob^.(language . bridging)) mempty
+    blobToApiBlob b
+      = defMessage
+      & P.content .~ Source.toText (Data.blobSource b)
+      & P.path .~ T.pack (Data.blobPath b)
+      & P.language .~ (bridging # Data.blobLanguage b)
+    apiBlobToBlob blob =
+      let src = blob^.content.to Source.fromText
+          pth = fromRight (Path.toAbsRel Path.emptyFile) (blob^.path._Text.to Path.parse)
+      in Data.Blob
+      { blobSource = src
+      , blobFile = File pth (Source.totalSpan src) (blob^.language.bridging)
+      }
 
 
 instance APIConvert API.BlobPair Data.BlobPair where

src/Semantic/Api/LegacyTypes.hs

@@ -1,4 +1,9 @@
-{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass, DuplicateRecordFields, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 module Semantic.Api.LegacyTypes
   ( DiffTreeRequest(..)
   , ParseTreeRequest(..)
@@ -10,7 +15,7 @@ module Semantic.Api.LegacyTypes
   ) where
 
 import Data.Aeson
-import Data.Blob hiding (File(..))
+import Data.Blob
 import Prologue
 
 newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] }
@@ -27,9 +32,9 @@ newtype ParseTreeSymbolResponse = ParseTreeSymbolResponse { files :: [File] }
   deriving (Eq, Show, Generic, ToJSON)
 
 data File = File
-  { filePath :: Text
+  { filePath     :: Text
   , fileLanguage :: Text
-  , fileSymbols :: [Symbol]
+  , fileSymbols  :: [Symbol]
   }
   deriving (Eq, Show, Generic)
 

src/Semantic/Api/Symbols.hs

@@ -1,4 +1,14 @@
-{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Semantic.Api.Symbols
   ( legacyParseSymbols
   , parseSymbols
@@ -12,11 +22,11 @@ import           Control.Effect.Reader
 import           Control.Exception
 import           Control.Lens
 import           Data.Abstract.Declarations
-import           Data.Blob hiding (File (..))
+import           Data.Blob
 import           Data.ByteString.Builder
 import           Data.Language
 import           Data.ProtoLens (defMessage)
-import           Data.Term (IsTerm(..), TermF)
+import           Data.Term (IsTerm (..), TermF)
 import           Data.Text (pack)
 import qualified Parsing.Parser as Parser
 import           Prologue
@@ -78,7 +88,6 @@ parseSymbols blobs = do
           & P.language .~ (bridging # blobLanguage')
           & P.symbols .~ mempty
           & P.errors .~ [defMessage & P.error .~ pack e]
-          & P.blobOid .~ blobOid
 
         tagsToFile :: [Tag] -> File
         tagsToFile tags = defMessage
@@ -86,7 +95,6 @@ parseSymbols blobs = do
           & P.language .~ (bridging # blobLanguage')
           & P.symbols .~ fmap tagToSymbol tags
           & P.errors .~ mempty
-          & P.blobOid .~ blobOid
 
         tagToSymbol :: Tag -> Symbol
         tagToSymbol Tag{..} = defMessage

src/Semantic/CLI.hs

@@ -1,10 +1,12 @@
-{-# LANGUAGE ApplicativeDo, FlexibleContexts #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Semantic.CLI (main) where
 
+import qualified Analysis.File as File
 import qualified Control.Carrier.Parse.Measured as Parse
 import           Control.Carrier.Reader
-import           Data.Blob
 import           Data.Blob.IO
+import           Data.Either
 import qualified Data.Flag as Flag
 import           Data.Handle
 import qualified Data.Language as Language
@@ -22,7 +24,6 @@ import qualified Semantic.Telemetry.Log as Log
 import           Semantic.Version
 import           Serializing.Format hiding (Options)
 import           System.Exit (die)
-import           System.FilePath
 import qualified System.Path as Path
 import qualified System.Path.PartClass as Path.PartClass
 
@@ -151,10 +152,11 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
       <$> (   Just <$> some (strArgument (metavar "FILES..."))
           <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
     makeReadProjectFromPathsTask maybePaths = do
-      paths <- maybeM (liftIO (many getLine)) maybePaths
-      blobs <- traverse readBlobFromFile' (fileForPath <$> paths)
+      strPaths <- maybeM (liftIO (many getLine)) maybePaths
+      let paths = rights (Path.parse <$> strPaths)
+      blobs <- traverse readBlobFromPath paths
       case paths of
-        (x:_) -> pure $! Project (takeDirectory x) blobs (Language.languageForFilePath x) mempty
+        (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.forPath x) mempty
         _     -> pure $! Project "/" mempty Language.Unknown mempty
 
     allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound]
@@ -183,8 +185,8 @@ languageModes = Language.PerLanguageModes
                     <> value Language.ALaCarte
                     <> showDefault)
 
-filePathReader :: ReadM File
-filePathReader = fileForPath <$> str
+filePathReader :: ReadM (File.File Language.Language)
+filePathReader = File.fromPath <$> path
 
 path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd)
 path = eitherReader Path.parse

src/Semantic/Config.hs

@@ -43,20 +43,21 @@ data FailOnParseError = FailOnParseError
 
 data Config
   = Config
-  { configAppName                :: String               -- ^ Application name ("semantic")
-  , configHostName               :: String               -- ^ HostName from getHostName
-  , configProcessID              :: ProcessID            -- ^ ProcessID from getProcessID
-  , configStatsHost              :: Stat.Host            -- ^ Host of statsd/datadog (default: "127.0.0.1")
-  , configStatsPort              :: Stat.Port            -- ^ Port of statsd/datadog (default: "28125")
-  , configTreeSitterParseTimeout :: Duration             -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
-  , configAssignmentTimeout      :: Duration             -- ^ Millisecond timeout for assignment (default: 4000)
-  , configMaxTelemetyQueueSize   :: Int                  -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
-  , configIsTerminal             :: Flag IsTerminal      -- ^ Whether a terminal is attached (set automaticaly at runtime).
-  , configLogPrintSource         :: Flag LogPrintSource  -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
-  , configLogFormatter           :: LogFormatter         -- ^ Log formatter to use (set automatically at runtime).
-  , configSHA                    :: String               -- ^ SHA to include in log messages (set automatically).
-  , configFailParsingForTesting  :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False).
-  , configOptions                :: Options              -- ^ Options configurable via command line arguments.
+  { configAppName                    :: String               -- ^ Application name ("semantic")
+  , configHostName                   :: String               -- ^ HostName from getHostName
+  , configProcessID                  :: ProcessID            -- ^ ProcessID from getProcessID
+  , configStatsHost                  :: Stat.Host            -- ^ Host of statsd/datadog (default: "127.0.0.1")
+  , configStatsPort                  :: Stat.Port            -- ^ Port of statsd/datadog (default: "28125")
+  , configTreeSitterParseTimeout     :: Duration             -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
+  , configTreeSitterUnmarshalTimeout :: Duration             -- ^ Timeout in milliseconds before canceling tree-sitter unmarshalling (default: 4000).
+  , configAssignmentTimeout          :: Duration             -- ^ Millisecond timeout for assignment (default: 4000)
+  , configMaxTelemetyQueueSize       :: Int                  -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
+  , configIsTerminal                 :: Flag IsTerminal      -- ^ Whether a terminal is attached (set automaticaly at runtime).
+  , configLogPrintSource             :: Flag LogPrintSource  -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
+  , configLogFormatter               :: LogFormatter         -- ^ Log formatter to use (set automatically at runtime).
+  , configSHA                        :: String               -- ^ SHA to include in log messages (set automatically).
+  , configFailParsingForTesting      :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False).
+  , configOptions                    :: Options              -- ^ Options configurable via command line arguments.
   }
 
 -- Options configurable via command line arguments.
@@ -85,6 +86,7 @@ defaultConfig options@Options{..} = do
   (statsHost, statsPort) <- lookupStatsAddr
   size <- envLookupNum 1000 "MAX_TELEMETRY_QUEUE_SIZE"
   parseTimeout <- envLookupNum 6000 "TREE_SITTER_PARSE_TIMEOUT"
+  unmarshalTimeout <- envLookupNum 4000 "TREE_SITTER_UNMARSHAL_TIMEOUT"
   assignTimeout <- envLookupNum 4000 "SEMANTIC_ASSIGNMENT_TIMEOUT"
   pure Config
     { configAppName = "semantic"
@@ -94,6 +96,7 @@ defaultConfig options@Options{..} = do
     , configStatsPort = statsPort
 
     , configTreeSitterParseTimeout = fromMilliseconds parseTimeout
+    , configTreeSitterUnmarshalTimeout = fromMilliseconds unmarshalTimeout
     , configAssignmentTimeout = fromMilliseconds assignTimeout
     , configMaxTelemetyQueueSize = size
     , configIsTerminal = flag IsTerminal isTerminal

src/Semantic/Graph.hs

@@ -43,6 +43,7 @@ import Prelude hiding (readFile)
 import           Analysis.Abstract.Caching.FlowInsensitive
 import           Analysis.Abstract.Collecting
 import           Analysis.Abstract.Graph as Graph
+import           Analysis.File
 import           Control.Abstract hiding (String)
 import           Control.Abstract.PythonPackage as PythonPackage
 import           Control.Algebra
@@ -68,7 +69,7 @@ import           Data.Blob
 import           Data.Graph
 import           Data.Graph.ControlFlowVertex (VertexDeclaration)
 import           Data.Language as Language
-import           Data.List (isPrefixOf, isSuffixOf)
+import           Data.List (isPrefixOf)
 import qualified Data.Map as Map
 import           Data.Project
 import           Data.Text (pack, unpack)
@@ -81,6 +82,7 @@ import           Semantic.Task as Task
 import           Source.Loc as Loc
 import           Source.Span
 import           System.FilePath.Posix (takeDirectory, (</>))
+import qualified System.Path as Path
 import           Text.Show.Pretty (ppShow)
 
 data GraphType = ImportGraph | CallGraph
@@ -334,8 +336,9 @@ parsePythonPackage parser project = do
                                         ]
     PythonPackage.FindPackages excludeDirs -> do
       trace "In Graph.FindPackages"
-      let initFiles = filter (("__init__.py" `isSuffixOf`) . filePath) (projectFiles project)
-      let packageDirs = filter (`notElem` ((projectRootDir project </>) . unpack <$> excludeDirs)) (takeDirectory . filePath <$> initFiles)
+      let initFiles = filter (isInit . filePath) (projectFiles project)
+          isInit = (== Path.relFile "__init__.py") . Path.takeFileName
+          packageDirs = filter (`notElem` ((projectRootDir project </>) . unpack <$> excludeDirs)) (takeDirectory . Path.toString . filePath <$> initFiles)
       packageFromProject project [ blob | dir <- packageDirs
                                         , blob <- projectBlobs project
                                         , dir `isPrefixOf` blobPath blob

src/Semantic/IO.hs

@@ -1,4 +1,8 @@
-{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Semantic.IO
   ( isDirectory
   , findFilesInDir
@@ -7,7 +11,6 @@ module Semantic.IO
 import Prelude hiding (readFile)
 import Prologue
 
-import           Data.Language
 import           System.Directory (doesDirectoryExist)
 import           System.Directory.Tree (AnchoredDirTree (..))
 import qualified System.Directory.Tree as Tree
@@ -18,6 +21,9 @@ import qualified System.Path.PartClass as Path.PartClass
 isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path)
 
+pathIsMinified :: FilePath -> Bool
+pathIsMinified = isExtensionOf ".min.js"
+
 -- Recursively find files in a directory.
 findFilesInDir :: (Path.PartClass.AbsRel ar, MonadIO m) => Path.Dir ar -> [String] -> [Path.Dir ar] -> m [Path.File ar]
 findFilesInDir path exts excludeDirs = do

src/Semantic/Resolution.hs

@@ -1,4 +1,16 @@
-{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Semantic.Resolution
   ( Resolution (..)
   , nodeJSResolutionMap
@@ -7,6 +19,7 @@ module Semantic.Resolution
   , ResolutionC(..)
   ) where
 
+import           Analysis.File as File
 import           Control.Algebra
 import           Data.Aeson
 import           Data.Aeson.Types (parseMaybe)
@@ -21,10 +34,10 @@ import           System.FilePath.Posix
 import qualified System.Path as Path
 
 
-nodeJSResolutionMap :: (Has Files sig m, MonadIO m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
+nodeJSResolutionMap :: Has Files sig m => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
 nodeJSResolutionMap rootDir prop excludeDirs = do
   files <- findFiles (Path.absRel rootDir) [".json"] (fmap Path.absRel excludeDirs)
-  let packageFiles = fileForTypedPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files
+  let packageFiles = File.fromPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files
   blobs <- readBlobs (FilesFromPaths packageFiles)
   pure $ fold (mapMaybe (lookup prop) blobs)
   where

src/Semantic/Task/Files.hs

@@ -1,6 +1,15 @@
-{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs,
-             GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeOperators,
-             UndecidableInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Semantic.Task.Files
   ( Files
@@ -18,6 +27,7 @@ module Semantic.Task.Files
   , FilesArg(..)
   ) where
 
+import           Analysis.File
 import           Control.Algebra
 import           Control.Effect.Error
 import           Data.Blob
@@ -34,10 +44,10 @@ import qualified System.Path as Path
 import qualified System.Path.IO as IO (withBinaryFile)
 
 data Source blob where
-  FromPath       :: File                            -> Source Blob
+  FromPath       :: File Language                   -> Source Blob
   FromHandle     :: Handle 'IO.ReadMode             -> Source [Blob]
   FromDir        :: Path.AbsRelDir                  -> Source [Blob]
-  FromPathPair   :: File -> File                    -> Source BlobPair
+  FromPathPair   :: File Language -> File Language  -> Source BlobPair
   FromPairHandle :: Handle 'IO.ReadMode             -> Source [BlobPair]
 
 data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)
@@ -83,26 +93,21 @@ instance (Has (Error SomeException) sig m, MonadFail m, MonadIO m) => Algebra (F
     Write (ToPath path) builder k                             -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k
     Write (ToHandle (WriteHandle handle)) builder k           -> liftIO (B.hPutBuilder handle builder) >> k
 
-readBlob :: Has Files sig m => File -> m Blob
+readBlob :: Has Files sig m => File Language -> m Blob
 readBlob file = send (Read (FromPath file) pure)
 
 -- Various ways to read in files
 data FilesArg
   = FilesFromHandle (Handle 'IO.ReadMode)
-  | FilesFromPaths [File]
+  | FilesFromPaths [File Language]
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
-readBlobs :: (Has Files sig m, MonadIO m) => FilesArg -> m [Blob]
+readBlobs :: Has Files sig m => FilesArg -> m [Blob]
 readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure)
-readBlobs (FilesFromPaths [path]) = do
-  isDir <- isDirectory (filePath path)
-  if isDir
-    then send (Read (FromDir (Path.path (filePath path))) pure)
-    else pure <$> send (Read (FromPath path) pure)
-readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
+readBlobs (FilesFromPaths paths)   = traverse (send . flip Read pure . FromPath) paths
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair]
+readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File Language, File Language)] -> m [BlobPair]
 readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
 readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths
 

src/Semantic/Util.hs

@@ -1,4 +1,10 @@
-{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, PartialTypeSignatures, TypeApplications, TypeOperators #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-}
 module Semantic.Util
   ( evaluateProject'
@@ -11,14 +17,15 @@ module Semantic.Util
 
 import Prelude hiding (readFile)
 
+import           Analysis.File
 import           Control.Abstract
 import           Control.Carrier.Fresh.Strict
-import           Control.Carrier.Parse.Simple
 import           Control.Carrier.Lift
-import           Control.Carrier.Trace.Printing
+import           Control.Carrier.Parse.Simple
 import           Control.Carrier.Reader
 import           Control.Carrier.Resumable.Either (SomeError (..))
 import           Control.Carrier.State.Strict
+import           Control.Carrier.Trace.Printing
 import           Control.Lens.Getter
 import           Data.Abstract.Address.Precise as Precise
 import           Data.Abstract.Evaluatable
@@ -26,7 +33,6 @@ import           Data.Abstract.Module
 import qualified Data.Abstract.ModuleTable as ModuleTable
 import           Data.Abstract.Package
 import           Data.Abstract.Value.Concrete as Concrete
-import           Data.Blob
 import           Data.Blob.IO
 import           Data.Graph (topologicalSort)
 import qualified Data.Language as Language
@@ -39,9 +45,10 @@ import           Semantic.Analysis
 import           Semantic.Config
 import           Semantic.Graph
 import           Semantic.Task
-import           Source.Span (HasSpan(..))
+import           Source.Span (HasSpan (..))
 import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
+import qualified System.Path as Path
 
 justEvaluating :: Evaluator term Precise (Value term Precise) _ result
                -> IO ( Heap Precise Precise (Value term Precise),
@@ -69,7 +76,7 @@ justEvaluating
 evaluateProject' session proxy parser paths = do
   let lang = Language.reflect proxy
   res <- runTask session $ asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout $ do
-    blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths)
+    blobs <- catMaybes <$> traverse readBlobFromFile (fileForPath <$> paths)
     package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
     modules <- topologicalSort <$> runImportGraphToModules proxy package
     trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
@@ -86,6 +93,9 @@ parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
 parseFile      parser = runTask'     . (parse parser <=< readBlob . fileForPath)
 parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
 
+fileForPath :: FilePath -> File Language.Language
+fileForPath (Path.absRel -> p) = File p lowerBound (Language.forPath p)
+
 runTask', runTaskQuiet :: ParseC TaskC a -> IO a
 runTask'     task = runTaskWithOptions debugOptions   (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
 runTaskQuiet task = runTaskWithOptions defaultOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure

test/Data/Language/Spec.hs

@@ -1,8 +1,9 @@
 module Data.Language.Spec (testTree) where
 
-import Data.Language
-import Test.Tasty
-import Test.Tasty.HUnit
+import           Data.Language as Language
+import qualified System.Path as Path
+import           Test.Tasty
+import           Test.Tasty.HUnit
 
 testTree :: TestTree
 testTree = testGroup "Data.Language"
@@ -13,7 +14,7 @@ testTree = testGroup "Data.Language"
       codeNavLanguages @=? [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
 
   , testCase "languageForFilePath works for languages with ambiguous lingo extensions" $ do
-      languageForFilePath "foo.php" @=? PHP
-      languageForFilePath "foo.md" @=? Markdown
-      languageForFilePath "foo.tsx" @=? TSX
+      Language.forPath (Path.relFile "foo.php") @=? PHP
+      Language.forPath (Path.relFile "foo.md" ) @=? Markdown
+      Language.forPath (Path.relFile "foo.tsx") @=? TSX
   ]

test/Examples.hs

@@ -1,13 +1,14 @@
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -O1 #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-}
 module Main (main) where
 
+import qualified Analysis.File as File
 import           Control.Carrier.Parse.Measured
 import           Control.Carrier.Reader
 import           Control.Concurrent.Async (forConcurrently)
@@ -16,9 +17,9 @@ import           Control.Lens
 import           Control.Monad
 import           Data.Blob
 import           Data.Foldable
+import           Data.Int
 import           Data.Language (LanguageMode (..), PerLanguageModes (..))
 import           Data.List
-import           Data.Int
 import qualified Data.Text as Text
 import           Data.Traversable
 import           System.FilePath.Glob
@@ -174,7 +175,7 @@ buildExamples session lang tsDir = do
     assertOK msg = either (\e -> HUnit.assertFailure (msg <> " failed to parse" <> show e)) (refuteErrors msg)
     refuteErrors msg a = case toList (a^.files) of
       [x] | (e:_) <- toList (x^.errors) -> HUnit.assertFailure (msg <> " parse errors " <> show e)
-      _ -> pure ()
+      _                                 -> pure ()
 
     assertMatch a b = case (a, b) of
       (Right a, Right b) -> case (toList (a^.files), toList (b^.files)) of
@@ -307,4 +308,4 @@ parseSymbolsFilePath ::
   => PerLanguageModes
   -> Path.RelFile
   -> m ParseTreeSymbolResponse
-parseSymbolsFilePath languageModes path = readBlob (fileForTypedPath path) >>= runReader languageModes . parseSymbols . pure @[]
+parseSymbolsFilePath languageModes path = readBlob (File.fromPath path) >>= runReader languageModes . parseSymbols . pure @[]

test/Graphing/Calls/Spec.hs

@@ -1,4 +1,8 @@
-{-# LANGUAGE DataKinds, GADTs, OverloadedStrings, PackageImports, TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Graphing.Calls.Spec ( spec ) where
 
@@ -7,6 +11,7 @@ import SpecHelpers
 
 import Algebra.Graph
 
+import qualified Analysis.File as File
 import           Control.Effect.Parse
 import           "semantic" Data.Graph (Graph (..), topologicalSort)
 import           Data.Graph.ControlFlowVertex
@@ -19,7 +24,7 @@ callGraphPythonProject path = runTaskOrDie $ do
   let proxy = Proxy @'Language.Python
       lang = Language.Python
   SomeParser parser <- pure . fromJust $! parserForLanguage analysisParsers Language.Python
-  blob <- readBlobFromFile' (fileForTypedPath path)
+  blob <- readBlobFromFile' (File.fromPath path)
   package <- fmap snd <$> parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   runCallGraph proxy False modules package

test/Parsing/Spec.hs

@@ -1,21 +1,22 @@
 {-# LANGUAGE TypeApplications #-}
 module Parsing.Spec (spec) where
 
-import Data.Blob
-import Data.ByteString.Char8 (pack)
-import Data.Duration
-import Data.Either
-import Data.Language
-import Parsing.TreeSitter
-import Source.Source
-import SpecHelpers
-import TreeSitter.JSON (Grammar, tree_sitter_json)
+import           Data.Blob
+import           Data.ByteString.Char8 (pack)
+import           Data.Duration
+import           Data.Either
+import           Data.Language
+import           Parsing.TreeSitter
+import           Source.Source
+import           SpecHelpers
+import qualified System.Path as Path
+import           TreeSitter.JSON (Grammar, tree_sitter_json)
 
 spec :: Spec
 spec = do
   describe "parseToAST" $ do
     let source = toJSONSource [1 :: Int .. 10000]
-    let largeBlob = sourceBlob "large.json" JSON source
+    let largeBlob = fromSource (Path.relFile "large.json") JSON source
 
     it "returns a result when the timeout does not expire" $ do
       let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout

test/Rendering/TOC/Spec.hs

@@ -141,7 +141,7 @@ spec = do
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
-      runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":3}}}]}]}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":3,\"column\":1}}}]}]}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
       blobs <- blobsForPaths (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb")

test/Semantic/CLI/Spec.hs

@@ -1,14 +1,16 @@
 module Semantic.CLI.Spec (testTree) where
 
+import           Analysis.File
 import           Control.Carrier.Parse.Simple
 import           Control.Carrier.Reader
 import           Data.ByteString.Builder
+import           Data.Language
 import           Semantic.Api hiding (Blob, BlobPair, File)
 import           Semantic.Task
 import           Serializing.Format
 import           System.IO.Unsafe
-import qualified System.Path as Path
 import           System.Path ((</>))
+import qualified System.Path as Path
 import qualified System.Path.Directory as Path
 
 import SpecHelpers
@@ -34,7 +36,7 @@ renderDiff ref new = unsafePerformIO $ do
     else ["git", "diff", ref, new]
 {-# NOINLINE renderDiff #-}
 
-testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile) -> TestTree
+testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile) -> TestTree
 testForDiffFixture (diffRenderer, runDiff, files, expected) =
   goldenVsStringDiff
     ("diff fixture renders to " <> diffRenderer <> " " <> show files)
@@ -42,7 +44,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) =
     (Path.toString expected)
     (fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff)
 
-testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile) -> TestTree
+testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile) -> TestTree
 testForParseFixture (format, runParse, files, expected) =
   goldenVsStringDiff
     ("diff fixture renders to " <> format)
@@ -50,7 +52,7 @@ testForParseFixture (format, runParse, files, expected) =
     (Path.toString expected)
     (fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse)
 
-parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile)]
+parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile)]
 parseFixtures =
   [ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt")
   , ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json")
@@ -59,18 +61,18 @@ parseFixtures =
   , ("symbols", run . parseSymbolsBuilder Serializing.Format.JSON, path'', prefix </> Path.file "parse-tree.symbols.json")
   , ("protobuf symbols", run . parseSymbolsBuilder Serializing.Format.Proto, path'', prefix </> Path.file "parse-tree.symbols.protobuf.bin")
   ]
-  where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby]
-        path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby]
-        path'' = [File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby]
+  where path = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby]
+        path' = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby, File (Path.absRel"test/fixtures/ruby/corpus/and-or.B.rb") lowerBound Ruby]
+        path'' = [File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby]
         prefix = Path.relDir "test/fixtures/cli"
         run = runReader defaultLanguageModes
 
-diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile)]
+diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile)]
 diffFixtures =
   [ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
   , ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")
   , ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json")
   , ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin")
   ]
-  where pathMode = [(File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby, File "test/fixtures/ruby/corpus/method-declaration.B.rb"  Ruby)]
+  where pathMode = [(File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby, File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.B.rb") lowerBound Ruby)]
         prefix = Path.relDir "test/fixtures/cli"

test/Semantic/IO/Spec.hs

@@ -4,23 +4,25 @@ module Semantic.IO.Spec (spec) where
 
 import Prelude hiding (readFile)
 
-import           Data.Blob
+import           Analysis.File as File
+import           Data.Blob as Blob
 import           Data.Handle
 import           SpecHelpers
+import qualified System.Path as Path
 
 spec :: Spec
 spec = do
   describe "readFile" $ do
     it "returns a blob for extant files" $ do
-      Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
+      Just blob <- readBlobFromFile (File (Path.absRel "semantic.cabal") lowerBound Unknown)
       blobPath blob `shouldBe` "semantic.cabal"
 
     it "throws for absent files" $ do
-      readBlobFromFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException
+      readBlobFromFile (File (Path.absRel "/dev/doesnotexist") lowerBound Unknown) `shouldThrow` anyIOException
 
   describe "readBlobPairsFromHandle" $ do
-    let a = sourceBlob "method.rb" Ruby "def foo; end"
-    let b = sourceBlob "method.rb" Ruby "def bar(x); end"
+    let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end"
+    let b = Blob.fromSource (Path.relFile "method.rb") Ruby "def bar(x); end"
     it "returns blobs for valid JSON encoded diff input" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
       blobs `shouldBe` [Compare a b]
@@ -45,7 +47,7 @@ spec = do
     it "returns blobs for unsupported language" $ do
       h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json"
       blobs <- readBlobPairsFromHandle h
-      let b' = sourceBlob "test.kt" Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
+      let b' = Blob.fromSource (Path.relFile "test.kt") Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
       blobs `shouldBe` [Insert b']
 
     it "detects language based on filepath for empty language" $ do
@@ -68,7 +70,7 @@ spec = do
     it "returns blobs for valid JSON encoded parse input" $ do
       h <- openFileForReading "test/fixtures/cli/parse.json"
       blobs <- readBlobsFromHandle h
-      let a = sourceBlob "method.rb" Ruby "def foo; end"
+      let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end"
       blobs `shouldBe` [a]
 
     it "throws on blank input" $ do

test/Semantic/Spec.hs

@@ -1,20 +1,23 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Semantic.Spec (spec) where
 
-import Control.Carrier.Reader
-import Control.Exception (fromException)
-import SpecHelpers
+import           Analysis.File
+import           Control.Carrier.Reader
+import           Control.Exception (fromException)
+import qualified Data.Blob as Blob
+import           SpecHelpers
+import qualified System.Path as Path
 
 import Semantic.Api hiding (Blob)
 
  -- we need some lenses here, oof
 setBlobLanguage :: Language -> Blob -> Blob
-setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }}
+setBlobLanguage lang b = b { blobFile = (blobFile b) { fileBody = lang }}
 
 spec :: Spec
 spec = do
   describe "parseBlob" $ do
-    let methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty
+    let methodsBlob = Blob.fromSource (Path.relFile "methods.rb") Ruby "def foo\nend\n"
 
     it "returns error if given an unknown language (json)" $ do
       output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ]
@@ -23,8 +26,8 @@ spec = do
     it "throws if given an unknown language for sexpression output" $ do
       res <- runTaskWithOptions defaultOptions (runReader defaultLanguageModes (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob])))
       case res of
-        Left exc    -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb")
-        Right _bad  -> fail "Expected parseTermBuilder to fail for an unknown language"
+        Left exc   -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb")
+        Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language"
 
     it "renders with the specified renderer" $ do
       output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermSExpression [methodsBlob]

test/SpecHelpers.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE DataKinds, FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module SpecHelpers
@@ -23,63 +24,64 @@ module SpecHelpers
 , evaluateProject
 ) where
 
-import Control.Abstract
-import Control.Carrier.Fresh.Strict
-import Control.Carrier.Parse.Simple
-import Control.Carrier.Reader as X
+import qualified Analysis.File as File
+import           Control.Abstract
+import           Control.Carrier.Fresh.Strict
+import           Control.Carrier.Lift
+import           Control.Carrier.Parse.Simple
+import           Control.Carrier.Reader as X
+import           Control.Carrier.Resumable.Either
+import           Control.Carrier.State.Strict
 import qualified Control.Carrier.Trace.Ignoring as Trace.Ignoring
-import Control.Carrier.Resumable.Either
-import Control.Carrier.Lift
-import Control.Carrier.State.Strict
-import Control.Exception (displayException)
-import Control.Monad as X
-import Data.Abstract.Address.Precise as X
-import Data.Abstract.Evaluatable
-import Data.Abstract.FreeVariables as X
+import           Control.Exception (displayException)
+import           Control.Monad as X
+import           Data.Abstract.Address.Precise as X
+import           Data.Abstract.Evaluatable
+import           Data.Abstract.FreeVariables as X
 import qualified Data.Abstract.Heap as Heap
-import Data.Abstract.Module as X
-import Data.Abstract.ModuleTable as X hiding (lookup)
-import Data.Abstract.Name as X
+import           Data.Abstract.Module as X
+import           Data.Abstract.ModuleTable as X hiding (lookup)
+import           Data.Abstract.Name as X
 import qualified Data.Abstract.ScopeGraph as ScopeGraph
-import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError)
-import Data.Blob as X
-import Data.Blob.IO as X
-import Data.ByteString as X (ByteString)
-import Data.ByteString.Builder (Builder, toLazyByteString)
-import Data.ByteString.Lazy (toStrict)
-import Data.Edit as X
-import Data.Foldable (toList)
-import Data.Functor.Listable as X
-import Data.Language as X hiding (Precise)
-import Data.List.NonEmpty as X (NonEmpty(..))
-import Data.Maybe as X
-import Data.Monoid as X (Monoid(..), First(..), Last(..))
-import Data.Project as X
-import Data.Proxy as X
-import Data.Semigroup as X (Semigroup(..))
-import Data.Semilattice.Lower as X
-import Data.String
-import Data.Sum as Sum
-import Data.Term as X
-import Data.Traversable as X (for)
-import Debug.Trace as X (traceShowM, traceM)
-import Parsing.Parser as X
-import Semantic.Api hiding (File, Blob, BlobPair)
-import Semantic.Config (Config(..), optionsLogLevel)
-import Semantic.Graph (analysisParsers, runHeap, runScopeGraph)
-import Semantic.Task as X
-import Semantic.Telemetry (LogQueue, StatQueue)
-import Semantic.Util as X
-import Source.Range as X hiding (start, end, point)
-import Source.Source as X (Source)
-import Source.Span as X hiding (HasSpan(..), start, end, point)
-import System.Exit (die)
+import           Data.Abstract.Value.Concrete (Value (..), ValueError, runValueError)
+import           Data.Blob as X
+import           Data.Blob.IO as X
+import           Data.ByteString as X (ByteString)
+import           Data.ByteString.Builder (Builder, toLazyByteString)
+import           Data.ByteString.Lazy (toStrict)
+import           Data.Edit as X
+import           Data.Foldable (toList)
+import           Data.Functor.Listable as X
+import           Data.Language as X hiding (Precise)
+import           Data.List.NonEmpty as X (NonEmpty (..))
+import           Data.Maybe as X
+import           Data.Monoid as X (First (..), Last (..), Monoid (..))
+import           Data.Project as X
+import           Data.Proxy as X
+import           Data.Semigroup as X (Semigroup (..))
+import           Data.Semilattice.Lower as X
+import           Data.String
+import           Data.Sum as Sum
+import           Data.Term as X
+import           Data.Traversable as X (for)
+import           Debug.Trace as X (traceM, traceShowM)
+import           Parsing.Parser as X
+import           Semantic.Api hiding (Blob, BlobPair, File)
+import           Semantic.Config (Config (..), optionsLogLevel)
+import           Semantic.Graph (analysisParsers, runHeap, runScopeGraph)
+import           Semantic.Task as X
+import           Semantic.Telemetry (LogQueue, StatQueue)
+import           Semantic.Util as X
+import           Source.Range as X hiding (end, point, start)
+import           Source.Source as X (Source)
+import           Source.Span as X hiding (HasSpan (..), end, point, start)
+import           System.Exit (die)
 import qualified System.Path as Path
-import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO)
-import Test.Hspec.Expectations as X
-import Test.Hspec.LeanCheck as X
-import Test.LeanCheck as X
-import Unsafe.Coerce (unsafeCoerce)
+import           Test.Hspec as X (Spec, SpecWith, around, context, describe, it, parallel, pendingWith, runIO, xit)
+import           Test.Hspec.Expectations as X
+import           Test.Hspec.LeanCheck as X
+import           Test.LeanCheck as X
+import           Unsafe.Coerce (unsafeCoerce)
 
 runBuilder :: Builder -> ByteString
 runBuilder = toStrict . toLazyByteString
@@ -99,7 +101,7 @@ diffFilePaths session p1 p2 = do
 -- | Returns an s-expression parse tree for the specified path.
 parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
 parseFilePath session path = do
-  blob <- readBlobFromFile (fileForTypedPath path)
+  blob <- readBlobFromFile (File.fromPath path)
   res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader defaultLanguageModes $ parseTermBuilder TermSExpression (toList blob)
   pure (runBuilder <$> res)
 
@@ -108,7 +110,7 @@ runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> run
 
 -- | Read two files to a BlobPair.
 readFilePathPair :: Path.RelFile -> Path.RelFile -> IO BlobPair
-readFilePathPair p1 p2 = readFilePair (fileForTypedPath p1) (fileForTypedPath p2)
+readFilePathPair p1 p2 = readFilePair (File.fromPath p1) (File.fromPath p2)
 
 -- Run a Task and call `die` if it returns an Exception.
 runTaskOrDie :: ParseC TaskC a -> IO a

test/Tags/Spec.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Tags.Spec (spec) where
 
-import Control.Carrier.Reader
-import Semantic.Api.Symbols
-import Source.Loc
-import SpecHelpers
+import qualified Analysis.File as File
+import           Control.Carrier.Reader
+import           Semantic.Api.Symbols
+import           Source.Loc
+import           SpecHelpers
 import qualified System.Path as Path
-import Tags.Tagging as Tags
+import           Tags.Tagging as Tags
 
 spec :: Spec
 spec = do
@@ -90,4 +91,4 @@ spec = do
         ]
 
 parseTestFile :: Foldable t => t Tags.Kind -> Path.RelFile -> IO [Tag]
-parseTestFile include path = runTaskOrDie $ readBlob (fileForPath (Path.toString path)) >>= runReader defaultLanguageModes . fmap (filter ((`elem` include) . kind)) . tagsForBlob
+parseTestFile include path = runTaskOrDie $ readBlob (File.fromPath path) >>= runReader defaultLanguageModes . fmap (filter ((`elem` include) . kind)) . tagsForBlob