Skip to content

Instantly share code, notes, and snippets.

@roberth
Created July 1, 2018 20:39
Show Gist options
  • Save roberth/886f658dca37915b3051380fc08f23b2 to your computer and use it in GitHub Desktop.
Save roberth/886f658dca37915b3051380fc08f23b2 to your computer and use it in GitHub Desktop.
Allow weird stuff when reading Dhall, like redundant fields
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment