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