diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# 0.4.0.0 + +Rewrite to use Template Haskell splices instead of a custom Setup.hs. + +Add support for the Bazel build system. + # 0.3.0.0 `languageForPath` is now `languagesForPath`, which returns multiple results in cases of ambiguity. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,13 @@ ## Development ``` -cabal new-update -cabal new-configure -cabal new-build +cabal v2-update +cabal v2-configure +cabal v2-build +``` + +You can also use the [Bazel](https://haskell.build) build system: + +``` +bazel build //... ``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,116 +1,2 @@ -{-# LANGUAGE OverloadedStrings #-} - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import Debug.Trace -import Distribution.PackageDescription -import Distribution.Simple hiding (Language) -import Distribution.Simple.BuildPaths -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup -import System.Directory -import System.FilePath.Posix (()) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Yaml as Y -import Data.Yaml (FromJSON (..), (.!=), (.:), (.:?)) - -main = defaultMainWithHooks simpleUserHooks { postConf = conf } - -conf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () -conf _ _ _ info = do - let autogenDir = autogenPackageModulesDir info - createDirectoryIfMissing True autogenDir - traceM $ "Writing Gen_Languages.hs to autogenDir: " <> autogenDir - dir <- getCurrentDirectory - let yamlFile = dir "languages.yml" - yaml <- B.readFile yamlFile - B.writeFile (autogenDir "Gen_Languages.hs") (contents yaml) - pure () - -contents :: B.ByteString -> B.ByteString -contents yaml = - "module Gen_Languages where\n\ - \\n\ - \import Data.ByteString (ByteString)\n\ - \import Data.Text (Text)\n\ - \import qualified Data.Map.Strict as Map\n\ - \\n\ - \-- | Type synonym for linguist's language name key.\n\ - \type LanguageKey = Text\n\ - \\n\ - \-- | Identifies a programming language.\n\ - \data Language\n\ - \ = Language\n\ - \ { languageID :: Integer\n\ - \ , languageName :: Text\n\ - \ , languageExtensions :: [Text]\n\ - \ , languageFileNames :: [Text]\n\ - \ } deriving (Eq, Show)\n\ - \\n\ - \-- | Complete map of programming languages known to linguist.\n\ - \languages :: Map.Map LanguageKey Language\n\ - \languages = Map.fromList\ - \ [\n " - <> - either (BC.pack . show) (B.intercalate ",\n ") langs - <> - " ]\n\ - \\n\ - \-- | Map of languages by file extension.\n\ - \languagesByExtension :: Map.Map Text [LanguageKey]\n\ - \languagesByExtension = Map.fromList\ - \ [\n " - <> - either (BC.pack . show) (B.intercalate ",\n ") langsByExt - <> - " ]\n\ - \\n\ - \-- | Map of languages by filename.\n\ - \languagesByFileName :: Map.Map Text [LanguageKey]\n\ - \languagesByFileName = Map.fromList\ - \ [\n " - <> - either (BC.pack . show) (B.intercalate ",\n ") langsByFileName - <> - " ]\n\ - \" - - where - langs = Map.foldrWithKey (\k v xs -> "(\"" <> encodeUtf8 k <> "\", " <> BC.pack (show v { languageName = k }) <> ")" : xs) mempty <$> languages - langsByExt = Map.foldrWithKey (\k vs xs -> "(\"" <> encodeUtf8 k <> "\", [" <> showLanguages vs <> "])" : xs) mempty <$> languagesByExtension - langsByFileName = Map.foldrWithKey (\k vs xs -> "(\"" <> encodeUtf8 k <> "\", [" <> showLanguages vs <> "])" : xs) mempty <$> languagesByFileName - - showLanguages = BC.intercalate ", " . fmap (wrap . encodeUtf8 . languageName) - wrap x = "\"" <> x <> "\"" - - languages :: Either Y.ParseException (Map.Map Text Language) - languages = Y.decodeEither' yaml - - languagesByExtension :: Either Y.ParseException (Map.Map Text [Language]) - languagesByExtension = Map.foldrWithKey (buildMap languageExtensions) mempty <$> languages - - languagesByFileName :: Either Y.ParseException (Map.Map Text [Language]) - languagesByFileName = Map.foldrWithKey (buildMap languageFileNames) mempty <$> languages - - buildMap :: (Language -> [Text]) -> Text -> Language -> Map.Map Text [Language] -> Map.Map Text [Language] - buildMap f k l m = foldr (\ext b -> Map.insertWith (<>) ext (pure lang) b) m (f lang) - where lang = l { languageName = k } - -data Language - = Language - { languageID :: Integer - , languageName :: Text - , languageExtensions :: [Text] - , languageFileNames :: [Text] - } deriving (Eq, Show) - -instance FromJSON Language where - parseJSON (Y.Object v) = - Language <$> - v .: "language_id" <*> - v .:? "language_name" .!= mempty <*> - v .:? "extensions" .!= mempty <*> - v .:? "filenames" .!= mempty - parseJSON _ = fail "Expected Object for Language value" +import Distribution.Simple +main = defaultMain diff --git a/lingo.cabal b/lingo.cabal --- a/lingo.cabal +++ b/lingo.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 -build-type: Custom +build-type: Simple name: lingo -version: 0.3.2.0 +version: 0.4.0.0 synopsis: File extension based programming language detection description: Lingo uses github/linguist's language registry to enable fast detection of a file path's programming langauge based on extension or filename. homepage: https://github.com/tclem/lingo-haskell @@ -11,32 +11,26 @@ maintainer: timothy.clem@gmail.com category: Data extra-source-files: README.md - , languages.yml , ChangeLog.md - -tested-with: GHC == 8.6.5 - GHC == 8.8.1 +data-files: languages.yml -custom-setup - setup-depends: Cabal - , base - , bytestring - , containers - , directory - , filepath - , text - , yaml +tested-with: GHC == 8.6.5 + , GHC == 8.8.1 + , GHC == 8.10.1 library - exposed-modules: Data.Languages - other-modules: Gen_Languages - autogen-modules: Gen_Languages + exposed-modules: Data.Languages + , Data.Languages.Templates + autogen-modules: Paths_lingo + other-modules: Paths_lingo build-depends: base >= 4.12 && < 5 + , aeson >= 1.4 && <2 , bytestring ^>= 0.10.8.2 , containers ^>= 0.6.0.1 , filepath ^>= 1.4.2.1 , raw-strings-qq ^>= 1.1 - , text ^>= 1.2.3.1 + , text ^>= 1.2.3.2 + , template-haskell >= 2.14.0.0 && < 2.17.0.0 , yaml ^>= 0.11.1.2 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Data/Languages.hs b/src/Data/Languages.hs --- a/src/Data/Languages.hs +++ b/src/Data/Languages.hs @@ -1,23 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Primary interface for looking up the programming language of a file or -- interacting with languages known to linguist -- (https://github.com/github/linguist). module Data.Languages - ( languagesForPath - , languages - , languagesByExtension - , languagesByFileName - , LanguageKey - , Language(..) - ) where + ( languagesForPath, + languages, + languagesByExtension, + languagesByFileName, + LanguageKey, + Language (..), + languageName + ) +where -import Control.Applicative +import Control.Applicative +import Data.Languages.Templates import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Text (Text) +import Data.Maybe +import Data.Text (Text) import qualified Data.Text as Text -import Gen_Languages -import System.FilePath.Posix +import System.FilePath.Posix +$(generateLanguageMap) + -- | Find the set of possible languages for a given file path. -- -- Multiple results will be returned for ambiguous files; for example, @.md@ files can be Markdown or GCC machine descriptions, and @.php@ files can be PHP or Hack source files. @@ -26,8 +32,8 @@ where languageForFileName = languageFor (takeFileName path) languagesByFileName languageForExtension = languageFor (takeExtension path) languagesByExtension - languageFor :: String -> Map.Map Text [LanguageKey] -> [Language] - languageFor k - = foldMap (maybeToList . flip Map.lookup languages) - . fromMaybe [] - . Map.lookup (Text.pack k) + languageFor :: String -> Map.Map String [LanguageKey] -> [Language] + languageFor k = + foldMap (maybeToList . flip Map.lookup languages) + . fromMaybe [] + . Map.lookup k diff --git a/src/Data/Languages/Templates.hs b/src/Data/Languages/Templates.hs new file mode 100644 --- /dev/null +++ b/src/Data/Languages/Templates.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Languages.Templates + ( Language (..), + LanguageKey, + generateLanguageMap, + languageName, + ) +where + +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Yaml +import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +#ifndef LANGUAGES_YAML_PATH +import Paths_lingo +#endif + +-- | Type synonym for linguist's language name key. +type LanguageKey = String + +-- | Identifies a programming language. +data Language = Language + { languageId :: Integer, + languageKey :: LanguageKey, + languageExtensions :: [String], + languageFileNames :: [String] + } + deriving (Eq, Show, Lift) + +languageName :: Language -> Text +languageName = Text.pack . languageKey + +instance FromJSON Language where + parseJSON = withObject "Language" $ \l -> + Language + <$> l .: "language_id" + <*> pure "unspecified" -- this is set later in map iteration + <*> l .:? "extensions" .!= [] + <*> l .:? "filenames" .!= [] + +languagesYamlPath :: IO String +#ifdef LANGUAGES_YAML_PATH +languagesYamlPath = pure LANGUAGES_YAML_PATH +#else +languagesYamlPath = getDataFileName "languages.yml" +#endif + +generateLanguageMap :: DecsQ +generateLanguageMap = do + langYaml <- runIO languagesYamlPath + langs <- runIO (decodeFileThrow @IO @(Map.Map LanguageKey Language) langYaml) + let normalizedLangs = Map.mapWithKey (\name lang -> lang {languageKey = name}) langs + + byExtension = Map.foldr (process languageExtensions) mempty normalizedLangs + byFileName = Map.foldr (process languageFileNames) mempty normalizedLangs + + process :: (Language -> [String]) -> Language -> Map.Map String [LanguageKey] -> Map.Map String [LanguageKey] + process selector lang acc = foldr (\ext -> Map.insertWith mappend ext [languageKey lang]) acc (selector lang) + + [d| + languages :: Map.Map LanguageKey Language + languages = Map.fromDistinctAscList $(lift (Map.toAscList normalizedLangs)) + + languagesByExtension :: Map.Map String [LanguageKey] + languagesByExtension = Map.fromDistinctAscList $(lift (Map.toAscList byExtension)) + + languagesByFileName :: Map.Map String [LanguageKey] + languagesByFileName = Map.fromDistinctAscList $(lift (Map.toAscList byFileName)) + |]