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