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