diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 0.0.2.0 + +- Adds `Source.Language`. +- Adds `ToJSON` instances for `Range` and `Loc`. + # 0.0.1.0 - Adds an `NFData` instance for `Source`. 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.0.1.0 +version: 0.0.2.0 synopsis: Types and functionality for working with source code description: Types and functionality for working with source code (program text). homepage: https://github.com/github/semantic/tree/master/semantic-source#readme @@ -42,6 +42,7 @@ library import: haskell exposed-modules: + Source.Language Source.Loc Source.Range Source.Source @@ -51,8 +52,11 @@ , base >= 4.12 && < 5 , bytestring ^>= 0.10.8.2 , deepseq ^>= 1.4.4.0 + , containers ^>= 0.6.2 , generic-monoid ^>= 0.1.0.0 , hashable >= 1.2.7 && < 1.4 + , lingo ^>= 0.3 + , pathtype ^>= 0.8.1 , semilattices ^>= 0.0.0.3 , text ^>= 1.2.3.1 hs-source-dirs: src diff --git a/src/Source/Language.hs b/src/Source/Language.hs new file mode 100644 --- /dev/null +++ b/src/Source/Language.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Source.Language + ( Language (..) + , SLanguage (..) + , extensionsForLanguage + , knownLanguage + , forPath + , textToLanguage + , languageToText + ) where + +import Data.Aeson +import Data.Hashable (Hashable) +import qualified Data.Languages as Lingo +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified System.Path as Path +import qualified System.Path.PartClass as Path.PartClass + +-- | The various languages we support. +data Language + = Unknown + | Go + | Haskell + | Java + | JavaScript + | JSON + | JSX + | Markdown + | Python + | Ruby + | TypeScript + | PHP + | TSX + deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Enum) + +-- | Reifies a proxied type-level 'Language' to a value. +class SLanguage (lang :: Language) where + reflect :: proxy lang -> Language + +instance SLanguage 'Unknown where + reflect _ = Unknown + +instance SLanguage 'Go where + reflect _ = Go + +instance SLanguage 'Haskell where + reflect _ = Haskell + +instance SLanguage 'Java where + reflect _ = Java + +instance SLanguage 'JavaScript where + reflect _ = JavaScript + +instance SLanguage 'JSON where + reflect _ = JSON + +instance SLanguage 'JSX where + reflect _ = JSX + +instance SLanguage 'Markdown where + reflect _ = Markdown + +instance SLanguage 'Python where + reflect _ = Python + +instance SLanguage 'Ruby where + reflect _ = Ruby + +instance SLanguage 'TypeScript where + reflect _ = TypeScript + +instance SLanguage 'PHP where + reflect _ = PHP + +instance FromJSON Language where + parseJSON = withText "Language" $ \l -> + pure $ textToLanguage l + + +-- | Predicate failing on 'Unknown' and passing in all other cases. +knownLanguage :: Language -> Bool +knownLanguage = (/= Unknown) + +extensionsForLanguage :: Language -> [String] +extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages) + +forPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language +forPath path = + let spurious lang = lang `elem` [ "Hack" -- .php files + , "GCC Machine Description" -- .md files + , "XML" -- .tsx files + ] + allResults = Lingo.languageName <$> Lingo.languagesForPath (Path.toString path) + in case filter (not . spurious) allResults of + [result] -> textToLanguage result + _ -> Unknown + +languageToText :: Language -> T.Text +languageToText = \case + Unknown -> "Unknown" + Go -> "Go" + Haskell -> "Haskell" + Java -> "Java" + JavaScript -> "JavaScript" + JSON -> "JSON" + JSX -> "JSX" + Markdown -> "Markdown" + Python -> "Python" + Ruby -> "Ruby" + TypeScript -> "TypeScript" + TSX -> "TSX" + PHP -> "PHP" + +textToLanguage :: T.Text -> Language +textToLanguage = \case + "Go" -> Go + "Haskell" -> Haskell + "Java" -> Java + "JavaScript" -> JavaScript + "JSON" -> JSON + "JSX" -> JSX + "Markdown" -> Markdown + "Python" -> Python + "Ruby" -> Ruby + "TypeScript" -> TypeScript + "TSX" -> TSX + "PHP" -> PHP + _ -> Unknown 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 #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes, NamedFieldPuns, OverloadedStrings #-} module Source.Loc ( Loc(..) , byteRange_ @@ -7,6 +7,7 @@ ) where import Control.DeepSeq (NFData) +import Data.Aeson (ToJSON(..), object, (.=)) import Data.Hashable (Hashable) import Data.Monoid.Generic import GHC.Generics (Generic) @@ -28,6 +29,9 @@ span_ = lens span (\l s -> l { span = s }) {-# INLINE span_ #-} +instance ToJSON Loc where + toJSON Loc{byteRange, span} = object ["sourceRange" .= byteRange + , "sourceSpan" .= span] byteRange_ :: Lens' Loc Range byteRange_ = lens byteRange (\l r -> l { byteRange = r }) @@ -38,3 +42,4 @@ 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, RankNTypes #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RankNTypes, NamedFieldPuns #-} module Source.Range ( Range(..) , point @@ -10,6 +10,7 @@ ) where import Control.DeepSeq (NFData) +import Data.Aeson (ToJSON(..)) import Data.Hashable (Hashable) import Data.Semilattice.Lower (Lower(..)) import GHC.Generics (Generic) @@ -24,6 +25,8 @@ instance Hashable Range instance NFData Range + + -- $ -- prop> a <> (b <> c) === (a <> b) <> (c :: Range) instance Semigroup Range where @@ -32,6 +35,8 @@ instance Lower Range where lowerBound = Range 0 0 +instance ToJSON Range where + toJSON Range { start, end } = toJSON [ start, end ] -- | Construct a 'Range' with a given value for both its start and end indices. point :: Int -> Range @@ -60,3 +65,4 @@ -- $setup -- >>> import Test.QuickCheck -- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary ; shrink (Range s e) = Range <$> shrink s <*> shrink e +