{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# 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 GHC.Generics (Generic) import Language.Haskell.TH import System.Directory (getCurrentDirectory) import System.FilePath ((</>)) data NamePreset = NamePreset { NamePreset -> [String] falseList :: [String], NamePreset -> Map String String preset :: Map String String } deriving stock ((forall x. NamePreset -> Rep NamePreset x) -> (forall x. Rep NamePreset x -> NamePreset) -> Generic NamePreset forall x. Rep NamePreset x -> NamePreset forall x. NamePreset -> Rep NamePreset x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep NamePreset x -> NamePreset $cfrom :: forall x. NamePreset -> Rep NamePreset x Generic) instance FromJSON NamePreset 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 String getCurrentDirectory IO String -> (String -> IO ByteString) -> IO ByteString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \String dot -> String -> IO ByteString BS.readFile (String -> IO ByteString) -> String -> IO ByteString forall a b. (a -> b) -> a -> b $ String dot String -> String -> String </> String "data" String -> String -> String </> String "NAME_PRESET.json" let NamePreset {[String] Map String String preset :: Map String String falseList :: [String] preset :: NamePreset -> Map String String falseList :: NamePreset -> [String] ..} = case ByteString -> Maybe NamePreset forall a. FromJSON a => ByteString -> Maybe a decodeStrict ByteString txt of Just NamePreset x -> NamePreset x Maybe NamePreset _ -> String -> NamePreset 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" (Map String String -> DecQ) -> Map String String -> DecQ forall a b. (a -> b) -> a -> b $ [(String, String)] -> Map String String forall k a. Ord k => [(k, a)] -> Map k a fromList ([(String, String)] -> Map String String) -> (Map String String -> [(String, String)]) -> Map String String -> Map String String forall b c a. (b -> c) -> (a -> b) -> a -> c . ((String, String) -> (String, String)) -> [(String, String)] -> [(String, String)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (String, String) -> (String, String) forall a b. (a, b) -> (b, a) swap ([(String, String)] -> [(String, String)]) -> (Map String String -> [(String, String)]) -> Map String String -> [(String, String)] forall b c a. (b -> c) -> (a -> b) -> a -> c . Map String String -> [(String, String)] forall k a. Map k a -> [(k, a)] toList (Map String String -> Map String String) -> Map String String -> Map String String forall a b. (a -> b) -> a -> b $ Map String String preset Dec c <- String -> [String] -> DecQ genArray String "falseListP" [String] falseList Dec d <- String -> [String] -> DecQ genArray String "communityListP" ([String] -> DecQ) -> [String] -> DecQ forall a b. (a -> b) -> a -> b $ Map String String -> [String] forall k a. Map k a -> [k] keys Map String String preset [Dec] -> DecsQ forall (m :: * -> *) a. Monad m => a -> m a return [Dec a, Dec b, Dec c, Dec d] genFunc :: String -> Map String String -> DecQ genFunc :: String -> Map String String -> DecQ genFunc String name Map String String src = do let temp :: [ClauseQ] temp = (String, String) -> ClauseQ genClause ((String, String) -> ClauseQ) -> [(String, String)] -> [ClauseQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Map String String -> [(String, String)] forall k a. Map k a -> [(k, a)] toList Map String String src Name -> [ClauseQ] -> DecQ funD (String -> Name mkName String 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 :: (String, String) -> ClauseQ genClause (String from, String to) = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [Lit -> PatQ litP (Lit -> PatQ) -> Lit -> PatQ forall a b. (a -> b) -> a -> b $ String -> Lit stringL String 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) -> (String -> Lit) -> String -> ExpQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Lit stringL (String -> ExpQ) -> String -> ExpQ forall a b. (a -> b) -> a -> b $ String to)) [] nothingClause :: ClauseQ nothingClause = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [PatQ wildP] (ExpQ -> BodyQ normalB [|Nothing|]) [] genArray :: String -> [String] -> DecQ genArray :: String -> [String] -> DecQ genArray String name [String] src = Name -> [ClauseQ] -> DecQ funD (String -> Name mkName String name) [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause [] (ExpQ -> BodyQ normalB [|src|]) []]