packages feed

semantic-source (empty) → 0.0.0.0

raw patch · 11 files changed

+572/−0 lines, 11 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, deepseq, doctest, generic-monoid, hashable, hedgehog, semantic-source, semilattices, tasty, tasty-hedgehog, tasty-hunit, text

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ semantic-source.cabal view
@@ -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
+ src/Source/Loc.hs view
@@ -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 #-}
+ src/Source/Range.hs view
@@ -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
+ src/Source/Source.hs view
@@ -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 #-}
+ src/Source/Span.hs view
@@ -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 #-}
+ test/Doctest.hs view
@@ -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))
+ test/Source/Test.hs view
@@ -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
+ test/Test.hs view
@@ -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+  ]