Dhall.hs

{-# 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
  ( dhallFileToJson
  , showJson
  , showYaml
  , showDhall
  , packageConfig
  ) where

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

-- SEE: http://onoffswitch.net/adventures-pretty-printing-json-haskell/
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

-- | The default package file name is @package.dhall@.
packageConfig :: FilePath
packageConfig = "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 fieldOrdering file = do
  x <- dhallFileToJson file
  return $ case x of
    Left err -> err
    Right (_, v) -> getJson (fromMaybe cmp fieldOrdering) 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 fieldOrdering file = do
  x <- dhallFileToJson file
  return $ case x of
    Left err -> err
    Right (_, v) -> getYaml (fromMaybe cmp fieldOrdering) 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 file = do
  text <- T.readFile file
  expr <- check (inputSettings file) text
  return . T.unpack $ renderDhall 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>.
dhallFileToJson
  :: FilePath
  -- ^ Path to a @.dhall@ file
  -> IO (Either String ([String], Value))
dhallFileToJson file =
  liftIO (T.readFile file)
    >>= dhallTextToJson (inputSettings file)

inputSettings :: FilePath -> InputSettings
inputSettings file =
  Dhall.defaultInputSettings
    & set rootDirectory (takeDirectory file)
    & set sourceName file

dhallTextToJson
  :: InputSettings
  -> T.Text
  -> IO (Either String ([String], Value))
dhallTextToJson settings text = runExceptT $ do
  expr <- liftIO $ check settings text
  _ <- liftResult $ typeOf expr
  liftResult $ ([],) . omitNull <$> 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 Void)
check settings text = do
  expr <- either throwIO return $ exprFromText mempty text
  State.evalStateT (loadWith expr) (emptyStatus $ settings ^. rootDirectory)

-- SEE: https://github.com/mstksg/hakyll-dhall
renderDhall :: PP.Pretty a => Expr Src a -> T.Text
renderDhall =
  PP.renderStrict
    . PP.layoutSmart layoutOpts
    . PP.unAnnotate
    . prettyExpr