{-# LANGUAGE FlexibleInstances, LambdaCase, Rank2Types #-}
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 Data.HashMap.Strict (HashMap)
import Hpp.Config
import Hpp.Env (emptyEnv, lookupKey)
import Hpp.StringSig (toChars)
import Hpp.Tokens
import Prelude hiding (String)
import qualified Prelude as P
import System.FilePath (takeDirectory)
type LineNum = Int
type Env = HashMap ByteString 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 (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Eq Error
Eq Error
-> (Error -> Error -> Ordering)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Error)
-> (Error -> Error -> Error)
-> Ord Error
Error -> Error -> Bool
Error -> Error -> Ordering
Error -> Error -> Error
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Error -> Error -> Error
$cmin :: Error -> Error -> Error
max :: Error -> Error -> Error
$cmax :: Error -> Error -> Error
>= :: Error -> Error -> Bool
$c>= :: Error -> Error -> Bool
> :: Error -> Error -> Bool
$c> :: Error -> Error -> Bool
<= :: Error -> Error -> Bool
$c<= :: Error -> Error -> Bool
< :: Error -> Error -> Bool
$c< :: Error -> Error -> Bool
compare :: Error -> Error -> Ordering
$ccompare :: Error -> Error -> Ordering
$cp1Ord :: Eq Error
Ord, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)
instance Exception Error
class HasError m where
throwError :: Error -> m a
instance Monad m => HasError (ExceptT Error m) where
throwError :: Error -> ExceptT Error m a
throwError = Error -> ExceptT Error m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
{-# INLINE throwError #-}
instance (Monad m, HasHppState m) => HasHppState (ExceptT e m) where
getState :: ExceptT e m HppState
getState = m HppState -> ExceptT e m HppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState
{-# INLINE getState #-}
setState :: HppState -> ExceptT e m ()
setState = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> (HppState -> m ()) -> HppState -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState
{-# INLINE setState #-}
instance (Monad m, HasError m) => HasError (StateT s m) where
throwError :: Error -> StateT s m a
throwError = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a) -> (Error -> m a) -> Error -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> m a
forall (m :: * -> *) a. HasError m => Error -> m a
throwError
{-# INLINE throwError #-}
instance (Monad m, HasError m) => HasError (HppT t m) where
throwError :: Error -> HppT t m a
throwError = m a -> HppT t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HppT t m a) -> (Error -> m a) -> Error -> HppT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> m a
forall (m :: * -> *) a. HasError m => Error -> m a
throwError
{-# INLINE throwError #-}
data FreeF f a r = PureF a | FreeF (f r)
instance Functor f => Functor (FreeF f a) where
fmap :: (a -> b) -> FreeF f a a -> FreeF f a b
fmap a -> b
_ (PureF a
x) = a -> FreeF f a b
forall (f :: * -> *) a r. a -> FreeF f a r
PureF a
x
fmap a -> b
f (FreeF f a
x) = f b -> FreeF f a b
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (f b -> FreeF f a b) -> f b -> FreeF f a b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x
{-# INLINE fmap #-}
data HppState = HppState { HppState -> Config
hppConfig :: Config
, HppState -> String
hppCurDir :: FilePath
, HppState -> Int
hppLineNum :: LineNum
, HppState -> Env
hppEnv :: Env
}
deriving Int -> HppState -> ShowS
[HppState] -> ShowS
HppState -> String
(Int -> HppState -> ShowS)
-> (HppState -> String) -> ([HppState] -> ShowS) -> Show HppState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HppState] -> ShowS
$cshowList :: [HppState] -> ShowS
show :: HppState -> String
$cshow :: HppState -> String
showsPrec :: Int -> HppState -> ShowS
$cshowsPrec :: Int -> HppState -> ShowS
Show
data HppF t r = ReadFile Int FilePath (t -> r)
| ReadNext Int FilePath (t -> r)
| WriteOutput t r
instance Functor (HppF t) where
fmap :: (a -> b) -> HppF t a -> HppF t b
fmap a -> b
f (ReadFile Int
ln String
file t -> a
k) = Int -> String -> (t -> b) -> HppF t b
forall t r. Int -> String -> (t -> r) -> HppF t r
ReadFile Int
ln String
file (a -> b
f (a -> b) -> (t -> a) -> t -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> a
k)
fmap a -> b
f (ReadNext Int
ln String
file t -> a
k) = Int -> String -> (t -> b) -> HppF t b
forall t r. Int -> String -> (t -> r) -> HppF t r
ReadNext Int
ln String
file (a -> b
f (a -> b) -> (t -> a) -> t -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> a
k)
fmap a -> b
f (WriteOutput t
o a
k) = t -> b -> HppF t b
forall t r. t -> r -> HppF t r
WriteOutput t
o (a -> b
f a
k)
{-# INLINE fmap #-}
type Hpp t = FreeF (HppF t)
newtype HppT t m a = HppT { HppT t m a -> m (Hpp t a (HppT t m a))
runHppT :: m (Hpp t a (HppT t m a)) }
hppReadFile :: Monad m => Int -> FilePath -> HppT src m src
hppReadFile :: Int -> String -> HppT src m src
hppReadFile Int
n String
file = m (Hpp src src (HppT src m src)) -> HppT src m src
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (Hpp src src (HppT src m src) -> m (Hpp src src (HppT src m src))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HppF src (HppT src m src) -> Hpp src src (HppT src m src)
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (Int
-> String -> (src -> HppT src m src) -> HppF src (HppT src m src)
forall t r. Int -> String -> (t -> r) -> HppF t r
ReadFile Int
n String
file src -> HppT src m src
forall (m :: * -> *) a. Monad m => a -> m a
return)))
{-# INLINE hppReadFile #-}
hppReadNext :: Monad m => Int -> FilePath -> HppT src m src
hppReadNext :: Int -> String -> HppT src m src
hppReadNext Int
n String
file = m (Hpp src src (HppT src m src)) -> HppT src m src
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (Hpp src src (HppT src m src) -> m (Hpp src src (HppT src m src))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HppF src (HppT src m src) -> Hpp src src (HppT src m src)
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (Int
-> String -> (src -> HppT src m src) -> HppF src (HppT src m src)
forall t r. Int -> String -> (t -> r) -> HppF t r
ReadNext Int
n String
file src -> HppT src m src
forall (m :: * -> *) a. Monad m => a -> m a
return)))
{-# INLINE hppReadNext #-}
hppWriteOutput :: Monad m => t -> HppT t m ()
hppWriteOutput :: t -> HppT t m ()
hppWriteOutput = m (Hpp t () (HppT t m ())) -> HppT t m ()
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t () (HppT t m ())) -> HppT t m ())
-> (t -> m (Hpp t () (HppT t m ()))) -> t -> HppT t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hpp t () (HppT t m ()) -> m (Hpp t () (HppT t m ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Hpp t () (HppT t m ()) -> m (Hpp t () (HppT t m ())))
-> (t -> Hpp t () (HppT t m ())) -> t -> m (Hpp t () (HppT t m ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppF t (HppT t m ()) -> Hpp t () (HppT t m ())
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (HppF t (HppT t m ()) -> Hpp t () (HppT t m ()))
-> (t -> HppF t (HppT t m ())) -> t -> Hpp t () (HppT t m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> HppT t m () -> HppF t (HppT t m ()))
-> HppT t m () -> t -> HppF t (HppT t m ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip t -> HppT t m () -> HppF t (HppT t m ())
forall t r. t -> r -> HppF t r
WriteOutput (() -> HppT t m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE hppWriteOutput #-}
instance Functor m => Functor (HppT t m) where
fmap :: (a -> b) -> HppT t m a -> HppT t m b
fmap a -> b
f (HppT m (Hpp t a (HppT t m a))
x) = m (Hpp t b (HppT t m b)) -> HppT t m b
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t b (HppT t m b)) -> HppT t m b)
-> m (Hpp t b (HppT t m b)) -> HppT t m b
forall a b. (a -> b) -> a -> b
$ (Hpp t a (HppT t m a) -> Hpp t b (HppT t m b))
-> m (Hpp t a (HppT t m a)) -> m (Hpp t b (HppT t m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hpp t a (HppT t m a) -> Hpp t b (HppT t m b)
forall (f :: * -> *) (f :: * -> *).
(Functor f, Functor f) =>
FreeF f a (f a) -> FreeF f b (f b)
f' m (Hpp t a (HppT t m a))
x
where f' :: FreeF f a (f a) -> FreeF f b (f b)
f' (PureF a
y) = b -> FreeF f b (f b)
forall (f :: * -> *) a r. a -> FreeF f a r
PureF (a -> b
f a
y)
f' (FreeF f (f a)
y) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (f a)
y
{-# INLINE fmap #-}
instance Monad m => Applicative (HppT t m) where
pure :: a -> HppT t m a
pure = m (Hpp t a (HppT t m a)) -> HppT t m a
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t a (HppT t m a)) -> HppT t m a)
-> (a -> m (Hpp t a (HppT t m a))) -> a -> HppT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hpp t a (HppT t m a) -> m (Hpp t a (HppT t m a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hpp t a (HppT t m a) -> m (Hpp t a (HppT t m a)))
-> (a -> Hpp t a (HppT t m a)) -> a -> m (Hpp t a (HppT t m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Hpp t a (HppT t m a)
forall (f :: * -> *) a r. a -> FreeF f a r
PureF
{-# INLINE pure #-}
<*> :: HppT t m (a -> b) -> HppT t m a -> HppT t m b
(<*>) = HppT t m (a -> b) -> HppT t m a -> HppT t m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
{-# INLINE (<*>) #-}
instance Monad m => Monad (HppT t m) where
return :: a -> HppT t m a
return = a -> HppT t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
HppT m (Hpp t a (HppT t m a))
ma >>= :: HppT t m a -> (a -> HppT t m b) -> HppT t m b
>>= a -> HppT t m b
fb = m (Hpp t b (HppT t m b)) -> HppT t m b
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t b (HppT t m b)) -> HppT t m b)
-> m (Hpp t b (HppT t m b)) -> HppT t m b
forall a b. (a -> b) -> a -> b
$ m (Hpp t a (HppT t m a))
ma m (Hpp t a (HppT t m a))
-> (Hpp t a (HppT t m a) -> m (Hpp t b (HppT t m b)))
-> m (Hpp t b (HppT t m b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
PureF a
x -> HppT t m b -> m (Hpp t b (HppT t m b))
forall t (m :: * -> *) a. HppT t m a -> m (Hpp t a (HppT t m a))
runHppT (HppT t m b -> m (Hpp t b (HppT t m b)))
-> HppT t m b -> m (Hpp t b (HppT t m b))
forall a b. (a -> b) -> a -> b
$ a -> HppT t m b
fb a
x
FreeF HppF t (HppT t m a)
x -> Hpp t b (HppT t m b) -> m (Hpp t b (HppT t m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Hpp t b (HppT t m b) -> m (Hpp t b (HppT t m b)))
-> (HppF t (HppT t m b) -> Hpp t b (HppT t m b))
-> HppF t (HppT t m b)
-> m (Hpp t b (HppT t m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppF t (HppT t m b) -> Hpp t b (HppT t m b)
forall (f :: * -> *) a r. f r -> FreeF f a r
FreeF (HppF t (HppT t m b) -> m (Hpp t b (HppT t m b)))
-> HppF t (HppT t m b) -> m (Hpp t b (HppT t m b))
forall a b. (a -> b) -> a -> b
$ (HppT t m a -> HppT t m b)
-> HppF t (HppT t m a) -> HppF t (HppT t m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HppT t m a -> (a -> HppT t m b) -> HppT t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> HppT t m b
fb) HppF t (HppT t m a)
x
instance MonadTrans (HppT t) where
lift :: m a -> HppT t m a
lift = m (Hpp t a (HppT t m a)) -> HppT t m a
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t a (HppT t m a)) -> HppT t m a)
-> (m a -> m (Hpp t a (HppT t m a))) -> m a -> HppT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Hpp t a (HppT t m a)) -> m a -> m (Hpp t a (HppT t m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Hpp t a (HppT t m a)
forall (f :: * -> *) a r. a -> FreeF f a r
PureF
{-# INLINE lift #-}
instance MonadIO m => MonadIO (HppT t m) where
liftIO :: IO a -> HppT t m a
liftIO = m (Hpp t a (HppT t m a)) -> HppT t m a
forall t (m :: * -> *) a. m (Hpp t a (HppT t m a)) -> HppT t m a
HppT (m (Hpp t a (HppT t m a)) -> HppT t m a)
-> (IO a -> m (Hpp t a (HppT t m a))) -> IO a -> HppT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Hpp t a (HppT t m a)) -> m a -> m (Hpp t a (HppT t m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Hpp t a (HppT t m a)
forall (f :: * -> *) a r. a -> FreeF f a r
PureF (m a -> m (Hpp t a (HppT t m a)))
-> (IO a -> m a) -> IO a -> m (Hpp t a (HppT t m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE liftIO #-}
class HasHppState m where
getState :: m HppState
setState :: HppState -> m ()
instance {-# OVERLAPS #-} Monad m => HasHppState (StateT HppState m) where
getState :: StateT HppState m HppState
getState = StateT HppState m HppState
forall (m :: * -> *) s. Monad m => StateT s m s
get
{-# INLINE getState #-}
setState :: HppState -> StateT HppState m ()
setState = HppState -> StateT HppState m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
{-# INLINE setState #-}
instance (Monad m, HasHppState m) => HasHppState (StateT s m) where
getState :: StateT s m HppState
getState = m HppState -> StateT s m HppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState
{-# INLINE getState #-}
setState :: HppState -> StateT s m ()
setState = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (HppState -> m ()) -> HppState -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState
{-# INLINE setState #-}
instance (Monad m, HasHppState m) => HasHppState (HppT t m) where
getState :: HppT t m HppState
getState = m HppState -> HppT t m HppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState
{-# INLINE getState #-}
setState :: HppState -> HppT t m ()
setState = m () -> HppT t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HppT t m ())
-> (HppState -> m ()) -> HppState -> HppT t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState
{-# INLINE setState #-}
class HasEnv m where
getEnv :: m Env
setEnv :: Env -> m ()
instance (Monad m, HasHppState m) => HasEnv (HppT t m) where
getEnv :: HppT t m Env
getEnv = (HppState -> Env) -> HppT t m HppState -> HppT t m Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HppState -> Env
hppEnv (m HppState -> HppT t m HppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState)
{-# INLINE getEnv #-}
setEnv :: Env -> HppT t m ()
setEnv Env
e = m HppState -> HppT t m HppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState HppT t m HppState -> (HppState -> HppT t m ()) -> HppT t m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> HppT t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HppT t m ())
-> (HppState -> m ()) -> HppState -> HppT t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState (HppState -> m ()) -> (HppState -> HppState) -> HppState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\HppState
s -> HppState
s { hppEnv :: Env
hppEnv = Env
e })
{-# INLINE setEnv #-}
instance Monad m => HasEnv (StateT HppState m) where
getEnv :: StateT HppState m Env
getEnv = HppState -> Env
hppEnv (HppState -> Env)
-> StateT HppState m HppState -> StateT HppState m Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HppState m HppState
forall (m :: * -> *) s. Monad m => StateT s m s
get
{-# INLINE getEnv #-}
setEnv :: Env -> StateT HppState m ()
setEnv = (Lens HppState Env
env Lens HppState Env -> Env -> StateT HppState m ()
forall (m :: * -> *) a.
(HasHppState m, Monad m) =>
Lens HppState a -> a -> m ()
.=)
{-# INLINE setEnv #-}
instance Monad m => HasEnv (StateT Env m) where
getEnv :: StateT Env m Env
getEnv = StateT Env m Env
forall (m :: * -> *) s. Monad m => StateT s m s
get
{-# INLINE getEnv #-}
setEnv :: Env -> StateT Env m ()
setEnv = Env -> StateT Env m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
{-# INLINE setEnv #-}
instance (HasEnv m, Monad m) => HasEnv (ExceptT e m) where
getEnv :: ExceptT e m Env
getEnv = m Env -> ExceptT e m Env
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Env
forall (m :: * -> *). HasEnv m => m Env
getEnv
{-# INLINE getEnv #-}
setEnv :: Env -> ExceptT e m ()
setEnv = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ()) -> (Env -> m ()) -> Env -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> m ()
forall (m :: * -> *). HasEnv m => Env -> m ()
setEnv
{-# INLINE setEnv #-}
data Scan = Unmask String
| Mask String
| Scan (Token String)
| Rescan (Token String)
deriving (Scan -> Scan -> Bool
(Scan -> Scan -> Bool) -> (Scan -> Scan -> Bool) -> Eq Scan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scan -> Scan -> Bool
$c/= :: Scan -> Scan -> Bool
== :: Scan -> Scan -> Bool
$c== :: Scan -> Scan -> Bool
Eq, Int -> Scan -> ShowS
[Scan] -> ShowS
Scan -> String
(Int -> Scan -> ShowS)
-> (Scan -> String) -> ([Scan] -> ShowS) -> Show Scan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scan] -> ShowS
$cshowList :: [Scan] -> ShowS
show :: Scan -> String
$cshow :: Scan -> String
showsPrec :: Int -> Scan -> ShowS
$cshowsPrec :: Int -> Scan -> ShowS
Show)
data Macro = Object [Token String]
| Function Int ([([Scan], String)] -> [Scan])
instance Show Macro where
show :: Macro -> String
show (Object [Token String]
ts) = String
"Object "String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> String
forall s. Stringy s => s -> String
toChars ([Token String] -> String
forall s. Monoid s => [Token s] -> s
detokenize [Token String]
ts)
show (Function Int
n [([Scan], String)] -> [Scan]
_) = String
"Fun<"String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
nString -> ShowS
forall a. [a] -> [a] -> [a]
++String
">"
lookupMacro :: (HasEnv m, Monad m) => String -> m (Maybe Macro)
lookupMacro :: String -> m (Maybe Macro)
lookupMacro String
s = String -> Env -> Maybe Macro
forall a. String -> HashMap String a -> Maybe a
lookupKey String
s (Env -> Maybe Macro) -> m Env -> m (Maybe Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Env
forall (m :: * -> *). HasEnv m => m Env
getEnv
{-# INLINE lookupMacro #-}
type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s
setL :: Lens s a -> a -> s -> s
setL :: Lens s a -> a -> s -> s
setL Lens s a
l a
x = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> s -> Identity s
Lens s a
l (Identity a -> a -> Identity a
forall a b. a -> b -> a
const (Identity a -> a -> Identity a) -> Identity a -> a -> Identity a
forall a b. (a -> b) -> a -> b
$ a -> Identity a
forall a. a -> Identity a
Identity a
x)
{-# INLINE setL #-}
getL :: Lens s a -> s -> a
getL :: Lens s a -> s -> a
getL Lens s a
l = Constant a s -> a
forall a k (b :: k). Constant a b -> a
getConstant (Constant a s -> a) -> (s -> Constant a s) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Constant a a) -> s -> Constant a s
Lens s a
l a -> Constant a a
forall k a (b :: k). a -> Constant a b
Constant
{-# INLINE getL #-}
over :: Lens s a -> (a -> a) -> s -> s
over :: Lens s a -> (a -> a) -> s -> s
over Lens s a
l a -> a
f = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> s -> Identity s
Lens s a
l (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)
{-# INLINE over #-}
emptyHppState :: Config -> HppState
emptyHppState :: Config -> HppState
emptyHppState Config
cfg = Config -> String -> Int -> Env -> HppState
HppState Config
cfg (ShowS
takeDirectory (Config -> String
curFileName Config
cfg)) Int
1 Env
forall a. HashMap String a
emptyEnv
config :: Lens HppState Config
config :: (Config -> f Config) -> HppState -> f HppState
config Config -> f Config
f (HppState Config
cfg String
_dir Int
ln Env
e) =
(\Config
cfg' -> Config -> String -> Int -> Env -> HppState
HppState Config
cfg' (ShowS
takeDirectory (Config -> String
curFileName Config
cfg')) Int
ln Env
e) (Config -> HppState) -> f Config -> f HppState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> f Config
f Config
cfg
{-# INLINE config #-}
dir :: Lens HppState FilePath
dir :: (String -> f String) -> HppState -> f HppState
dir String -> f String
f (HppState Config
cfg String
dirOld Int
ln Env
e) =
(\String
dirNew -> Config -> String -> Int -> Env -> HppState
HppState Config
cfg String
dirNew Int
ln Env
e) (String -> HppState) -> f String -> f HppState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f String
dirOld
{-# INLINE dir #-}
lineNum :: Lens HppState LineNum
lineNum :: (Int -> f Int) -> HppState -> f HppState
lineNum Int -> f Int
f (HppState Config
cfg String
dir0 Int
ln Env
e) = (\Int
ln' -> Config -> String -> Int -> Env -> HppState
HppState Config
cfg String
dir0 Int
ln' Env
e) (Int -> HppState) -> f Int -> f HppState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f Int
f Int
ln
{-# INLINE lineNum #-}
env :: Lens HppState Env
env :: (Env -> f Env) -> HppState -> f HppState
env Env -> f Env
f (HppState Config
cfg String
dir0 Int
ln Env
e) = (\Env
e' -> Config -> String -> Int -> Env -> HppState
HppState Config
cfg String
dir0 Int
ln Env
e') (Env -> HppState) -> f Env -> f HppState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> f Env
f Env
e
{-# INLINE env #-}
use :: (HasHppState m, Functor m) => Lens HppState a -> m a
use :: Lens HppState a -> m a
use Lens HppState a
l = Lens HppState a -> HppState -> a
forall s a. Lens s a -> s -> a
getL Lens HppState a
l (HppState -> a) -> m HppState -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState
{-# INLINE use #-}
(.=) :: (HasHppState m, Monad m) => Lens HppState a -> a -> m ()
Lens HppState a
l .= :: Lens HppState a -> a -> m ()
.= a
x = m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState m HppState -> (HppState -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState (HppState -> m ()) -> (HppState -> HppState) -> HppState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens HppState a -> a -> HppState -> HppState
forall s a. Lens s a -> a -> s -> s
setL Lens HppState a
l a
x
infix 4 .=
{-# INLINE (.=) #-}
(%=) :: (HasHppState m, Monad m) => Lens HppState a -> (a -> a) -> m ()
Lens HppState a
l %= :: Lens HppState a -> (a -> a) -> m ()
%= a -> a
f = m HppState
forall (m :: * -> *). HasHppState m => m HppState
getState m HppState -> (HppState -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HppState -> m ()
forall (m :: * -> *). HasHppState m => HppState -> m ()
setState (HppState -> m ()) -> (HppState -> HppState) -> HppState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens HppState a -> (a -> a) -> HppState -> HppState
forall s a. Lens s a -> (a -> a) -> s -> s
over Lens HppState a
l a -> a
f
infix 4 %=
{-# INLINE (%=) #-}