{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}
module Hpp.Conditional (dropBranch, takeBranch) where
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup ((<>))
#endif
import Data.String (fromString)
import Hpp.Parser (replace, awaitJust, Parser)
import Hpp.Tokens (notImportant, Token(..))
import Hpp.Types (lineNum, use, HasHppState, HasError, LineNum, TOKEN, String)
import Prelude hiding (String)
yieldLineNum :: LineNum -> [TOKEN]
yieldLineNum :: LineNum -> [TOKEN]
yieldLineNum !LineNum
ln = [ByteString -> TOKEN
forall s. s -> Token s
Important (ByteString
"#line " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a. IsString a => String -> a
fromString (LineNum -> String
forall a. Show a => a -> String
show LineNum
ln)), ByteString -> TOKEN
forall s. s -> Token s
Other ByteString
"\n"]
getCmd :: [TOKEN] -> Maybe String
getCmd :: [TOKEN] -> Maybe ByteString
getCmd = [TOKEN] -> Maybe ByteString
forall a. (Eq a, IsString a) => [Token a] -> Maybe a
aux ([TOKEN] -> Maybe ByteString)
-> ([TOKEN] -> [TOKEN]) -> [TOKEN] -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile TOKEN -> Bool
forall s. Token s -> Bool
notImportant
where aux :: [Token a] -> Maybe a
aux (Important a
"#" : [Token a]
ts) = case (Token a -> Bool) -> [Token a] -> [Token a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token a -> Bool
forall s. Token s -> Bool
notImportant [Token a]
ts of
(Important a
cmd:[Token a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
cmd
[Token a]
_ -> Maybe a
forall a. Maybe a
Nothing
aux [Token a]
_ = Maybe a
forall a. Maybe a
Nothing
dropBranchFun :: [[TOKEN]] -> (Int, [[TOKEN]])
dropBranchFun :: [[TOKEN]] -> (LineNum, [[TOKEN]])
dropBranchFun = LineNum -> LineNum -> [[TOKEN]] -> (LineNum, [[TOKEN]])
forall a a.
(Eq a, Num a, Num a) =>
a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go (LineNum
1::Int) LineNum
0
where go :: a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go a
_ !a
n [] = (a
n,[])
go !a
nesting !a
n ([TOKEN]
ln:[[TOKEN]]
lns) =
case [TOKEN] -> Maybe ByteString
getCmd [TOKEN]
ln of
Just ByteString
cmd
| ByteString
cmd ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"endif" -> if a
nesting a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
then (a
n, [TOKEN]
ln[TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
:[[TOKEN]]
lns)
else a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go (a
nestinga -> a -> a
forall a. Num a => a -> a -> a
-a
1) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) [[TOKEN]]
lns
| ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"if",ByteString
"ifdef",ByteString
"ifndef"] ->
a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go (a
nestinga -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) [[TOKEN]]
lns
| ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"else",ByteString
"elif"] -> if a
nesting a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
then (a
n, [TOKEN]
ln [TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
: [[TOKEN]]
lns)
else a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go a
nesting (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) [[TOKEN]]
lns
Maybe ByteString
_ -> a -> a -> [[TOKEN]] -> (a, [[TOKEN]])
go a
nesting (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) [[TOKEN]]
lns
takeBranch :: LineNum -> [[TOKEN]] -> [[TOKEN]]
takeBranch :: LineNum -> [[TOKEN]] -> [[TOKEN]]
takeBranch = LineNum -> LineNum -> [[TOKEN]] -> [[TOKEN]]
forall a. (Eq a, Num a) => a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go (LineNum
1::Int)
where go :: a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go a
_ LineNum
_ [] = []
go a
0 !LineNum
n [[TOKEN]]
lns = LineNum -> [TOKEN]
yieldLineNum LineNum
n [TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
: [[TOKEN]]
lns
go !a
nesting !LineNum
n ([TOKEN]
ln:[[TOKEN]]
lns) =
case [TOKEN] -> Maybe ByteString
getCmd [TOKEN]
ln of
Just ByteString
cmd
| ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"if",ByteString
"ifdef",ByteString
"ifndef"] ->
[TOKEN]
ln [TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
: a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go (a
nestinga -> a -> a
forall a. Num a => a -> a -> a
+a
1) (LineNum
nLineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+LineNum
1) [[TOKEN]]
lns
| ByteString
cmd ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"endif" -> [TOKEN]
ln [TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
: a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go (a
nesting a -> a -> a
forall a. Num a => a -> a -> a
- a
1) (LineNum
n LineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+ LineNum
1) [[TOKEN]]
lns
| a
nesting a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 Bool -> Bool -> Bool
&& ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"else",ByteString
"elif"] ->
let (LineNum
numSkipped, [[TOKEN]]
lns') = [[TOKEN]] -> (LineNum, [[TOKEN]])
dropBranchFun [[TOKEN]]
lns
in a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go a
1 (LineNum
nLineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+LineNum
1LineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+LineNum
numSkipped) [[TOKEN]]
lns'
Maybe ByteString
_ -> [TOKEN]
ln [TOKEN] -> [[TOKEN]] -> [[TOKEN]]
forall a. a -> [a] -> [a]
: a -> LineNum -> [[TOKEN]] -> [[TOKEN]]
go a
nesting (LineNum
nLineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+LineNum
1) [[TOKEN]]
lns
dropBranch :: (HasError m, HasHppState m, Monad m) => Parser m [TOKEN] ()
dropBranch :: Parser m [TOKEN] ()
dropBranch = do LineNum
ln <- Lens HppState LineNum
-> StateT (Source m (Input m [[TOKEN]]) [TOKEN]) m LineNum
forall (m :: * -> *) a.
(HasHppState m, Functor m) =>
Lens HppState a -> m a
use Lens HppState LineNum
lineNum
(Maybe [TOKEN]
el, LineNum
numSkipped) <- Parser m [TOKEN] (Maybe [TOKEN], LineNum)
forall (m :: * -> *).
(HasError m, Monad m) =>
Parser m [TOKEN] (Maybe [TOKEN], LineNum)
dropBranchAux
let ln' :: LineNum
ln' = LineNum
ln LineNum -> LineNum -> LineNum
forall a. Num a => a -> a -> a
+ LineNum
numSkipped
[TOKEN] -> Parser m [TOKEN] ()
forall (m :: * -> *) i src. Monad m => i -> ParserT m src i ()
replace (LineNum -> [TOKEN]
yieldLineNum LineNum
ln')
([TOKEN] -> Parser m [TOKEN] ())
-> Maybe [TOKEN] -> Parser m [TOKEN] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [TOKEN] -> Parser m [TOKEN] ()
forall (m :: * -> *) i src. Monad m => i -> ParserT m src i ()
replace Maybe [TOKEN]
el
dropBranchAux :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int)
dropBranchAux :: Parser m [TOKEN] (Maybe [TOKEN], LineNum)
dropBranchAux = LineNum -> LineNum -> Parser m [TOKEN] (Maybe [TOKEN], LineNum)
forall (m :: * -> *) a a src.
(Monad m, HasError m, Eq a, Num a, Num a) =>
a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go (LineNum
1::Int) LineNum
0
where go :: a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go !a
nesting !a
n =
do [TOKEN]
ln <- String -> ParserT m src [TOKEN] [TOKEN]
forall (m :: * -> *) src i.
(Monad m, HasError m) =>
String -> ParserT m src i i
awaitJust String
"dropBranch"
case [TOKEN] -> Maybe ByteString
getCmd [TOKEN]
ln of
Just ByteString
cmd
| ByteString
cmd ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"endif" -> if a
nesting a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
then (Maybe [TOKEN], a)
-> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [TOKEN]
forall a. Maybe a
Nothing, a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)
else a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go (a
nestinga -> a -> a
forall a. Num a => a -> a -> a
-a
1) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)
| ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"if",ByteString
"ifdef",ByteString
"ifndef"] ->
a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go (a
nestinga -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)
| ByteString
cmd ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"else", ByteString
"elif"] -> if a
nesting a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
then (Maybe [TOKEN], a)
-> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TOKEN] -> Maybe [TOKEN]
forall a. a -> Maybe a
Just [TOKEN]
ln, a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)
else a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go a
nesting (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)
Maybe ByteString
_ -> a -> a -> StateT (Source m src [TOKEN]) m (Maybe [TOKEN], a)
go a
nesting (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1)