{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Distribution.ArchHs.Internal.NamePresetLoader (loadNamePreset) where import Data.Aeson import qualified Data.ByteString as BS import Data.Map.Strict (Map, fromList, keys, toList) import Data.Tuple (swap) import Language.Haskell.TH import System.Directory (getCurrentDirectory) import System.FilePath ((</>)) loadNamePreset :: DecsQ loadNamePreset :: DecsQ loadNamePreset = do ByteString txt <- IO ByteString -> Q ByteString forall a. IO a -> Q a runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString forall a b. (a -> b) -> a -> b $ IO FilePath getCurrentDirectory IO FilePath -> (FilePath -> IO ByteString) -> IO ByteString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \FilePath dot -> FilePath -> IO ByteString BS.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString forall a b. (a -> b) -> a -> b $ FilePath dot FilePath -> FilePath -> FilePath </> FilePath "data" FilePath -> FilePath -> FilePath </> FilePath "NAME_PRESET.json" let preset :: Map FilePath FilePath preset = case ByteString -> Maybe (Map FilePath FilePath) forall a. FromJSON a => ByteString -> Maybe a decodeStrict @(Map String String) ByteString txt of Just Map FilePath FilePath x -> Map FilePath FilePath x Maybe (Map FilePath FilePath) _ -> FilePath -> Map FilePath FilePath forall a. HasCallStack => FilePath -> a error FilePath "Failed to parse json" Dec a <- FilePath -> Map FilePath FilePath -> DecQ genFunc FilePath "communityToHackageP" Map FilePath FilePath preset Dec b <- FilePath -> Map FilePath FilePath -> DecQ genFunc FilePath "hackageToCommunityP" (Map FilePath FilePath -> DecQ) -> Map FilePath FilePath -> DecQ forall a b. (a -> b) -> a -> b $ [(FilePath, FilePath)] -> Map FilePath FilePath forall k a. Ord k => [(k, a)] -> Map k a fromList ([(FilePath, FilePath)] -> Map FilePath FilePath) -> (Map FilePath FilePath -> [(FilePath, FilePath)]) -> Map FilePath FilePath -> Map FilePath FilePath forall b c a. (b -> c) -> (a -> b) -> a -> c . ((FilePath, FilePath) -> (FilePath, FilePath)) -> [(FilePath, FilePath)] -> [(FilePath, FilePath)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (FilePath, FilePath) -> (FilePath, FilePath) forall a b. (a, b) -> (b, a) swap ([(FilePath, FilePath)] -> [(FilePath, FilePath)]) -> (Map FilePath FilePath -> [(FilePath, FilePath)]) -> Map FilePath FilePath -> [(FilePath, FilePath)] forall b c a. (b -> c) -> (a -> b) -> a -> c . Map FilePath FilePath -> [(FilePath, FilePath)] forall k a. Map k a -> [(k, a)] toList (Map FilePath FilePath -> Map FilePath FilePath) -> Map FilePath FilePath -> Map FilePath FilePath forall a b. (a -> b) -> a -> b $ Map FilePath FilePath preset Dec d <- FilePath -> [FilePath] -> DecQ genArray FilePath "communityListP" ([FilePath] -> DecQ) -> [FilePath] -> DecQ forall a b. (a -> b) -> a -> b $ Map FilePath FilePath -> [FilePath] forall k a. Map k a -> [k] keys Map FilePath FilePath preset [Dec] -> DecsQ forall (m :: * -> *) a. Monad m => a -> m a return [Dec a, Dec b, Dec d] genFunc :: String -> Map String String -> DecQ genFunc :: FilePath -> Map FilePath FilePath -> DecQ genFunc FilePath name Map FilePath FilePath src = do let temp :: [ClauseQ] temp = (FilePath, FilePath) -> ClauseQ genClause ((FilePath, FilePath) -> ClauseQ) -> [(FilePath, FilePath)] -> [ClauseQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Map FilePath FilePath -> [(FilePath, FilePath)] forall k a. Map k a -> [(k, a)] toList Map FilePath FilePath src Name -> [ClauseQ] -> DecQ funD (FilePath -> Name mkName FilePath name) ([ClauseQ] -> DecQ) -> [ClauseQ] -> DecQ forall a b. (a -> b) -> a -> b $ [ClauseQ] temp [ClauseQ] -> [ClauseQ] -> [ClauseQ] forall a. Semigroup a => a -> a -> a <> [ClauseQ nothingClause] where genClause :: (FilePath, FilePath) -> ClauseQ genClause (FilePath from, FilePath to) = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [Lit -> PatQ litP (Lit -> PatQ) -> Lit -> PatQ forall a b. (a -> b) -> a -> b $ FilePath -> Lit stringL FilePath from] (ExpQ -> BodyQ normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ forall a b. (a -> b) -> a -> b $ [|Just|] ExpQ -> ExpQ -> ExpQ `appE` (Lit -> ExpQ litE (Lit -> ExpQ) -> (FilePath -> Lit) -> FilePath -> ExpQ forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> Lit stringL (FilePath -> ExpQ) -> FilePath -> ExpQ forall a b. (a -> b) -> a -> b $ FilePath to)) [] nothingClause :: ClauseQ nothingClause = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [PatQ wildP] (ExpQ -> BodyQ normalB [|Nothing|]) [] genArray :: String -> [String] -> DecQ genArray :: FilePath -> [FilePath] -> DecQ genArray FilePath name [FilePath] src = Name -> [ClauseQ] -> DecQ funD (FilePath -> Name mkName FilePath name) [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [] (ExpQ -> BodyQ normalB [|src|]) []]