{-# 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
  { Language -> Integer
languageId :: Integer,
    Language -> LanguageKey
languageKey :: LanguageKey,
    Language -> [LanguageKey]
languageExtensions :: [String],
    Language -> [LanguageKey]
languageFileNames :: [String]
  }
  deriving (Language -> Language -> Bool
(Language -> Language -> Bool)
-> (Language -> Language -> Bool) -> Eq Language
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Language -> Language -> Bool
$c/= :: Language -> Language -> Bool
== :: Language -> Language -> Bool
$c== :: Language -> Language -> Bool
Eq, Int -> Language -> ShowS
[Language] -> ShowS
Language -> LanguageKey
(Int -> Language -> ShowS)
-> (Language -> LanguageKey)
-> ([Language] -> ShowS)
-> Show Language
forall a.
(Int -> a -> ShowS)
-> (a -> LanguageKey) -> ([a] -> ShowS) -> Show a
showList :: [Language] -> ShowS
$cshowList :: [Language] -> ShowS
show :: Language -> LanguageKey
$cshow :: Language -> LanguageKey
showsPrec :: Int -> Language -> ShowS
$cshowsPrec :: Int -> Language -> ShowS
Show, Language -> Q Exp
Language -> Q (TExp Language)
(Language -> Q Exp)
-> (Language -> Q (TExp Language)) -> Lift Language
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Language -> Q (TExp Language)
$cliftTyped :: Language -> Q (TExp Language)
lift :: Language -> Q Exp
$clift :: Language -> Q Exp
Lift)

languageName :: Language -> Text
languageName :: Language -> Text
languageName = LanguageKey -> Text
Text.pack (LanguageKey -> Text)
-> (Language -> LanguageKey) -> Language -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> LanguageKey
languageKey

instance FromJSON Language where
  parseJSON :: Value -> Parser Language
parseJSON = LanguageKey
-> (Object -> Parser Language) -> Value -> Parser Language
forall a. LanguageKey -> (Object -> Parser a) -> Value -> Parser a
withObject LanguageKey
"Language" ((Object -> Parser Language) -> Value -> Parser Language)
-> (Object -> Parser Language) -> Value -> Parser Language
forall a b. (a -> b) -> a -> b
$ \Object
l ->
    Integer
-> LanguageKey -> [LanguageKey] -> [LanguageKey] -> Language
Language
      (Integer
 -> LanguageKey -> [LanguageKey] -> [LanguageKey] -> Language)
-> Parser Integer
-> Parser
     (LanguageKey -> [LanguageKey] -> [LanguageKey] -> Language)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
l Object -> Text -> Parser Integer
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"language_id"
      Parser (LanguageKey -> [LanguageKey] -> [LanguageKey] -> Language)
-> Parser LanguageKey
-> Parser ([LanguageKey] -> [LanguageKey] -> Language)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LanguageKey -> Parser LanguageKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure LanguageKey
"unspecified" -- this is set later in map iteration
      Parser ([LanguageKey] -> [LanguageKey] -> Language)
-> Parser [LanguageKey] -> Parser ([LanguageKey] -> Language)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
l Object -> Text -> Parser (Maybe [LanguageKey])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"extensions" Parser (Maybe [LanguageKey])
-> [LanguageKey] -> Parser [LanguageKey]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      Parser ([LanguageKey] -> Language)
-> Parser [LanguageKey] -> Parser Language
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
l Object -> Text -> Parser (Maybe [LanguageKey])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"filenames" Parser (Maybe [LanguageKey])
-> [LanguageKey] -> Parser [LanguageKey]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []

languagesYamlPath :: IO String
#ifdef LANGUAGES_YAML_PATH
languagesYamlPath = pure LANGUAGES_YAML_PATH
#else
languagesYamlPath :: IO LanguageKey
languagesYamlPath = LanguageKey -> IO LanguageKey
getDataFileName LanguageKey
"languages.yml"
#endif

generateLanguageMap :: DecsQ
generateLanguageMap :: DecsQ
generateLanguageMap = do
  LanguageKey
langYaml <- IO LanguageKey -> Q LanguageKey
forall a. IO a -> Q a
runIO IO LanguageKey
languagesYamlPath
  Map LanguageKey Language
langs <- IO (Map LanguageKey Language) -> Q (Map LanguageKey Language)
forall a. IO a -> Q a
runIO (LanguageKey -> IO (Map LanguageKey Language)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
LanguageKey -> m a
decodeFileThrow @IO @(Map.Map LanguageKey Language) LanguageKey
langYaml)
  let normalizedLangs :: Map LanguageKey Language
normalizedLangs = (LanguageKey -> Language -> Language)
-> Map LanguageKey Language -> Map LanguageKey Language
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\LanguageKey
name Language
lang -> Language
lang {languageKey :: LanguageKey
languageKey = LanguageKey
name}) Map LanguageKey Language
langs

      byExtension :: Map LanguageKey [LanguageKey]
byExtension = (Language
 -> Map LanguageKey [LanguageKey] -> Map LanguageKey [LanguageKey])
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey Language
-> Map LanguageKey [LanguageKey]
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr ((Language -> [LanguageKey])
-> Language
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey [LanguageKey]
process Language -> [LanguageKey]
languageExtensions) Map LanguageKey [LanguageKey]
forall a. Monoid a => a
mempty Map LanguageKey Language
normalizedLangs
      byFileName :: Map LanguageKey [LanguageKey]
byFileName = (Language
 -> Map LanguageKey [LanguageKey] -> Map LanguageKey [LanguageKey])
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey Language
-> Map LanguageKey [LanguageKey]
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr ((Language -> [LanguageKey])
-> Language
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey [LanguageKey]
process Language -> [LanguageKey]
languageFileNames) Map LanguageKey [LanguageKey]
forall a. Monoid a => a
mempty Map LanguageKey Language
normalizedLangs

      process :: (Language -> [String]) -> Language -> Map.Map String [LanguageKey] -> Map.Map String [LanguageKey]
      process :: (Language -> [LanguageKey])
-> Language
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey [LanguageKey]
process Language -> [LanguageKey]
selector Language
lang Map LanguageKey [LanguageKey]
acc = (LanguageKey
 -> Map LanguageKey [LanguageKey] -> Map LanguageKey [LanguageKey])
-> Map LanguageKey [LanguageKey]
-> [LanguageKey]
-> Map LanguageKey [LanguageKey]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LanguageKey
ext -> ([LanguageKey] -> [LanguageKey] -> [LanguageKey])
-> LanguageKey
-> [LanguageKey]
-> Map LanguageKey [LanguageKey]
-> Map LanguageKey [LanguageKey]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [LanguageKey] -> [LanguageKey] -> [LanguageKey]
forall a. Monoid a => a -> a -> a
mappend LanguageKey
ext [Language -> LanguageKey
languageKey Language
lang]) Map LanguageKey [LanguageKey]
acc (Language -> [LanguageKey]
selector Language
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))
    |]