github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into speed-up-foldMapA

Browse Source
This commit is contained in:
Patrick Thomson 2019-09-21 08:56:52 -04:00 committed by GitHub
commit bcedb937db
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
96 changed files with 999 additions and 1015 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -39,6 +39,8 @@ script:
- cabal new-run semantic-core:spec
- cabal new-run semantic-core:doctest
- cabal new-run semantic-python:test
- cabal new-run semantic-source:test
- cabal new-run semantic-source:doctest
# parse-examples is disabled because it slaughters our CI
# - cabal new-run semantic:parse-examples

2
cabal.project
View File

@ -1,4 +1,4 @@
packages: . semantic-core semantic-python
packages: . semantic-core semantic-python semantic-source
jobs: $ncpus

4
docs/assignment.md
View File

@ -29,7 +29,7 @@ someLanguageConstruct :: Assignment
someLanguageConstruct = makeTerm <$> symbol NodeNameOfSymbolToMatch <*> children (SyntaxDataType <$> field1 <*> field2)
```
The building blocks that compose this DSL come from: `Assigning.Assignment`, explained below.
The building blocks that compose this DSL come from: `Assigning.Assignment`, explained below.
### The underlying machinery of `Assigning.Assignment`
@ -73,7 +73,7 @@ TODO: explain how traversal works in terms of matching/advancing -->
#### Ways to combine assignments
1. The `Functor` instance maps values from the AST (`Location`, `ByteString`, etc.) onto another structure.
1. The `Functor` instance maps values from the AST (`Loc`, `ByteString`, etc.) onto another structure.
2. The `Applicative` instance assigns sequences of (sibling) AST nodes in order, as well as providing `pure` assignments.

2
semantic-core/test/Generators.hs
View File

@ -12,8 +12,6 @@ module Generators
, expr
) where
import Prelude hiding (span)
import Hedgehog hiding (Var)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

21
semantic-source/LICENSE Normal file
View File

@ -0,0 +1,21 @@
MIT License
Copyright (c) 2015-2019 GitHub
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

18
semantic-source/README.md Normal file
View File

@ -0,0 +1,18 @@
# semantic-source
Types and functionality for working with source code (program text).
## Development
This project consists of a Haskell package named `semantic-source`. The library’s sources are in [`src`][].
Development of `semantic-source` is typically done using `cabal v2-build`:
```shell
cabal v2-build # build the library
cabal v2-repl # load the package into ghci
cabal v2-test # build and run the doctests
```
[`src`]: https://github.com/github/semantic/tree/master/semantic-source/src

2
semantic-source/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

88
semantic-source/semantic-source.cabal Normal file
View File

@ -0,0 +1,88 @@
cabal-version: 2.4
name: semantic-source
version: 0.0.0.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
bug-reports: https://github.com/github/semantic/issues
license: MIT
license-file: LICENSE
author: The Semantic authors
maintainer: opensource+semantic@github.com
copyright: (c) 2019 GitHub, Inc.
category: Data
build-type: Simple
stability: alpha
extra-source-files:
README.md
tested-with:
GHC == 8.6.5
common common
default-language: Haskell2010
ghc-options:
-Weverything
-Wno-missing-local-signatures
-Wno-missing-import-lists
-Wno-implicit-prelude
-Wno-safe
-Wno-unsafe
-Wno-name-shadowing
-Wno-monomorphism-restriction
-Wno-missed-specialisations
-Wno-all-missed-specialisations
-Wno-star-is-type
library
import: common
exposed-modules:
Source.Loc
Source.Range
Source.Source
Source.Span
-- other-modules:
-- other-extensions:
build-depends:
aeson ^>= 1.4.2.0
, base >= 4.12 && < 5
, bytestring ^>= 0.10.8.2
, deepseq ^>= 1.4.4.0
, generic-monoid ^>= 0.1.0.0
, hashable ^>= 1.2.7.0
, semilattices ^>= 0.0.0.3
, text ^>= 1.2.3.1
hs-source-dirs: src
test-suite doctest
import: common
type: exitcode-stdio-1.0
main-is: Doctest.hs
build-depends:
base
, doctest >= 0.7 && <1.0
, QuickCheck
, semantic-source
hs-source-dirs: test
test-suite test
import: common
type: exitcode-stdio-1.0
main-is: Test.hs
other-modules:
Source.Test
build-depends:
base
, hedgehog ^>= 1
, semantic-source
, tasty >= 1.2 && <2
, tasty-hedgehog ^>= 1.0.0.1
, tasty-hunit >= 0.10 && <1
, text
hs-source-dirs: test
source-repository head
type: git
location: https://github.com/github/semantic

40
semantic-source/src/Source/Loc.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes #-}
module Source.Loc
( Loc(..)
, byteRange_
, Span(Span)
, Range(Range)
) where
import Control.DeepSeq (NFData)
import Data.Hashable (Hashable)
import Data.Monoid.Generic
import GHC.Generics (Generic)
import Prelude hiding (span)
import Source.Range
import Source.Span
data Loc = Loc
{ byteRange :: {-# UNPACK #-} !Range
, span :: {-# UNPACK #-} !Span
}
deriving (Eq, Ord, Show, Generic)
deriving Semigroup via GenericSemigroup Loc
instance Hashable Loc
instance NFData Loc
instance HasSpan Loc where
span_ = lens span (\l s -> l { span = s })
{-# INLINE span_ #-}
byteRange_ :: Lens' Loc Range
byteRange_ = lens byteRange (\l r -> l { byteRange = r })
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 #-}

62
semantic-source/src/Source/Range.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE DeriveGeneric, RankNTypes #-}
module Source.Range
( Range(..)
, point
, rangeLength
, subtractRange
-- * Lenses
, start_
, end_
) where
import Control.DeepSeq (NFData)
import Data.Hashable (Hashable)
import Data.Semilattice.Lower (Lower(..))
import GHC.Generics (Generic)
-- | A 0-indexed, half-open interval of integers, defined by start & end indices.
data Range = Range
{ start :: {-# UNPACK #-} !Int
, end :: {-# UNPACK #-} !Int
}
deriving (Eq, Generic, Ord, Show)
instance Hashable Range
instance NFData Range
-- $
-- prop> a <> (b <> c) === (a <> b) <> (c :: Range)
instance Semigroup Range where
Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2)
instance Lower Range where
lowerBound = Range 0 0
-- | Construct a 'Range' with a given value for both its start and end indices.
point :: Int -> Range
point i = Range i i
-- | Return the length of the range.
rangeLength :: Range -> Int
rangeLength range = end range - start range
subtractRange :: Range -> Range -> Range
subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Range (start range2) (max (end range1) (end range2))))
start_, end_ :: Lens' Range Int
start_ = lens start (\r s -> r { start = s })
end_ = lens end (\r e -> r { end = e })
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 #-}
-- $setup
-- >>> import Test.QuickCheck
-- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary ; shrink (Range s e) = Range <$> shrink s <*> shrink e

142
semantic-source/src/Source/Source.hs Normal file
View File

@ -0,0 +1,142 @@
{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
{-|
'Source' models source code, represented as a thin wrapper around a 'B.ByteString' with conveniences for splitting by line, slicing, etc.
This module is intended to be imported qualified to avoid name clashes with 'Prelude':
> import qualified Source.Source as Source
-}
module Source.Source
( Source
, bytes
, fromUTF8
-- * Measurement
, Source.Source.length
, Source.Source.null
, totalRange
, totalSpan
-- * En/decoding
, fromText
, toText
-- * Slicing
, slice
, drop
, take
-- * Splitting
, Source.Source.lines
, lineRanges
, lineRangesWithin
, newlineIndices
) where
import Prelude hiding (drop, take)
import Control.Arrow ((&&&))
import Data.Aeson (FromJSON (..), withText)
import qualified Data.ByteString as B
import Data.Char (ord)
import Data.Maybe (fromMaybe)
import Data.Monoid (Last(..))
import Data.Semilattice.Lower
import Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.Generics (Generic)
import Source.Range
import Source.Span (Span(Span), Pos(..))
-- | The contents of a source file. This is represented as a UTF-8
-- 'ByteString' under the hood. Construct these with 'fromUTF8'; obviously,
-- passing 'fromUTF8' non-UTF8 bytes will cause crashes.
newtype Source = Source { bytes :: B.ByteString }
deriving (Eq, Semigroup, Monoid, IsString, Show, Generic)
fromUTF8 :: B.ByteString -> Source
fromUTF8 = Source
instance FromJSON Source where
parseJSON = withText "Source" (pure . fromText)
-- Measurement
length :: Source -> Int
length = B.length . bytes
null :: Source -> Bool
null = B.null . bytes
-- | Return a 'Range' that covers the entire text.
totalRange :: Source -> Range
totalRange = Range 0 . B.length . bytes
-- | Return a 'Span' that covers the entire text.
totalSpan :: Source -> Span
totalSpan source = Span lowerBound (Pos (Prelude.length ranges) (succ (end lastRange - start lastRange))) where
ranges = lineRanges source
lastRange = fromMaybe lowerBound (getLast (foldMap (Last . Just) ranges))
-- En/decoding
-- | Return a 'Source' from a 'Text'.
fromText :: T.Text -> Source
fromText = Source . T.encodeUtf8
-- | Return the Text contained in the 'Source'.
toText :: Source -> T.Text
toText = T.decodeUtf8 . bytes
-- Slicing
-- | Return a 'Source' that contains a slice of the given 'Source'.
slice :: Source -> Range -> Source
slice source range = taking $ dropping source where
dropping = drop (start range)
taking = take (rangeLength range)
drop :: Int -> Source -> Source
drop i = Source . B.drop i . bytes
take :: Int -> Source -> Source
take i = Source . B.take i . bytes
-- Splitting
-- | Split the contents of the source after newlines.
lines :: Source -> [Source]
lines source = slice source <$> lineRanges source
-- | Compute the 'Range's of each line in a 'Source'.
lineRanges :: Source -> [Range]
lineRanges source = lineRangesWithin source (totalRange source)
-- | Compute the 'Range's of each line in a 'Range' of a 'Source'.
lineRangesWithin :: Source -> Range -> [Range]
lineRangesWithin source range
= uncurry (zipWith Range)
. ((start range:) &&& (<> [ end range ]))
. fmap (+ succ (start range))
. newlineIndices
. bytes
$ slice source range
-- | Return all indices of newlines ('\n', '\r', and '\r\n') in the 'ByteString'.
newlineIndices :: B.ByteString -> [Int]
newlineIndices = go 0 where
go n bs
| B.null bs = []
| otherwise = case (searchCR bs, searchLF bs) of
(Nothing, Nothing) -> []
(Just i, Nothing) -> recur n i bs
(Nothing, Just i) -> recur n i bs
(Just crI, Just lfI)
| succ crI == lfI -> recur n lfI bs
| otherwise -> recur n (min crI lfI) bs
recur n i bs = let j = n + i in j : go (succ j) (B.drop (succ i) bs)
searchLF = B.elemIndex (toEnum (ord '\n'))
searchCR = B.elemIndex (toEnum (ord '\r'))
{-# INLINE newlineIndices #-}

116
semantic-source/src/Source/Span.hs Normal file
View File

@ -0,0 +1,116 @@
{-# LANGUAGE DeriveGeneric, OverloadedStrings, RankNTypes #-}
-- | Source position and span information
--
-- Mostly taken from purescript's SourcePos definition.
module Source.Span
( Span(..)
, point
, spanFromSrcLoc
, Pos(..)
, line_
, column_
, HasSpan(..)
) where
import Control.DeepSeq (NFData)
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson as A
import Data.Hashable (Hashable)
import Data.Semilattice.Lower (Lower(..))
import GHC.Generics (Generic)
import GHC.Stack (SrcLoc(..))
-- | A Span of position information
data Span = Span
{ start :: {-# UNPACK #-} !Pos
, end :: {-# UNPACK #-} !Pos
}
deriving (Eq, Ord, Generic, Show)
instance Hashable Span
instance NFData Span
instance Semigroup Span where
Span start1 end1 <> Span start2 end2 = Span (min start1 start2) (max end1 end2)
instance A.ToJSON Span where
toJSON s = A.object
[ "start" .= start s
, "end" .= end s
]
instance A.FromJSON Span where
parseJSON = A.withObject "Span" $ \o -> Span
<$> o .: "start"
<*> o .: "end"
instance Lower Span where
lowerBound = Span lowerBound lowerBound
-- | Construct a Span with a given value for both its start and end positions.
point :: Pos -> Span
point p = Span p p
spanFromSrcLoc :: SrcLoc -> Span
spanFromSrcLoc s = Span (Pos (srcLocStartLine s) (srcLocStartCol s)) (Pos (srcLocEndLine s) (srcLocEndCol s))
-- | Source position information (1-indexed)
data Pos = Pos
{ line :: {-# UNPACK #-} !Int
, column :: {-# UNPACK #-} !Int
}
deriving (Eq, Ord, Generic, Show)
instance Hashable Pos
instance NFData Pos
instance A.ToJSON Pos where
toJSON p = A.toJSON
[ line p
, column p
]
instance A.FromJSON Pos where
parseJSON arr = do
[ line, col ] <- A.parseJSON arr
pure $ Pos line col
instance Lower Pos where
lowerBound = Pos 1 1
line_, column_ :: Lens' Pos Int
line_ = lens line (\p l -> p { line = l })
column_ = lens column (\p l -> p { column = l })
-- | "Classy-fields" interface for data types that have spans.
class HasSpan a where
span_ :: Lens' a Span
start_ :: Lens' a Pos
start_ = span_.start_
{-# INLINE start_ #-}
end_ :: Lens' a Pos
end_ = span_.end_
{-# INLINE end_ #-}
instance HasSpan Span where
span_ = id
{-# INLINE span_ #-}
start_ = lens start (\s t -> s { start = t })
{-# INLINE start_ #-}
end_ = lens end (\s t -> s { end = t })
{-# INLINE end_ #-}
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 #-}

12
semantic-source/test/Doctest.hs Normal file
View File

@ -0,0 +1,12 @@
module Main
( main
) where
import System.Environment
import Test.DocTest
main :: IO ()
main = do
args <- getArgs
autogen <- fmap (<> "/build/doctest/autogen") <$> lookupEnv "HASKELL_DIST_DIR"
doctest (maybe id ((:) . ("-i" <>)) autogen ("-isemantic-source/src" : "--fast" : if null args then ["semantic-source/src"] else args))

60
semantic-source/test/Source/Test.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE OverloadedStrings #-}
module Source.Test
( testTree
) where
import qualified Data.Text as Text
import Hedgehog hiding (Range)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import qualified Source.Source as Source
import Source.Span
import qualified Test.Tasty as Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog (testProperty)
source :: MonadGen m => Range.Range Int -> m Source.Source
source r = Gen.frequency [ (1, empty), (20, nonEmpty) ] where
empty = pure mempty
nonEmpty = Source.fromUTF8 <$> Gen.utf8 r (Gen.frequency [ (1, pure '\r'), (1, pure '\n'), (20, Gen.unicode) ])
testTree :: Tasty.TestTree
testTree = Tasty.testGroup "Data.Source"
[ Tasty.testGroup "lineRanges"
[ testProperty "produces 1 more range than there are newlines" . property $ do
source <- forAll (source (Range.linear 0 100))
summarize source
length (Source.lineRanges source) === length (Text.splitOn "\r\n" (Source.toText source) >>= Text.splitOn "\r" >>= Text.splitOn "\n")
, testProperty "produces exhaustive ranges" . property $ do
source <- forAll (source (Range.linear 0 100))
summarize source
foldMap (Source.slice source) (Source.lineRanges source) === source
]
, Tasty.testGroup "totalSpan"
[ testProperty "covers single lines" . property $ do
n <- forAll $ Gen.int (Range.linear 0 100)
Source.totalSpan (Source.fromText (Text.replicate n "*")) === Span (Pos 1 1) (Pos 1 (max 1 (succ n)))
, testProperty "covers multiple lines" . property $ do
n <- forAll $ Gen.int (Range.linear 0 100)
Source.totalSpan (Source.fromText (Text.intersperse '\n' (Text.replicate n "*"))) === Span (Pos 1 1) (Pos (max 1 n) (if n > 0 then 2 else 1))
]
, Tasty.testGroup "newlineIndices"
[ testCase "finds \\n" $ Source.newlineIndices "a\nb" @?= [1]
, testCase "finds \\r" $ Source.newlineIndices "a\rb" @?= [1]
, testCase "finds \\r\\n" $ Source.newlineIndices "a\r\nb" @?= [2]
, testCase "finds intermixed line endings" $ Source.newlineIndices "hi\r}\r}\n xxx \r a" @?= [2, 4, 6, 12]
]
]
summarize :: Source.Source -> PropertyT IO ()
summarize src = do
let lines = Source.lines src
-- FIXME: this should be using cover (reverted in 1b427b995), but that leads to flaky tests: hedgehog’s 'cover' implementation fails tests instead of warning, and currently has no equivalent to 'checkCoverage'.
classify "empty" $ Source.null src
classify "single-line" $ length lines == 1
classify "multiple lines" $ length lines > 1

11
semantic-source/test/Test.hs Normal file
View File

@ -0,0 +1,11 @@
module Main
( main
) where
import qualified Source.Test as Source
import Test.Tasty as Tasty
main :: IO ()
main = defaultMain $ testGroup "semantic-source"
[ Source.testTree
]

7
semantic.cabal
View File

@ -65,6 +65,7 @@ common dependencies
, recursion-schemes ^>= 5.1
, scientific ^>= 0.3.6.2
, safe-exceptions ^>= 0.1.7.0
, semantic-source ^>= 0.0
, semilattices ^>= 0.0.0.3
, shelly >= 1.5 && <2
, streaming ^>= 0.2.2.0
@ -158,12 +159,10 @@ library
, Data.ImportPath
, Data.JSON.Fields
, Data.Language
, Data.Location
, Data.Map.Monoidal
, Data.Patch
, Data.Project
, Data.Quieterm
, Data.Range
, Data.Reprinting.Errors
, Data.Reprinting.Fragment
, Data.Reprinting.Operator
@ -172,8 +171,6 @@ library
, Data.Reprinting.Token
, Data.Semigroup.App
, Data.Scientific.Exts
, Data.Source
, Data.Span
-- À la carte syntax types
, Data.Syntax
, Data.Syntax.Comment
@ -360,10 +357,8 @@ test-suite test
, Data.Graph.Spec
, Data.Mergeable
, Data.Language.Spec
, Data.Range.Spec
, Data.Scientific.Spec
, Data.Semigroup.App.Spec
, Data.Source.Spec
, Data.Term.Spec
, Diffing.Algorithm.RWS.Spec
, Diffing.Algorithm.SES.Spec

4
src/Analysis/Abstract/Graph.hs
View File

@ -27,10 +27,10 @@ import Data.ByteString.Builder
import Data.Graph
import Data.Graph.ControlFlowVertex
import Data.Term
import Data.Location
import qualified Data.Map as Map
import qualified Data.Text.Encoding as T
import Prologue
import Source.Loc
style :: Style ControlFlowVertex Builder
style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
@ -74,7 +74,7 @@ graphingTerms :: ( Member (Reader ModuleInfo) sig
, Declarations1 syntax
, Ord address
, Foldable syntax
, term ~ Term syntax Location
, term ~ Term syntax Loc
, Carrier sig m
)
=> Open (term -> Evaluator term address value m a)

14
src/Analysis/PackageDef.hs
View File

@ -6,13 +6,13 @@ module Analysis.PackageDef
) where
import Data.Blob
import Data.Location
import Data.Source as Source
import Source.Source as Source
import Data.Sum
import Data.Term
import qualified Data.Text as T
import qualified Language.Go.Syntax
import Prologue
import Source.Loc
newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
deriving (Eq, Generic, Show)
@ -27,7 +27,7 @@ newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
-- If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1.
--
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe PackageDef)
packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe PackageDef)
packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
@ -36,7 +36,7 @@ packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasPackageDef syntax where
-- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
toPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition.
--
@ -50,13 +50,13 @@ instance (PackageDefStrategy syntax ~ strategy, HasPackageDefWithStrategy strate
-- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasPackageDef syntax where
-- | Produce a customized 'PackageDef' for a given syntax node.
customToPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
customToPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
instance CustomHasPackageDef Language.Go.Syntax.Package where
customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _)
= Just $ PackageDef (getSource fromAnn)
where getSource = toText . flip Source.slice blobSource . locationByteRange
where getSource = toText . Source.slice blobSource . byteRange
-- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'.
instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where
@ -70,7 +70,7 @@ data Strategy = Default | Custom
--
-- You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class.
class HasPackageDefWithStrategy (strategy :: Strategy) syntax where
toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.

52
src/Analysis/TOCSummary.hs
View File

@ -13,13 +13,13 @@ import Data.Blob
import Data.Error (Error (..), Colourize (..), showExpectation)
import Data.Flag
import Data.Language as Language
import Data.Location
import Data.Range
import Data.Source as Source
import Source.Source as Source
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Data.Term
import qualified Data.Text as T
import Source.Loc as Loc
import Source.Range
import qualified Language.Markdown.Syntax as Markdown
-- | A declaration’s identifier and type.
@ -42,12 +42,12 @@ data Declaration
--
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
declarationAlgebra :: (Foldable syntax, HasDeclaration syntax)
=> Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe Declaration)
=> Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe Declaration)
declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax
-- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass
class HasDeclaration syntax where
toDeclaration :: (Foldable syntax) => Blob -> Location -> syntax (Term syntax Location, Maybe Declaration) -> Maybe Declaration
toDeclaration :: (Foldable syntax) => Blob -> Loc -> syntax (Term syntax Loc, Maybe Declaration) -> Maybe Declaration
instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
toDeclaration = toDeclaration'
@ -57,7 +57,7 @@ instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasDeclaration' whole syntax where
-- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toDeclaration' :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
toDeclaration' :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition.
--
@ -71,22 +71,22 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy stra
-- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasDeclaration whole syntax where
-- | Produce a customized 'Declaration' for a given syntax node.
customToDeclaration :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
customToDeclaration :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
instance CustomHasDeclaration whole Markdown.Heading where
customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _)
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) (blobLanguage blob) level
where headingText terms = getSource $ maybe (locationByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = locationByteRange ann
getSource = firstLine . toText . flip Source.slice blobSource
= Just $ HeadingDeclaration (headingText terms) mempty (Loc.span ann) (blobLanguage blob) level
where headingText terms = getSource $ maybe (byteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = byteRange ann
getSource = firstLine . toText . Source.slice blobSource
firstLine = T.takeWhile (/= '\n')
-- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
instance CustomHasDeclaration whole Syntax.Error where
customToDeclaration blob@Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) (blobLanguage blob)
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (Loc.span ann) err))) mempty (Loc.span ann) (blobLanguage blob)
where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
@ -95,22 +95,22 @@ instance CustomHasDeclaration whole Declaration.Function where
-- Do not summarize anonymous functions
| isEmpty identifierAnn = Nothing
-- Named functions
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) (blobLanguage blob)
where isEmpty = (== 0) . rangeLength . locationByteRange
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (Loc.span ann) (blobLanguage blob)
where isEmpty = (== 0) . rangeLength . byteRange
functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
-- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
instance CustomHasDeclaration whole Declaration.Method where
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
-- Methods without a receiver
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) Nothing
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) Nothing
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage blob == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverType))
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverType))
-- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn))
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (Loc.span ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn))
where
isEmpty = (== 0) . rangeLength . locationByteRange
isEmpty = (== 0) . rangeLength . byteRange
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
-- When encountering a Declaration-annotated term, we need to extract a Text
@ -118,19 +118,19 @@ instance CustomHasDeclaration whole Declaration.Method where
-- is constructed by slicing out text from the original blob corresponding
-- to a location, which is found via the passed-in rule.
getIdentifier :: Functor m
=> Rewrite (m (Term syntax Location)) (Term syntax Location)
=> Rewrite (m (Term syntax Loc)) (Term syntax Loc)
-> Blob
-> TermF m Location (Term syntax Location, a)
-> TermF m Loc (Term syntax Loc, a)
-> Text
getIdentifier finder Blob{..} (In a r)
= let declRange = locationByteRange a
bodyRange = locationByteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
= let declRange = byteRange a
bodyRange = byteRange <$> rewrite (fmap fst r) (finder >>^ annotation)
-- Text-based gyrations to slice the identifier out of the provided blob source
sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange
sliceFrom = T.stripEnd . toText . Source.slice blobSource . subtractRange declRange
in maybe mempty sliceFrom bodyRange
getSource :: Source -> Location -> Text
getSource blobSource = toText . flip Source.slice blobSource . locationByteRange
getSource :: Source -> Loc -> Text
getSource blobSource = toText . Source.slice blobSource . byteRange
-- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'.
instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where
@ -144,7 +144,7 @@ data Strategy = Default | Custom
--
-- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class.
class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe Declaration) -> Maybe Declaration
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.

36
src/Assigning/Assignment.hs
View File

@ -8,7 +8,7 @@
--
-- 1. 'symbol' rules match a node against a specific symbol in the source language’s grammar; they succeed iff a) there is a current node, and b) its symbol is equal to the argument symbol. Matching a 'symbol' rule does not advance past the current node, meaning that you can match a node against a symbol and also e.g. match against the node’s 'children'. This also means that some care must be taken, as repeating a symbol with 'many' or 'some' (see below) will never advance past the current node and could therefore loop forever.
--
-- 2. 'location' rules always succeed, and produce the current node’s Location (byte Range and Span). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties.
-- 2. 'location' rules always succeed, and produce the current node’s Loc (byte Range and Span). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties.
--
-- 3. 'source' rules succeed whenever there is a current node (i.e. matching has not advanced past the root node or the last child node when operating within a 'children' rule), and produce its source as a ByteString. 'source' is intended to match leaf nodes such as e.g. comments. 'source' rules advance past the current node.
--
@ -20,7 +20,7 @@
--
-- Assignments can further be combined in a few different ways:
--
-- 1. The 'Functor' instance maps values from the AST (Location, ByteString, etc.) into another structure.
-- 1. The 'Functor' instance maps values from the AST (Loc, ByteString, etc.) into another structure.
--
-- 2. The 'Applicative' instance assigns sequences of (sibling) AST nodes in order, as well as providing 'pure' assignments (see above). Most assignments of a single piece of syntax consist of an 'Applicative' chain of assignments.
--
@ -61,7 +61,7 @@
module Assigning.Assignment
-- Types
( Assignment
, L.Location(..)
, L.Loc(..)
-- Combinators
, branchNode
, leafNode
@ -100,13 +100,13 @@ import qualified Assigning.Assignment.Table as Table
import Control.Monad.Except (MonadError (..))
import Data.AST
import Data.Error
import Data.Range
import qualified Data.Location as L
import qualified Data.Source as Source (Source, slice, sourceBytes)
import Data.Span hiding (HasSpan(..))
import qualified Source.Source as Source
import Data.Term
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import qualified Source.Loc as L
import Source.Range as Range
import Source.Span as Span
import Text.Parser.Combinators as Parsers hiding (choice)
import TreeSitter.Language
@ -120,8 +120,8 @@ leafNode sym = symbol sym *> source
-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's.
toTerm :: Element syntax syntaxes
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Location))
-> Assignment ast grammar (Term (Sum syntaxes) L.Location)
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Loc))
-> Assignment ast grammar (Term (Sum syntaxes) L.Loc)
toTerm syntax = termIn <$> location <*> (inject <$> syntax)
@ -132,7 +132,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
data AssignmentF ast grammar a where
End :: AssignmentF ast grammar ()
Location :: AssignmentF ast grammar L.Location
Loc :: AssignmentF ast grammar L.Loc
CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ())
Source :: AssignmentF ast grammar ByteString
Children :: Assignment ast grammar a -> AssignmentF ast grammar a
@ -159,8 +159,8 @@ tracing f = case getCallStack callStack of
-- | Zero-width production of the current location.
--
-- If assigning at the end of input or at the end of a list of children, the location will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node.
location :: Assignment ast grammar L.Location
location = tracing Location `Then` pure
location :: Assignment ast grammar L.Loc
location = tracing Loc `Then` pure
getLocals :: HasCallStack => Assignment ast grammar [Text]
getLocals = tracing GetLocals `Then` pure
@ -174,7 +174,7 @@ currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar)
currentNode = tracing CurrentNode `Then` pure
-- | Zero-width match of a node with the given symbol, producing the current node’s location.
symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location
symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Loc
symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` pure
-- | A rule to produce a node’s source as a ByteString.
@ -213,7 +213,7 @@ choice alternatives
mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
-- | Match and advance past a node with the given symbol.
token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location
token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Loc
token s = symbol s <* advance
@ -261,11 +261,11 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
-> Either (Error (Either String grammar)) (result, State ast grammar)
run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
where atNode (Term (In node f)) = case runTracing t of
Location -> yield (nodeLocation node) state
Loc -> yield (nodeLocation node) state
GetLocals -> yield stateLocals state
PutLocals l -> yield () (state { stateLocals = l })
CurrentNode -> yield (In node (() <$ f)) state
Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
Source -> yield (Source.bytes (Source.slice source (nodeByteRange node))) (advanceState state)
Children child -> do
(a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites })
@ -274,7 +274,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
anywhere node = case runTracing t of
End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield
Location -> yield (L.Location (Range stateOffset stateOffset) (Span statePos statePos)) state
Loc -> yield (L.Loc (Range stateOffset stateOffset) (Span statePos statePos)) state
Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield
Alt (a:as) -> sconcat (flip yield state <$> a:|as)
Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield
@ -305,7 +305,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
-- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
advanceState :: State ast grammar -> State ast grammar
advanceState state@State{..}
| Term (In node _) : rest <- stateNodes = State (end (nodeByteRange node)) (spanEnd (nodeSpan node)) stateCallSites rest stateLocals
| Term (In node _) : rest <- stateNodes = State (Range.end (nodeByteRange node)) (Span.end (nodeSpan node)) stateCallSites rest stateLocals
| otherwise = state
-- | State kept while running 'Assignment's.

22
src/Assigning/Assignment/Deterministic.hs
View File

@ -13,29 +13,29 @@ import Data.AST
import Data.Error
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Range
import Data.Location
import Data.Source as Source
import Data.Span hiding (HasSpan (..))
import Source.Source as Source
import qualified Data.Syntax as Syntax
import Data.Term (Term, termIn, termAnnotation, termOut)
import Data.Text.Encoding (decodeUtf8')
import Prologue
import Source.Loc
import Source.Range as Range
import Source.Span as Span
class (Alternative f, Ord symbol, Show symbol) => Assigning symbol f | f -> symbol where
leafNode :: symbol -> f Text
branchNode :: symbol -> f a -> f a
toTerm :: (Element syntax syntaxes, Element Syntax.Error syntaxes)
=> f (syntax (Term (Sum syntaxes) Location))
-> f (Term (Sum syntaxes) Location)
=> f (syntax (Term (Sum syntaxes) Loc))
-> f (Term (Sum syntaxes) Loc)
parseError :: ( Bounded symbol
, Element Syntax.Error syntaxes
, HasCallStack
, Assigning symbol f
)
=> f (Term (Sum syntaxes) Location)
=> f (Term (Sum syntaxes) Loc)
parseError = toTerm (leafNode maxBound $> Syntax.Error (Syntax.ErrorStack (Syntax.errorSite <$> getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
@ -100,7 +100,7 @@ instance (Enum symbol, Ord symbol, Show symbol) => Assigning symbol (Assignment
leafNode s = Assignment NotNullable (IntSet.singleton (fromEnum s))
[ (s, \ src state _ -> case stateInput state of
[] -> Left (makeError (stateSpan state) [Right s] Nothing)
s:_ -> case decodeUtf8' (sourceBytes (Source.slice (astRange s) src)) of
s:_ -> case decodeUtf8' (Source.bytes (Source.slice src (astRange s))) of
Left err -> Left (makeError (astSpan s) [Left "valid utf-8"] (Just (Left (show err))))
Right text -> Right (advanceState state, text))
]
@ -168,12 +168,12 @@ stateSpan :: State s -> Span
stateSpan state@(State _ _ []) = Span (statePos state) (statePos state)
stateSpan (State _ _ (s:_)) = astSpan s
stateLocation :: State s -> Location
stateLocation state = Location (stateRange state) (stateSpan state)
stateLocation :: State s -> Loc
stateLocation state = Loc (stateRange state) (stateSpan state)
advanceState :: State s -> State s
advanceState state
| s:ss <- stateInput state = State (end (astRange s)) (spanEnd (astSpan s)) ss
| s:ss <- stateInput state = State (Range.end (astRange s)) (Span.end (astSpan s)) ss
| otherwise = state

2
src/Control/Abstract/Context.hs
View File

@ -16,9 +16,9 @@ import Control.Effect.Reader
import Control.Effect.State
import Data.Abstract.Module
import Data.Abstract.Package
import Data.Span
import GHC.Stack
import Prologue
import Source.Span
-- | Get the currently evaluating 'ModuleInfo'.
currentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => m ModuleInfo

4
src/Control/Abstract/Heap.hs
View File

@ -57,8 +57,8 @@ import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.ScopeGraph (Kind(..), Path (..), Relation(..), putDeclarationScopeAtPosition)
import qualified Data.Map.Strict as Map
import Data.Span (Span, emptySpan)
import Prologue
import Source.Span (Span)
-- | Evaluates an action locally the scope and frame of the given frame address.
@ -180,7 +180,7 @@ define :: ( HasCallStack
-> Evaluator term address value m ()
define declaration rel accessControl def = withCurrentCallStack callStack $ do
-- TODO: This span is still wrong.
declare declaration rel accessControl emptySpan Unknown Nothing
declare declaration rel accessControl lowerBound Unknown Nothing
slot <- lookupSlot declaration
value <- def
assign slot value

4
src/Control/Abstract/Modules.hs
View File

@ -26,8 +26,8 @@ import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Language
import qualified Data.Set as Set
import Data.Span
import Prologue
import Source.Span
import System.FilePath.Posix (takeDirectory)
-- A scope address, frame address, and value ref.
@ -125,7 +125,7 @@ runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwLoadError :: (Member (Resumable (BaseError (LoadError address value))) sig, Carrier sig m)
=> LoadError address value resume
-> m resume
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name Unknown mempty) emptySpan err
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name Unknown mempty) lowerBound err
-- TODO: Might be able to get rest of ModuleInfo from the env ^.

5
src/Control/Abstract/Primitive.hs
View File

@ -14,7 +14,6 @@ import Data.Abstract.BaseError
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Name
import Data.Map.Strict as Map
import Data.Span
import Prologue
defineBuiltIn :: ( HasCallStack
@ -43,11 +42,11 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
associatedScope <- newPreludeScope lexicalEdges
-- TODO: This span is still wrong.
declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope)
declare declaration rel accessControl lowerBound ScopeGraph.Unknown (Just associatedScope)
withScope associatedScope $ do
param <- gensym
declare (Declaration param) ScopeGraph.Gensym accessControl emptySpan ScopeGraph.Unknown Nothing
declare (Declaration param) ScopeGraph.Gensym accessControl lowerBound ScopeGraph.Unknown Nothing
slot <- lookupSlot declaration
value <- builtIn associatedScope value

2
src/Control/Abstract/ScopeGraph.hs
View File

@ -50,9 +50,9 @@ import Data.Abstract.Module
import Data.Abstract.Name hiding (name)
import Data.Abstract.ScopeGraph (Kind, Declaration(..), EdgeLabel, Reference, Relation(..), Scope (..), ScopeGraph, Slot(..), Info(..), AccessControl(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Span
import Prelude hiding (lookup)
import Prologue
import Source.Span
lookup :: ( Ord address
, Member (State (ScopeGraph address)) sig

2
src/Control/Abstract/Value.hs
View File

@ -80,9 +80,9 @@ import Data.Abstract.Module
import Data.Abstract.Name
import Data.Abstract.Number (Number, SomeNumber)
import Data.Scientific (Scientific)
import Data.Span
import Prelude hiding (String)
import Prologue hiding (TypeError, hash)
import Source.Span
-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
-- have built-in generalized-comparison ("spaceship") operators. If you want to

10
src/Data/AST.hs
View File

@ -6,18 +6,18 @@ module Data.AST
, AST
) where
import Data.Location
import Data.Term
import Data.Aeson
import Data.Text (pack)
import Data.JSON.Fields
import Source.Loc as Loc
-- | An AST node labelled with symbols and source location.
type AST syntax grammar = Term syntax (Node grammar)
data Node grammar = Node
{ nodeSymbol :: !grammar
, nodeLocation :: {-# UNPACK #-} !Location
, nodeLocation :: {-# UNPACK #-} !Loc
}
deriving (Eq, Ord, Show)
@ -25,11 +25,11 @@ data Node grammar = Node
instance Show grammar => ToJSONFields (Node grammar) where
toJSONFields Node{..} =
[ "symbol" .= pack (show nodeSymbol)
, "span" .= locationSpan nodeLocation
, "span" .= Loc.span nodeLocation
]
nodeSpan :: Node grammar -> Span
nodeSpan = locationSpan . nodeLocation
nodeSpan = Loc.span . nodeLocation
nodeByteRange :: Node grammar -> Range
nodeByteRange = locationByteRange . nodeLocation
nodeByteRange = byteRange . nodeLocation

10
src/Data/Abstract/BaseError.hs
View File

@ -9,8 +9,8 @@ where
import Control.Abstract.Context
import Control.Abstract.Evaluator
import qualified Data.Abstract.Module as M
import qualified Data.Span as S
import Prologue
import qualified Source.Span as S
data BaseError (exc :: * -> *) resume = BaseError { baseErrorModuleInfo :: ModuleInfo, baseErrorSpan :: Span, baseErrorException :: exc resume }
@ -18,10 +18,10 @@ instance (Show (exc resume)) => Show (BaseError exc resume) where
showsPrec _ BaseError{..} = shows baseErrorException <> showString " " <> showString errorLocation
where errorLocation | startErrorLine == endErrorLine = M.modulePath baseErrorModuleInfo <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorCol
| otherwise = M.modulePath baseErrorModuleInfo <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorLine <> ":" <> endErrorCol
startErrorLine = show $ S.posLine (S.spanStart baseErrorSpan)
endErrorLine = show $ S.posLine (S.spanEnd baseErrorSpan)
startErrorCol = show $ S.posColumn (S.spanStart baseErrorSpan)
endErrorCol = show $ S.posColumn (S.spanEnd baseErrorSpan)
startErrorLine = show $ S.line (S.start baseErrorSpan)
endErrorLine = show $ S.line (S.end baseErrorSpan)
startErrorCol = show $ S.column (S.start baseErrorSpan)
endErrorCol = show $ S.column (S.end baseErrorSpan)
instance (Eq1 exc) => Eq1 (BaseError exc) where
liftEq f (BaseError info1 span1 exc1) (BaseError info2 span2 exc2) = info1 == info2 && span1 == span2 && liftEq f exc1 exc2

4
src/Data/Abstract/Evaluatable.hs
View File

@ -35,10 +35,10 @@ import Data.Language
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Span (HasSpan(..), emptySpan)
import Data.Sum hiding (project)
import Data.Term
import Prologue
import Source.Span (HasSpan(..))
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
class (Show1 constr, Foldable constr) => Evaluatable constr where
@ -191,7 +191,7 @@ defineSelf :: ( Carrier sig m
=> Evaluator term address value m ()
defineSelf = do
let self = Declaration X.__self
declare self ScopeGraph.Prelude Public emptySpan ScopeGraph.Unknown Nothing
declare self ScopeGraph.Prelude Public lowerBound ScopeGraph.Unknown Nothing
slot <- lookupSlot self
assign slot =<< object =<< currentFrame

10
src/Data/Abstract/ScopeGraph.hs
View File

@ -47,11 +47,11 @@ import Data.Aeson
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Span
import Control.Abstract.Hole
import Data.Abstract.Module
import Data.JSON.Fields
import Data.Abstract.Name
import Source.Span
-- A slot is a location in the heap where a value is stored.
data Slot address = Slot { frameAddress :: address, position :: Position }
@ -103,8 +103,8 @@ data Info scopeAddress = Info
} deriving (Eq, Show, Ord, Generic, NFData)
instance HasSpan (Info scopeAddress) where
span = lens infoSpan (\i s -> i { infoSpan = s })
{-# INLINE span #-}
span_ = lens infoSpan (\i s -> i { infoSpan = s })
{-# INLINE span_ #-}
instance Lower (Info scopeAddress) where
lowerBound = Info lowerBound lowerBound lowerBound Public lowerBound lowerBound Nothing
@ -116,8 +116,8 @@ data ReferenceInfo = ReferenceInfo
} deriving (Eq, Show, Ord, Generic, NFData)
instance HasSpan ReferenceInfo where
span = lens refSpan (\r s -> r { refSpan = s })
{-# INLINE span #-}
span_ = lens refSpan (\r s -> r { refSpan = s })
{-# INLINE span_ #-}
data Kind = AbstractClass
| Assignment

6
src/Data/Blob.hs
View File

@ -32,9 +32,11 @@ import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Data.JSON.Fields
import Data.Language
import Data.Source as Source
import Source.Source (Source)
import qualified Source.Source as Source
import qualified System.Path as Path
-- | A 'FilePath' paired with its corresponding 'Language'.
-- Unpacked to have the same size overhead as (FilePath, Language).
data File = File
@ -76,7 +78,7 @@ instance FromJSON Blob where
<*> b .: "language"
nullBlob :: Blob -> Bool
nullBlob Blob{..} = nullSource blobSource
nullBlob Blob{..} = Source.null blobSource
sourceBlob :: FilePath -> Language -> Source -> Blob
sourceBlob filepath language source = makeBlob source filepath language mempty

6
src/Data/Blob/IO.hs
View File

@ -16,7 +16,7 @@ import Prologue
import Data.Blob
import Data.Language
import Semantic.IO
import Data.Source
import qualified Source.Source as Source
import qualified Semantic.Git as Git
import qualified Control.Concurrent.Async as Async
import qualified Data.ByteString as B
@ -28,7 +28,7 @@ readBlobFromFile :: forall m. 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 . fromUTF8 $ raw
pure . Just . sourceBlob path language . Source.fromUTF8 $ raw
-- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found.
readBlobFromFile' :: MonadIO m => File -> m Blob
@ -58,7 +58,7 @@ readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybe
, not (pathIsMinified path)
, path `notElem` excludePaths
, null includePaths || path `elem` includePaths
= Just . sourceBlob' path lang oid . fromText <$> Git.catFile gitDir oid
= Just . sourceBlob' path lang oid . Source.fromText <$> Git.catFile gitDir oid
blobFromTreeEntry _ _ = pure Nothing
sourceBlob' filepath language (Git.OID oid) source = makeBlob source filepath language oid

24
src/Data/Error.hs
View File

@ -18,10 +18,10 @@ import Data.Ix (inRange)
import Data.List (intersperse, isSuffixOf)
import System.Console.ANSI
import Data.Blob
import Data.Flag as Flag
import Data.Source
import Data.Span
import Data.Blob
import Data.Flag as Flag
import qualified Source.Source as Source
import Source.Span
data LogPrintSource = LogPrintSource
data Colourize = Colourize
@ -61,14 +61,14 @@ showExcerpt colourize Span{..} Blob{..}
= showString context . (if "\n" `isSuffixOf` context then id else showChar '\n')
. showString (replicate (caretPaddingWidth + lineNumberDigits) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showString caret) . showChar '\n'
where context = fold contextLines
contextLines = [ showLineNumber i <> ": " <> unpack (sourceBytes l)
| (i, l) <- zip [1..] (sourceLines blobSource)
, inRange (posLine spanStart - 2, posLine spanStart) i
contextLines = [ showLineNumber i <> ": " <> unpack (Source.bytes l)
| (i, l) <- zip [1..] (Source.lines blobSource)
, inRange (line start - 2, line start) i
]
showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
lineNumberDigits = succ (floor (logBase 10 (fromIntegral (posLine spanStart) :: Double)))
caretPaddingWidth = succ (posColumn spanStart)
caret | posLine spanStart == posLine spanEnd = replicate (max 1 (posColumn spanEnd - posColumn spanStart)) '^'
lineNumberDigits = succ (floor (logBase 10 (fromIntegral (line start) :: Double)))
caretPaddingWidth = succ (column start)
caret | line start == line end = replicate (max 1 (column end - column start)) '^'
| otherwise = "^..."
withSGRCode :: Flag Colourize -> [SGR] -> ShowS -> ShowS
@ -93,8 +93,8 @@ showSymbols colourize = go
showSymbol = withSGRCode colourize [SetColor Foreground Vivid Red] . showString
showSpan :: Maybe FilePath -> Span -> ShowS
showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if spanStart == spanEnd then showPos spanStart else showPos spanStart . showChar '-' . showPos spanEnd)
where showPos Pos{..} = shows posLine . showChar ':' . shows posColumn
showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if start == end then showPos start else showPos start . showChar '-' . showPos end)
where showPos Pos{..} = shows line . showChar ':' . shows column
showCallStack :: Flag Colourize -> CallStack -> ShowS
showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))

26
src/Data/Graph/ControlFlowVertex.hs
View File

@ -22,14 +22,14 @@ import Data.Abstract.Package (PackageInfo (..))
import Data.Aeson
import Data.Graph (VertexTag (..))
import qualified Data.Graph as G
import Data.Location
import Data.Span
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression
import Data.Term
import qualified Data.Text as T
import Prologue
import Source.Loc as Loc
import Source.Span
-- | A vertex of representing some node in a control flow graph.
data ControlFlowVertex
@ -101,9 +101,9 @@ instance ToJSON ControlFlowVertex where
class VertexDeclaration syntax where
toVertex :: (Declarations1 syntax, Foldable syntax)
=> Location
=> Loc
-> ModuleInfo
-> syntax (Term syntax Location)
-> syntax (Term syntax Loc)
-> Maybe (ControlFlowVertex, Name)
instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
@ -111,9 +111,9 @@ instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
class VertexDeclaration' whole syntax where
toVertex' :: (Declarations1 whole, Foldable whole)
=> Location
=> Loc
-> ModuleInfo
-> syntax (Term whole Location)
-> syntax (Term whole Loc)
-> Maybe (ControlFlowVertex, Name)
instance (VertexDeclarationStrategy syntax ~ strategy, VertexDeclarationWithStrategy strategy whole syntax) => VertexDeclaration' whole syntax where
@ -132,9 +132,9 @@ type family VertexDeclarationStrategy syntax where
class VertexDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toVertexWithStrategy :: (Declarations1 whole, Foldable whole)
=> proxy strategy
-> Location
-> Loc
-> ModuleInfo
-> syntax (Term whole Location)
-> syntax (Term whole Loc)
-> Maybe (ControlFlowVertex, Name)
-- | The 'Default' strategy produces 'Nothing'.
@ -145,17 +145,17 @@ instance Apply (VertexDeclaration' whole) fs => VertexDeclarationWithStrategy 'C
toVertexWithStrategy _ ann info = apply @(VertexDeclaration' whole) (toVertex' ann info)
instance VertexDeclarationWithStrategy 'Custom whole Syntax.Identifier where
toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (locationSpan ann), name)
toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (Loc.span ann), name)
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Function where
toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term
toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (Loc.span ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Method where
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (Loc.span ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole whole => VertexDeclarationWithStrategy 'Custom whole Expression.MemberAccess where
toVertexWithStrategy proxy ann info (Expression.MemberAccess (Term (In lhsAnn lhs)) (Term (In rhsAnn rhs))) =
case (toVertexWithStrategy proxy lhsAnn info lhs, toVertexWithStrategy proxy rhsAnn info rhs) of
(Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (locationSpan ann), name)
(_, Just (_, name)) -> Just (variableVertex (formatName name) info (locationSpan ann), name)
(Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (Loc.span ann), name)
(_, Just (_, name)) -> Just (variableVertex (formatName name) info (Loc.span ann), name)
_ -> Nothing

6
src/Data/History.hs
View File

@ -6,7 +6,7 @@ module Data.History
, remark
) where
import Data.Location
import Source.Loc
-- | 'History' values, when attached to a given 'Term', describe the ways in
-- which that term was modified during a refactoring pass, if any.
@ -21,9 +21,9 @@ data History
-- | Convert a 'Term' annotated with a 'Range' to one annotated with a 'History'.
mark :: Functor f
=> (Range -> History)
-> f Location
-> f Loc
-> f History
mark f = fmap (f . locationByteRange)
mark f = fmap (f . byteRange)
-- | Change the 'History' annotation on a 'Term'.
remark :: Functor f

11
src/Data/JSON/Fields.hs
View File

@ -14,6 +14,8 @@ import Data.Sum (Apply (..), Sum)
import qualified Data.Text as Text
import GHC.Generics
import Prologue
import Source.Loc
import Source.Range
class ToJSONFields a where
toJSONFields :: KeyValue kv => a -> [kv]
@ -46,6 +48,15 @@ instance Apply ToJSONFields1 fs => ToJSONFields1 (Sum fs) where
instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (a, b) where
toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance ToJSONFields Loc where
toJSONFields Loc{..} = toJSONFields byteRange <> toJSONFields span
newtype JSONFields a = JSONFields { unJSONFields :: a }

29
src/Data/Location.hs
View File

@ -1,29 +0,0 @@
{-# LANGUAGE DeriveAnyClass, DerivingVia #-}
module Data.Location
( Location(..)
, Span(..)
, Range(..)
) where
import Prologue
import Control.Lens.Lens
import Data.JSON.Fields
import Data.Range
import Data.Span
data Location
= Location
{ locationByteRange :: {-# UNPACK #-} Range
, locationSpan :: {-# UNPACK #-} Span
}
deriving (Eq, Ord, Show, Generic, NFData)
deriving Semigroup via GenericSemigroup Location
instance HasSpan Location where
span = lens locationSpan (\l s -> l { locationSpan = s })
{-# INLINE span #-}
instance ToJSONFields Location where
toJSONFields Location{..} = toJSONFields locationByteRange <> toJSONFields locationSpan

8
src/Data/Quieterm.hs
View File

@ -4,16 +4,14 @@ module Data.Quieterm
, quieterm
) where
import Prelude hiding (span)
import Control.Lens
import Control.DeepSeq
import Data.Abstract.Declarations (Declarations)
import Data.Abstract.FreeVariables (FreeVariables)
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Span
import Data.Term
import Source.Span
import Text.Show (showListWith)
newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) }
@ -48,8 +46,8 @@ instance (NFData1 f, NFData a) => NFData (Quieterm f a) where
rnf = liftRnf rnf
instance HasSpan ann => HasSpan (Quieterm syntax ann) where
span = lens (view span . unQuieterm) (\(Quieterm i) s -> Quieterm (set span s i))
{-# INLINE span #-}
span_ = lens (view span_ . unQuieterm) (\(Quieterm i) s -> Quieterm (set span_ s i))
{-# INLINE span_ #-}
quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann
quieterm = cata Quieterm

42
src/Data/Range.hs
View File

@ -1,42 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Range
( Range(..)
, emptyRange
, rangeLength
, subtractRange
) where
import Prologue
import Data.Aeson
import Data.JSON.Fields
-- | A half-open interval of integers, defined by start & end indices.
data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
deriving (Eq, Generic, NFData, Ord)
emptyRange :: Range
emptyRange = Range 0 0
-- | Return the length of the range.
rangeLength :: Range -> Int
rangeLength range = end range - start range
subtractRange :: Range -> Range -> Range
subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Range (start range2) (max (end range1) (end range2))))
-- Instances
-- | The associativity of this instance is specced in @Data.Range.Spec@.
instance Semigroup Range where
Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2)
instance Show Range where
showsPrec _ Range{..} = showChar '[' . shows start . showString " .. " . shows end . showChar ']'
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
instance Lower Range where
lowerBound = Range 0 0

8
src/Data/Reprinting/Token.hs
View File

@ -7,9 +7,9 @@ module Data.Reprinting.Token
, Flow (..)
) where
import Data.Text (Text)
import Data.Source (Source)
import Data.Reprinting.Scope
import Data.Text (Text)
import Source.Source (Source)
-- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced
-- portions of the original 'Source' for a given AST.
@ -21,11 +21,11 @@ data Token
isChunk :: Token -> Bool
isChunk (Chunk _) = True
isChunk _ = False
isChunk _ = False
isControl :: Token -> Bool
isControl (Control _) = True
isControl _ = False
isControl _ = False
-- | 'Element' tokens describe atomic pieces of source code to be
-- output to a rendered document. These tokens are language-agnostic

161
src/Data/Source.hs
View File

@ -1,161 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Source
( Source
, sourceBytes
, fromUTF8
-- Measurement
, sourceLength
, nullSource
, totalRange
, totalSpan
-- En/decoding
, fromText
, toText
-- Slicing
, slice
, dropSource
-- Splitting
, sourceLines
, sourceLineRanges
, sourceLineRangesWithin
-- Conversion
, spanToRange
, spanToRangeInLineRanges
, sourceLineRangesByLineNumber
, rangeToSpan
, newlineIndices
) where
import Prologue
import Data.Aeson (FromJSON (..), withText)
import Data.Array
import qualified Data.ByteString as B
import Data.Char (ord)
import Data.List (span)
import Data.Range
import Data.Span hiding (HasSpan (..))
import Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- | The contents of a source file. This is represented as a UTF-8
-- 'ByteString' under the hood. Construct these with 'fromUTF8'; obviously,
-- passing 'fromUTF8' non-UTF8 bytes will cause crashes.
newtype Source = Source { sourceBytes :: B.ByteString }
deriving (Eq, Semigroup, Monoid, IsString, Show, Generic)
fromUTF8 :: B.ByteString -> Source
fromUTF8 = Source
instance FromJSON Source where
parseJSON = withText "Source" (pure . fromText)
-- Measurement
sourceLength :: Source -> Int
sourceLength = B.length . sourceBytes
nullSource :: Source -> Bool
nullSource = B.null . sourceBytes
-- | Return a 'Range' that covers the entire text.
totalRange :: Source -> Range
totalRange = Range 0 . B.length . sourceBytes
-- | Return a 'Span' that covers the entire text.
totalSpan :: Source -> Span
totalSpan source = Span (Pos 1 1) (Pos (length ranges) (succ (end lastRange - start lastRange)))
where ranges = sourceLineRanges source
lastRange = fromMaybe emptyRange (getLast (foldMap (Last . Just) ranges))
-- En/decoding
-- | Return a 'Source' from a 'Text'.
fromText :: T.Text -> Source
fromText = Source . T.encodeUtf8
-- | Return the Text contained in the 'Source'.
toText :: Source -> T.Text
toText = T.decodeUtf8 . sourceBytes
-- | Return a 'Source' that contains a slice of the given 'Source'.
slice :: Range -> Source -> Source
slice range = take . drop
where drop = dropSource (start range)
take = takeSource (rangeLength range)
dropSource :: Int -> Source -> Source
dropSource i = Source . drop . sourceBytes
where drop = B.drop i
takeSource :: Int -> Source -> Source
takeSource i = Source . take . sourceBytes
where take = B.take i
-- Splitting
-- | Split the contents of the source after newlines.
sourceLines :: Source -> [Source]
sourceLines source = (`slice` source) <$> sourceLineRanges source
-- | Compute the 'Range's of each line in a 'Source'.
sourceLineRanges :: Source -> [Range]
sourceLineRanges source = sourceLineRangesWithin (totalRange source) source
-- | Compute the 'Range's of each line in a 'Range' of a 'Source'.
sourceLineRangesWithin :: Range -> Source -> [Range]
sourceLineRangesWithin range = uncurry (zipWith Range)
. ((start range:) &&& (<> [ end range ]))
. fmap (+ succ (start range))
. newlineIndices
. sourceBytes
. slice range
-- | Return all indices of newlines ('\n', '\r', and '\r\n') in the 'ByteString'.
newlineIndices :: B.ByteString -> [Int]
newlineIndices = go 0
where go n bs | B.null bs = []
| otherwise = case (searchCR bs, searchLF bs) of
(Nothing, Nothing) -> []
(Just i, Nothing) -> recur n i bs
(Nothing, Just i) -> recur n i bs
(Just crI, Just lfI)
| succ crI == lfI -> recur n lfI bs
| otherwise -> recur n (min crI lfI) bs
recur n i bs = let j = n + i in j : go (succ j) (B.drop (succ i) bs)
searchLF = B.elemIndex (toEnum (ord '\n'))
searchCR = B.elemIndex (toEnum (ord '\r'))
{-# INLINE newlineIndices #-}
-- Conversion
-- | Compute the byte 'Range' corresponding to a given 'Span' in a 'Source'.
spanToRange :: Source -> Span -> Range
spanToRange = spanToRangeInLineRanges . sourceLineRangesByLineNumber
spanToRangeInLineRanges :: Array Int Range -> Span -> Range
spanToRangeInLineRanges lineRanges Span{..} = Range
(start (lineRanges ! posLine spanStart) + pred (posColumn spanStart))
(start (lineRanges ! posLine spanEnd) + pred (posColumn spanEnd))
sourceLineRangesByLineNumber :: Source -> Array Int Range
sourceLineRangesByLineNumber source = listArray (1, length lineRanges) lineRanges
where lineRanges = sourceLineRanges source
-- | Compute the 'Span' corresponding to a given byte 'Range' in a 'Source'.
rangeToSpan :: Source -> Range -> Span
rangeToSpan source (Range rangeStart rangeEnd) = Span startPos endPos
where startPos = Pos (firstLine + 1) (rangeStart - start firstRange + 1)
endPos = Pos (firstLine + length lineRanges) (rangeEnd - start lastRange + 1)
firstLine = length before
(before, rest) = span ((< rangeStart) . end) (sourceLineRanges source)
(lineRanges, _) = span ((<= rangeEnd) . start) rest
firstRange = fromMaybe emptyRange (getFirst (foldMap (First . Just) lineRanges))
lastRange = fromMaybe firstRange (getLast (foldMap (Last . Just) lineRanges))

109
src/Data/Span.hs
View File

@ -1,109 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- | Source position and span information
--
-- Mostly taken from purescript's SourcePos definition.
module Data.Span
( Span(..)
, HasSpan(..)
, Pos(..)
, line
, column
, spanFromSrcLoc
, emptySpan
) where
import Prelude hiding (span)
import Prologue
import Control.Lens.Lens
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson as A
import Proto3.Suite
import Data.JSON.Fields
-- | Source position information (1 indexed)
data Pos = Pos
{ posLine :: !Int
, posColumn :: !Int
} deriving (Eq, Ord, Generic, Hashable, NFData)
line, column :: Lens' Pos Int
line = lens posLine (\p l -> p { posLine = l })
column = lens posColumn (\p l -> p { posColumn = l })
-- | A Span of position information
data Span = Span
{ spanStart :: Pos
, spanEnd :: Pos
} deriving (Eq, Ord, Generic, Hashable, Named, NFData)
-- | "Classy-fields" interface for data types that have spans.
class HasSpan a where
span :: Lens' a Span
start :: Lens' a Pos
start = span.start
{-# INLINE start #-}
end :: Lens' a Pos
end = span.end
{-# INLINE end #-}
instance HasSpan Span where
span = id
{-# INLINE span #-}
start = lens spanStart (\s t -> s { spanStart = t })
{-# INLINE start #-}
end = lens spanEnd (\s t -> s { spanEnd = t })
{-# INLINE end #-}
-- Instances
instance Show Pos where
showsPrec _ Pos{..} = showChar '[' . shows posLine . showString ", " . shows posColumn . showChar ']'
instance A.ToJSON Pos where
toJSON Pos{..} =
A.toJSON [posLine, posColumn]
instance A.FromJSON Pos where
parseJSON arr = do
[line, col] <- A.parseJSON arr
pure $ Pos line col
instance Lower Pos where
lowerBound = Pos 1 1
instance Show Span where
showsPrec _ Span{..} = shows spanStart . showString ".." . shows spanEnd
spanFromSrcLoc :: SrcLoc -> Span
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
emptySpan :: Span
emptySpan = Span (Pos 1 1) (Pos 1 1)
instance Semigroup Span where
Span start1 end1 <> Span start2 end2 = Span (min start1 start2) (max end1 end2)
instance A.ToJSON Span where
toJSON Span{..} =
A.object [ "start" .= spanStart
, "end" .= spanEnd
]
instance A.FromJSON Span where
parseJSON = A.withObject "Span" $ \o ->
Span <$>
o .: "start" <*>
o .: "end"
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance Lower Span where
lowerBound = emptySpan

13
src/Data/Syntax.hs
View File

@ -5,8 +5,6 @@ module Data.Syntax where
import Data.Abstract.Evaluatable hiding (Empty, Error)
import Data.Aeson as Aeson (ToJSON(..), object)
import Data.JSON.Fields
import Data.Range
import Data.Location
import qualified Data.Set as Set
import Data.Sum
import Data.Term
@ -17,6 +15,9 @@ import Diffing.Algorithm
import Prelude
import Prologue
import Reprinting.Tokenize hiding (Element)
import Source.Loc
import Source.Range as Range
import Source.Span as Span
import qualified Assigning.Assignment as Assignment
import qualified Data.Error as Error
import Control.Abstract.ScopeGraph (reference, Reference(..), Declaration(..))
@ -50,16 +51,16 @@ makeTerm1' syntax = case toList syntax of
_ -> error "makeTerm1': empty structure"
-- | Construct an empty term at the current position.
emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location)
emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
where startLocation Location{..} = Location (Range (start locationByteRange) (start locationByteRange)) (Span (spanStart locationSpan) (spanStart locationSpan))
where startLocation Loc{..} = Loc (Range.point (Range.start byteRange)) (Span.point (Span.start span))
-- | Catch assignment errors into an error term.
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Location)
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
-- | Catch parse errors into an error term.
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location)
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Loc)
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") [])
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.

11
src/Data/Syntax/Declaration.hs
View File

@ -2,7 +2,6 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Data.Syntax.Declaration where
import Prelude hiding (span)
import Prologue
import Control.Lens.Getter
@ -15,9 +14,9 @@ import Data.Abstract.Name (__self)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import qualified Data.Reprinting.Scope as Scope
import Data.Span
import Diffing.Algorithm
import Reprinting.Tokenize hiding (Superclass)
import Source.Span
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1, NFData1)
@ -34,7 +33,7 @@ instance Evaluatable Function where
current <- ask @Span
(name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public current ScopeGraph.Function
params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span) ScopeGraph.Parameter Nothing
params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing
addr <- lookupSlot (Declaration name)
v <- function name params functionBody associatedScope
@ -95,8 +94,8 @@ instance Evaluatable Method where
params <- withScope associatedScope $ do
-- TODO: Should we give `self` a special Relation?
declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span) ScopeGraph.Parameter Nothing
declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public lowerBound ScopeGraph.Unknown Nothing
for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing
addr <- lookupSlot (Declaration name)
v <- function name params methodBody associatedScope
@ -164,7 +163,7 @@ instance Evaluatable VariableDeclaration where
eval _ _ (VariableDeclaration []) = unit
eval eval _ (VariableDeclaration decs) = do
for_ decs $ \declaration -> do
_ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public (declaration^.span) ScopeGraph.VariableDeclaration Nothing
_ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public (declaration^.span_) ScopeGraph.VariableDeclaration Nothing
eval declaration
unit

4
src/Data/Syntax/Directive.hs
View File

@ -7,10 +7,10 @@ import Prologue
import Data.Abstract.Evaluatable
import Data.Abstract.Module (ModuleInfo (..))
import Data.JSON.Fields
import Data.Span
import qualified Data.Text as T
import Diffing.Algorithm
import Reprinting.Tokenize
import Source.Span
-- A file directive like the Ruby constant `__FILE__`.
data File a = File
@ -31,7 +31,7 @@ data Line a = Line
deriving (Eq1, Show1, Ord1) via Generically Line
instance Evaluatable Line where
eval _ _ Line = currentSpan >>= integer . fromIntegral . posLine . spanStart
eval _ _ Line = currentSpan >>= integer . fromIntegral . line . start
-- PT TODO: proper token for this
instance Tokenize Line where

6
src/Data/Tag.hs
View File

@ -10,7 +10,7 @@ import Prologue
import Data.Aeson
import Control.Lens.Lens
import Data.Span
import Source.Span
-- | These selectors aren't prefixed with @tag@ for reasons of JSON
-- backwards compatibility.
@ -24,5 +24,5 @@ data Tag = Tag
} deriving (Eq, Show, Generic, ToJSON)
instance HasSpan Tag where
span = lens Data.Tag.span (\t s -> t { Data.Tag.span = s })
{-# INLINE span #-}
span_ = lens span (\t s -> t { span = s })
{-# INLINE span_ #-}

11
src/Data/Term.hs
View File

@ -14,14 +14,13 @@ module Data.Term
, Annotated (..)
) where
import Prelude hiding (span)
import Prologue
import Control.Lens.Lens
import Data.Aeson
import Data.JSON.Fields
import Data.Span
import qualified Data.Sum as Sum
import Source.Span
import Text.Show
-- | A Term with an abstract syntax tree and an annotation.
@ -49,12 +48,12 @@ annotationLens = lens termFAnnotation (\t a -> t { termFAnnotation = a })
{-# INLINE annotationLens #-}
instance HasSpan ann => HasSpan (TermF syntax ann recur) where
span = annotationLens.span
{-# INLINE span #-}
span_ = annotationLens.span_
{-# INLINE span_ #-}
instance HasSpan ann => HasSpan (Term syntax ann) where
span = inner.span where inner = lens unTerm (\t i -> t { unTerm = i })
{-# INLINE span #-}
span_ = inner.span_ where inner = lens unTerm (\t i -> t { unTerm = i })
{-# INLINE span_ #-}
-- | A convenience typeclass to get the annotation out of a 'Term' or 'TermF'.
-- Useful in term-rewriting algebras.

2
src/Language/Go/Assignment.hs
View File

@ -132,7 +132,7 @@ type Syntax =
, Literal.Boolean
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Go's grammar onto a program in Go's syntax.

2
src/Language/Haskell/Assignment.hs
View File

@ -169,7 +169,7 @@ type Syntax = '[
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
assignment :: Assignment Term

4
src/Language/JSON/Assignment.hs
View File

@ -9,11 +9,11 @@ where
import Assigning.Assignment.Deterministic hiding (Assignment)
import qualified Assigning.Assignment.Deterministic as Deterministic
import Data.Sum
import Data.Location
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Literal as Literal
import qualified Data.Term as Term
import Prologue
import Source.Loc
import Text.Parser.Combinators
import TreeSitter.JSON as Grammar
@ -28,7 +28,7 @@ type Syntax =
, Syntax.Error
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Deterministic.Assignment Grammar
assignment :: Assignment Term

2
src/Language/Java/Assignment.hs
View File

@ -155,7 +155,7 @@ type Syntax =
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Java's grammar onto a program in Java's syntax.

2
src/Language/Markdown/Assignment.hs
View File

@ -46,7 +46,7 @@ type Syntax =
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment (Term.TermF [] CMarkGFM.NodeType) Grammar
assignment :: Assignment Term

2
src/Language/PHP/Assignment.hs
View File

@ -162,7 +162,7 @@ type Syntax = '[
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in PHP's grammar onto a program in PHP's syntax.

7
src/Language/PHP/Syntax.hs
View File

@ -2,7 +2,6 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Language.PHP.Syntax where
import Prelude hiding (span)
import Prologue hiding (Text)
import Control.Lens.Getter
@ -17,8 +16,8 @@ import Data.Abstract.Path
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import qualified Data.Language as Language
import Data.Span
import Diffing.Algorithm
import Source.Span
newtype Text a = Text { value :: T.Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, NFData1)
@ -185,7 +184,7 @@ instance Evaluatable QualifiedName where
eval _ _ (QualifiedName obj iden) = do
-- TODO: Consider gensym'ed names used for References.
name <- maybeM (throwNoNameError obj) (declaredName obj)
reference (Reference name) (obj^.span) ScopeGraph.Identifier (Declaration name)
reference (Reference name) (obj^.span_) ScopeGraph.Identifier (Declaration name)
childScope <- associatedScope (Declaration name)
propName <- maybeM (throwNoNameError iden) (declaredName iden)
@ -195,7 +194,7 @@ instance Evaluatable QualifiedName where
currentFrameAddress <- currentFrame
frameAddress <- newFrame childScope (Map.singleton Lexical (Map.singleton currentScopeAddress currentFrameAddress))
withScopeAndFrame frameAddress $ do
reference (Reference propName) (iden^.span) ScopeGraph.Identifier (Declaration propName)
reference (Reference propName) (iden^.span_) ScopeGraph.Identifier (Declaration propName)
slot <- lookupSlot (Declaration propName)
deref slot
Nothing ->

2
src/Language/Python/Assignment.hs
View File

@ -118,7 +118,7 @@ type Syntax =
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Python's grammar onto a program in Python's syntax.

9
src/Language/Python/Syntax.hs
View File

@ -3,7 +3,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME
module Language.Python.Syntax where
import Prelude hiding (span)
import Prologue
import Control.Lens.Getter
@ -22,8 +21,8 @@ import Data.Abstract.Module
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import qualified Data.Language as Language
import Data.Span
import Diffing.Algorithm
import Source.Span
data QualifiedName
= QualifiedName { paths :: NonEmpty FilePath }
@ -135,7 +134,7 @@ instance Evaluatable Import where
-- Add declaration of the alias name to the current scope (within our current module).
aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm)
declare (Declaration aliasName) Default Public (aliasTerm^.span) ScopeGraph.UnqualifiedImport (Just importScope)
declare (Declaration aliasName) Default Public (aliasTerm^.span_) ScopeGraph.UnqualifiedImport (Just importScope)
-- Retrieve the frame slot for the new declaration.
aliasSlot <- lookupSlot (Declaration aliasName)
assign aliasSlot =<< object aliasFrame
@ -173,7 +172,7 @@ instance Evaluatable Import where
aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm)
aliasValue <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
if aliasValue /= aliasName then do
insertImportReference (Reference aliasName) (aliasTerm^.span) ScopeGraph.Identifier (Declaration aliasValue) scopeAddress
insertImportReference (Reference aliasName) (aliasTerm^.span_) ScopeGraph.Identifier (Declaration aliasValue) scopeAddress
else
pure ()
@ -199,7 +198,7 @@ instance Evaluatable QualifiedImport where
go [] = pure ()
go (((nameTerm, name), modulePath) : namesAndPaths) = do
scopeAddress <- newScope mempty
declare (Declaration name) Default Public (nameTerm^.span) ScopeGraph.QualifiedImport (Just scopeAddress)
declare (Declaration name) Default Public (nameTerm^.span_) ScopeGraph.QualifiedImport (Just scopeAddress)
aliasSlot <- lookupSlot (Declaration name)
-- a.b.c
withScope scopeAddress $

4
src/Language/Ruby/Assignment.hs
View File

@ -129,7 +129,7 @@ type Syntax = '[
, []
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
@ -487,7 +487,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Ruby.Syntax.
<|> lhsIdent
<|> expression
identWithLocals :: Assignment (Location, Text, [Text])
identWithLocals :: Assignment (Loc, Text, [Text])
identWithLocals = do
loc <- symbol Identifier
-- source advances, so it's important we call getLocals first

2
src/Language/TSX/Assignment.hs
View File

@ -208,7 +208,7 @@ type Syntax = '[
, TSX.Syntax.AnnotatedExpression
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax.

143
src/Language/TSX/Syntax/Types.hs
View File

@ -1,143 +0,0 @@
{-# LANGUAGE DeriveAnyClass, DerivingVia, DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Language.TypeScript.Syntax.Types where
import Prologue
import Control.Abstract hiding (Import)
import Data.Abstract.Evaluatable as Evaluatable
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import qualified Data.Abstract.ScopeGraph as ScopeGraph
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically LookupType
instance Evaluatable LookupType
data FunctionType a = FunctionType { functionTypeParameters :: !a, functionFormalParameters :: ![a], functionType :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically FunctionType
instance Evaluatable FunctionType
data TypeParameter a = TypeParameter { typeParameter :: !a, typeParameterConstraint :: !a, typeParameterDefaultType :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypeParameter
instance Evaluatable TypeParameter
data TypeAssertion a = TypeAssertion { typeAssertionParameters :: !a, typeAssertionExpression :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypeAssertion
instance Evaluatable TypeAssertion
newtype DefaultType a = DefaultType { defaultType :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically DefaultType
instance Evaluatable DefaultType
newtype ParenthesizedType a = ParenthesizedType { parenthesizedType :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically ParenthesizedType
instance Evaluatable ParenthesizedType
newtype PredefinedType a = PredefinedType { predefinedType :: T.Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically PredefinedType
-- TODO: Implement Eval instance for PredefinedType
instance Evaluatable PredefinedType
newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text }
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypeIdentifier
instance Declarations1 TypeIdentifier where
liftDeclaredName _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier)
-- TODO: TypeIdentifier shouldn't evaluate to an address in the heap?
instance Evaluatable TypeIdentifier where
eval _ _ TypeIdentifier{..} = do
-- Add a reference to the type identifier in the current scope.
span <- ask @Span
reference (Reference (Evaluatable.name contents)) span ScopeGraph.TypeIdentifier (Declaration (Evaluatable.name contents))
unit
data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically NestedTypeIdentifier
instance Evaluatable NestedTypeIdentifier
data GenericType a = GenericType { genericTypeIdentifier :: !a, genericTypeArguments :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically GenericType
instance Evaluatable GenericType
data TypePredicate a = TypePredicate { typePredicateIdentifier :: !a, typePredicateType :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypePredicate
instance Evaluatable TypePredicate
newtype ObjectType a = ObjectType { objectTypeElements :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically ObjectType
instance Evaluatable ObjectType
newtype ArrayType a = ArrayType { arrayType :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically ArrayType
instance Evaluatable ArrayType
newtype FlowMaybeType a = FlowMaybeType { flowMaybeType :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically FlowMaybeType
instance Evaluatable FlowMaybeType
newtype TypeQuery a = TypeQuery { typeQuerySubject :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypeQuery
instance Evaluatable TypeQuery
newtype IndexTypeQuery a = IndexTypeQuery { indexTypeQuerySubject :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically IndexTypeQuery
instance Evaluatable IndexTypeQuery
newtype TypeArguments a = TypeArguments { typeArguments :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically TypeArguments
instance Evaluatable TypeArguments
newtype ThisType a = ThisType { contents :: T.Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically ThisType
instance Evaluatable ThisType
newtype ExistentialType a = ExistentialType { contents :: T.Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically ExistentialType
instance Evaluatable ExistentialType
newtype LiteralType a = LiteralType { literalTypeSubject :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, NFData1, Ord, Show, ToJSONFields1, Traversable)
deriving (Eq1, Show1, Ord1) via Generically LiteralType
instance Evaluatable LiteralType

2
src/Language/TypeScript/Assignment.hs
View File

@ -199,7 +199,7 @@ type Syntax = '[
, TypeScript.Syntax.AnnotatedExpression
]
type Term = Term.Term (Sum Syntax) Location
type Term = Term.Term (Sum Syntax) Loc
type Assignment = Assignment.Assignment [] Grammar
-- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax.

7
src/Language/TypeScript/Syntax/Import.hs
View File

@ -11,7 +11,6 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import Diffing.Algorithm
import Language.TypeScript.Resolution
import Data.Span (emptySpan)
import qualified Data.Map.Strict as Map
import Data.Aeson (ToJSON)
@ -38,7 +37,7 @@ instance Evaluatable Import where
for_ symbols $ \Alias{..} ->
-- TODO: Need an easier way to get the span of an Alias. It's difficult because we no longer have a term.
-- Even if we had one we'd have to evaluate it at the moment.
insertImportReference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue) scopeAddress
insertImportReference (Reference aliasName) lowerBound ScopeGraph.Identifier (Declaration aliasValue) scopeAddress
-- Create edges from the current scope/frame to the import scope/frame.
insertImportEdge scopeAddress
@ -89,7 +88,7 @@ instance Evaluatable QualifiedExport where
withScope exportScope .
for_ exportSymbols $ \Alias{..} -> do
-- TODO: Replace Alias in QualifedExport with terms and use a real span
reference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue)
reference (Reference aliasName) lowerBound ScopeGraph.Identifier (Declaration aliasValue)
-- Create an export edge from a new scope to the qualifed export's scope.
unit
@ -116,7 +115,7 @@ instance Evaluatable QualifiedExportFrom where
withScopeAndFrame moduleFrame .
for_ exportSymbols $ \Alias{..} -> do
-- TODO: Replace Alias with terms in QualifiedExportFrom and use a real span below.
insertImportReference (Reference aliasName) emptySpan ScopeGraph.Identifier (Declaration aliasValue) exportScope
insertImportReference (Reference aliasName) lowerBound ScopeGraph.Identifier (Declaration aliasValue) exportScope
insertExportEdge exportScope
insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame)

77
src/Parsing/CMark.hs
View File

@ -5,15 +5,16 @@ module Parsing.CMark
, toGrammar
) where
import CMarkGFM
import CMarkGFM
import Data.Array
import qualified Data.AST as A
import Data.Ix
import Data.Range
import Data.Location
import Data.Span
import Data.Source
import Data.Term
import TreeSitter.Language (Symbol(..), SymbolType(..))
import Data.Term
import Source.Loc
import qualified Source.Range as Range
import Source.Source (Source)
import qualified Source.Source as Source
import Source.Span hiding (HasSpan (..))
import TreeSitter.Language (Symbol (..), SymbolType (..))
data Grammar
= Document
@ -51,43 +52,53 @@ exts = [
]
cmarkParser :: Source -> A.AST (TermF [] NodeType) Grammar
cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos ] exts (toText source)
cmarkParser source = toTerm (Source.totalRange source) (Source.totalSpan source) $ commonmarkToNode [ optSourcePos ] exts (Source.toText source)
where toTerm :: Range -> Span -> Node -> A.AST (TermF [] NodeType) Grammar
toTerm within withinSpan (Node position t children) =
let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position
span = maybe withinSpan toSpan position
in termIn (A.Node (toGrammar t) (Location range span)) (In t (toTerm range span <$> children))
in termIn (A.Node (toGrammar t) (Loc range span)) (In t (toTerm range span <$> children))
toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn)))
lineRanges = sourceLineRangesByLineNumber source
toGrammar :: NodeType -> Grammar
toGrammar DOCUMENT{} = Document
toGrammar DOCUMENT{} = Document
toGrammar THEMATIC_BREAK{} = ThematicBreak
toGrammar PARAGRAPH{} = Paragraph
toGrammar BLOCK_QUOTE{} = BlockQuote
toGrammar HTML_BLOCK{} = HTMLBlock
toGrammar CUSTOM_BLOCK{} = CustomBlock
toGrammar CODE_BLOCK{} = CodeBlock
toGrammar HEADING{} = Heading
toGrammar LIST{} = List
toGrammar ITEM{} = Item
toGrammar TEXT{} = Text
toGrammar SOFTBREAK{} = SoftBreak
toGrammar LINEBREAK{} = LineBreak
toGrammar HTML_INLINE{} = HTMLInline
toGrammar CUSTOM_INLINE{} = CustomInline
toGrammar CODE{} = Code
toGrammar EMPH{} = Emphasis
toGrammar STRONG{} = Strong
toGrammar LINK{} = Link
toGrammar IMAGE{} = Image
toGrammar STRIKETHROUGH{} = Strikethrough
toGrammar TABLE{} = Table
toGrammar TABLE_ROW{} = TableRow
toGrammar TABLE_CELL{} = TableCell
toGrammar PARAGRAPH{} = Paragraph
toGrammar BLOCK_QUOTE{} = BlockQuote
toGrammar HTML_BLOCK{} = HTMLBlock
toGrammar CUSTOM_BLOCK{} = CustomBlock
toGrammar CODE_BLOCK{} = CodeBlock
toGrammar HEADING{} = Heading
toGrammar LIST{} = List
toGrammar ITEM{} = Item
toGrammar TEXT{} = Text
toGrammar SOFTBREAK{} = SoftBreak
toGrammar LINEBREAK{} = LineBreak
toGrammar HTML_INLINE{} = HTMLInline
toGrammar CUSTOM_INLINE{} = CustomInline
toGrammar CODE{} = Code
toGrammar EMPH{} = Emphasis
toGrammar STRONG{} = Strong
toGrammar LINK{} = Link
toGrammar IMAGE{} = Image
toGrammar STRIKETHROUGH{} = Strikethrough
toGrammar TABLE{} = Table
toGrammar TABLE_ROW{} = TableRow
toGrammar TABLE_CELL{} = TableCell
instance Symbol Grammar where
symbolType _ = Regular
spanToRangeInLineRanges :: Array Int Range -> Span -> Range
spanToRangeInLineRanges lineRanges Span{..} = Range
(Range.start (lineRanges ! line start) + pred (column start))
(Range.start (lineRanges ! line end) + pred (column end))
sourceLineRangesByLineNumber :: Source -> Array Int Range
sourceLineRangesByLineNumber source = listArray (1, length lineRanges) lineRanges
where lineRanges = Source.lineRanges source

12
src/Parsing/Parser.hs
View File

@ -84,7 +84,7 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
)
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select.
-> SomeAnalysisParser typeclasses Location -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced.
-> SomeAnalysisParser typeclasses Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced.
someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go)
someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell)
someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'JavaScript)
@ -102,13 +102,13 @@ data Parser term where
ASTParser :: (Bounded grammar, Enum grammar, Show grammar) => Ptr TS.Language -> Parser (AST [] grammar)
-- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type.
AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast)
=> Parser (Term ast (Node grammar)) -- ^ A parser producing AST.
-> Assignment ast grammar (Term (Sum fs) Location) -- ^ An assignment from AST onto 'Term's.
-> Parser (Term (Sum fs) Location) -- ^ A parser producing 'Term's.
=> Parser (Term ast (Node grammar)) -- ^ A parser producing AST.
-> Assignment ast grammar (Term (Sum fs) Loc) -- ^ An assignment from AST onto 'Term's.
-> Parser (Term (Sum fs) Loc) -- ^ A parser producing 'Term's.
DeterministicParser :: (Enum grammar, Ord grammar, Show grammar, Element Syntax.Error syntaxes, Apply Foldable syntaxes, Apply Functor syntaxes)
=> Parser (AST [] grammar)
-> Deterministic.Assignment grammar (Term (Sum syntaxes) Location)
-> Parser (Term (Sum syntaxes) Location)
-> Deterministic.Assignment grammar (Term (Sum syntaxes) Loc)
-> Parser (Term (Sum syntaxes) Loc)
-- | A parser for 'Markdown' using cmark.
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-- | An abstraction over parsers when we don’t know the details of the term type.

21
src/Parsing/TreeSitter.hs
View File

@ -6,21 +6,22 @@ module Parsing.TreeSitter
import Prologue hiding (bracket)
import qualified Control.Exception as Exc (bracket)
import Control.Effect.Resource
import Control.Effect.Trace
import qualified Control.Exception as Exc (bracket)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign
import Foreign.C.Types (CBool (..))
import Foreign.Marshal.Array (allocaArray)
import Data.AST (AST, Node (Node))
import Data.Blob
import Data.Duration
import Data.Location
import Data.Source
import Data.Span
import Data.Term
import Data.AST (AST, Node (Node))
import Data.Blob
import Data.Duration
import Data.Term
import Source.Loc
import Source.Source (Source)
import qualified Source.Source as Source
import Source.Span
import qualified TreeSitter.Language as TS
import qualified TreeSitter.Node as TS
@ -32,7 +33,7 @@ data Result grammar
| Succeeded (AST [] grammar)
runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Result grammar)
runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do
runParser parser blobSource = unsafeUseAsCStringLen (Source.bytes blobSource) $ \ (source, len) -> do
alloca (\ rootPtr -> do
let acquire = do
-- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation
@ -84,7 +85,7 @@ toAST node@TS.Node{..} = do
children <- allocaArray count $ \ childNodesPtr -> do
_ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` childNodesPtr)
peekArray count childNodesPtr
pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Location (nodeRange node) (nodeSpan node))) children
pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Loc (nodeRange node) (nodeSpan node))) children
anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t
anaM g = a where a = pure . embed <=< traverse a <=< g

12
src/Rendering/Graph.hs
View File

@ -14,13 +14,13 @@ import Control.Effect.Reader
import Control.Effect.State
import Data.Diff
import Data.Graph
import Data.Location
import Data.Patch
import Data.String (IsString (..))
import Data.Term
import Prologue
import Semantic.Api.Bridge
import Semantic.Proto.SemanticPB
import Source.Loc as Loc
import qualified Data.Text as T
@ -61,7 +61,7 @@ class ToTreeGraph vertex t | t -> vertex where
toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph TermVertex (TermF syntax Location) where
ToTreeGraph TermVertex (TermF syntax Loc) where
toTreeGraph = termAlgebra where
termAlgebra ::
( ConstructorName syntax
@ -70,17 +70,17 @@ instance (ConstructorName syntax, Foldable syntax) =>
, Member (Reader (Graph TermVertex)) sig
, Carrier sig m
)
=> TermF syntax Location (m (Graph TermVertex))
=> TermF syntax Loc (m (Graph TermVertex))
-> m (Graph TermVertex)
termAlgebra (In ann syntax) = do
i <- fresh
parent <- ask
let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locationSpan ann)
let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? Loc.span ann)
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) where
ToTreeGraph DiffTreeVertex (DiffF syntax Loc Loc) where
toTreeGraph d = case d of
Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2))))
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1))))
@ -94,7 +94,7 @@ instance (ConstructorName syntax, Foldable syntax) =>
graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
pure (parent `connect` replace `overlay` graph)
where
ann a = converting #? locationSpan a
ann a = converting #? Loc.span a
diffAlgebra ::
( Foldable f
, Member Fresh sig

2
src/Rendering/TOC.hs
View File

@ -26,9 +26,9 @@ import Data.List (sortOn)
import qualified Data.List as List
import qualified Data.Map.Monoidal as Map
import Data.Patch
import Data.Location
import Data.Term
import qualified Data.Text as T
import Source.Loc
data Summaries = Summaries { changes, errors :: Map.Map T.Text [Value] }
deriving stock (Eq, Show, Generic)

2
src/Reprinting/Pipeline.hs
View File

@ -115,11 +115,11 @@ import Data.Reprinting.Errors
import Data.Reprinting.Scope
import Data.Reprinting.Splice
import Data.Reprinting.Token
import qualified Data.Source as Source
import Data.Term
import Reprinting.Tokenize
import Reprinting.Translate
import Reprinting.Typeset
import qualified Source.Source as Source
-- | Run the reprinting pipeline given the original 'Source', a language specific
-- translation function (as a function over 'Stream's) and the provided 'Term'.

17
src/Reprinting/Tokenize.hs
View File

@ -27,20 +27,21 @@ module Reprinting.Tokenize
, tokenizing
) where
import Prelude hiding (fail, log, filter)
import Prologue hiding (Element, hash)
import Streaming hiding (Sum)
import Prelude hiding (fail, filter, log)
import Prologue hiding (Element, hash)
import Streaming hiding (Sum)
import qualified Streaming.Prelude as Streaming
import Data.History
import Data.List (intersperse)
import Data.Range
import Data.Reprinting.Operator as Operator
import Data.Reprinting.Scope (Scope)
import qualified Data.Reprinting.Scope as Scope
import Data.Reprinting.Token as Token
import Data.Reprinting.Operator as Operator
import Data.Source
import Data.Term
import Source.Range
import Source.Source (Source)
import qualified Source.Source as Source
-- | The 'Tokenizer' monad represents a context in which 'Control'
-- tokens and 'Element' tokens can be sent to some downstream
@ -115,7 +116,7 @@ finish = do
crs <- asks cursor
log ("Finishing, cursor is " <> show crs)
src <- asks source
chunk (dropSource crs src)
chunk (Source.drop crs src)
-- State handling
@ -169,7 +170,7 @@ descend t = do
let delimiter = Range crs (start r)
unless (delimiter == Range 0 0) $ do
log ("slicing: " <> show delimiter)
chunk (slice delimiter src)
chunk (Source.slice src delimiter)
move (start r)
tokenize (fmap (withStrategy PrettyPrinting . into) t)
move (end r)

2
src/Reprinting/Translate.hs
View File

@ -16,7 +16,7 @@ import Data.Reprinting.Errors
import Data.Reprinting.Scope
import Data.Reprinting.Splice
import Data.Reprinting.Token
import qualified Data.Source as Source
import qualified Source.Source as Source
type TranslatorC
= StateC [Scope]

2
src/Semantic/Analysis.hs
View File

@ -17,7 +17,7 @@ import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Language (Language)
import Data.Span
import Source.Span
type ModuleC address value m
= ErrorC (LoopControl value)

28
src/Semantic/Api/Bridge.hs
View File

@ -8,11 +8,11 @@ module Semantic.Api.Bridge
import Control.Lens
import qualified Data.Blob as Data
import qualified Data.Language as Data
import Data.Source (fromText, toText)
import qualified Data.Span as Data
import qualified Data.Text as T
import qualified Semantic.Api.LegacyTypes as Legacy
import qualified Semantic.Proto.SemanticPB as API
import Source.Source (fromText, toText)
import qualified Source.Span as Source
-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
-- This is suitable for types such as 'Pos' which are representationally equivalent
@ -43,25 +43,25 @@ class APIConvert api native | api -> native where
rev #? item = item ^? re rev
infixr 8 #?
instance APIBridge Legacy.Position Data.Pos where
instance APIBridge Legacy.Position Source.Pos where
bridging = iso fromAPI toAPI where
toAPI Data.Pos{..} = Legacy.Position posLine posColumn
fromAPI Legacy.Position{..} = Data.Pos line column
toAPI Source.Pos{..} = Legacy.Position line column
fromAPI Legacy.Position{..} = Source.Pos line column
instance APIBridge API.Position Data.Pos where
instance APIBridge API.Position Source.Pos where
bridging = iso fromAPI toAPI where
toAPI Data.Pos{..} = API.Position (fromIntegral posLine) (fromIntegral posColumn)
fromAPI API.Position{..} = Data.Pos (fromIntegral line) (fromIntegral column)
toAPI Source.Pos{..} = API.Position (fromIntegral line) (fromIntegral column)
fromAPI API.Position{..} = Source.Pos (fromIntegral line) (fromIntegral column)
instance APIConvert API.Span Data.Span where
instance APIConvert API.Span Source.Span where
converting = prism' toAPI fromAPI where
toAPI Data.Span{..} = API.Span (bridging #? spanStart) (bridging #? spanEnd)
fromAPI API.Span{..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
toAPI Source.Span{..} = API.Span (bridging #? start) (bridging #? end)
fromAPI API.Span{..} = Source.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
instance APIConvert Legacy.Span Data.Span where
instance APIConvert Legacy.Span Source.Span where
converting = prism' toAPI fromAPI where
toAPI Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd)
fromAPI Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
toAPI Source.Span{..} = Legacy.Span (bridging #? start) (bridging #? end)
fromAPI Legacy.Span {..} = Source.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
instance APIBridge T.Text Data.Language where
bridging = iso Data.textToLanguage Data.languageToText

12
src/Semantic/Api/Diffs.hs
View File

@ -23,7 +23,6 @@ import Data.Diff
import Data.Graph
import Data.JSON.Fields
import Data.Language
import Data.Location
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
@ -39,6 +38,7 @@ import Semantic.Task as Task
import Semantic.Telemetry as Stat
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
import Source.Loc
data DiffOutputFormat
= DiffJSONTree
@ -55,7 +55,7 @@ parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
parseDiffBuilder DiffShow = distributeFoldMap showDiff
parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff
type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Location Location -> m (Rendering.JSON.JSON "diffs" SomeJSON)
type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blobPair
@ -63,7 +63,7 @@ jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blob
jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Location Location -> m (Rendering.JSON.JSON "diffs" SomeJSON)
renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
renderJSONTree blobPair = pure . renderJSONDiff blobPair
diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
@ -77,7 +77,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor
path = T.pack $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph
render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Loc Loc -> m DiffTreeFileGraph
render _ diff =
let graph = renderTreeGraph diff
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
@ -111,7 +111,7 @@ type TermPairConstraints =
]
doDiff :: (DiffEffects sig m)
=> BlobPair -> Decorate m Location ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
=> BlobPair -> Decorate m Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
doDiff blobPair decorate render = do
SomeTermPair terms <- doParse blobPair decorate
diff <- diffTerms blobPair terms
@ -125,7 +125,7 @@ diffTerms blobs terms = time "diff" languageTag $ do
where languageTag = languageTagForBlobPair blobs
doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m)
=> BlobPair -> Decorate m Location ann -> m (SomeTermPair TermPairConstraints ann)
=> BlobPair -> Decorate m Loc ann -> m (SomeTermPair TermPairConstraints ann)
doParse blobPair decorate = case languageForBlobPair blobPair of
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob)
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse haskellParser blob >>= decorate blob)

8
src/Semantic/Api/Symbols.hs
View File

@ -5,14 +5,11 @@ module Semantic.Api.Symbols
, parseSymbolsBuilder
) where
import Prelude hiding (span)
import Control.Effect.Error
import Control.Exception
import Control.Lens
import Data.Blob hiding (File (..))
import Data.ByteString.Builder
import Data.Location
import Data.Maybe
import Data.Term
import qualified Data.Text as T
@ -26,6 +23,7 @@ import Semantic.Api.Terms (ParseEffects, doParse)
import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task
import Serializing.Format
import Source.Loc
import Tags.Taggable
import Tags.Tagging
@ -41,7 +39,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m [Legacy.File]
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m [Legacy.File]
renderToSymbols = pure . pure . tagsToFile . runTagging blob symbolsToSummarize
tagsToFile :: [Tag] -> Legacy.File
@ -72,7 +70,7 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m File
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m File
renderToSymbols term = pure $ tagsToFile (runTagging blob symbolsToSummarize term)
tagsToFile :: [Tag] -> File

4
src/Semantic/Api/TOCSummaries.hs
View File

@ -9,9 +9,9 @@ import Data.Blob
import Data.ByteString.Builder
import Data.Diff
import qualified Data.Map.Monoidal as Map
import Data.Span (emptySpan)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Semilattice.Lower
import Rendering.TOC
import Semantic.Api.Diffs
import Semantic.Api.Bridge
@ -28,7 +28,7 @@ legacyDiffSummary = distributeFoldMap go
go :: (DiffEffects sig m) => BlobPair -> m Summaries
go blobPair = doDiff blobPair (decorate . declarationAlgebra) render
`catchError` \(SomeException e) ->
pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) emptySpan lang)])
pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)])
where path = T.pack $ pathKeyForBlobPair blobPair
lang = languageForBlobPair blobPair

6
src/Semantic/Api/Terms.hs
View File

@ -26,7 +26,6 @@ import Data.Either
import Data.Graph
import Data.JSON.Fields
import Data.Language
import Data.Location
import Data.Quieterm
import Data.Term
import qualified Data.Text as T
@ -41,6 +40,7 @@ import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
import Source.Loc
import Tags.Taggable
termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse
@ -54,7 +54,7 @@ termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor
path = T.pack $ blobPath blob
lang = bridging # blobLanguage blob
render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph
render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Loc -> ParseTreeFileGraph
render t = let graph = renderTreeGraph t
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
@ -113,7 +113,7 @@ type TermConstraints =
, Traversable
]
doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Location)
doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Loc)
doParse blob = case blobLanguage blob of
Go -> SomeTerm <$> parse goParser blob
Haskell -> SomeTerm <$> parse haskellParser blob

12
src/Semantic/Graph.hs
View File

@ -55,8 +55,6 @@ import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, Vertex
import Data.Language as Language
import Data.List (isPrefixOf, isSuffixOf)
import Data.Project
import Data.Location
import Data.Span
import Data.Term
import Data.Text (pack, unpack)
import Language.Haskell.HsColour
@ -65,6 +63,8 @@ import Parsing.Parser
import Prologue hiding (TypeError (..))
import Semantic.Analysis
import Semantic.Task as Task
import Source.Loc as Loc
import Source.Span
import System.FilePath.Posix (takeDirectory, (</>))
import Text.Show.Pretty (ppShow)
@ -102,7 +102,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
, Ord1 syntax
, Functor syntax
, Evaluatable syntax
, term ~ Term syntax Location
, term ~ Term syntax Loc
, FreeVariables1 syntax
, HasPrelude lang
, Member Trace sig
@ -255,7 +255,7 @@ parsePythonPackage :: forall syntax sig m term.
, FreeVariables1 syntax
, AccessControls1 syntax
, Functor syntax
, term ~ Term syntax Location
, term ~ Term syntax Loc
, Member (Error SomeException) sig
, Member Distribute sig
, Member Resolution sig
@ -335,11 +335,11 @@ withTermSpans :: ( Member (Reader Span) sig
, Member (State Span) sig -- last evaluated child's span
, Recursive term
, Carrier sig m
, Base term ~ TermF syntax Location
, Base term ~ TermF syntax Loc
)
=> Open (term -> Evaluator term address value m a)
withTermSpans recur term = let
span = locationSpan (termFAnnotation (project term))
span = Loc.span (termFAnnotation (project term))
updatedSpanAlg = withCurrentSpan span (recur term)
in modifyChildSpan span updatedSpanAlg

8
src/Semantic/REPL.hs
View File

@ -27,7 +27,6 @@ import Data.Language as Language
import Data.List (uncons)
import Data.Project
import Data.Quieterm
import Data.Span
import qualified Data.Text as T
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.LocalTime as LocalTime
@ -45,6 +44,7 @@ import Semantic.Telemetry
import Semantic.Timeout
import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage)
import Semantic.Util
import Source.Span
import System.Console.Haskeline
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.FilePath
@ -212,6 +212,6 @@ shouldBreak = do
span <- ask
pure (any @[] (matching span) breakpoints)
where matching Span{..} (OnLine n)
| n >= posLine spanStart
, n <= posLine spanEnd = True
| otherwise = False
| n >= line start
, n <= line end = True
| otherwise = False

13
src/Semantic/Resolution.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds, DeriveAnyClass, DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, DeriveAnyClass, DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Resolution
( Resolution (..)
, nodeJSResolutionMap
@ -11,13 +12,13 @@ import Control.Effect.Carrier
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Blob
import Data.Project
import qualified Data.Map as Map
import Data.Source
import Data.Language
import Prologue
import qualified Data.Map as Map
import Data.Project
import GHC.Generics (Generic1)
import Prologue
import Semantic.Task.Files
import qualified Source.Source as Source
import System.FilePath.Posix
@ -29,7 +30,7 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
pure $ fold (mapMaybe (lookup prop) blobs)
where
lookup :: Text -> Blob -> Maybe (Map FilePath FilePath)
lookup k b@Blob{..} = decodeStrict (sourceBytes blobSource) >>= lookupProp (blobPath b) k
lookup k b@Blob{..} = decodeStrict (Source.bytes blobSource) >>= lookupProp (blobPath b) k
lookupProp :: FilePath -> Text -> Object -> Maybe (Map FilePath FilePath)
lookupProp path k res = flip parseMaybe res $ \obj -> Map.singleton relPkgDotJSONPath . relEntryPath <$> obj .: k

49
src/Semantic/Task.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( Task
, TaskEff
@ -71,8 +72,6 @@ import Data.ByteString.Builder
import Data.Diff
import qualified Data.Error as Error
import qualified Data.Flag as Flag
import Data.Location
import Data.Source (Source)
import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
@ -84,11 +83,13 @@ import Parsing.TreeSitter
import Prologue hiding (project)
import Semantic.Config
import Semantic.Distribute
import qualified Semantic.Task.Files as Files
import Semantic.Timeout
import Semantic.Resolution
import qualified Semantic.Task.Files as Files
import Semantic.Telemetry
import Semantic.Timeout
import Serializing.Format hiding (Options)
import Source.Loc
import Source.Source (Source)
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff
@ -117,8 +118,8 @@ parse parser blob = send (Parse parser blob pure)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: (Functor f, Member Task sig, Carrier sig m)
=> RAlgebra (TermF f Location) (Term f Location) field
-> Term f Location
=> RAlgebra (TermF f Loc) (Term f Loc) field
-> Term f Loc
-> m (Term f field)
decorate algebra term = send (Decorate algebra term pure)
@ -191,14 +192,14 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a
deriving (Applicative, Functor, Monad, MonadIO)
instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
eff (L (Trace str k)) = writeLog Debug str [] >> k
-- | An effect describing high-level tasks to be performed.
data Task (m :: * -> *) k
= forall term . Parse (Parser term) Blob (term -> m k)
| forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> m k)
| forall f field . Functor f => Decorate (RAlgebra (TermF f Loc) (Term f Loc) field) (Term f Loc) (Term f field -> m k)
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k)
| forall input output . Render (Renderer input output) input (output -> m k)
| forall input . Serialize (Format input) input (Builder -> m k)
@ -206,18 +207,18 @@ data Task (m :: * -> *) k
deriving instance Functor m => Functor (Task m)
instance HFunctor Task where
hmap f (Parse parser blob k) = Parse parser blob (f . k)
hmap f (Decorate decorator term k) = Decorate decorator term (f . k)
hmap f (Parse parser blob k) = Parse parser blob (f . k)
hmap f (Decorate decorator term k) = Decorate decorator term (f . k)
hmap f (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (f . k)
hmap f (Render renderer input k) = Render renderer input (f . k)
hmap f (Serialize format input k) = Serialize format input (f . k)
hmap f (Render renderer input k) = Render renderer input (f . k)
hmap f (Serialize format input k) = Serialize format input (f . k)
instance Effect Task where
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: TaskC m a -> m a
@ -277,10 +278,10 @@ runParser blob@Blob{..} parser = case parser of
in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser blob parser
where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage blob
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Location -> [Error.Error String]
errors = cata $ \ (In Assignment.Location{..} syntax) -> case syntax of
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locationSpan err]
_ -> fold syntax
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String]
errors = cata $ \ (In Assignment.Loc{..} syntax) -> case syntax of
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError span err]
_ -> fold syntax
runAssignment :: ( Apply Foldable syntaxes
, Apply Functor syntaxes
, Element Syntax.Error syntaxes
@ -294,10 +295,10 @@ runParser blob@Blob{..} parser = case parser of
, Carrier sig m
, MonadIO m
)
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location))
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Loc) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Loc))
-> Parser ast
-> assignment (Term (Sum syntaxes) Assignment.Location)
-> m (Term (Sum syntaxes) Assignment.Location)
-> assignment (Term (Sum syntaxes) Assignment.Loc)
-> m (Term (Sum syntaxes) Assignment.Loc)
runAssignment assign parser assignment = do
taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession)

6
src/Semantic/Util.hs
View File

@ -33,7 +33,6 @@ import Data.Blob.IO
import Data.Graph (topologicalSort)
import qualified Data.Language as Language
import Data.List (uncons)
import Data.Location
import Data.Project hiding (readFile)
import Data.Quieterm (Quieterm, quieterm)
import Data.Sum (weaken)
@ -48,6 +47,7 @@ import Semantic.Analysis
import Semantic.Config
import Semantic.Graph
import Semantic.Task
import Source.Loc
import System.Exit (die)
import System.FilePath.Posix (takeDirectory)
@ -76,10 +76,10 @@ justEvaluating
type FileEvaluator err syntax =
[FilePath]
-> IO
( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise),
( Heap Precise Precise (Value (Quieterm (Sum syntax) Loc) Precise),
( ScopeGraph Precise
, Either (SomeError (Sum err))
(ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Location) Precise))))))
(ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Loc) Precise))))))
evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax
evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser

35
src/Semantic/UtilDisabled.hs
View File

@ -48,11 +48,10 @@ import Semantic.Analysis
import Semantic.Config
import Semantic.Graph
import Semantic.Task
import Source.Loc
import System.Exit (die)
import System.FilePath.Posix (takeDirectory)
import Data.Location
type ProjectEvaluator syntax =
Project
-> IO
@ -60,7 +59,7 @@ type ProjectEvaluator syntax =
(Hole (Maybe Name) Precise)
(Hole (Maybe Name) Precise)
(Value
(Quieterm (Sum syntax) Location)
(Quieterm (Sum syntax) Loc)
(Hole (Maybe Name) Precise)),
(ScopeGraph (Hole (Maybe Name) Precise),
ModuleTable
@ -68,7 +67,7 @@ type ProjectEvaluator syntax =
(ModuleResult
(Hole (Maybe Name) Precise)
(Value
(Quieterm (Sum syntax) Location)
(Quieterm (Sum syntax) Loc)
(Hole (Maybe Name) Precise))))))
type FileTypechecker (syntax :: [* -> *]) qterm value address result
@ -132,7 +131,7 @@ type EvalEffects qterm err = ResumableC (BaseError err)
-- We can't go with the inferred type because this needs to be
-- polymorphic in @lang@.
justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
, term ~ Quieterm (Sum lang) Location
, term ~ Quieterm (Sum lang) Loc
, value ~ Concrete.Value term hole
, Apply Show1 lang
)
@ -149,7 +148,7 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
(ResumableWithC (BaseError (LoadError hole value))
(FreshC
(StateC (ScopeGraph hole)
(StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
(StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Loc) (Hole (Maybe Name) Precise)))
(TraceByPrintingC
(LiftC IO))))))))))))) a
-> IO (Heap hole hole value, (ScopeGraph hole, a))
@ -200,7 +199,7 @@ callGraphProject
syntax
syntax) =>
Parser
(Term syntax Location)
(Term syntax Loc)
-> Proxy lang
-> [FilePath]
-> IO
@ -238,7 +237,7 @@ evalJavaScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser
typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location
, qterm ~ Quieterm (Sum syntax) Loc
, value ~ Type
, address ~ Monovariant
, result ~ (ModuleTable (Module (ModuleResult address value))))
@ -246,15 +245,15 @@ typecheckGoFile :: ( syntax ~ Language.Go.Assignment.Syntax
typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser
typecheckRubyFile :: ( syntax ~ Language.Ruby.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location
, qterm ~ Quieterm (Sum syntax) Loc
, value ~ Type
, address ~ Monovariant
, result ~ (ModuleTable (Module (ModuleResult address value))))
=> FileTypechecker syntax qterm value address result
typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser
evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location
, qterm ~ Quieterm (Sum syntax) Location
evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Loc
, qterm ~ Quieterm (Sum syntax) Loc
, address ~ Hole (Maybe Name) Precise
, LanguageSyntax lang syntax
)
@ -290,8 +289,8 @@ evaluateProjectForScopeGraph proxy parser project = runTask' $ do
(raiseHandler (runReader (lowerBound @Span))
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
, qterm ~ Quieterm (Sum syntax) Location
evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Loc
, qterm ~ Quieterm (Sum syntax) Loc
, LanguageSyntax lang syntax
)
=> Proxy (lang :: Language.Language)
@ -309,8 +308,8 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
(ResumableC (BaseError (LoadError Monovariant Type))
(ReaderC (Live Monovariant)
(NonDetC
(ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Loc) Monovariant Type)
(StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Loc) Monovariant Type)
(FreshC
(StateC (ScopeGraph Monovariant)
(StateC (Heap Monovariant Monovariant Type)
@ -341,8 +340,8 @@ type LanguageSyntax lang syntax = ( Language.SLanguage lang
, Apply AccessControls1 syntax
, Apply FreeVariables1 syntax)
evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Location
, qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Location
evaluatePythonProjects :: ( term ~ Term (Sum Language.Python.Assignment.Syntax) Loc
, qterm ~ Quieterm (Sum Language.Python.Assignment.Syntax) Loc
)
=> Proxy 'Language.Python
-> Parser term
@ -366,7 +365,7 @@ evaluatePythonProjects proxy parser lang path = runTask' $ do
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
evaluatePythonProject :: ( syntax ~ Language.Python.Assignment.Syntax
, qterm ~ Quieterm (Sum syntax) Location
, qterm ~ Quieterm (Sum syntax) Loc
, value ~ (Concrete.Value qterm address)
, address ~ Precise
, result ~ (ModuleTable (Module (ModuleResult address value)))) => FilePath

60
src/Tags/Taggable.hs
View File

@ -31,10 +31,10 @@ import Data.Abstract.Declarations
import Data.Abstract.Name
import Data.Blob
import Data.Language
import Data.Location
import Data.Range
import Data.Term
import Data.Text hiding (empty)
import Source.Loc as Loc
import Source.Range
import Streaming hiding (Sum)
import Streaming.Prelude (yield)
@ -67,11 +67,11 @@ class Taggable constr where
( Foldable syntax
, HasTextElement syntax
)
=> Language -> constr (Term syntax Location) -> Maybe Range
=> Language -> constr (Term syntax Loc) -> Maybe Range
snippet :: Foldable syntax => Location -> constr (Term syntax Location) -> Maybe Range
snippet :: Foldable syntax => Loc -> constr (Term syntax Loc) -> Maybe Range
symbolName :: Declarations1 syntax => constr (Term syntax Location) -> Maybe Name
symbolName :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name
data Strategy = Default | Custom
@ -80,13 +80,13 @@ class TaggableBy (strategy :: Strategy) constr where
( Foldable syntax
, HasTextElement syntax
)
=> Language -> constr (Term syntax Location) -> Maybe Range
=> Language -> constr (Term syntax Loc) -> Maybe Range
docsLiteral' _ _ = Nothing
snippet' :: (Foldable syntax) => Location -> constr (Term syntax Location) -> Maybe Range
snippet' :: (Foldable syntax) => Loc -> constr (Term syntax Loc) -> Maybe Range
snippet' _ _ = Nothing
symbolName' :: Declarations1 syntax => constr (Term syntax Location) -> Maybe Name
symbolName' :: Declarations1 syntax => constr (Term syntax Loc) -> Maybe Name
symbolName' _ = Nothing
type IsTaggable syntax =
@ -100,28 +100,28 @@ type IsTaggable syntax =
tagging :: (Monad m, IsTaggable syntax)
=> Blob
-> Term syntax Location
-> Term syntax Loc
-> Stream (Of Token) m ()
tagging b = foldSubterms (descend (blobLanguage b))
descend ::
( ConstructorName (TermF syntax Location)
( ConstructorName (TermF syntax Loc)
, IsTaggable syntax
, Monad m
)
=> Language -> SubtermAlgebra (TermF syntax Location) (Term syntax Location) (Tagger m ())
=> Language -> SubtermAlgebra (TermF syntax Loc) (Term syntax Loc) (Tagger m ())
descend lang t@(In loc _) = do
let term = fmap subterm t
let snippetRange = snippet loc term
let litRange = docsLiteral lang term
enter (constructorName term) snippetRange
maybe (pure ()) (emitIden (locationSpan loc) litRange) (symbolName term)
maybe (pure ()) (emitIden (Loc.span loc) litRange) (symbolName term)
traverse_ subtermRef t
exit (constructorName term) snippetRange
subtractLocation :: Location -> Location -> Range
subtractLocation a b = subtractRange (locationByteRange a) (locationByteRange b)
subtractLoc :: Loc -> Loc -> Range
subtractLoc a b = subtractRange (byteRange a) (byteRange b)
-- Instances
@ -151,60 +151,60 @@ instance Apply Taggable fs => TaggableBy 'Custom (Sum fs) where
snippet' x = apply @Taggable (snippet x)
symbolName' = apply @Taggable symbolName
instance Taggable a => TaggableBy 'Custom (TermF a Location) where
instance Taggable a => TaggableBy 'Custom (TermF a Loc) where
docsLiteral' l t = docsLiteral l (termFOut t)
snippet' ann t = snippet ann (termFOut t)
symbolName' t = symbolName (termFOut t)
instance TaggableBy 'Custom Syntax.Context where
snippet' ann (Syntax.Context _ (Term (In subj _))) = Just (subtractLocation ann subj)
snippet' ann (Syntax.Context _ (Term (In subj _))) = Just (subtractLoc ann subj)
instance TaggableBy 'Custom Declaration.Function where
docsLiteral' Python (Declaration.Function _ _ _ (Term (In _ bodyF)))
| (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn)
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Function _ _ _ (Term (In body _))) = Just $ subtractLocation ann body
snippet' ann (Declaration.Function _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.functionName
instance TaggableBy 'Custom Declaration.Method where
docsLiteral' Python (Declaration.Method _ _ _ _ (Term (In _ bodyF)) _)
| (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn)
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Method _ _ _ _ (Term (In body _)) _) = Just $ subtractLocation ann body
snippet' ann (Declaration.Method _ _ _ _ (Term (In body _)) _) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.methodName
instance TaggableBy 'Custom Declaration.Class where
docsLiteral' Python (Declaration.Class _ _ _ (Term (In _ bodyF)))
| (Term (In exprAnn exprF):_) <- toList bodyF
, isTextElement exprF = Just (locationByteRange exprAnn)
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Class _ _ _ (Term (In body _))) = Just $ subtractLocation ann body
snippet' ann (Declaration.Class _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Declaration.classIdentifier
instance TaggableBy 'Custom Ruby.Class where
snippet' ann (Ruby.Class _ _ (Term (In body _))) = Just $ subtractLocation ann body
snippet' ann (Ruby.Class _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Ruby.classIdentifier
instance TaggableBy 'Custom Ruby.Module where
snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body
snippet' ann (Ruby.Module _ _) = Just $ locationByteRange ann
snippet' ann (Ruby.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
snippet' ann (Ruby.Module _ _) = Just $ byteRange ann
symbolName' = declaredName . Ruby.moduleIdentifier
instance TaggableBy 'Custom TypeScript.Module where
snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLocation ann body
snippet' ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann
snippet' ann (TypeScript.Module _ (Term (In body _):_)) = Just $ subtractLoc ann body
snippet' ann (TypeScript.Module _ _ ) = Just $ byteRange ann
symbolName' = declaredName . TypeScript.moduleIdentifier
instance TaggableBy 'Custom Expression.Call where
snippet' ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLocation ann body
snippet' ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLoc ann body
symbolName' = declaredName . Expression.callFunction
instance TaggableBy 'Custom Ruby.Send where
snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body
snippet' ann _ = Just $ locationByteRange ann
snippet' ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLoc ann body
snippet' ann _ = Just $ byteRange ann
symbolName' Ruby.Send{..} = declaredName =<< sendSelector

10
src/Tags/Tagging.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators, ScopedTypeVariables, UndecidableInstances #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Tags.Tagging
( runTagging
, Tag(..)
@ -14,16 +14,16 @@ import Streaming
import qualified Streaming.Prelude as Streaming
import Data.Blob
import Data.Location
import qualified Data.Source as Source
import Data.Tag
import Data.Term
import Source.Loc
import qualified Source.Source as Source
import Tags.Taggable
runTagging :: (IsTaggable syntax)
=> Blob
-> [Text]
-> Term syntax Location
-> Term syntax Loc
-> [Tag]
runTagging blob symbolsToSummarize
= Eff.run
@ -51,7 +51,7 @@ contextualizing Blob{..} symbolsToSummarize = Streaming.mapMaybeM $ \case
-> Just $ Tag iden x span (fmap fst xs) (firstLine (slice r)) (slice docsLiteralRange)
_ -> Nothing
where
slice = fmap (stripEnd . Source.toText . flip Source.slice blobSource)
slice = fmap (stripEnd . Source.toText . Source.slice blobSource)
firstLine = fmap (T.take 180 . fst . breakOn "\n")
enterScope, exitScope :: ( Member (State [ContextToken]) sig

6
test/Analysis/TypeScript/Spec.hs
View File

@ -14,12 +14,12 @@ import Data.Abstract.Number as Number
import Data.Abstract.Package (PackageInfo (..))
import Data.Abstract.Value.Concrete as Concrete
import qualified Data.Language as Language
import Data.Location
import Data.Quieterm
import Data.Scientific (scientific)
import Data.Sum
import Data.Text (pack)
import qualified Language.TypeScript.Assignment as TypeScript
import Source.Loc
import SpecHelpers
spec :: (?session :: TaskSession) => Spec
@ -176,7 +176,7 @@ spec = do
it "member access of private methods throws AccessControlError" $ do
(_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_method.ts"]
let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo "private_method.ts" Language.TypeScript mempty) (Span (Pos 4 1) (Pos 4 16)) (AccessControlError ("foo", ScopeGraph.Public) ("private_add", ScopeGraph.Private) (Closure (PackageInfo "access_control" mempty) (ModuleInfo "adder.ts" Language.TypeScript mempty) (Just "private_add") Nothing [] (Right (Quieterm (In (Location (Range 146 148) (Span (Pos 7 27) (Pos 7 29))) (inject (StatementBlock []))))) (Precise 20) (Precise 18))))))
let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo "private_method.ts" Language.TypeScript mempty) (Span (Pos 4 1) (Pos 4 16)) (AccessControlError ("foo", ScopeGraph.Public) ("private_add", ScopeGraph.Private) (Closure (PackageInfo "access_control" mempty) (ModuleInfo "adder.ts" Language.TypeScript mempty) (Just "private_add") Nothing [] (Right (Quieterm (In (Loc (Range 146 148) (Span (Pos 7 27) (Pos 7 29))) (inject (StatementBlock []))))) (Precise 20) (Precise 18))))))
res `shouldBe` expected
where
@ -184,5 +184,5 @@ spec = do
evaluate = evalTypeScriptProject . map (fixtures <>)
evalTypeScriptProject = testEvaluating <=< (evaluateProject' ?session (Proxy :: Proxy 'Language.TypeScript) typescriptParser)
type TypeScriptTerm = Quieterm (Sum TypeScript.Syntax) Location
type TypeScriptTerm = Quieterm (Sum TypeScript.Syntax) Loc
type TypeScriptEvalError = BaseError (EvalError TypeScriptTerm Precise (Concrete.Value TypeScriptTerm Precise))

8
test/Assigning/Assignment/Spec.hs
View File

@ -5,15 +5,15 @@ import Assigning.Assignment
import Data.AST
import Data.Bifunctor (first)
import Data.Ix
import Data.Range
import Data.Semigroup ((<>))
import Data.Source
import Data.Span
import Data.Term
import Data.Text as T (Text, length, words)
import Data.Text.Encoding (encodeUtf8)
import GHC.Stack (getCallStack)
import Prelude hiding (words)
import Source.Range
import Source.Source
import Source.Span
import Test.Hspec
import TreeSitter.Language (Symbol (..), SymbolType (..))
@ -255,7 +255,7 @@ spec = do
Left [ "symbol" ]
node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol
node symbol start end children = Term (Node symbol (Location (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children)
node symbol start end children = Term (Node symbol (Loc (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children)
data Grammar = Palette | Red | Green | Blue | Magenta
deriving (Bounded, Enum, Eq, Ix, Ord, Show)

4
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -33,9 +33,9 @@ spec = do
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
x = SpecHelpers.name "x"
associatedScope <- newScope lexicalEdges
declare (ScopeGraph.Declaration "identity") Default Public emptySpan ScopeGraph.Function (Just associatedScope)
declare (ScopeGraph.Declaration "identity") Default Public lowerBound ScopeGraph.Function (Just associatedScope)
withScope associatedScope $ do
declare (Declaration x) Default Public emptySpan ScopeGraph.RequiredParameter Nothing
declare (Declaration x) Default Public lowerBound ScopeGraph.RequiredParameter Nothing
identity <- function "identity" [ x ]
(SpecEff (Heap.lookupSlot (ScopeGraph.Declaration (SpecHelpers.name "x")) >>= deref)) associatedScope
val <- integer 123

9
test/Data/Functor/Listable.hs
View File

@ -28,10 +28,7 @@ import Data.Functor.Both
import qualified Data.Language as Language
import Data.List.NonEmpty
import Data.Patch
import Data.Range
import Data.Location
import Data.Semigroup.App
import Data.Span
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Comment as Comment
@ -47,6 +44,8 @@ import Data.Text as T (Text, pack)
import Data.These
import Data.Sum
import Diffing.Algorithm.RWS
import Source.Loc
import Source.Span
import Test.LeanCheck
type Tier a = [a]
@ -542,8 +541,8 @@ instance Listable (f a) => Listable (App f a) where
instance Listable (f a) => Listable (AppMerge f a) where
tiers = cons1 AppMerge
instance Listable Location where
tiers = cons2 Location
instance Listable Loc where
tiers = cons2 Loc
instance Listable Range where
tiers = cons2 Range

11
test/Data/Range/Spec.hs
View File

@ -1,11 +0,0 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Range.Spec (spec) where
import Data.Range
import SpecHelpers
spec :: Spec
spec = describe "Data.Range" $
prop "should have an associative Semigroup instance" $
\(a, b, c) -> a <> (b <> c) `shouldBe` (a <> b) <> (c :: Range)

100
test/Data/Source/Spec.hs
View File

@ -1,100 +0,0 @@
module Data.Source.Spec (spec, testTree) where
import Data.Range
import Data.Source
import Data.Span
import qualified Data.Text as Text
import Test.Hspec
import qualified Generators as Gen
import Hedgehog hiding (Range)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range
import qualified Test.Tasty as Tasty
import Test.Tasty.Hedgehog (testProperty)
prop :: HasCallStack => String -> (Source -> PropertyT IO ()) -> Tasty.TestTree
prop desc f
= testProperty desc
. property
$ forAll (Gen.source (Hedgehog.Range.linear 0 100))
>>= f
testTree :: Tasty.TestTree
testTree = Tasty.testGroup "Data.Source"
[ Tasty.testGroup "sourceLineRanges"
[ prop "produces 1 more range than there are newlines" $ \ source -> do
summarize source
length (sourceLineRanges source) === length (Text.splitOn "\r\n" (toText source) >>= Text.splitOn "\r" >>= Text.splitOn "\n")
, prop "produces exhaustive ranges" $ \ source -> do
summarize source
foldMap (`slice` source) (sourceLineRanges source) === source
]
, Tasty.testGroup "spanToRange"
[ prop "computes single-line ranges" $ \ source -> do
let ranges = sourceLineRanges source
let spans = zipWith (\ i Range {..} -> Span (Pos i 1) (Pos i (succ (end - start)))) [1..] ranges
fmap (spanToRange source) spans === ranges
, prop "computes multi-line ranges" $
\ source ->
spanToRange source (totalSpan source) === totalRange source
, prop "computes sub-line ranges" $
\ s -> let source = "*" <> s <> "*" in
spanToRange source (insetSpan (totalSpan source)) === insetRange (totalRange source)
, testProperty "inverse of rangeToSpan" . property $ do
a <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
b <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
let s = a <> "\n" <> b in spanToRange s (totalSpan s) === totalRange s
]
, testProperty "rangeToSpan inverse of spanToRange" . property $ do
a <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
b <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
let s = a <> "\n" <> b in rangeToSpan s (totalRange s) === totalSpan s
, Tasty.testGroup "totalSpan"
[ testProperty "covers single lines" . property $ do
n <- forAll $ Gen.int (Hedgehog.Range.linear 0 100)
totalSpan (fromText (Text.replicate n "*")) === Span (Pos 1 1) (Pos 1 (max 1 (succ n)))
, testProperty "covers multiple lines" . property $ do
n <- forAll $ Gen.int (Hedgehog.Range.linear 0 100)
totalSpan (fromText (Text.intersperse '\n' (Text.replicate n "*"))) === Span (Pos 1 1) (Pos (max 1 n) (if n > 0 then 2 else 1))
]
]
where summarize src = do
let lines = sourceLines src
-- FIXME: this should be using cover (reverted in 1b427b995), but that leads to flaky tests: hedgehog’s 'cover' implementation fails tests instead of warning, and currently has no equivalent to 'checkCoverage'.
classify "empty" $ nullSource src
classify "single-line" $ length lines == 1
classify "multiple lines" $ length lines > 1
spec :: Spec
spec = do
describe "newlineIndices" $ do
it "finds \\n" $
let source = "a\nb" in
newlineIndices source `shouldBe` [1]
it "finds \\r" $
let source = "a\rb" in
newlineIndices source `shouldBe` [1]
it "finds \\r\\n" $
let source = "a\r\nb" in
newlineIndices source `shouldBe` [2]
it "finds intermixed line endings" $
let source = "hi\r}\r}\n xxx \r a" in
newlineIndices source `shouldBe` [2, 4, 6, 12]
insetSpan :: Span -> Span
insetSpan sourceSpan = sourceSpan { spanStart = (spanStart sourceSpan) { posColumn = succ (posColumn (spanStart sourceSpan)) }
, spanEnd = (spanEnd sourceSpan) { posColumn = pred (posColumn (spanEnd sourceSpan)) } }
insetRange :: Range -> Range
insetRange Range {..} = Range (succ start) (pred end)

14
test/Generators.hs
View File

@ -6,18 +6,18 @@ module Generators
, classifyScientific
) where
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Data.Source
import Data.Scientific (Scientific)
import Data.Ratio ((%))
import Data.Ratio ((%))
import Data.Scientific (Scientific)
import qualified Data.Scientific as Scientific
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Source.Source
source :: MonadGen m => Hedgehog.Range Int -> m Data.Source.Source
source :: MonadGen m => Hedgehog.Range Int -> m Source.Source.Source
source r = Gen.frequency [ (1, empty), (20, nonEmpty) ]
where empty = pure mempty
nonEmpty = Data.Source.fromUTF8 <$> Gen.utf8 r (Gen.frequency [ (1, pure '\r'), (1, pure '\n'), (20, Gen.unicode) ])
nonEmpty = Source.Source.fromUTF8 <$> Gen.utf8 r (Gen.frequency [ (1, pure '\r'), (1, pure '\n'), (20, Gen.unicode) ])
integerScientific :: MonadGen m => Hedgehog.Range Integer -> m Scientific
integerScientific = fmap fromIntegral . Gen.integral

4
test/Parsing/Spec.hs
View File

@ -6,10 +6,10 @@ import Data.ByteString.Char8 (pack)
import Data.Duration
import Data.Language
import Data.Maybe
import Data.Source
import Parsing.TreeSitter
import Source.Source
import SpecHelpers
import TreeSitter.JSON (tree_sitter_json, Grammar)
import TreeSitter.JSON (Grammar, tree_sitter_json)
spec :: Spec
spec = do

6
test/Rendering/TOC/Spec.hs
View File

@ -10,8 +10,6 @@ import Data.Diff
import Data.Functor.Classes
import Data.Hashable.Lifted
import Data.Patch
import Data.Location
import Data.Span
import Data.Sum
import Data.Term
import Data.Text (Text)
@ -23,6 +21,8 @@ import qualified Data.Syntax.Declaration as Declaration
import Rendering.TOC
import Semantic.Api (diffSummaryBuilder)
import Serializing.Format as Format
import Source.Loc
import Source.Span
import qualified System.Path as Path
import System.Path ((</>))
@ -235,7 +235,7 @@ diffWithParser :: ( Eq1 syntax
, Member Task sig
, Carrier sig m
)
=> Parser (Term syntax Location)
=> Parser (Term syntax Loc)
-> BlobPair
-> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin

2
test/Rewriting/JSON/Spec.hs
View File

@ -9,12 +9,12 @@ import Control.Category
import Control.Rewriting as Rewriting
import qualified Data.ByteString as B
import Data.History as History
import qualified Data.Source as Source
import Data.Sum
import qualified Data.Syntax.Literal as Literal
import Data.Text (Text)
import Language.JSON.PrettyPrint
import Reprinting.Pipeline
import qualified Source.Source as Source
-- Adds a "hi": "bye" key-value pair to any empty Hash.
onTrees :: ( Literal.TextElement :< syn

5
test/Spec.hs
View File

@ -15,10 +15,8 @@ import qualified Data.Abstract.Path.Spec
import qualified Data.Functor.Classes.Generic.Spec
import qualified Data.Graph.Spec
import qualified Data.Language.Spec
import qualified Data.Range.Spec
import qualified Data.Scientific.Spec
import qualified Data.Semigroup.App.Spec
import qualified Data.Source.Spec
import qualified Data.Term.Spec
import qualified Diffing.Algorithm.RWS.Spec
import qualified Diffing.Algorithm.SES.Spec
@ -48,7 +46,6 @@ tests =
[ Integration.Spec.testTree
, Semantic.CLI.Spec.testTree
, Data.Language.Spec.testTree
, Data.Source.Spec.testTree
, Semantic.Stat.Spec.testTree
, Data.Scientific.Spec.testTree
]
@ -81,9 +78,7 @@ legacySpecs = parallel $ do
describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
describe "Data.Range" Data.Range.Spec.spec
describe "Data.Semigroup.App" Data.Semigroup.App.Spec.spec
describe "Data.Source" Data.Source.Spec.spec
describe "Data.Term" Data.Term.Spec.spec
describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec
describe "Diffing.Algorithm.SES" Diffing.Algorithm.SES.Spec.spec

6
test/SpecHelpers.hs
View File

@ -44,10 +44,8 @@ import Data.Foldable (toList)
import Data.Functor.Listable as X
import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..))
import Data.Range as X
import Data.Semilattice.Lower as X
import Data.Source as X
import Data.Span as X hiding (HasSpan(..))
import Source.Source as X (Source)
import Data.String
import Data.Sum
import Data.Term as X
@ -55,6 +53,8 @@ import Parsing.Parser as X
import Semantic.Task as X
import Semantic.Util as X
import Semantic.Graph (runHeap, runScopeGraph)
import Source.Range as X hiding (start, end, point)
import Source.Span as X hiding (HasSpan(..), start, end, point)
import Debug.Trace as X (traceShowM, traceM)
import Data.ByteString as X (ByteString)