module Hpp.Types where
import Control.Monad (ap, join)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Hpp.Config
import Hpp.Tokens
type LineNum = Int
type Env = [(String, Macro)]
data Error = UnterminatedBranch
| BadMacroDefinition LineNum
| BadIfPredicate
| BadLineArgument LineNum String
| IncludeDoesNotExist LineNum FilePath
| FailedInclude LineNum FilePath
| UserError LineNum String
| UnknownCommand LineNum String
| TooFewArgumentsToMacro LineNum String
| BadMacroArguments LineNum String
| NoInputFile
| BadCommandLine String
| RanOutOfInput
deriving (Eq, Ord, Show)
class HasError m where
throwError :: Error -> m a
instance Monad m => HasError (ExceptT Error m) where
throwError = throwE
instance (Monad m, HasHppState m) => HasHppState (ExceptT e m) where
getState = lift getState
setState = lift . setState
newtype Cleanup = Cleanup (IORef (IO ()))
runCleanup :: Cleanup -> IO ()
runCleanup (Cleanup r) = join (readIORef r) >> writeIORef r (return ())
mkCleanup :: IO () -> IO (Cleanup, IO ())
mkCleanup m = do r <- newIORef m
return $ (Cleanup r, writeIORef r (return ()))
data FreeF f a r = PureF a | FreeF (f r)
instance Functor f => Functor (FreeF f a) where
fmap _ (PureF x) = PureF x
fmap f (FreeF x) = FreeF $ fmap f x
data HppState = HppState { hppConfig :: Config
, hppLineNum :: LineNum
, hppCleanups :: [Cleanup]
, hppEnv :: Env }
data HppF t r = ReadFile Int FilePath (t -> r)
| ReadNext Int FilePath (t -> r)
| GetState (HppState -> r)
| SetState HppState r
| ThrowError Error
instance Functor (HppF t) where
fmap f (ReadFile ln file k) = ReadFile ln file (f . k)
fmap f (ReadNext ln file k) = ReadNext ln file (f . k)
fmap f (GetState k) = GetState (f . k)
fmap f (SetState cfg k) = SetState cfg (f k)
fmap _ (ThrowError e) = ThrowError e
newtype HppT t m a = HppT { runHppT :: m (FreeF (HppF t) a (HppT t m a)) }
instance Functor m => Functor (HppT t m) where
fmap f (HppT x) = HppT $ fmap f' x
where f' (PureF y) = PureF (f y)
f' (FreeF y) = FreeF $ fmap (fmap f) y
instance Monad m => Applicative (HppT t m) where
pure = HppT . pure . PureF
(<*>) = ap
instance Monad m => Monad (HppT t m) where
return = pure
HppT ma >>= fb = HppT $ ma >>= \case
PureF x -> runHppT $ fb x
FreeF x -> return . FreeF $ fmap (>>= fb) x
instance MonadTrans (HppT t) where
lift = HppT . fmap PureF
instance MonadIO m => MonadIO (HppT t m) where
liftIO = HppT . fmap PureF . liftIO
class HasHppState m where
getState :: m HppState
setState :: HppState -> m ()
instance Monad m => HasHppState (HppT t m) where
getState = HppT . pure . FreeF $ GetState pure
setState s = HppT . pure . FreeF $ SetState s (pure ())
class HasEnv m where
getEnv :: m Env
setEnv :: Env -> m ()
instance Monad m => HasEnv (HppT t m) where
getEnv = fmap hppEnv getState
setEnv e = getState >>= setState . (\s -> s { hppEnv = e })
instance Applicative m => HasError (HppT t m) where
throwError = HppT . pure . FreeF . ThrowError
instance (HasEnv m, Monad m) => HasEnv (ExceptT e m) where
getEnv = lift getEnv
setEnv = lift . setEnv
data Scan = Unmask String
| Mask String
| Scan Token
| Rescan Token
deriving (Eq, Show)
data Macro = Object [Token]
| Function Int ([([Scan],String)] -> [Scan])
instance Show Macro where
show (Object ts) = "Object "++ detokenize ts
show (Function n _) = "Fun<"++show n++">"