{-# 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|]) []]