diff --git a/semantic-source.cabal b/semantic-source.cabal --- a/semantic-source.cabal +++ b/semantic-source.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: semantic-source -version: 0.1.0.0 +version: 0.1.0.1 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 @@ -10,7 +10,7 @@ license-file: LICENSE author: The Semantic authors maintainer: opensource+semantic@github.com -copyright: (c) 2019 GitHub, Inc. +copyright: (c) 2020 GitHub, Inc. category: Data build-type: Simple stability: alpha @@ -21,6 +21,7 @@ tested-with: GHC == 8.6.5 GHC == 8.8.1 + GHC == 8.10.1 common haskell default-language: Haskell2010 @@ -38,6 +39,10 @@ -Wno-star-is-type if (impl(ghc >= 8.8)) ghc-options: -Wno-missing-deriving-strategies + if (impl(ghc >= 8.10)) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module library import: haskell @@ -48,39 +53,28 @@ Source.Source Source.Span build-depends: - aeson ^>= 1.4.2.0 + , aeson ^>= 1.4.2.0 , base >= 4.12 && < 5 , bytestring ^>= 0.10.8.2 , deepseq ^>= 1.4.4.0 , containers ^>= 0.6.2 - , generic-monoid ^>= 0.1.0.0 , hashable >= 1.2.7 && < 1.4 , lingo ^>= 0.3.2.0 , pathtype ^>= 0.8.1 , semilattices ^>= 0.0.0.3 - , text ^>= 1.2.3.1 + , text ^>= 1.2.3.2 hs-source-dirs: src -test-suite doctest - import: haskell - 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: haskell type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Test.hs other-modules: + Range.Test Source.Test build-depends: - base + , base , hedgehog ^>= 1 , semantic-source , tasty >= 1.2 && <2 diff --git a/src/Source/Language.hs b/src/Source/Language.hs --- a/src/Source/Language.hs +++ b/src/Source/Language.hs @@ -94,7 +94,7 @@ knownLanguage = (/= Unknown) extensionsForLanguage :: Language -> [String] -extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages) +extensionsForLanguage language = fmap T.unpack (maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages)) forPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language forPath path = diff --git a/src/Source/Loc.hs b/src/Source/Loc.hs --- a/src/Source/Loc.hs +++ b/src/Source/Loc.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes, NamedFieldPuns, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, RankNTypes, NamedFieldPuns, OverloadedStrings #-} module Source.Loc ( Loc(..) , byteRange_ @@ -9,7 +9,6 @@ import Control.DeepSeq (NFData) import Data.Aeson (ToJSON(..), object, (.=)) import Data.Hashable (Hashable) -import Data.Monoid.Generic import GHC.Generics (Generic) import Prelude hiding (span) import Source.Range @@ -20,8 +19,10 @@ , span :: {-# UNPACK #-} !Span } deriving (Eq, Ord, Show, Generic) - deriving Semigroup via GenericSemigroup Loc +instance Semigroup Loc where + Loc b1 s1 <> Loc b2 s2 = Loc (b1 <> b2) (s1 <> s2) + instance Hashable Loc instance NFData Loc @@ -42,4 +43,3 @@ lens :: (s -> a) -> (s -> a -> s) -> Lens' s a lens get put afa s = fmap (put s) (afa (get s)) {-# INLINE lens #-} - diff --git a/src/Source/Range.hs b/src/Source/Range.hs --- a/src/Source/Range.hs +++ b/src/Source/Range.hs @@ -25,10 +25,6 @@ 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) @@ -60,9 +56,3 @@ 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 - diff --git a/test/Doctest.hs b/test/Doctest.hs deleted file mode 100644 --- a/test/Doctest.hs +++ /dev/null @@ -1,12 +0,0 @@ -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)) diff --git a/test/Range/Test.hs b/test/Range/Test.hs new file mode 100644 --- /dev/null +++ b/test/Range/Test.hs @@ -0,0 +1,30 @@ +module Range.Test +( testTree +) where + +import Control.Monad (join) +import Hedgehog hiding (Range) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Source.Range +import qualified Test.Tasty as Tasty +import Test.Tasty.Hedgehog (testProperty) + +testTree :: Tasty.TestTree +testTree = Tasty.testGroup "Source.Range" + [ Tasty.testGroup "Semigroup" + [ testProperty "associativity" . property $ do + (a, b, c) <- forAll ((,,) <$> range <*> range <*> range) + a <> (b <> c) === (a <> b) <> c + ] + ] + + +range :: MonadGen m => m Range +range = Gen.choice [ empty, nonEmpty ] where + point = Gen.int (Range.linear 0 100) + empty = join Range <$> point + nonEmpty = do + start <- point + length <- point + pure $! Range start (start + length + 1) diff --git a/test/Source/Test.hs b/test/Source/Test.hs --- a/test/Source/Test.hs +++ b/test/Source/Test.hs @@ -20,7 +20,7 @@ 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" +testTree = Tasty.testGroup "Source.Source" [ Tasty.testGroup "lineRanges" [ testProperty "produces 1 more range than there are newlines" . property $ do source <- forAll (source (Range.linear 0 100)) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -2,10 +2,12 @@ ( main ) where +import qualified Range.Test as Range import qualified Source.Test as Source import Test.Tasty as Tasty main :: IO () main = defaultMain $ testGroup "semantic-source" - [ Source.testTree + [ Range.testTree + , Source.testTree ]