{-# LANGUAGE TupleSections #-}
module Hpack.Dhall
( fileToJson
, showJson
, showYaml
, showDhall
, packageConfig
) where
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 (X, typeOf)
import Dhall.JSON (dhallToJSON)
import Dhall.Pretty (prettyExpr, layoutOpts)
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Text as PP
import qualified Data.Yaml.Pretty as Y
import qualified Data.Aeson.Encode.Pretty as A
import Hpack.Fields (cmp)
getJson :: ToJSON a => (Text -> Text -> Ordering) -> a -> String
getJson cmp' =
let cfg = A.defConfig {A.confCompare = cmp'}
in T.unpack . decodeUtf8 . BSL.toStrict . A.encodePretty' cfg
getYaml :: ToJSON a => (Text -> Text -> Ordering) -> a -> String
getYaml cmp' =
let cfg = Y.setConfCompare cmp' Y.defConfig
in T.unpack . decodeUtf8 . Y.encodePretty cfg
packageConfig :: FilePath
packageConfig = "package.dhall"
showJson
:: Maybe (Text -> Text -> Ordering)
-> FilePath
-> IO String
showJson fieldOrdering file = do
x <- fileToJson file
return $ case x of
Left err -> err
Right (_, v) -> getJson (fromMaybe cmp fieldOrdering) v
showYaml
:: Maybe (Text -> Text -> Ordering)
-> FilePath
-> IO String
showYaml fieldOrdering file = do
x <- fileToJson file
return $ case x of
Left err -> err
Right (_, v) -> getYaml (fromMaybe cmp fieldOrdering) v
showDhall
:: FilePath
-> IO String
showDhall file = do
text <- T.readFile file
expr <- check (inputSettings file) text
return . T.unpack $ renderDhall expr
fileToJson
:: FilePath
-> IO (Either String ([String], Value))
fileToJson file =
liftIO (T.readFile file)
>>= textToJson (inputSettings file)
inputSettings :: FilePath -> InputSettings
inputSettings file =
Dhall.defaultInputSettings
& set rootDirectory (takeDirectory file)
& set sourceName file
textToJson
:: InputSettings
-> T.Text
-> IO (Either String ([String], Value))
textToJson settings text = runExceptT $ do
expr <- liftIO $ check settings text
_ <- liftResult $ typeOf expr
liftResult $ ([],) <$> dhallToJSON expr
where
liftResult :: (Show b, Monad m) => Either b a -> ExceptT String m a
liftResult = ExceptT . return . first show
check :: InputSettings -> Text -> IO (Expr Src X)
check settings text = do
expr <- either throwIO return $ exprFromText mempty text
State.evalStateT (loadWith expr) (emptyStatus $ settings ^. rootDirectory)
renderDhall :: (PP.Pretty a, Eq a) => Expr Src a -> T.Text
renderDhall =
PP.renderStrict
. PP.layoutSmart layoutOpts
. PP.unAnnotate
. prettyExpr