Golden.hs

{-# LANGUAGE MultiWayIf, LambdaCase, CPP #-}

module Main (main) where

import System.FilePath
    ( (</>), (<.>), (-<.>)
    , takeBaseName, replaceExtension
    , takeDirectory, splitDirectories, joinPath
    )
import System.Directory (renameFile)
import Test.Tasty (defaultMain, TestTree, testGroup)
import Test.Tasty.Golden (findByExtension, goldenVsFile, goldenVsString)

import Hpack (Verbose(..), Options(..), hpack, defaultOptions, setDecode)
import Hpack.Config (DecodeOptions(..))
import Hpack.Dhall (fileToJson, showDhall, showJson, showYaml)
import Data.ByteString.Lazy.UTF8 (fromString)

data Out = Cabal | Dhall | Json | Yaml

main :: IO ()
main = defaultMain =<< goldenTests

goldExt :: Out -> FilePath
goldExt =
    \case
        Cabal -> ".cabal.golden"

        Dhall ->
            let d =
#if MIN_VERSION_dhall (1, 34, 0)
                    ".dhall-1.34"
#elif MIN_VERSION_dhall (1, 32, 0)
                    ".dhall-1.32"
#else
                    ".dhall"
#endif

            in d <> ".golden"

        Json -> ".json.golden"
        Yaml -> ".yaml.golden"

goldenTests :: IO TestTree
goldenTests = do
    ks <- findByExtension [".dhall"] "test-suite-golden/test-files/key"
    rs <- findByExtension [".dhall"] "test-suite-golden/test-files/real-world"
    g1 <- goldenTestSet "archetypes" ks
    g2 <- goldenTestSet "real-world examples" rs
    return $ testGroup "golden tests" [g1 , g2]

goldenTestSet :: String -> [FilePath] -> IO TestTree
goldenTestSet title dhallFiles = do
    return $ testGroup title
        [ testGroup ".dhall to .cabal"
            [ goldenVsFile
                (testName dhallFile)
                (cabalFile -<.> goldExt Cabal)
                cabalFile
                (writeDhallCabal dhallFile)
            | dhallFile <- dhallFiles
            , let cabalFile = cabalFilePath dhallFile
            ]
        , testGroup ".dhall to dhall"
            [ goldenVsString
                (testName dhallFile)
                (dhallFile -<.> goldExt Dhall)
                (fmap fromString . showDhall $ dhallFile)
            | dhallFile <- dhallFiles
            ]
        , testGroup ".dhall to json"
            [ goldenVsFile
                (testName dhallFile)
                (dhallFile -<.> goldExt Json)
                jsonFile
                (writeJson dhallFile jsonFile)
            | dhallFile <- dhallFiles
            , let jsonFile = dhallFile -<.> ".json"
            ]
        , testGroup ".dhall to yaml"
            [ goldenVsFile
                (testName dhallFile)
                (dhallFile -<.> goldExt Yaml)
                yamlFile
                (writeYaml dhallFile yamlFile)
            | dhallFile <- dhallFiles
            , let yamlFile = dhallFile -<.> ".yaml"
            ]
        , testGroup ".yaml to .cabal"
            [ goldenVsFile
                (testName dhallFile)
                (cabalFile -<.> goldExt Cabal)
                cabalFile
                (writeYamlCabal yamlFile cabalFile yamlCabalFile)
            | dhallFile <- dhallFiles
            , let yamlFile = dhallFile -<.> ".yaml"
            , let cabalFile = cabalFilePath dhallFile
            , let yamlCabalFile = yamlFile <.> ".cabal"
            ]
        ]

testName :: FilePath -> FilePath
testName p =
    if | fName == dName -> fName
       | fName == "package" -> dName
       | dName == "key" -> fName
       | dName == "real-world" -> fName
       | otherwise -> dName </> fName
    where
        dName =
            joinPath
            . take 1
            . reverse
            . splitDirectories
            . takeDirectory
            $ p

        fName = takeBaseName p

writeDhallCabal :: FilePath -> IO ()
writeDhallCabal dhallFile =
    hpack NoVerbose (setDecode fileToJson options)
    where
        d = optionsDecodeOptions defaultOptions
        d' = d {decodeOptionsTarget = dhallFile}
        options = defaultOptions {optionsDecodeOptions = d'}

writeYamlCabal :: FilePath -> FilePath -> FilePath -> IO ()
writeYamlCabal yamlFile cabalFile yamlCabalFile = do
        renameFile cabalFile tmp
        hpack NoVerbose options
        renameFile cabalFile yamlCabalFile
        renameFile tmp cabalFile
    where
        tmp = cabalFile <.> ".TMP"

        d = optionsDecodeOptions defaultOptions
        d' = d {decodeOptionsTarget = yamlFile}
        options =
            defaultOptions
                { optionsDecodeOptions = d'
                }

writeJson :: FilePath -> FilePath -> IO ()
writeJson dhallFile jsonFile = do
    s <- showJson Nothing dhallFile
    writeFile jsonFile s

writeYaml :: FilePath -> FilePath -> IO ()
writeYaml dhallFile yamlFile = do
    s <- showYaml Nothing dhallFile
    writeFile yamlFile s

cabalFilePath :: FilePath -> FilePath
cabalFilePath p
    | takeBaseName p == "package" =
        case reverse . splitDirectories $ ds of
            d : ds' -> joinPath (reverse ds') </> d </> d <.> ".cabal"
            _ -> replaceExtension p ".cabal"

    | otherwise =
        replaceExtension p ".cabal"

    where
        ds = takeDirectory p