{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module B9.Artifact.Content.StringTemplate
( subst
, substStr
, substFile
, substPath
, readTemplateFile
, withSubstitutedStringBindings
, SourceFile(..)
, SourceFileConversion(..)
)
where
import B9.B9Error
import B9.Environment
import B9.QCUtil
import Control.Exception ( displayException )
import Control.Monad ( foldM )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import Control.Eff as Eff
import Control.Monad.Trans.Identity ( )
import Control.Parallel.Strategies
import Data.Binary
import Data.Data
import Data.Hashable
import Data.Text ( Text )
import qualified Data.Text.Lazy as LazyText
( toStrict )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Text.Template ( renderA
, templateSafe
, Template
)
import GHC.Generics ( Generic )
import System.IO.B9Extras
import Test.QuickCheck
import Text.Printf
data SourceFile =
Source SourceFileConversion
FilePath
deriving (Read, Show, Typeable, Data, Eq, Generic)
instance Hashable SourceFile
instance Binary SourceFile
instance NFData SourceFile
data SourceFileConversion
= NoConversion
| ExpandVariables
deriving (Read, Show, Typeable, Data, Eq, Generic)
instance Hashable SourceFileConversion
instance Binary SourceFileConversion
instance NFData SourceFileConversion
readTemplateFile
:: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e)
=> SourceFile
-> Eff e Text
readTemplateFile (Source conv f') = do
let
onErrorFileName e = error
(printf
"Failed to substitute templates in source \
\file name '%s'/\nError: %s\n"
f'
(displayException e)
)
f <- subst (Text.pack f') `catchB9Error` onErrorFileName
c <- liftIO (Text.readFile (Text.unpack f))
case conv of
NoConversion -> return c
ExpandVariables ->
let onErrorFile e =
error
(printf "readTemplateFile '%s' failed: \n%s\n"
f
(displayException e)
)
in subst c `catchB9Error` onErrorFile
subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text
subst templateStr = do
t <- templateSafeExcB9 templateStr
LazyText.toStrict <$> renderA t lookupOrThrow
substStr
:: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
substStr templateStr = do
t <- templateSafeExcB9 (Text.pack templateStr)
Text.unpack . LazyText.toStrict <$> renderA t lookupOrThrow
templateSafeExcB9 :: Member ExcB9 e => Text -> Eff e Template
templateSafeExcB9 templateStr = case templateSafe templateStr of
Left (row, col) -> throwB9Error
( "Invalid template, error at row: "
++ show row
++ ", col: "
++ show col
++ " in: \""
++ show templateStr
)
Right t -> return t
substFile
:: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))
=> FilePath
-> FilePath
-> Eff e ()
substFile src dest = do
templatedText <- liftIO (Text.readFile src)
let t = templateSafe templatedText
case t of
Left (r, c) ->
let badLine = Text.unlines (take r (Text.lines templatedText))
colMarker = Text.replicate (c - 1) "-" <> "^"
in throwB9Error
(printf "Template error in file '%s' line %i:\n\n%s\n%s\n"
src
r
badLine
colMarker
)
Right template' -> do
out <- renderA template' (templateEnvLookupSrcFile src)
liftIO (Text.writeFile dest (LazyText.toStrict out))
templateEnvLookupSrcFile
:: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))
=> FilePath
-> Text
-> Eff e Text
templateEnvLookupSrcFile src x = do
r <- catchB9ErrorAsEither (lookupOrThrow x)
either err pure r
where err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n")
substPath
:: (Member EnvironmentReader e, Member ExcB9 e)
=> SystemPath
-> Eff e SystemPath
substPath src = case src of
Path p -> Path <$> substStr p
InHomeDir p -> InHomeDir <$> substStr p
InB9UserDir p -> InB9UserDir <$> substStr p
InTempDir p -> InTempDir <$> substStr p
instance Arbitrary SourceFile where
arbitrary =
Source
<$> elements [NoConversion, ExpandVariables]
<*> smaller arbitraryFilePath
withSubstitutedStringBindings
:: (Member EnvironmentReader e, Member ExcB9 e)
=> [(String, String)]
-> Eff e s
-> Eff e s
withSubstitutedStringBindings bs nested = do
let extend env (k, v) = localEnvironment (const env) $ do
kv <- (Text.pack k, ) <$> subst (Text.pack v)
addBinding kv env
env <- askEnvironment
envExt <- foldM extend env bs
localEnvironment (const envExt) nested