module Hpp.Types where
import Control.Exception (Exception (..))
import Control.Monad (ap)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Control.Monad.Trans.State.Strict (StateT, get, put)
import Data.ByteString.Char8 (ByteString)
import Data.Functor.Constant
import Data.Functor.Identity
import qualified Data.Trie as T
import Hpp.Config
import Hpp.Env (emptyEnv, lookupKey)
import Hpp.StringSig (toChars)
import Hpp.Tokens
import Prelude hiding (String)
import qualified Prelude as P
type LineNum = Int
type Env = T.Trie Macro
type String = ByteString
type TOKEN = Token ByteString
data Error = UnterminatedBranch
| BadMacroDefinition LineNum
| BadIfPredicate
| BadLineArgument LineNum P.String
| IncludeDoesNotExist LineNum FilePath
| FailedInclude LineNum FilePath
| UserError LineNum P.String
| UnknownCommand LineNum P.String
| TooFewArgumentsToMacro LineNum P.String
| BadMacroArguments LineNum P.String
| NoInputFile
| BadCommandLine P.String
| RanOutOfInput
deriving (Eq, Ord, Show)
instance Exception Error
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
instance (Monad m, HasError m) => HasError (StateT s m) where
throwError = lift . throwError
instance (Monad m, HasError m) => HasError (HppT t m) where
throwError = lift . throwError
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
, hppEnv :: Env
}
data HppF t r = ReadFile Int FilePath (t -> r)
| ReadNext Int FilePath (t -> r)
| WriteOutput t r
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 (WriteOutput o k) = WriteOutput o (f k)
newtype HppT t m a = HppT { runHppT :: m (FreeF (HppF t) a (HppT t m a)) }
writeOutput :: Monad m => t -> HppT t m ()
writeOutput = HppT . return . FreeF . flip WriteOutput (return ())
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 (StateT HppState m) where
getState = get
setState = put
instance (Monad m, HasHppState m) => HasHppState (StateT s m) where
getState = lift getState
setState = lift . setState
instance (Monad m, HasHppState m) => HasHppState (HppT t m) where
getState = lift getState
setState = lift . setState
class HasEnv m where
getEnv :: m Env
setEnv :: Env -> m ()
instance (Monad m, HasHppState m) => HasEnv (HppT t m) where
getEnv = fmap hppEnv (lift getState)
setEnv e = lift getState >>= lift . setState . (\s -> s { hppEnv = e })
instance Monad m => HasEnv (StateT HppState m) where
getEnv = hppEnv <$> get
setEnv = (env .=)
instance Monad m => HasEnv (StateT Env m) where
getEnv = get
setEnv = put
instance (HasEnv m, Monad m) => HasEnv (ExceptT e m) where
getEnv = lift getEnv
setEnv = lift . setEnv
data Scan = Unmask String
| Mask String
| Scan (Token String)
| Rescan (Token String)
deriving (Eq, Show)
data Macro = Object [Token String]
| Function Int ([([Scan], String)] -> [Scan])
instance Show Macro where
show (Object ts) = "Object "++ toChars (detokenize ts)
show (Function n _) = "Fun<"++show n++">"
lookupMacro :: (HasEnv m, Monad m) => String -> m (Maybe Macro)
lookupMacro s = lookupKey s <$> getEnv
type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s
setL :: Lens s a -> a -> s -> s
setL l x = runIdentity . l (const $ Identity x)
getL :: Lens s a -> s -> a
getL l = getConstant . l Constant
over :: Lens s a -> (a -> a) -> s -> s
over l f = runIdentity . l (Identity . f)
emptyHppState :: Config -> HppState
emptyHppState cfg = HppState cfg 1 emptyEnv
config :: Lens HppState Config
config f (HppState cfg ln e) = (\cfg' -> HppState cfg' ln e) <$> f cfg
lineNum :: Lens HppState LineNum
lineNum f (HppState cfg ln e) = (\ln' -> HppState cfg ln' e) <$> f ln
env :: Lens HppState Env
env f (HppState cfg ln e) = (\e' -> HppState cfg ln e') <$> f e
use :: (HasHppState m, Functor m) => Lens HppState a -> m a
use l = getL l <$> getState
(.=) :: (HasHppState m, Monad m) => Lens HppState a -> a -> m ()
l .= x = getState >>= setState . setL l x
infix 4 .=
(%=) :: (HasHppState m, Monad m) => Lens HppState a -> (a -> a) -> m ()
l %= f = getState >>= setState . over l f
infix 4 %=