{-# LANGUAGE TupleSections #-}

{-|
Module: Hpack.Dhall
Copyright:
    © 2018 - 2021 Phil de Joux
    © 2018 - 2021 Block Scope Limited
License: BSD3
Maintainer: Phil de Joux <phil.dejoux@blockscope.com>
Stability: experimental
The functions in this module make it possible to configure an
<https://github.com/sol/hpack#readme hpack>
package description with
<https://github.com/dhall-lang/dhall-lang#readme Dhall>
instead of
<https://en.wikipedia.org/wiki/YAML YAML>.
When doing so, note that all functions resolve imports relative to the location
of the given @.dhall@ input file.
-}
module Hpack.Dhall
    ( fileToJson
    , showJson
    , showYaml
    , showDhall
    , packageConfig
    ) where

import Data.Void (Void)
import Data.Maybe (fromMaybe)
import Data.Function ((&))
import Lens.Micro ((^.), set)
import System.FilePath (takeDirectory)
import Control.Exception (throwIO)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Bifunctor (first)
import Data.Aeson (ToJSON, Value)
import qualified Data.ByteString.Lazy as BSL (toStrict)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T (Text, unpack)
import qualified Data.Text.IO as T (readFile)
import Dhall
    ( InputSettings, Text
    , rootDirectory, sourceName, defaultInputSettings
    )
import Dhall.Core (Expr)
import Dhall.Parser (Src, exprFromText)
import Dhall.Import (loadWith, emptyStatus)
import Dhall.TypeCheck (typeOf)
import Dhall.JSON (dhallToJSON)
import Dhall.Pretty (prettyExpr, layoutOpts)
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP
import qualified Data.Yaml.Pretty as Y
import qualified Data.Aeson.Encode.Pretty as A
import Hpack.Fields (cmp)

-- SEE: http://onoffswitch.net/adventures-pretty-printing-json-haskell/
getJson :: ToJSON a => (Text -> Text -> Ordering) -> a -> String
getJson :: (Text -> Text -> Ordering) -> a -> String
getJson Text -> Text -> Ordering
cmp' =
    let cfg :: Config
cfg = Config
A.defConfig {confCompare :: Text -> Text -> Ordering
A.confCompare = Text -> Text -> Ordering
cmp'}
    in Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
A.encodePretty' Config
cfg

getYaml :: ToJSON a => (Text -> Text -> Ordering) -> a -> String
getYaml :: (Text -> Text -> Ordering) -> a -> String
getYaml Text -> Text -> Ordering
cmp' =
    let cfg :: Config
cfg = (Text -> Text -> Ordering) -> Config -> Config
Y.setConfCompare Text -> Text -> Ordering
cmp' Config
Y.defConfig
    in Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Y.encodePretty Config
cfg

-- | The default package file name is @package.dhall@.
packageConfig :: FilePath
packageConfig :: String
packageConfig = String
"package.dhall"

-- | Pretty prints JSON for the package description.
showJson
    :: Maybe (Text -> Text -> Ordering)
    -- ^ An ordering of JSON fields.
    -> FilePath
    -- ^ Path to a @.dhall@ file
    -> IO String
showJson :: Maybe (Text -> Text -> Ordering) -> String -> IO String
showJson Maybe (Text -> Text -> Ordering)
fieldOrdering String
file = do
    Either String ([String], Value)
x <- String -> IO (Either String ([String], Value))
fileToJson String
file
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case Either String ([String], Value)
x of
        Left String
err -> String
err
        Right ([String]
_, Value
v) -> (Text -> Text -> Ordering) -> Value -> String
forall a. ToJSON a => (Text -> Text -> Ordering) -> a -> String
getJson ((Text -> Text -> Ordering)
-> Maybe (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a. a -> Maybe a -> a
fromMaybe Text -> Text -> Ordering
forall a. (Ord a, IsString a) => a -> a -> Ordering
cmp Maybe (Text -> Text -> Ordering)
fieldOrdering) Value
v

-- | Pretty prints YAML for the package description.
showYaml
    :: Maybe (Text -> Text -> Ordering)
    -- ^ An ordering of YAML fields.
    -> FilePath
    -- ^ Path to a @.dhall@ file
    -> IO String
showYaml :: Maybe (Text -> Text -> Ordering) -> String -> IO String
showYaml Maybe (Text -> Text -> Ordering)
fieldOrdering String
file = do
    Either String ([String], Value)
x <- String -> IO (Either String ([String], Value))
fileToJson String
file
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case Either String ([String], Value)
x of
        Left String
err -> String
err
        Right ([String]
_, Value
v) -> (Text -> Text -> Ordering) -> Value -> String
forall a. ToJSON a => (Text -> Text -> Ordering) -> a -> String
getYaml ((Text -> Text -> Ordering)
-> Maybe (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a. a -> Maybe a -> a
fromMaybe Text -> Text -> Ordering
forall a. (Ord a, IsString a) => a -> a -> Ordering
cmp Maybe (Text -> Text -> Ordering)
fieldOrdering) Value
v

-- | Pretty prints the package description Dhall expression, resolving imports
-- relative to the location of the @.dhall@ file.
showDhall
    :: FilePath -- ^ Path to a @.dhall@ file
    -> IO String
showDhall :: String -> IO String
showDhall String
file = do
    Text
text <- String -> IO Text
T.readFile String
file
    Expr Src Void
expr <- InputSettings -> Text -> IO (Expr Src Void)
check (String -> InputSettings
inputSettings String
file) Text
text
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (Text -> String) -> Text -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO String) -> Text -> IO String
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Text
forall a. Pretty a => Expr Src a -> Text
renderDhall Expr Src Void
expr

-- | A file decoder for hpack. This should evaluate to a single record with
-- hpack's top-level <https://github.com/sol/hpack#top-level-fields fields>.
fileToJson
    :: FilePath -- ^ Path to a @.dhall@ file
    -> IO (Either String ([String], Value))
fileToJson :: String -> IO (Either String ([String], Value))
fileToJson String
file =
    IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
T.readFile String
file)
    IO Text
-> (Text -> IO (Either String ([String], Value)))
-> IO (Either String ([String], Value))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputSettings -> Text -> IO (Either String ([String], Value))
textToJson (String -> InputSettings
inputSettings String
file)

inputSettings :: FilePath -> InputSettings
inputSettings :: String -> InputSettings
inputSettings String
file =
    InputSettings
Dhall.defaultInputSettings
    InputSettings -> (InputSettings -> InputSettings) -> InputSettings
forall a b. a -> (a -> b) -> b
& ASetter InputSettings InputSettings String String
-> String -> InputSettings -> InputSettings
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter InputSettings InputSettings String String
forall (f :: * -> *). Functor f => LensLike' f InputSettings String
rootDirectory (String -> String
takeDirectory String
file)
    InputSettings -> (InputSettings -> InputSettings) -> InputSettings
forall a b. a -> (a -> b) -> b
& ASetter InputSettings InputSettings String String
-> String -> InputSettings -> InputSettings
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter InputSettings InputSettings String String
forall (f :: * -> *). Functor f => LensLike' f InputSettings String
sourceName String
file

textToJson
    :: InputSettings
    -> T.Text
    -> IO (Either String ([String], Value))
textToJson :: InputSettings -> Text -> IO (Either String ([String], Value))
textToJson InputSettings
settings Text
text = ExceptT String IO ([String], Value)
-> IO (Either String ([String], Value))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO ([String], Value)
 -> IO (Either String ([String], Value)))
-> ExceptT String IO ([String], Value)
-> IO (Either String ([String], Value))
forall a b. (a -> b) -> a -> b
$ do
    Expr Src Void
expr <- IO (Expr Src Void) -> ExceptT String IO (Expr Src Void)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Expr Src Void) -> ExceptT String IO (Expr Src Void))
-> IO (Expr Src Void) -> ExceptT String IO (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ InputSettings -> Text -> IO (Expr Src Void)
check InputSettings
settings Text
text
    Expr Src Void
_ <- Either (TypeError Src Void) (Expr Src Void)
-> ExceptT String IO (Expr Src Void)
forall b (m :: * -> *) a.
(Show b, Monad m) =>
Either b a -> ExceptT String m a
liftResult (Either (TypeError Src Void) (Expr Src Void)
 -> ExceptT String IO (Expr Src Void))
-> Either (TypeError Src Void) (Expr Src Void)
-> ExceptT String IO (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
typeOf Expr Src Void
expr
    Either CompileError ([String], Value)
-> ExceptT String IO ([String], Value)
forall b (m :: * -> *) a.
(Show b, Monad m) =>
Either b a -> ExceptT String m a
liftResult (Either CompileError ([String], Value)
 -> ExceptT String IO ([String], Value))
-> Either CompileError ([String], Value)
-> ExceptT String IO ([String], Value)
forall a b. (a -> b) -> a -> b
$ ([],) (Value -> ([String], Value))
-> Either CompileError Value
-> Either CompileError ([String], Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Src Void -> Either CompileError Value
forall s. Expr s Void -> Either CompileError Value
dhallToJSON Expr Src Void
expr
    where
        liftResult :: (Show b, Monad m) => Either b a -> ExceptT String m a
        liftResult :: Either b a -> ExceptT String m a
liftResult = m (Either String a) -> ExceptT String m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String a) -> ExceptT String m a)
-> (Either b a -> m (Either String a))
-> Either b a
-> ExceptT String m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m (Either String a))
-> (Either b a -> Either String a)
-> Either b a
-> m (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> String) -> Either b a -> Either String a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first b -> String
forall a. Show a => a -> String
show

check :: InputSettings -> Text -> IO (Expr Src Void)
check :: InputSettings -> Text -> IO (Expr Src Void)
check InputSettings
settings Text
text = do
    Expr Src Import
expr <- (ParseError -> IO (Expr Src Import))
-> (Expr Src Import -> IO (Expr Src Import))
-> Either ParseError (Expr Src Import)
-> IO (Expr Src Import)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError -> IO (Expr Src Import)
forall e a. Exception e => e -> IO a
throwIO Expr Src Import -> IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Expr Src Import) -> IO (Expr Src Import))
-> Either ParseError (Expr Src Import) -> IO (Expr Src Import)
forall a b. (a -> b) -> a -> b
$ String -> Text -> Either ParseError (Expr Src Import)
exprFromText String
forall a. Monoid a => a
mempty Text
text
    StateT Status IO (Expr Src Void) -> Status -> IO (Expr Src Void)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expr) (String -> Status
emptyStatus (String -> Status) -> String -> Status
forall a b. (a -> b) -> a -> b
$ InputSettings
settings InputSettings -> Getting String InputSettings String -> String
forall s a. s -> Getting a s a -> a
^. Getting String InputSettings String
forall (f :: * -> *). Functor f => LensLike' f InputSettings String
rootDirectory)

-- SEE: https://github.com/mstksg/hakyll-dhall
renderDhall :: PP.Pretty a => Expr Src a -> T.Text
renderDhall :: Expr Src a -> Text
renderDhall =
    SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict
    (SimpleDocStream Any -> Text)
-> (Expr Src a -> SimpleDocStream Any) -> Expr Src a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
layoutOpts
    (Doc Any -> SimpleDocStream Any)
-> (Expr Src a -> Doc Any) -> Expr Src a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Ann -> Doc Any
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate
    (Doc Ann -> Doc Any)
-> (Expr Src a -> Doc Ann) -> Expr Src a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Src a -> Doc Ann
forall a s. Pretty a => Expr s a -> Doc Ann
prettyExpr