{-# LANGUAGE FlexibleInstances, LambdaCase, Rank2Types #-}
-- | The core types involved used by the pre-processor.
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.Map as M
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)

-- | Line numbers are represented as 'Int's
type LineNum = Int

-- | A macro binding environment.
type Env = HashMap ByteString Macro

-- * Changing the underlying string type
type String = ByteString
type TOKEN = Token ByteString

-- * Errors

-- | Error conditions we may encounter.
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

-- | Hpp can raise various parsing errors.
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 #-}

-- * Free Monad Transformers

-- | Base functor for a free monad transformer
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 #-}

-- * Pre-processor Actions

-- | Dynamic state of the preprocessor engine.
data HppState = HppState { HppState -> Config
hppConfig :: Config
                           -- ^ Initial configuration
                         , HppState -> String
hppCurDir :: FilePath
                           -- ^ Directory of input file
                         , HppState -> Int
hppLineNum :: LineNum
                           -- ^ Current line number of input file
                         , HppState -> Env
hppEnv :: Env
                           -- ^ Preprocessor binding environment
                         }
  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

-- | A free monad construction to strictly delimit what capabilities
-- we need to perform pre-processing.
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 #-}

-- | 'Hpp' is a monad with 'HppF' as its base functor.
type Hpp t = FreeF (HppF t)

-- * Hpp Monad Transformer

-- | A free monad transformer specialized to HppF as the base functor.
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 lineNumber fileName@ introduces an @#include
-- <fileName>@ at the given line number.
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 lineNumber fileName@ introduces an @#include_next
-- <fileName>@ at the given line number.
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 #-}

-- | An interpreter capability to modify dynamic state.
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 #-}

-- | An interpreter capability of threading a binding environment.
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 #-}

-- * Expansion

-- | Macro expansion involves treating tokens differently if they
-- appear in the original source or as the result of a previous macro
-- expansion. This distinction is used to prevent divergence by
-- masking out definitions that could be used recursively.
--
-- Things are made somewhat more complicated than one might expect due
-- to the fact that the scope of this masking is /not/ structurally
-- recursive. A object-like macro can expand into a fragment of a
-- macro function application, one of whose arguments is a token
-- matching the original object-like macro. That argument should /not/
-- be expanded.
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)

-- * Macros

-- | There are object-like macros and function-like macros.
data Macro = Object [Token String]
           -- ^ An object-like macro is replaced with its definition
           | Function Int ([([Scan], String)] -> [Scan])
           -- ^ A function-like macro of some arity taks
           -- macro-expanded and raw versions of its arguments, then
           -- substitutes them into a body producing a new set of
           -- tokens.

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
">"

-- | Looks up a 'Macro' in the current environment. If the 'Macro' is
-- found, the environment is juggled so that subsequent lookups of the
-- same 'Macro' may evaluate more quickly.
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 #-}

-- * Nano-lens

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 #-}

-- * State Lenses

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 (%=) #-}