{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}
module Hpp (
preprocess, runHpp, streamHpp, expand,
T.HppState, emptyHppState, initHppState,
parseDefinition, addDefinition,
HppT, HppOutput(..)
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift, MonadTrans)
import Control.Monad.Trans.Except (ExceptT, Except, throwE, runExceptT)
import qualified Control.Monad.Trans.State.Strict as S
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.Maybe (fromMaybe)
import qualified Hpp.Config as C
import qualified Hpp.Env as E
import qualified Hpp.Macro as M
import qualified Hpp.RunHpp as R
import qualified Hpp.Types as T
import Hpp.Types (setL, config, env, lineNum)
import Hpp.Parser (evalParse, Parser)
import Hpp.StringSig (readLines)
import Hpp.Tokens (tokenize)
newtype HppT m a =
HppT (T.HppT [ByteString]
(Parser (S.StateT T.HppState (ExceptT T.Error m))
[T.TOKEN])
a)
deriving (Functor, Applicative, Monad)
instance MonadTrans HppT where
lift = HppT . lift . lift . lift . lift
data HppOutput = HppOutput { hppFilesRead :: [FilePath]
, hppOutput :: [ByteString] }
preprocess :: Monad m => [ByteString] -> HppT m ()
preprocess = HppT . R.preprocess
runHpp :: MonadIO m
=> T.HppState
-> HppT m a
-> ExceptT T.Error m (HppOutput, T.HppState)
runHpp st h =
do r <- liftIO (newIORef id)
let snk xs = modifyIORef r (. (xs++))
let fin (x, st') = do outLines <- ($ []) <$> readIORef r
return (HppOutput x outLines, st')
streamHpp st (liftIO . snk) h >>= liftIO . fin
streamHpp :: MonadIO m
=> T.HppState
-> ([ByteString] -> m ())
-> HppT m a
-> ExceptT T.Error m ([FilePath], T.HppState)
streamHpp st snk (HppT h) =
do (a, st') <- S.runStateT
(evalParse
(R.runHpp (liftIO . readLines)
(lift . lift . lift . snk)
h)
[])
st
either (throwE . snd) (return . (,st') . R.hppFilesRead) a
expand :: T.HppState
-> HppT (S.State ([ByteString] -> [ByteString])) a
-> Except T.Error (HppOutput, T.HppState)
expand st (HppT h) =
case result of
Left e -> throwE e
Right (Left (_, e), _) -> throwE e
Right (Right x, st') ->
return (HppOutput (R.hppFilesRead x) (outDlist []), st')
where snk xs = S.modify (. (xs++))
expanded = (S.runStateT
(evalParse
(R.expandHpp (lift . lift . lift . snk) h)
[])
st)
(result, outDlist) = S.runState (runExceptT expanded) id
emptyHppState :: T.HppState
emptyHppState = T.emptyHppState
$ fromMaybe (error "emptyHppState assumption wrong")
(C.realizeConfig cfg)
where cfg = C.defaultConfigF { C.curFileNameF = Just "NoFile" }
initHppState :: C.Config -> T.Env -> T.HppState
initHppState c e = setL lineNum 1 . setL env e . setL config c $ emptyHppState
addDefinition :: ByteString -> ByteString -> T.HppState -> Maybe T.HppState
addDefinition name val s = flip (T.over T.env) s . E.insertPair
<$> parseDefinition name val
parseDefinition :: ByteString -> ByteString -> Maybe (ByteString, T.Macro)
parseDefinition name val = M.parseDefinition (tokenize name ++ tokenize val)