{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}
-- | Parsing functionality for pre-processor conditionals.
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

-- | Take everything up to the end of this branch, drop all remaining
-- branches (if any).
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
_ [] = [] -- error: unterminated conditional
        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

-- | Drop the rest of a conditional expression incrementing the given
-- 'LineNum' by the number of lines skipped.
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

-- | Skip to the end of a conditional branch. Returns the 'Just' the
-- token that ends this branch if it is an @else@ or @elif@, or
-- 'Nothing' otherwise, and the number of lines skipped.
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)