{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} 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 <- forall a. IO a -> Q a runIO forall a b. (a -> b) -> a -> b $ IO String getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \String dot -> String -> IO ByteString BS.readFile forall a b. (a -> b) -> a -> b $ String dot String -> String -> String </> String "data" String -> String -> String </> String "NAME_PRESET.json" let preset :: Map String String preset = case forall a. FromJSON a => ByteString -> Maybe a decodeStrict @(Map String String) ByteString txt of Just Map String String x -> Map String String x Maybe (Map String String) _ -> forall a. HasCallStack => String -> a error String "Failed to parse json" Dec a <- String -> Map String String -> DecQ genFunc String "communityToHackageP" Map String String preset Dec b <- String -> Map String String -> DecQ genFunc String "hackageToCommunityP" forall a b. (a -> b) -> a -> b $ forall k a. Ord k => [(k, a)] -> Map k a fromList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a, b) -> (b, a) swap forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] toList forall a b. (a -> b) -> a -> b $ Map String String preset Dec d <- String -> [String] -> DecQ genArray String "communityListP" forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [k] keys Map String String preset forall (m :: * -> *) a. Monad m => a -> m a return [Dec a, Dec b, Dec d] genFunc :: String -> Map String String -> DecQ genFunc :: String -> Map String String -> DecQ genFunc String name Map String String src = do let temp :: [Q Clause] temp = forall {m :: * -> *}. Quote m => (String, String) -> m Clause genClause forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall k a. Map k a -> [(k, a)] toList Map String String src forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD (String -> Name mkName String name) forall a b. (a -> b) -> a -> b $ [Q Clause] temp forall a. Semigroup a => a -> a -> a <> [Q Clause nothingClause] where genClause :: (String, String) -> m Clause genClause (String from, String to) = forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [forall (m :: * -> *). Quote m => Lit -> m Pat litP forall a b. (a -> b) -> a -> b $ String -> Lit stringL String from] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB forall a b. (a -> b) -> a -> b $ [|Just|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp `appE` (forall (m :: * -> *). Quote m => Lit -> m Exp litE forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Lit stringL forall a b. (a -> b) -> a -> b $ String to)) [] nothingClause :: Q Clause nothingClause = forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [forall (m :: * -> *). Quote m => m Pat wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB [|Nothing|]) [] genArray :: String -> [String] -> DecQ genArray :: String -> [String] -> DecQ genArray String name [String] src = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD (String -> Name mkName String name) [forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB [|src|]) []]