mirror of
https://github.com/github/semantic.git
synced 2024-12-02 11:23:05 +03:00
fafd5a76f3
- [ ] Depends on #444. Because we need a separate release, this patch doesn't yet remove Data.Language.
137 lines
3.2 KiB
Haskell
137 lines
3.2 KiB
Haskell
{-# 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
|