{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Hakyll.Web.Dhall (
DhallCompilerOptions(..), DhallCompilerTrust(..)
, defaultDhallCompilerOptions, dcoResolver, dcoMinimize, dcoNormalize
, DhallResolver(..), DefaultDhallResolver(..), drRemap, drFull
, loadDhall, loadDhallWith
, loadDhallExpr, loadDhallExprWith
, DExpr(..)
, parseDhall, parseDhallWith
, dhallCompiler
, dhallRawCompiler, dhallFullCompiler
, dhallCompilerWith
, parseRawDhallWith
, resolveDhallImports
) where
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
import Data.Default.Class
import Data.IORef
import Data.Maybe
import Data.Typeable (Typeable)
import Dhall hiding (maybe)
import Dhall.Binary
import Dhall.Core
import Dhall.Diff
import Dhall.Import
import Dhall.Parser
import Dhall.Pretty
import Dhall.TypeCheck
import GHC.Generics (Generic)
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Writable
import Lens.Family (LensLike, LensLike', (.~), (&))
import System.FilePath
import System.IO
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Data.Binary as Bi
import qualified Data.Binary.Get as Bi
import qualified Data.Binary.Put as Bi
import qualified Data.Kind as K
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Text as PP
newtype DExpr a = DExpr { getDExpr :: Expr Src a }
deriving (Generic, Typeable)
instance (DefaultDhallResolver a, PP.Pretty a) => Bi.Binary (DExpr a) where
put = Bi.putBuilder
. CBOR.toBuilder
. CBOR.encodeTerm
. encode V_1_0
. fmap toImport
. getDExpr
where
toImport = case defaultDhallResolver @a of
DRRaw _ -> id
DRFull _ -> absurd
get = do
bs <- Bi.getRemainingLazyByteString
(_, t) <- either (fail . show) pure $
CBOR.deserialiseFromBytes CBOR.decodeTerm bs
e <- either (fail . show) pure $
decode t
DExpr <$> traverse fromImport e
where
fromImport i = case defaultDhallResolver @a of
DRRaw _ -> pure i
DRFull _ -> fail $
"Unexpected import in deserialization of `DExpr X`: "
++ T.unpack (iStr i)
iStr = PP.renderStrict
. PP.layoutSmart layoutOpts
. PP.pretty @Import
instance PP.Pretty a => Writable (DExpr a) where
write fp e = withFile fp WriteMode $ \h ->
PP.renderIO h
. PP.layoutSmart layoutOpts
. PP.unAnnotate
. prettyExpr
. getDExpr
. itemBody
$ e
data DhallCompilerTrust = DCTLocal
| DCTRemote
| DCTEnv
deriving (Generic, Typeable, Show, Eq, Ord)
data DhallCompilerOptions a = DCO
{ _dcoResolver :: DhallResolver a
, _dcoMinimize :: Bool
, _dcoNormalize :: Bool
}
deriving (Generic, Typeable)
dcoResolver
:: Functor f
=> LensLike f (DhallCompilerOptions a) (DhallCompilerOptions b) (DhallResolver a) (DhallResolver b)
dcoResolver f (DCO r m n) = (\r' -> DCO r' m n) <$> f r
dcoMinimize
:: Functor f
=> LensLike' f (DhallCompilerOptions a) Bool
dcoMinimize f (DCO r m n) = (\m' -> DCO r m' n) <$> f m
dcoNormalize
:: Functor f
=> LensLike' f (DhallCompilerOptions a) Bool
dcoNormalize f (DCO r m n) = DCO r m <$> f n
data DhallResolver :: K.Type -> K.Type where
DRRaw :: { _drRemap :: Import -> Compiler (Expr Src Import)
} -> DhallResolver Import
DRFull :: { _drTrust :: S.Set DhallCompilerTrust
} -> DhallResolver X
drRemap
:: Functor f
=> LensLike' f (DhallResolver Import) (Import -> Compiler (Expr Src Import))
drRemap f (DRRaw r) = DRRaw <$> f r
drFull
:: Functor f
=> LensLike' f (DhallResolver X) (S.Set DhallCompilerTrust)
drFull f (DRFull t) = DRFull <$> f t
defaultDhallCompilerOptions
:: DefaultDhallResolver a
=> DhallCompilerOptions a
defaultDhallCompilerOptions = DCO
{ _dcoResolver = defaultDhallResolver
, _dcoMinimize = False
, _dcoNormalize = True
}
class DefaultDhallResolver a where
defaultDhallResolver :: DhallResolver a
instance DefaultDhallResolver Import where
defaultDhallResolver = DRRaw $ pure . Embed
instance DefaultDhallResolver X where
defaultDhallResolver = DRFull $ S.singleton DCTRemote
instance DefaultDhallResolver a => Default (DhallCompilerOptions a) where
def = defaultDhallCompilerOptions
dhallCompiler
:: forall a. (DefaultDhallResolver a, PP.Pretty a)
=> Compiler (Item String)
dhallCompiler = dhallCompilerWith @a defaultDhallCompilerOptions
dhallRawCompiler :: Compiler (Item String)
dhallRawCompiler = dhallCompilerWith @Import defaultDhallCompilerOptions
dhallFullCompiler :: Compiler (Item String)
dhallFullCompiler = dhallCompilerWith @X defaultDhallCompilerOptions
dhallCompilerWith
:: PP.Pretty a
=> DhallCompilerOptions a
-> Compiler (Item String)
dhallCompilerWith dco = do
i <- getUnderlying
b <- T.pack . itemBody <$> getResourceBody
e <- parseDhallWith dco (Just i) b
makeItem $ T.unpack (disp e)
where
disp
| _dcoMinimize dco = pretty
| otherwise = PP.renderStrict
. PP.layoutSmart layoutOpts
. PP.unAnnotate
. prettyExpr
parseRawDhallWith
:: DhallCompilerOptions Import
-> Maybe Identifier
-> T.Text
-> Compiler (Expr Src Import)
parseRawDhallWith DCO{..} i b =
case exprFromText (maybe "Raw dhall string" toFilePath i) b of
Left e -> throwError . (:[]) $
"Error parsing raw dhall file: " ++ show e
Right e -> join <$> traverse (_drRemap _dcoResolver) e
parseDhall
:: DefaultDhallResolver a
=> Maybe Identifier
-> T.Text
-> Compiler (Expr Src a)
parseDhall = parseDhallWith defaultDhallCompilerOptions
parseDhallWith
:: DhallCompilerOptions a
-> Maybe Identifier
-> T.Text
-> Compiler (Expr Src a)
parseDhallWith dco i b = case _dcoResolver dco of
DRRaw _ -> norm <$> parseRawDhallWith dco i b
DRFull _ -> fmap norm
. resolveDhallImports dco i
=<< parseRawDhallWith (dco { _dcoResolver = defaultDhallResolver })
i b
where
norm :: Eq b => Expr s b -> Expr s b
norm
| _dcoNormalize dco = normalize
| otherwise = id
resolveDhallImports
:: DhallCompilerOptions X
-> Maybe Identifier
-> Expr Src Import
-> Compiler (Expr Src X)
resolveDhallImports DCO{..} ident e = do
(res, imps) <- unsafeCompiler $ do
iRef <- newIORef []
res <- evalStateT (loadWith e) $
emptyStatus (takeDirectory (maybe "./" toFilePath ident))
& resolver .~ \i -> do
liftIO $ modifyIORef iRef (i:)
exprFromImport i
(res,) <$> readIORef iRef
compilerTellDependencies $ mapMaybe mkDep imps
pure res
where
DRFull{..} = _dcoResolver
mkDep :: Import -> Maybe Dependency
mkDep i = case importType (importHashed i) of
Local Here (File (Directory xs) x) -> Just
. IdentifierDependency
. fromFilePath
. joinPath
. map T.unpack
. reverse
$ x : xs
Local _ _
| DCTLocal `S.member` _drTrust -> Nothing
| otherwise -> Just neverTrust
Remote _
| DCTRemote `S.member` _drTrust -> Nothing
| otherwise -> Just neverTrust
Env _
| DCTEnv `S.member` _drTrust -> Nothing
| otherwise -> Just neverTrust
Missing -> Just neverTrust
neverTrust = PatternDependency mempty mempty
loadDhallExpr
:: DefaultDhallResolver a
=> Identifier
-> Compiler (Item (Expr Src a))
loadDhallExpr = loadDhallExprWith defaultDhallCompilerOptions
loadDhallExprWith
:: DhallCompilerOptions a
-> Identifier
-> Compiler (Item (Expr Src a))
loadDhallExprWith dco i = do
b <- T.pack <$> loadBody i
Item i <$> parseDhallWith dco (Just i) b
loadDhall
:: Type a
-> Identifier
-> Compiler (Item a)
loadDhall = loadDhallWith defaultDhallCompilerOptions
loadDhallWith
:: DhallCompilerOptions X
-> Type a
-> Identifier
-> Compiler (Item a)
loadDhallWith dco t ident = traverse (inp t)
=<< loadDhallExprWith dco ident
where
inp :: Type a -> Expr Src X -> Compiler a
inp t' e = case rawInput t' e of
Nothing -> throwError . (terr:) . (:[]) $ case typeOf e of
Left err -> show err
Right t0 -> T.unpack
. PP.renderStrict
. PP.layoutSmart layoutOpts
. diffNormalized (expected t)
$ t0
Just x -> pure x
terr = "Error interpreting Dhall expression as desired type."