{-# 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 :: forall s a. Text -> Expr s a
horizonField = forall s a. Expr s a -> FieldSelection s -> Expr s a
Field forall s a. Expr s a
horizonSpecIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Text -> FieldSelection s
makeFieldSelection

callHackageLit :: Expr s a
callHackageLit :: forall s a. Expr s a
callHackageLit = forall s a. Text -> Expr s a
horizonField Text
"callHackage"

callGitLit :: Expr s a
callGitLit :: forall s a. Expr s a
callGitLit = forall s a. Text -> Expr s a
horizonField Text
"callGit"

callTarballLit :: Expr s a
callTarballLit :: forall s a. Expr s a
callTarballLit = forall s a. Text -> Expr s a
horizonField Text
"callTarball"

callLocalLit :: Expr s a
callLocalLit :: forall s a. Expr s a
callLocalLit = forall s a. Text -> Expr s a
horizonField Text
"callLocal"

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

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

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

callLocalApp :: LocalSource -> Expr s a
callLocalApp :: forall s a. LocalSource -> Expr s a
callLocalApp (MkLocalSource (MkSubdir Path Rel Dir
x)) = forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
callLocalLit forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
TextLit forall a b. (a -> b) -> a -> b
$ forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ Path Rel Dir
x

haskellSourceToExpr :: HaskellSource -> Expr s a
haskellSourceToExpr :: forall s a. HaskellSource -> Expr s a
haskellSourceToExpr HaskellSource
k = case HaskellSource
k of
  FromHackage HackageSource
x -> forall s a. HackageSource -> Expr s a
callHackageApp HackageSource
x
  FromGit GitSource
x     -> forall s a. GitSource -> Expr s a
callGitApp GitSource
x
  FromTarball TarballSource
x -> forall s a. TarballSource -> Expr s a
callTarballApp TarballSource
x
  FromLocal LocalSource
x   -> forall s a. LocalSource -> Expr s a
callLocalApp LocalSource
x

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

haskellPackageToExpr :: HaskellPackage -> Expr s a
haskellPackageToExpr :: forall s a. HaskellPackage -> Expr s a
haskellPackageToExpr (MkHaskellPackage HaskellSource
s Modifiers
_ [CabalFlag]
ys) =
  let t :: Expr s a
t = forall s a. HaskellSource -> Expr s a
haskellSourceToExpr HaskellSource
s
      applyFlagsExpr :: Expr s a -> Expr s a
applyFlagsExpr = if Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [CabalFlag]
ys then \Expr s a
x -> forall s a.
Expr s a -> NonEmpty WithComponent -> Expr s a -> Expr s a
With Expr s a
x (Text -> WithComponent
WithLabel Text
"flags" forall a. a -> [a] -> NonEmpty a
:| []) (forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
ListLit forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall l. IsList l => [Item l] -> l
GHC.Exts.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall s a. CabalFlag -> Expr s a
cabalFlagToExpr [CabalFlag]
ys) else forall a. a -> a
id
  in Expr s a -> Expr s a
applyFlagsExpr Expr s a
t

packageListToExpr :: PackageList -> Expr s a
packageListToExpr :: forall s a. PackageList -> Expr s a
packageListToExpr (MkPackageList (forall k a. Map k a -> [(k, a)]
Map.toList -> [(Name, HaskellPackage)]
ys)) = forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [(k, v)] -> Map k v
DMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(MkName Text
x, HaskellPackage
y) -> (Text
x, forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. HaskellPackage -> Expr s a
haskellPackageToExpr HaskellPackage
y)) forall a b. (a -> b) -> a -> b
$ [(Name, HaskellPackage)]
ys

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

packageSetToExpr :: PackageSet -> Expr s a -> Expr s a
packageSetToExpr :: forall s a. PackageSet -> Expr s a -> Expr s a
packageSetToExpr (MkPackageSet (MkCompiler Text
c) PackageList
_) Expr s a
xs = forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => [(k, v)] -> Map k v
DMap.fromList
  [ (Text
"compiler", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Chunks s a -> Expr s a
TextLit forall a b. (a -> b) -> a -> b
$ forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
c)
  , (Text
"packages", forall s a. Expr s a -> RecordField s a
makeRecordField Expr s a
xs)
  ]

compilerToExpr :: Compiler -> Expr s a
compilerToExpr :: forall s a. Compiler -> Expr s a
compilerToExpr (MkCompiler Text
c) = forall s a. Chunks s a -> Expr s a
TextLit forall a b. (a -> b) -> a -> b
$ forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
c

pathToExpr :: Path b t -> Expr s a
pathToExpr :: forall b t s a. Path b t -> Expr s a
pathToExpr = forall s a. Chunks s a -> Expr s a
TextLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath

packagesDirToExpr :: PackagesDir -> Expr s a
packagesDirToExpr :: forall s a. PackagesDir -> Expr s a
packagesDirToExpr (MkPackagesDir Path Rel Dir
d) = forall b t s a. Path b t -> Expr s a
pathToExpr Path Rel Dir
d

packageSetFileToExpr :: PackageSetFile -> Expr s a
packageSetFileToExpr :: forall s a. PackageSetFile -> Expr s a
packageSetFileToExpr (MkPackageSetFile Path Rel File
d) = forall b t s a. Path b t -> Expr s a
pathToExpr Path Rel File
d

overlayFileToExpr :: OverlayFile -> Expr s a
overlayFileToExpr :: forall s a. OverlayFile -> Expr s a
overlayFileToExpr (MkOverlayFile Path Rel File
d) = forall b t s a. Path b t -> Expr s a
pathToExpr Path Rel File
d

packageSetExportSettingsToExpr :: PackageSetExportSettings -> Expr s Import
packageSetExportSettingsToExpr :: forall s. PackageSetExportSettings -> Expr s Import
packageSetExportSettingsToExpr (MkPackageSetExportSettings PackagesDir
d PackageSetFile
f ys :: PackageSet
ys@(MkPackageSet Compiler
_ PackageList
xs)) = forall s. Expr s Import -> Expr s Import
letHorizonSpecIn forall a b. (a -> b) -> a -> b
$ forall s a. PackageList -> Expr s a -> Expr s a
letPackagesBindingIn PackageList
xs forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Expr s a -> Expr s a
App (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field (forall s a. Text -> Expr s a
horizonField Text
"HorizonExport") (forall s. Text -> FieldSelection s
makeFieldSelection Text
"MakePackageSet")) forall a b. (a -> b) -> a -> b
$ forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [(k, v)] -> Map k v
DMap.fromList forall a b. (a -> b) -> a -> b
$ [
    (Text
"packageSetFile", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. PackageSetFile -> Expr s a
packageSetFileToExpr PackageSetFile
f),
    (Text
"packagesDir", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. PackagesDir -> Expr s a
packagesDirToExpr PackagesDir
d),
    (Text
"packageSet", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. PackageSet -> Expr s a -> Expr s a
packageSetToExpr PackageSet
ys forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap Expr s Import
"packages" forall a. Maybe a
Nothing)
    ]


overlayExportSettingsToExpr :: OverlayExportSettings -> Expr s Import
overlayExportSettingsToExpr :: forall s. OverlayExportSettings -> Expr s Import
overlayExportSettingsToExpr (MkOverlayExportSettings PackagesDir
d OverlayFile
f (MkOverlay ys :: PackageSet
ys@(MkPackageSet Compiler
_ PackageList
xs))) = forall s. Expr s Import -> Expr s Import
letHorizonSpecIn forall a b. (a -> b) -> a -> b
$ forall s a. PackageList -> Expr s a -> Expr s a
letPackagesBindingIn PackageList
xs forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Expr s a -> Expr s a
App (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field (forall s a. Text -> Expr s a
horizonField Text
"HorizonExport") (forall s. Text -> FieldSelection s
makeFieldSelection Text
"MakeOverlay")) forall a b. (a -> b) -> a -> b
$ forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [(k, v)] -> Map k v
DMap.fromList forall a b. (a -> b) -> a -> b
$ [
    (Text
"packageSetFile", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. OverlayFile -> Expr s a
overlayFileToExpr OverlayFile
f),
    (Text
"packagesDir", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. PackagesDir -> Expr s a
packagesDirToExpr PackagesDir
d),
    (Text
"packageSet", forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. PackageSet -> Expr s a -> Expr s a
packageSetToExpr PackageSet
ys forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Maybe (Expr s a) -> Expr s a
ToMap Expr s Import
"packages" forall a. Maybe a
Nothing)
    ]


prettyHorizonExport :: HorizonExport -> Text
prettyHorizonExport :: HorizonExport -> Text
prettyHorizonExport = forall a. Pretty a => a -> Text
Dhall.Core.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. HorizonExport -> Expr s Import
horizonExportToExpr

writeHorizonFile :: HorizonExport -> IO ()
writeHorizonFile :: HorizonExport -> IO ()
writeHorizonFile = String -> ByteString -> IO ()
B.writeFile String
"horizon.dhall" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
Dhall.Core.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. HorizonExport -> Expr s Import
horizonExportToExpr

loadHorizon :: IO HorizonExport
loadHorizon :: IO HorizonExport
loadHorizon = forall a. Decoder a -> String -> IO a
Dhall.inputFile @HorizonExport forall a. FromDhall a => Decoder a
Dhall.auto String
"horizon.dhall"

horizonSpecUrl :: Dhall.Core.URL
horizonSpecUrl :: URL
horizonSpecUrl = Scheme
-> Text -> File -> Maybe Text -> Maybe (Expr Src Import) -> URL
Dhall.Core.URL Scheme
HTTPS Text
"gitlab.homotopic.tech" (Directory -> Text -> File
Dhall.Core.File ([Text] -> Directory
Dhall.Core.Directory [Text
"dhall", Text
"0.6", Text
"raw", Text
"-", Text
"horizon-spec", Text
"horizon"]) Text
"package.dhall") forall a. Maybe a
Nothing forall a. Maybe a
Nothing

horizonSpecImportHashed :: ImportHashed
horizonSpecImportHashed :: ImportHashed
horizonSpecImportHashed = Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed forall a. Maybe a
Nothing (URL -> ImportType
Remote URL
horizonSpecUrl)

horizonSpecImport :: Import
horizonSpecImport :: Import
horizonSpecImport = ImportHashed -> ImportMode -> Import
Import ImportHashed
horizonSpecImportHashed ImportMode
Code

horizonSpecIdentifier :: Expr s a
horizonSpecIdentifier :: forall s a. Expr s a
horizonSpecIdentifier = Expr s a
"H"

packagesIdentifier :: Text
packagesIdentifier :: Text
packagesIdentifier = Text
"packages"

horizonSpecBinding :: Binding s Import
horizonSpecBinding :: forall s. Binding s Import
horizonSpecBinding = forall s a. Text -> Expr s a -> Binding s a
makeBinding Text
"H" (forall s a. a -> Expr s a
Dhall.Core.Embed Import
horizonSpecImport)

letHorizonSpecIn :: Expr s Import -> Expr s Import
letHorizonSpecIn :: forall s. Expr s Import -> Expr s Import
letHorizonSpecIn = forall s a. Binding s a -> Expr s a -> Expr s a
Let forall s. Binding s Import
horizonSpecBinding

packagesBinding :: PackageList -> Binding s a
packagesBinding :: forall s a. PackageList -> Binding s a
packagesBinding = forall s a. Text -> Expr s a -> Binding s a
makeBinding Text
packagesIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. PackageList -> Expr s a
packageListToExpr

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