diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# 0.5.0.0 + +Revert to API provided by the 0.3 versions. + # 0.4.0.0 Rewrite to use Template Haskell splices instead of a custom Setup.hs. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Generate.hs b/app/Generate.hs new file mode 100644 --- /dev/null +++ b/app/Generate.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Debug.Trace +import System.Directory +import System.FilePath (()) +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 :: IO () +main = do + dir <- getCurrentDirectory + let yamlFile = dir "languages.yml" + yaml <- B.readFile yamlFile + B.writeFile (dir "src" "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" diff --git a/lingo.cabal b/lingo.cabal --- a/lingo.cabal +++ b/lingo.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 build-type: Simple name: lingo -version: 0.4.0.0 +version: 0.5.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,30 +11,43 @@ maintainer: timothy.clem@gmail.com category: Data extra-source-files: README.md + , languages.yml , ChangeLog.md -data-files: languages.yml -tested-with: GHC == 8.6.5 - , GHC == 8.8.1 - , GHC == 8.10.1 +tested-with: GHC == 8.6.5 + GHC == 8.8.1 + GHC == 8.10.1 +common haskell + default-language: Haskell2010 + default-extensions: OverloadedStrings + library - exposed-modules: Data.Languages - , Data.Languages.Templates - autogen-modules: Paths_lingo - other-modules: Paths_lingo + import: haskell + exposed-modules: Data.Languages + other-modules: Gen_Languages + autogen-modules: Gen_Languages 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.2 - , template-haskell >= 2.14.0.0 && < 2.17.0.0 + , text ^>= 1.2.3.1 , yaml ^>= 0.11.1.2 hs-source-dirs: src - default-language: Haskell2010 - default-extensions: OverloadedStrings + +executable generate + import: haskell + hs-source-dirs: app + main-is: Generate.hs + build-depends: base >= 4.12 && < 5 + , bytestring ^>= 0.10.8.2 + , containers ^>= 0.6.0.1 + , directory + , filepath ^>= 1.4.2.1 + , raw-strings-qq ^>= 1.1 + , text ^>= 1.2.3.1 + , yaml ^>= 0.11.1.2 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Data/Languages.hs b/src/Data/Languages.hs --- a/src/Data/Languages.hs +++ b/src/Data/Languages.hs @@ -1,28 +1,21 @@ -{-# 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). +-- interacting with languages known to linguist (https://github.com/github/linguist). module Data.Languages - ( languagesForPath, - languages, - languagesByExtension, - languagesByFileName, - LanguageKey, - Language (..), - languageName - ) -where + ( languagesForPath + , languages + , languagesByExtension + , languagesByFileName + , LanguageKey + , Language(..) + ) where -import Control.Applicative -import Data.Languages.Templates +import Control.Applicative 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 System.FilePath.Posix - -$(generateLanguageMap) +import Gen_Languages +import System.FilePath.Posix -- | Find the set of possible languages for a given file path. -- @@ -32,8 +25,8 @@ where languageForFileName = languageFor (takeFileName path) languagesByFileName languageForExtension = languageFor (takeExtension path) languagesByExtension - languageFor :: String -> Map.Map String [LanguageKey] -> [Language] - languageFor k = - foldMap (maybeToList . flip Map.lookup languages) - . fromMaybe [] - . Map.lookup k + languageFor :: String -> Map.Map Text [LanguageKey] -> [Language] + languageFor k + = foldMap (maybeToList . flip Map.lookup languages) + . fromMaybe [] + . Map.lookup (Text.pack k) diff --git a/src/Data/Languages/Templates.hs b/src/Data/Languages/Templates.hs deleted file mode 100644 --- a/src/Data/Languages/Templates.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# 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)) - |]