diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Timothy Clem + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Timothy Clem nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# Lingo + +Detect programming languages from file extensions and common filenames. Based on [linguist's](https://github.com/github/linguist) registry of languages. + +## Development + +``` +cabal new-update +cabal new-configure +cabal new-build +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,116 @@ +{-# 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" diff --git a/lingo.cabal b/lingo.cabal new file mode 100644 --- /dev/null +++ b/lingo.cabal @@ -0,0 +1,52 @@ +cabal-version: 2.4 +build-type: Custom +name: lingo +version: 0.1.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 +license: BSD-3-Clause +license-file: LICENSE +author: Timothy Clem +maintainer: timothy.clem@gmail.com +category: Data +extra-source-files: README.md + +custom-setup + setup-depends: Cabal + , base + , bytestring + , containers + , directory + , filepath + , text + , yaml + +library + exposed-modules: Data.Languages + other-modules: Gen_Languages + autogen-modules: Gen_Languages + build-depends: base ^>=4.12.0.0 + , bytestring + , containers + , filepath + , raw-strings-qq + , text + , yaml + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: OverloadedStrings + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base ^>=4.12.0.0 + , lingo + , hspec + default-language: Haskell2010 + default-extensions: OverloadedStrings + +source-repository head + type: git + location: https://github.com/tclem/lingo-haskell diff --git a/src/Data/Languages.hs b/src/Data/Languages.hs new file mode 100644 --- /dev/null +++ b/src/Data/Languages.hs @@ -0,0 +1,35 @@ +-- | 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 + ( languageForPath + , languages + , languagesByExtension + , languagesByFileName + , LanguageKey + , Language(..) + ) where + +import Control.Applicative +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Gen_Languages +import System.FilePath.Posix + +-- | Find the Language (if any) for a FilePath. +languageForPath :: FilePath -> Maybe Language +languageForPath path = languageForFileName <|> languageForExtension + where + languageForFileName = languageFor (takeFileName path) languagesByFileName + languageForExtension = languageFor (takeExtension path) languagesByExtension + languageFor k f = maybe Nothing lookupPrimary $ Map.lookup (Text.pack k) f + + -- Some extensions and filenames associate with multiple languages, this is + -- a dumb way to specify which is the primary language. + lookupPrimary xs + | null xs = Nothing + | "Markdown" `elem` xs = lookup "Markdown" + | otherwise = lookup (head xs) + where lookup k = Map.lookup k languages diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,25 @@ +module Main where + +import Test.Hspec +import Data.Languages + +main :: IO () +main = hspec $ do + describe "detect language for path" $ do + it "can detect Ruby by file extension" $ + languageName <$> languageForPath "test.rb" `shouldBe` Just "Ruby" + + it "can detect Ruby by filename" $ + languageName <$> languageForPath "Rakefile" `shouldBe` Just "Ruby" + + it "returns Nothing for unknown files" $ + languageName <$> languageForPath "noideawhatthisis" `shouldBe` Nothing + + it "returns Nothing for unknown extensions" $ + languageName <$> languageForPath ".noideawhatthisis" `shouldBe` Nothing + + describe "languages" $ + it "parsed languages.yml" $ do + length languages `shouldBe` 519 + length languagesByExtension `shouldBe` 1117 + length languagesByFileName `shouldBe` 235