Allow weird stuff when reading Dhall, like redundant fields

dhall-lenient.hs

module LambdaCI.CLI.Config where

import           Prelude()
import           Protolude

import           System.Directory
import qualified Data.Text.IO as T

import           Dhall hiding (Text)
import           Dhall.Pretty(prettyExpr, annToAnsiStyle)
import           Dhall.Parser(exprFromText)
import           Dhall.Import(load)
import           Dhall.TypeCheck
import           Dhall.Core
import           Dhall.Diff
import           Data.Text.Prettyprint.Doc hiding ((<>))
import           Data.Text.Prettyprint.Doc.Render.Text
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as RT

inputOrWriteDefault :: forall a. (Interpret a, Inject a) => FilePath -> a -> IO a
inputOrWriteDefault path defaultTerm = do
  whenM (not <$> doesFileExist path) $ do
    T.writeFile path $ render $ prettyExpr $ embed inject defaultTerm

  configText <- T.readFile path
  unloadedExpr <- case exprFromText path configText of
    Left e -> die $ show e
    Right r -> pure r
  expr <- load unloadedExpr

  exprType <- case typeOf expr of
    Left e -> die $ show e
    Right r -> pure r

  -- FIXME: also try typechecking as in
  -- https://hackage.haskell.org/package/dhall-1.15.0/docs/src/Dhall.html#inputFromWith
  -- and if it succeeds we're done, else warn and continue lenient extraction below.

  case extract auto (normalize expr) of
    Just config -> do
      putStrLn $ render $ prettyExpr $ embed inject (config :: a)
      pure config
    Nothing -> do
      putMsgLn ""
      putMsgLn "Lenient extraction failed."
      putMsgLn ""
      putMsgLn "Here's how you could change the type of your config. Note that"
      putMsgLn "most actual removals are not necessary."

      RT.renderIO stderr $ fmap annToAnsiStyle $ layoutPretty defaultLayoutOptions $ diffNormalized exprType (expected (auto :: Type a))
      die "Could not extract the configuration. See above message for details."

render :: Doc a -> Text
render = renderStrict . layoutPretty opts
  where opts =
          defaultLayoutOptions

putMsgLn :: Text -> IO ()
putMsgLn = hPutStrLn stderr