{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

module Horizon.Spec.Pretty where

import qualified Data.ByteString    as B
import           Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map           as Map
import           Data.Text          (Text)
import qualified Data.Text          as T
import qualified Data.Text.Encoding as T
import qualified Dhall
import           Dhall.Core         (Binding, Chunks (Chunks),
                                     Directory (Directory),
                                     Expr (App, Embed, Field, Let, ListLit, None, RecordLit, Some, TextLit, ToMap, With),
                                     File (File), Import (Import),
                                     ImportHashed (ImportHashed),
                                     ImportMode (Code), ImportType (Remote),
                                     Scheme (HTTPS), URL (URL),
                                     WithComponent (WithLabel), makeBinding,
                                     makeFieldSelection, makeRecordField,
                                     pretty)
import qualified Dhall.Map          as DMap
import           GHC.Exts           (fromList)
import           Horizon.Spec       (CabalFlag (MkCabalFlag),
                                     Compiler (MkCompiler),
                                     Flag (Disable, Enable),
                                     GitSource (MkGitSource),
                                     HackageSource (MkHackageSource),
                                     HaskellPackage (MkHaskellPackage),
                                     HaskellSource (FromGit, FromHackage, FromLocal, FromTarball),
                                     HorizonExport (MakeOverlay, MakePackageSet),
                                     LocalSource (MkLocalSource), Name (MkName),
                                     Overlay (MkOverlay),
                                     OverlayExportSettings (MkOverlayExportSettings),
                                     OverlayFile (MkOverlayFile),
                                     PackageList (MkPackageList),
                                     PackageSet (MkPackageSet),
                                     PackageSetExportSettings (MkPackageSetExportSettings),
                                     PackageSetFile (MkPackageSetFile),
                                     PackagesDir (MkPackagesDir), Repo (MkRepo),
                                     Revision (MkRevision), Subdir (MkSubdir),
                                     TarballSource (MkTarballSource),
                                     Url (MkUrl), Version (MkVersion))
import           Path               (Path, toFilePath)

horizonField :: Text -> Expr s a
horizonField = Field horizonSpecIdentifier . makeFieldSelection

callHackageLit :: Expr s a
callHackageLit = horizonField "callHackage"

callGitLit :: Expr s a
callGitLit = horizonField "callGit"

callTarballLit :: Expr s a
callTarballLit = horizonField "callTarball"

callLocalLit :: Expr s a
callLocalLit = horizonField "callLocal"

callHackageApp :: HackageSource -> Expr s a
callHackageApp (MkHackageSource (MkName x) (MkVersion v)) = App (App callHackageLit (TextLit $ Chunks [] x)) (TextLit $ Chunks [] v)

callGitApp :: GitSource -> Expr s a
callGitApp (MkGitSource (MkRepo (MkUrl x)) (MkRevision v) d) =
  let z = case d of
           Nothing -> App None $ horizonField "Subdir"
           Just (MkSubdir k) -> Some $ TextLit $ Chunks [] $ T.pack $ toFilePath k
  in App (App (App callGitLit (TextLit $ Chunks [] x)) (TextLit $ Chunks [] v)) z

callTarballApp :: TarballSource -> Expr s a
callTarballApp (MkTarballSource (MkUrl x)) = App callTarballLit $ TextLit $ Chunks [] x

callLocalApp :: LocalSource -> Expr s a
callLocalApp (MkLocalSource (MkSubdir x)) = App callLocalLit $ TextLit $ Chunks [] $ T.pack . toFilePath $ x

haskellSourceToExpr :: HaskellSource -> Expr s a
haskellSourceToExpr k = case k of
  FromHackage x -> callHackageApp x
  FromGit x     -> callGitApp x
  FromTarball x -> callTarballApp x
  FromLocal x   -> callLocalApp x

cabalFlagToExpr :: CabalFlag -> Expr s a
cabalFlagToExpr (MkCabalFlag x) =
  let (z, t) = case x of
                Disable a -> (makeFieldSelection "Disable", a)
                Enable a  -> (makeFieldSelection "Enable", a)
  in App (Field (horizonField "CabalFlag") z) (TextLit $ Chunks [] t)

haskellPackageToExpr :: HaskellPackage -> Expr s a
haskellPackageToExpr (MkHaskellPackage s _ ys) =
  let t = haskellSourceToExpr s
      applyFlagsExpr = if not . null $ ys then \x -> With x (WithLabel "flags" :| []) (ListLit Nothing $ GHC.Exts.fromList $ map cabalFlagToExpr ys) else id
  in applyFlagsExpr t

packageListToExpr :: PackageList -> Expr s a
packageListToExpr (MkPackageList (Map.toList -> ys)) = RecordLit . DMap.fromList . map (\(MkName x, y) -> (x, makeRecordField $ haskellPackageToExpr y)) $ ys

horizonExportToExpr :: HorizonExport -> Expr s Import
horizonExportToExpr (MakePackageSet x) = packageSetExportSettingsToExpr x
horizonExportToExpr (MakeOverlay x)    = overlayExportSettingsToExpr x

packageSetToExpr :: PackageSet -> Expr s a -> Expr s a
packageSetToExpr (MkPackageSet (MkCompiler c) _) xs = RecordLit $ DMap.fromList
  [ ("compiler", makeRecordField $ TextLit $ Chunks [] c)
  , ("packages", makeRecordField xs)
  ]

compilerToExpr :: Compiler -> Expr s a
compilerToExpr (MkCompiler c) = TextLit $ Chunks [] c

pathToExpr :: Path b t -> Expr s a
pathToExpr = TextLit . Chunks [] . T.pack . toFilePath

packagesDirToExpr :: PackagesDir -> Expr s a
packagesDirToExpr (MkPackagesDir d) = pathToExpr d

packageSetFileToExpr :: PackageSetFile -> Expr s a
packageSetFileToExpr (MkPackageSetFile d) = pathToExpr d

overlayFileToExpr :: OverlayFile -> Expr s a
overlayFileToExpr (MkOverlayFile d) = pathToExpr d

packageSetExportSettingsToExpr :: PackageSetExportSettings -> Expr s Import
packageSetExportSettingsToExpr (MkPackageSetExportSettings d f ys@(MkPackageSet _ xs)) = letHorizonSpecIn $ letPackagesBindingIn xs $ App (Field (horizonField "HorizonExport") (makeFieldSelection "MakePackageSet")) $ RecordLit . DMap.fromList $ [
    ("packageSetFile", makeRecordField $ packageSetFileToExpr f),
    ("packagesDir", makeRecordField $ packagesDirToExpr d),
    ("packageSet", makeRecordField $ packageSetToExpr ys $ ToMap "packages" Nothing)
    ]


overlayExportSettingsToExpr :: OverlayExportSettings -> Expr s Import
overlayExportSettingsToExpr (MkOverlayExportSettings d f (MkOverlay ys@(MkPackageSet _ xs))) = letHorizonSpecIn $ letPackagesBindingIn xs $ App (Field (horizonField "HorizonExport") (makeFieldSelection "MakeOverlay")) $ RecordLit . DMap.fromList $ [
    ("packageSetFile", makeRecordField $ overlayFileToExpr f),
    ("packagesDir", makeRecordField $ packagesDirToExpr d),
    ("packageSet", makeRecordField $ packageSetToExpr ys $ ToMap "packages" Nothing)
    ]


prettyHorizonExport :: HorizonExport -> Text
prettyHorizonExport = Dhall.Core.pretty . horizonExportToExpr

writeHorizonFile :: HorizonExport -> IO ()
writeHorizonFile = B.writeFile "horizon.dhall" . T.encodeUtf8 . Dhall.Core.pretty . horizonExportToExpr

loadHorizon :: IO HorizonExport
loadHorizon = Dhall.inputFile @HorizonExport Dhall.auto "horizon.dhall"

horizonSpecUrl :: Dhall.Core.URL
horizonSpecUrl = Dhall.Core.URL HTTPS "gitlab.homotopic.tech" (Dhall.Core.File (Dhall.Core.Directory ["dhall", "0.6", "raw", "-", "horizon-spec", "horizon"]) "package.dhall") Nothing Nothing

horizonSpecImportHashed :: ImportHashed
horizonSpecImportHashed = ImportHashed Nothing (Remote horizonSpecUrl)

horizonSpecImport :: Import
horizonSpecImport = Import horizonSpecImportHashed Code

horizonSpecIdentifier :: Expr s a
horizonSpecIdentifier = "H"

packagesIdentifier :: Text
packagesIdentifier = "packages"

horizonSpecBinding :: Binding s Import
horizonSpecBinding = makeBinding "H" (Dhall.Core.Embed horizonSpecImport)

letHorizonSpecIn :: Expr s Import -> Expr s Import
letHorizonSpecIn = Let horizonSpecBinding

packagesBinding :: PackageList -> Binding s a
packagesBinding = makeBinding packagesIdentifier . packageListToExpr

letPackagesBindingIn :: PackageList -> Expr s a -> Expr s a
letPackagesBindingIn xs = Let (packagesBinding xs)