{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Aihc.Cpp
-- Description : Pure Haskell C preprocessor for Haskell source files
-- License     : Unlicense
--
-- This module provides a C preprocessor implementation designed for
-- preprocessing Haskell source files that use CPP extensions.
--
-- The main entry point is 'preprocess', which takes a 'Config' and
-- source text, returning a 'Step' that either completes with a 'Result'
-- or requests an include file to be resolved.
module Aihc.Cpp
  ( -- * Preprocessing
    preprocess,

    -- * Configuration
    Config (..),
    defaultConfig,

    -- * Results
    Step (..),
    Result (..),

    -- * Include handling
    IncludeRequest (..),
    IncludeKind (..),

    -- * Diagnostics
    Diagnostic (..),
    Severity (..),
  )
where

import Control.DeepSeq (NFData)
import Data.Char (isAlphaNum, isDigit, isLetter, isSpace)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Read as TR
import GHC.Generics (Generic)
import System.FilePath (takeDirectory, (</>))

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Map.Strict as M
-- >>> import qualified Data.Text as T
-- >>> import qualified Data.Text.IO as T

-- | Configuration for the C preprocessor.
data Config = Config
  { -- | The name of the input file, used in @#line@ directives and
    -- @__FILE__@ expansion.
    Config -> FilePath
configInputFile :: FilePath,
    -- | User-defined macros. These are expanded as object-like macros.
    -- Note that the values should include any necessary quoting. For
    -- example, to define a string macro, use @"\"value\""@.
    Config -> Map Text Text
configMacros :: !(Map Text Text)
  }

data MacroDef
  = ObjectMacro !Text
  | FunctionMacro ![Text] !Text
  deriving (MacroDef -> MacroDef -> Bool
(MacroDef -> MacroDef -> Bool)
-> (MacroDef -> MacroDef -> Bool) -> Eq MacroDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MacroDef -> MacroDef -> Bool
== :: MacroDef -> MacroDef -> Bool
$c/= :: MacroDef -> MacroDef -> Bool
/= :: MacroDef -> MacroDef -> Bool
Eq, Int -> MacroDef -> ShowS
[MacroDef] -> ShowS
MacroDef -> FilePath
(Int -> MacroDef -> ShowS)
-> (MacroDef -> FilePath) -> ([MacroDef] -> ShowS) -> Show MacroDef
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MacroDef -> ShowS
showsPrec :: Int -> MacroDef -> ShowS
$cshow :: MacroDef -> FilePath
show :: MacroDef -> FilePath
$cshowList :: [MacroDef] -> ShowS
showList :: [MacroDef] -> ShowS
Show)

-- | Default configuration with sensible defaults.
--
-- * 'configInputFile' is set to @\"\<input\>\"@
-- * 'configMacros' includes @__DATE__@ and @__TIME__@ set to the Unix epoch
--
-- To customize the date and time macros:
--
-- >>> import qualified Data.Map.Strict as M
-- >>> let cfg = defaultConfig { configMacros = M.fromList [("__DATE__", "\"Mar 15 2026\""), ("__TIME__", "\"14:30:00\"")] }
-- >>> configMacros cfg
-- fromList [("__DATE__","\"Mar 15 2026\""),("__TIME__","\"14:30:00\"")]
--
-- To add additional macros while keeping the defaults:
--
-- >>> import qualified Data.Map.Strict as M
-- >>> let cfg = defaultConfig { configMacros = M.insert "VERSION" "42" (configMacros defaultConfig) }
-- >>> M.lookup "VERSION" (configMacros cfg)
-- Just "42"
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config
    { configInputFile :: FilePath
configInputFile = FilePath
"<input>",
      configMacros :: Map Text Text
configMacros =
        [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          [ (Text
"__DATE__", Text
"\"Jan  1 1970\""),
            (Text
"__TIME__", Text
"\"00:00:00\"")
          ]
    }

-- | The kind of @#include@ directive.
data IncludeKind = IncludeLocal | IncludeSystem deriving (IncludeKind -> IncludeKind -> Bool
(IncludeKind -> IncludeKind -> Bool)
-> (IncludeKind -> IncludeKind -> Bool) -> Eq IncludeKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncludeKind -> IncludeKind -> Bool
== :: IncludeKind -> IncludeKind -> Bool
$c/= :: IncludeKind -> IncludeKind -> Bool
/= :: IncludeKind -> IncludeKind -> Bool
Eq, Int -> IncludeKind -> ShowS
[IncludeKind] -> ShowS
IncludeKind -> FilePath
(Int -> IncludeKind -> ShowS)
-> (IncludeKind -> FilePath)
-> ([IncludeKind] -> ShowS)
-> Show IncludeKind
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncludeKind -> ShowS
showsPrec :: Int -> IncludeKind -> ShowS
$cshow :: IncludeKind -> FilePath
show :: IncludeKind -> FilePath
$cshowList :: [IncludeKind] -> ShowS
showList :: [IncludeKind] -> ShowS
Show, (forall x. IncludeKind -> Rep IncludeKind x)
-> (forall x. Rep IncludeKind x -> IncludeKind)
-> Generic IncludeKind
forall x. Rep IncludeKind x -> IncludeKind
forall x. IncludeKind -> Rep IncludeKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncludeKind -> Rep IncludeKind x
from :: forall x. IncludeKind -> Rep IncludeKind x
$cto :: forall x. Rep IncludeKind x -> IncludeKind
to :: forall x. Rep IncludeKind x -> IncludeKind
Generic, IncludeKind -> ()
(IncludeKind -> ()) -> NFData IncludeKind
forall a. (a -> ()) -> NFData a
$crnf :: IncludeKind -> ()
rnf :: IncludeKind -> ()
NFData)

-- | Information about a pending @#include@ that needs to be resolved.
data IncludeRequest = IncludeRequest
  { -- | The path specified in the include directive.
    IncludeRequest -> FilePath
includePath :: !FilePath,
    -- | Whether this is a local (@\"...\"@) or system (@\<...\>@) include.
    IncludeRequest -> IncludeKind
includeKind :: !IncludeKind,
    -- | The file that contains the @#include@ directive.
    IncludeRequest -> FilePath
includeFrom :: !FilePath,
    -- | The line number of the @#include@ directive.
    IncludeRequest -> Int
includeLine :: !Int
  }
  deriving (IncludeRequest -> IncludeRequest -> Bool
(IncludeRequest -> IncludeRequest -> Bool)
-> (IncludeRequest -> IncludeRequest -> Bool) -> Eq IncludeRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncludeRequest -> IncludeRequest -> Bool
== :: IncludeRequest -> IncludeRequest -> Bool
$c/= :: IncludeRequest -> IncludeRequest -> Bool
/= :: IncludeRequest -> IncludeRequest -> Bool
Eq, Int -> IncludeRequest -> ShowS
[IncludeRequest] -> ShowS
IncludeRequest -> FilePath
(Int -> IncludeRequest -> ShowS)
-> (IncludeRequest -> FilePath)
-> ([IncludeRequest] -> ShowS)
-> Show IncludeRequest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncludeRequest -> ShowS
showsPrec :: Int -> IncludeRequest -> ShowS
$cshow :: IncludeRequest -> FilePath
show :: IncludeRequest -> FilePath
$cshowList :: [IncludeRequest] -> ShowS
showList :: [IncludeRequest] -> ShowS
Show, (forall x. IncludeRequest -> Rep IncludeRequest x)
-> (forall x. Rep IncludeRequest x -> IncludeRequest)
-> Generic IncludeRequest
forall x. Rep IncludeRequest x -> IncludeRequest
forall x. IncludeRequest -> Rep IncludeRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncludeRequest -> Rep IncludeRequest x
from :: forall x. IncludeRequest -> Rep IncludeRequest x
$cto :: forall x. Rep IncludeRequest x -> IncludeRequest
to :: forall x. Rep IncludeRequest x -> IncludeRequest
Generic, IncludeRequest -> ()
(IncludeRequest -> ()) -> NFData IncludeRequest
forall a. (a -> ()) -> NFData a
$crnf :: IncludeRequest -> ()
rnf :: IncludeRequest -> ()
NFData)

-- | Severity level for diagnostics.
data Severity = Warning | Error deriving (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
/= :: Severity -> Severity -> Bool
Eq, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> FilePath
(Int -> Severity -> ShowS)
-> (Severity -> FilePath) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Severity -> ShowS
showsPrec :: Int -> Severity -> ShowS
$cshow :: Severity -> FilePath
show :: Severity -> FilePath
$cshowList :: [Severity] -> ShowS
showList :: [Severity] -> ShowS
Show, (forall x. Severity -> Rep Severity x)
-> (forall x. Rep Severity x -> Severity) -> Generic Severity
forall x. Rep Severity x -> Severity
forall x. Severity -> Rep Severity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Severity -> Rep Severity x
from :: forall x. Severity -> Rep Severity x
$cto :: forall x. Rep Severity x -> Severity
to :: forall x. Rep Severity x -> Severity
Generic, Severity -> ()
(Severity -> ()) -> NFData Severity
forall a. (a -> ()) -> NFData a
$crnf :: Severity -> ()
rnf :: Severity -> ()
NFData)

-- | A diagnostic message emitted during preprocessing.
data Diagnostic = Diagnostic
  { -- | The severity of the diagnostic.
    Diagnostic -> Severity
diagSeverity :: !Severity,
    -- | The diagnostic message text.
    Diagnostic -> Text
diagMessage :: !Text,
    -- | The file where the diagnostic occurred.
    Diagnostic -> FilePath
diagFile :: !FilePath,
    -- | The line number where the diagnostic occurred.
    Diagnostic -> Int
diagLine :: !Int
  }
  deriving (Diagnostic -> Diagnostic -> Bool
(Diagnostic -> Diagnostic -> Bool)
-> (Diagnostic -> Diagnostic -> Bool) -> Eq Diagnostic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Diagnostic -> Diagnostic -> Bool
== :: Diagnostic -> Diagnostic -> Bool
$c/= :: Diagnostic -> Diagnostic -> Bool
/= :: Diagnostic -> Diagnostic -> Bool
Eq, Int -> Diagnostic -> ShowS
[Diagnostic] -> ShowS
Diagnostic -> FilePath
(Int -> Diagnostic -> ShowS)
-> (Diagnostic -> FilePath)
-> ([Diagnostic] -> ShowS)
-> Show Diagnostic
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Diagnostic -> ShowS
showsPrec :: Int -> Diagnostic -> ShowS
$cshow :: Diagnostic -> FilePath
show :: Diagnostic -> FilePath
$cshowList :: [Diagnostic] -> ShowS
showList :: [Diagnostic] -> ShowS
Show, (forall x. Diagnostic -> Rep Diagnostic x)
-> (forall x. Rep Diagnostic x -> Diagnostic) -> Generic Diagnostic
forall x. Rep Diagnostic x -> Diagnostic
forall x. Diagnostic -> Rep Diagnostic x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Diagnostic -> Rep Diagnostic x
from :: forall x. Diagnostic -> Rep Diagnostic x
$cto :: forall x. Rep Diagnostic x -> Diagnostic
to :: forall x. Rep Diagnostic x -> Diagnostic
Generic, Diagnostic -> ()
(Diagnostic -> ()) -> NFData Diagnostic
forall a. (a -> ()) -> NFData a
$crnf :: Diagnostic -> ()
rnf :: Diagnostic -> ()
NFData)

-- | The result of preprocessing.
data Result = Result
  { -- | The preprocessed output text.
    Result -> Text
resultOutput :: !Text,
    -- | Any diagnostics (warnings or errors) emitted during preprocessing.
    Result -> [Diagnostic]
resultDiagnostics :: ![Diagnostic]
  }
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
/= :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> FilePath
(Int -> Result -> ShowS)
-> (Result -> FilePath) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> FilePath
show :: Result -> FilePath
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show, (forall x. Result -> Rep Result x)
-> (forall x. Rep Result x -> Result) -> Generic Result
forall x. Rep Result x -> Result
forall x. Result -> Rep Result x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Result -> Rep Result x
from :: forall x. Result -> Rep Result x
$cto :: forall x. Rep Result x -> Result
to :: forall x. Rep Result x -> Result
Generic, Result -> ()
(Result -> ()) -> NFData Result
forall a. (a -> ()) -> NFData a
$crnf :: Result -> ()
rnf :: Result -> ()
NFData)

-- | A step in the preprocessing process. Either preprocessing is complete
-- ('Done') or an @#include@ directive needs to be resolved ('NeedInclude').
data Step
  = -- | Preprocessing is complete.
    Done !Result
  | -- | An @#include@ directive was encountered. The caller must provide
    -- the contents of the included file (or 'Nothing' if not found),
    -- and preprocessing will continue.
    NeedInclude !IncludeRequest !(Maybe Text -> Step)

-- | Preprocess C preprocessor directives in the input text.
--
-- This function handles:
--
-- * Macro definitions (@#define@) and expansion
-- * Conditional compilation (@#if@, @#ifdef@, @#ifndef@, @#elif@, @#else@, @#endif@)
-- * File inclusion (@#include@)
-- * Diagnostics (@#warning@, @#error@)
-- * Line control (@#line@)
-- * Predefined macros (@__FILE__@, @__LINE__@, @__DATE__@, @__TIME__@)
--
-- === Macro expansion
--
-- Object-like macros are expanded in the output:
--
-- >>> let Done r = preprocess defaultConfig "#define FOO 42\nThe answer is FOO"
-- >>> T.putStr (resultOutput r)
-- #line 1 "<input>"
-- <BLANKLINE>
-- The answer is 42
--
-- Function-like macros are also supported:
--
-- >>> let Done r = preprocess defaultConfig "#define MAX(a,b) ((a) > (b) ? (a) : (b))\nMAX(3, 5)"
-- >>> T.putStr (resultOutput r)
-- #line 1 "<input>"
-- <BLANKLINE>
-- ((3) > (5) ? (3) : (5))
--
-- === Conditional compilation
--
-- Conditional directives control which sections of code are included:
--
-- >>> :{
-- let Done r = preprocess defaultConfig
--       "#define DEBUG 1\n#if DEBUG\ndebug mode\n#else\nrelease mode\n#endif"
-- in T.putStr (resultOutput r)
-- :}
-- #line 1 "<input>"
-- <BLANKLINE>
-- <BLANKLINE>
-- debug mode
-- <BLANKLINE>
-- <BLANKLINE>
-- <BLANKLINE>
--
-- === Include handling
--
-- When an @#include@ directive is encountered, 'preprocess' returns a
-- 'NeedInclude' step. The caller must provide the contents of the included
-- file:
--
-- >>> :{
-- let NeedInclude req k = preprocess defaultConfig "#include \"header.h\"\nmain code"
--     Done r = k (Just "-- header content")
-- in T.putStr (resultOutput r)
-- :}
-- #line 1 "<input>"
-- #line 1 "./header.h"
-- -- header content
-- #line 2 "<input>"
-- main code
--
-- If the include file is not found, pass 'Nothing' to emit an error:
--
-- >>> :{
-- let NeedInclude _ k = preprocess defaultConfig "#include \"missing.h\""
--     Done r = k Nothing
-- in do
--   T.putStr (resultOutput r)
--   mapM_ print (resultDiagnostics r)
-- :}
-- #line 1 "<input>"
-- Diagnostic {diagSeverity = Error, diagMessage = "missing include: missing.h", diagFile = "<input>", diagLine = 1}
--
-- === Diagnostics
--
-- The @#warning@ directive emits a warning:
--
-- >>> :{
-- let Done r = preprocess defaultConfig "#warning This is a warning"
-- in do
--   T.putStr (resultOutput r)
--   mapM_ print (resultDiagnostics r)
-- :}
-- #line 1 "<input>"
-- <BLANKLINE>
-- Diagnostic {diagSeverity = Warning, diagMessage = "This is a warning", diagFile = "<input>", diagLine = 1}
--
-- The @#error@ directive emits an error and stops preprocessing:
--
-- >>> :{
-- let Done r = preprocess defaultConfig "#error Build failed\nthis line is not processed"
-- in do
--   T.putStr (resultOutput r)
--   mapM_ print (resultDiagnostics r)
-- :}
-- #line 1 "<input>"
-- <BLANKLINE>
-- Diagnostic {diagSeverity = Error, diagMessage = "Build failed", diagFile = "<input>", diagLine = 1}
preprocess :: Config -> Text -> Step
preprocess :: Config -> Text -> Step
preprocess Config
cfg Text
input =
  FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile (Config -> FilePath
configInputFile Config
cfg) (Int -> [Text] -> [(Int, Int, Text)]
joinMultiline Int
1 (Text -> [Text]
T.lines Text
input)) [] EngineState
initialState Continuation
finish
  where
    initialState :: EngineState
initialState =
      let st0 :: EngineState
st0 = Text -> EngineState -> EngineState
emitLine (Int -> FilePath -> Text
linePragma Int
1 (Config -> FilePath
configInputFile Config
cfg)) (FilePath -> EngineState
emptyState (Config -> FilePath
configInputFile Config
cfg))
       in EngineState
st0
            { stMacros = M.map ObjectMacro (configMacros cfg)
            }
    finish :: Continuation
finish EngineState
st =
      let out :: Text
out = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> [Text]
forall a. [a] -> [a]
reverse (EngineState -> [Text]
stOutputRev EngineState
st))
          outWithTrailingNewline :: Text
outWithTrailingNewline =
            if Text -> Bool
T.null Text
out
              then Text
out
              else Text
out Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
       in Result -> Step
Done
            Result
              { resultOutput :: Text
resultOutput = Text
outWithTrailingNewline,
                resultDiagnostics :: [Diagnostic]
resultDiagnostics = [Diagnostic] -> [Diagnostic]
forall a. [a] -> [a]
reverse (EngineState -> [Diagnostic]
stDiagnosticsRev EngineState
st)
              }

joinMultiline :: Int -> [Text] -> [(Int, Int, Text)]
joinMultiline :: Int -> [Text] -> [(Int, Int, Text)]
joinMultiline Int
_ [] = []
joinMultiline Int
n (Text
l : [Text]
ls)
  | Text
"\\" Text -> Text -> Bool
`T.isSuffixOf` Text
l Bool -> Bool -> Bool
&& Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.stripStart Text
l =
      let (Text
content, [Text]
rest, Int
extraLines) = Text -> [Text] -> (Text, [Text], Int)
forall {c}. Num c => Text -> [Text] -> (Text, [Text], c)
pull (HasCallStack => Text -> Text
Text -> Text
T.init Text
l) [Text]
ls
          spanLen :: Int
spanLen = Int
extraLines Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
       in (Int
n, Int
spanLen, Text
content) (Int, Int, Text) -> [(Int, Int, Text)] -> [(Int, Int, Text)]
forall a. a -> [a] -> [a]
: Int -> [Text] -> [(Int, Int, Text)]
joinMultiline (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spanLen) [Text]
rest
  | Bool
otherwise = (Int
n, Int
1, Text
l) (Int, Int, Text) -> [(Int, Int, Text)] -> [(Int, Int, Text)]
forall a. a -> [a] -> [a]
: Int -> [Text] -> [(Int, Int, Text)]
joinMultiline (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
ls
  where
    pull :: Text -> [Text] -> (Text, [Text], c)
pull Text
acc [] = (Text
acc, [], c
0)
    pull Text
acc (Text
x : [Text]
xs)
      | Text
"\\" Text -> Text -> Bool
`T.isSuffixOf` Text
x =
          let (Text
res, [Text]
r, c
c) = Text -> [Text] -> (Text, [Text], c)
pull (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text
Text -> Text
T.init Text
x) [Text]
xs
           in (Text
res, [Text]
r, c
c c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
      | Bool
otherwise = (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x, [Text]
xs, c
1)

splitLines :: Text -> [Text]
splitLines :: Text -> [Text]
splitLines Text
txt
  | Text -> Bool
T.null Text
txt = []
  | Bool
otherwise = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
txt

data EngineState = EngineState
  { EngineState -> Map Text MacroDef
stMacros :: !(Map Text MacroDef),
    EngineState -> [Text]
stOutputRev :: ![Text],
    EngineState -> [Diagnostic]
stDiagnosticsRev :: ![Diagnostic],
    EngineState -> Bool
stSkippingDanglingElse :: !Bool,
    EngineState -> Int
stHsBlockCommentDepth :: !Int,
    EngineState -> Int
stCBlockCommentDepth :: !Int,
    EngineState -> FilePath
stCurrentFile :: !FilePath,
    EngineState -> Int
stCurrentLine :: !Int
  }

emptyState :: FilePath -> EngineState
emptyState :: FilePath -> EngineState
emptyState FilePath
filePath =
  EngineState
    { stMacros :: Map Text MacroDef
stMacros = Map Text MacroDef
forall k a. Map k a
M.empty,
      stOutputRev :: [Text]
stOutputRev = [],
      stDiagnosticsRev :: [Diagnostic]
stDiagnosticsRev = [],
      stSkippingDanglingElse :: Bool
stSkippingDanglingElse = Bool
False,
      stHsBlockCommentDepth :: Int
stHsBlockCommentDepth = Int
0,
      stCBlockCommentDepth :: Int
stCBlockCommentDepth = Int
0,
      stCurrentFile :: FilePath
stCurrentFile = FilePath
filePath,
      stCurrentLine :: Int
stCurrentLine = Int
1
    }

data CondFrame = CondFrame
  { CondFrame -> Bool
frameOuterActive :: !Bool,
    CondFrame -> Bool
frameConditionTrue :: !Bool,
    CondFrame -> Bool
frameInElse :: !Bool,
    CondFrame -> Bool
frameCurrentActive :: !Bool
  }

currentActive :: [CondFrame] -> Bool
currentActive :: [CondFrame] -> Bool
currentActive [] = Bool
True
currentActive (CondFrame
f : [CondFrame]
_) = CondFrame -> Bool
frameCurrentActive CondFrame
f

type Continuation = EngineState -> Step

data LineContext = LineContext
  { LineContext -> FilePath
lcFilePath :: !FilePath,
    LineContext -> Int
lcLineNo :: !Int,
    LineContext -> Int
lcLineSpan :: !Int,
    LineContext -> Int
lcNextLineNo :: !Int,
    LineContext -> [(Int, Int, Text)]
lcRestLines :: ![(Int, Int, Text)],
    LineContext -> [CondFrame]
lcStack :: ![CondFrame],
    LineContext -> Continuation
lcContinue :: EngineState -> Step,
    LineContext -> [CondFrame] -> Continuation
lcContinueWith :: [CondFrame] -> EngineState -> Step,
    LineContext -> Continuation
lcDone :: Continuation
  }

processFile :: FilePath -> [(Int, Int, Text)] -> [CondFrame] -> EngineState -> Continuation -> Step
processFile :: FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile FilePath
_ [] [CondFrame]
_ EngineState
st Continuation
k = Continuation
k EngineState
st
processFile FilePath
filePath ((Int
lineNo, Int
lineSpan, Text
line) : [(Int, Int, Text)]
restLines) [CondFrame]
stack EngineState
st Continuation
k =
  let lineScan :: LineScan
lineScan = Int -> Int -> Text -> LineScan
scanLine (EngineState -> Int
stHsBlockCommentDepth EngineState
st) (EngineState -> Int
stCBlockCommentDepth EngineState
st) Text
line
      startsInBlockComment :: Bool
startsInBlockComment = EngineState -> Int
stHsBlockCommentDepth EngineState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| EngineState -> Int
stCBlockCommentDepth EngineState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      parsedDirective :: Maybe Directive
parsedDirective =
        if Bool
startsInBlockComment
          then Maybe Directive
forall a. Maybe a
Nothing
          else Text -> Maybe Directive
parseDirective Text
line
      nextLineNo :: Int
nextLineNo = case [(Int, Int, Text)]
restLines of
        (Int
n, Int
_, Text
_) : [(Int, Int, Text)]
_ -> Int
n
        [] -> Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineSpan
      advanceLineState :: EngineState -> EngineState
advanceLineState EngineState
st' =
        EngineState
st'
          { stCurrentLine = nextLineNo,
            stHsBlockCommentDepth = lineScanFinalHsDepth lineScan,
            stCBlockCommentDepth = lineScanFinalCDepth lineScan
          }
      continue :: Continuation
continue EngineState
st' = FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile FilePath
filePath [(Int, Int, Text)]
restLines [CondFrame]
stack (EngineState -> EngineState
advanceLineState EngineState
st') Continuation
k
      continueWith :: [CondFrame] -> Continuation
continueWith [CondFrame]
stack' EngineState
st' = FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile FilePath
filePath [(Int, Int, Text)]
restLines [CondFrame]
stack' (EngineState -> EngineState
advanceLineState EngineState
st') Continuation
k
      ctx :: LineContext
ctx =
        LineContext
          { lcFilePath :: FilePath
lcFilePath = FilePath
filePath,
            lcLineNo :: Int
lcLineNo = Int
lineNo,
            lcLineSpan :: Int
lcLineSpan = Int
lineSpan,
            lcNextLineNo :: Int
lcNextLineNo = Int
nextLineNo,
            lcRestLines :: [(Int, Int, Text)]
lcRestLines = [(Int, Int, Text)]
restLines,
            lcStack :: [CondFrame]
lcStack = [CondFrame]
stack,
            lcContinue :: Continuation
lcContinue = Continuation
continue,
            lcContinueWith :: [CondFrame] -> Continuation
lcContinueWith = [CondFrame] -> Continuation
continueWith,
            lcDone :: Continuation
lcDone = Continuation
k
          }
   in if EngineState -> Bool
stSkippingDanglingElse EngineState
st
        then LineContext -> Maybe Directive -> Continuation
recoverDanglingElse LineContext
ctx Maybe Directive
parsedDirective EngineState
st
        else case Maybe Directive
parsedDirective of
          Maybe Directive
Nothing ->
            if [CondFrame] -> Bool
currentActive [CondFrame]
stack
              then Continuation
continue (Text -> EngineState -> EngineState
emitLine (EngineState -> [LineSpan] -> Text
expandLineBySpan EngineState
st (LineScan -> [LineSpan]
lineScanSpans LineScan
lineScan)) EngineState
st)
              else Continuation
continue (Int -> EngineState -> EngineState
emitBlankLines Int
lineSpan EngineState
st)
          Just Directive
directive ->
            LineContext -> EngineState -> Directive -> Step
handleDirective LineContext
ctx EngineState
st Directive
directive

recoverDanglingElse :: LineContext -> Maybe Directive -> EngineState -> Step
recoverDanglingElse :: LineContext -> Maybe Directive -> Continuation
recoverDanglingElse LineContext
ctx Maybe Directive
parsedDirective EngineState
st =
  case Maybe Directive
parsedDirective of
    Just Directive
DirEndIf ->
      LineContext -> Continuation
lcContinue
        LineContext
ctx
        ( Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag
            Severity
Warning
            Text
"unmatched #endif"
            (LineContext -> FilePath
lcFilePath LineContext
ctx)
            (LineContext -> Int
lcLineNo LineContext
ctx)
            (EngineState
st {stSkippingDanglingElse = False})
        )
    Just Directive
_ ->
      LineContext -> Continuation
lcContinue LineContext
ctx EngineState
st
    Maybe Directive
Nothing ->
      LineContext -> Continuation
lcContinue LineContext
ctx (LineContext -> EngineState -> EngineState
emitDirectiveBlank LineContext
ctx EngineState
st)

handleDirective :: LineContext -> EngineState -> Directive -> Step
handleDirective :: LineContext -> EngineState -> Directive -> Step
handleDirective LineContext
ctx EngineState
st Directive
directive =
  case Directive
directive of
    DirDefineObject Text
name Text
value ->
      LineContext
-> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step
mutateMacrosWhenActive LineContext
ctx EngineState
st (Text -> MacroDef -> Map Text MacroDef -> Map Text MacroDef
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name (Text -> MacroDef
ObjectMacro Text
value))
    DirDefineFunction Text
name [Text]
params Text
body ->
      LineContext
-> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step
mutateMacrosWhenActive LineContext
ctx EngineState
st (Text -> MacroDef -> Map Text MacroDef -> Map Text MacroDef
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name ([Text] -> Text -> MacroDef
FunctionMacro [Text]
params Text
body))
    DirUndef Text
name ->
      LineContext
-> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step
mutateMacrosWhenActive LineContext
ctx EngineState
st (Text -> Map Text MacroDef -> Map Text MacroDef
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
name)
    DirInclude IncludeKind
kind Text
includeTarget ->
      LineContext -> EngineState -> IncludeKind -> Text -> Step
handleIncludeDirective LineContext
ctx EngineState
st IncludeKind
kind Text
includeTarget
    DirIf Text
expr ->
      LineContext -> EngineState -> Bool -> Step
pushConditionalFrame LineContext
ctx EngineState
st (EngineState -> Text -> Bool
evalCondition EngineState
st Text
expr)
    DirIfDef Text
name ->
      LineContext -> EngineState -> Bool -> Step
pushConditionalFrame LineContext
ctx EngineState
st (Text -> Map Text MacroDef -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
name (EngineState -> Map Text MacroDef
stMacros EngineState
st))
    DirIfNDef Text
name ->
      LineContext -> EngineState -> Bool -> Step
pushConditionalFrame LineContext
ctx EngineState
st (Bool -> Bool
not (Text -> Map Text MacroDef -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
name (EngineState -> Map Text MacroDef
stMacros EngineState
st)))
    DirElif Text
expr ->
      LineContext -> EngineState -> Text -> Step
handleElifDirective LineContext
ctx EngineState
st Text
expr
    Directive
DirElse ->
      LineContext -> Continuation
handleElseDirective LineContext
ctx EngineState
st
    Directive
DirEndIf ->
      case LineContext -> [CondFrame]
lcStack LineContext
ctx of
        [] ->
          LineContext -> Continuation
lcContinue
            LineContext
ctx
            (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Warning Text
"unmatched #endif" (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
        CondFrame
_ : [CondFrame]
rest ->
          LineContext -> [CondFrame] -> Continuation
continueBlankWithStack LineContext
ctx [CondFrame]
rest EngineState
st
    DirWarning Text
msg ->
      LineContext -> Severity -> Text -> Continuation
addDiagnosticWhenActive LineContext
ctx Severity
Warning Text
msg EngineState
st
    DirError Text
msg ->
      if [CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)
        then
          LineContext -> Continuation
lcDone
            LineContext
ctx
            (LineContext -> EngineState -> EngineState
emitDirectiveBlank LineContext
ctx (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Error Text
msg (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st))
        else LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st
    DirLine Int
n Maybe FilePath
mPath ->
      LineContext -> EngineState -> Int -> Maybe FilePath -> Step
handleLineDirective LineContext
ctx EngineState
st Int
n Maybe FilePath
mPath
    DirUnsupported Text
name ->
      LineContext -> Severity -> Text -> Continuation
addDiagnosticWhenActive LineContext
ctx Severity
Warning (Text
"unsupported directive: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) EngineState
st

emitDirectiveBlank :: LineContext -> EngineState -> EngineState
emitDirectiveBlank :: LineContext -> EngineState -> EngineState
emitDirectiveBlank LineContext
ctx = Int -> EngineState -> EngineState
emitBlankLines (LineContext -> Int
lcLineSpan LineContext
ctx)

continueBlank :: LineContext -> EngineState -> Step
continueBlank :: LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st = LineContext -> Continuation
lcContinue LineContext
ctx (LineContext -> EngineState -> EngineState
emitDirectiveBlank LineContext
ctx EngineState
st)

continueBlankWithStack :: LineContext -> [CondFrame] -> EngineState -> Step
continueBlankWithStack :: LineContext -> [CondFrame] -> Continuation
continueBlankWithStack LineContext
ctx [CondFrame]
stack EngineState
st = LineContext -> [CondFrame] -> Continuation
lcContinueWith LineContext
ctx [CondFrame]
stack (LineContext -> EngineState -> EngineState
emitDirectiveBlank LineContext
ctx EngineState
st)

mutateMacrosWhenActive :: LineContext -> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step
mutateMacrosWhenActive :: LineContext
-> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step
mutateMacrosWhenActive LineContext
ctx EngineState
st Map Text MacroDef -> Map Text MacroDef
mutate =
  if [CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)
    then LineContext -> Continuation
continueBlank LineContext
ctx (EngineState
st {stMacros = mutate (stMacros st)})
    else LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st

addDiagnosticWhenActive :: LineContext -> Severity -> Text -> EngineState -> Step
addDiagnosticWhenActive :: LineContext -> Severity -> Text -> Continuation
addDiagnosticWhenActive LineContext
ctx Severity
severity Text
message EngineState
st =
  if [CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)
    then LineContext -> Continuation
continueBlank LineContext
ctx (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
severity Text
message (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
    else LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st

pushConditionalFrame :: LineContext -> EngineState -> Bool -> Step
pushConditionalFrame :: LineContext -> EngineState -> Bool -> Step
pushConditionalFrame LineContext
ctx EngineState
st Bool
cond =
  let frame :: CondFrame
frame = Bool -> Bool -> CondFrame
mkFrame ([CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)) Bool
cond
   in LineContext -> [CondFrame] -> Continuation
continueBlankWithStack LineContext
ctx (CondFrame
frame CondFrame -> [CondFrame] -> [CondFrame]
forall a. a -> [a] -> [a]
: LineContext -> [CondFrame]
lcStack LineContext
ctx) EngineState
st

handleElifDirective :: LineContext -> EngineState -> Text -> Step
handleElifDirective :: LineContext -> EngineState -> Text -> Step
handleElifDirective LineContext
ctx EngineState
st Text
expr =
  case LineContext -> [CondFrame]
lcStack LineContext
ctx of
    [] ->
      LineContext -> Continuation
continueBlank
        LineContext
ctx
        (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Error Text
"#elif without matching #if" (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
    CondFrame
f : [CondFrame]
rest ->
      if CondFrame -> Bool
frameInElse CondFrame
f
        then
          LineContext -> Continuation
continueBlank
            LineContext
ctx
            (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Error Text
"#elif after #else" (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
        else
          let anyTaken :: Bool
anyTaken = CondFrame -> Bool
frameConditionTrue CondFrame
f
              newCond :: Bool
newCond = Bool -> Bool
not Bool
anyTaken Bool -> Bool -> Bool
&& EngineState -> Text -> Bool
evalCondition EngineState
st Text
expr
              f' :: CondFrame
f' =
                CondFrame
f
                  { frameConditionTrue = anyTaken || newCond,
                    frameCurrentActive = frameOuterActive f && newCond
                  }
           in LineContext -> [CondFrame] -> Continuation
continueBlankWithStack LineContext
ctx (CondFrame
f' CondFrame -> [CondFrame] -> [CondFrame]
forall a. a -> [a] -> [a]
: [CondFrame]
rest) EngineState
st

handleElseDirective :: LineContext -> EngineState -> Step
handleElseDirective :: LineContext -> Continuation
handleElseDirective LineContext
ctx EngineState
st =
  case LineContext -> [CondFrame]
lcStack LineContext
ctx of
    [] ->
      LineContext -> Continuation
lcContinue LineContext
ctx (EngineState
st {stSkippingDanglingElse = True})
    CondFrame
f : [CondFrame]
rest ->
      if CondFrame -> Bool
frameInElse CondFrame
f
        then
          LineContext -> Continuation
continueBlank
            LineContext
ctx
            (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Error Text
"duplicate #else in conditional block" (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
        else
          let newCurrent :: Bool
newCurrent = CondFrame -> Bool
frameOuterActive CondFrame
f Bool -> Bool -> Bool
&& Bool -> Bool
not (CondFrame -> Bool
frameConditionTrue CondFrame
f)
              f' :: CondFrame
f' =
                CondFrame
f
                  { frameInElse = True,
                    frameCurrentActive = newCurrent
                  }
           in LineContext -> [CondFrame] -> Continuation
continueBlankWithStack LineContext
ctx (CondFrame
f' CondFrame -> [CondFrame] -> [CondFrame]
forall a. a -> [a] -> [a]
: [CondFrame]
rest) EngineState
st

handleIncludeDirective :: LineContext -> EngineState -> IncludeKind -> Text -> Step
handleIncludeDirective :: LineContext -> EngineState -> IncludeKind -> Text -> Step
handleIncludeDirective LineContext
ctx EngineState
st IncludeKind
kind Text
includeTarget
  | Bool -> Bool
not ([CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)) = LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st
  | Bool
otherwise = IncludeRequest -> (Maybe Text -> Step) -> Step
NeedInclude IncludeRequest
includeReq Maybe Text -> Step
nextStep
  where
    includePathText :: FilePath
includePathText = Text -> FilePath
T.unpack Text
includeTarget
    includeReq :: IncludeRequest
includeReq =
      IncludeRequest
        { includePath :: FilePath
includePath = FilePath
includePathText,
          includeKind :: IncludeKind
includeKind = IncludeKind
kind,
          includeFrom :: FilePath
includeFrom = LineContext -> FilePath
lcFilePath LineContext
ctx,
          includeLine :: Int
includeLine = LineContext -> Int
lcLineNo LineContext
ctx
        }
    nextStep :: Maybe Text -> Step
nextStep Maybe Text
Nothing =
      LineContext -> Continuation
lcContinue
        LineContext
ctx
        (Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
Error (Text
"missing include: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
includeTarget) (LineContext -> FilePath
lcFilePath LineContext
ctx) (LineContext -> Int
lcLineNo LineContext
ctx) EngineState
st)
    nextStep (Just Text
includeText) =
      let includeFilePath :: FilePath
includeFilePath =
            case IncludeKind
kind of
              IncludeKind
IncludeLocal -> ShowS
takeDirectory (LineContext -> FilePath
lcFilePath LineContext
ctx) FilePath -> ShowS
</> FilePath
includePathText
              IncludeKind
IncludeSystem -> FilePath
includePathText
          stWithIncludePragma :: EngineState
stWithIncludePragma =
            Text -> EngineState -> EngineState
emitLine (Int -> FilePath -> Text
linePragma Int
1 FilePath
includeFilePath) (EngineState
st {stCurrentFile = includeFilePath, stCurrentLine = 1})
          resumeParent :: Continuation
resumeParent EngineState
stAfterInclude =
            FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile
              (LineContext -> FilePath
lcFilePath LineContext
ctx)
              (LineContext -> [(Int, Int, Text)]
lcRestLines LineContext
ctx)
              (LineContext -> [CondFrame]
lcStack LineContext
ctx)
              ( Text -> EngineState -> EngineState
emitLine
                  (Int -> FilePath -> Text
linePragma (LineContext -> Int
lcNextLineNo LineContext
ctx) (LineContext -> FilePath
lcFilePath LineContext
ctx))
                  (EngineState
stAfterInclude {stCurrentFile = lcFilePath ctx, stCurrentLine = lcNextLineNo ctx})
              )
              (LineContext -> Continuation
lcDone LineContext
ctx)
       in FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile FilePath
includeFilePath (Int -> [Text] -> [(Int, Int, Text)]
joinMultiline Int
1 (Text -> [Text]
splitLines Text
includeText)) [] EngineState
stWithIncludePragma Continuation
resumeParent

handleLineDirective :: LineContext -> EngineState -> Int -> Maybe FilePath -> Step
handleLineDirective :: LineContext -> EngineState -> Int -> Maybe FilePath -> Step
handleLineDirective LineContext
ctx EngineState
st Int
lineNumber Maybe FilePath
maybePath
  | Bool -> Bool
not ([CondFrame] -> Bool
currentActive (LineContext -> [CondFrame]
lcStack LineContext
ctx)) = LineContext -> Continuation
continueBlank LineContext
ctx EngineState
st
  | Bool
otherwise =
      let stWithFile :: EngineState
stWithFile =
            case Maybe FilePath
maybePath of
              Just FilePath
path -> EngineState
st {stCurrentFile = path}
              Maybe FilePath
Nothing -> EngineState
st
          stWithLinePragma :: EngineState
stWithLinePragma =
            Text -> EngineState -> EngineState
emitLine
              (Int -> FilePath -> Text
linePragma Int
lineNumber (EngineState -> FilePath
stCurrentFile EngineState
stWithFile))
              (EngineState
stWithFile {stCurrentLine = lineNumber})
       in FilePath
-> [(Int, Int, Text)]
-> [CondFrame]
-> EngineState
-> Continuation
-> Step
processFile
            (LineContext -> FilePath
lcFilePath LineContext
ctx)
            (LineContext -> [(Int, Int, Text)]
lcRestLines LineContext
ctx)
            (LineContext -> [CondFrame]
lcStack LineContext
ctx)
            (EngineState
stWithLinePragma {stCurrentLine = lineNumber})
            (LineContext -> Continuation
lcDone LineContext
ctx)

mkFrame :: Bool -> Bool -> CondFrame
mkFrame :: Bool -> Bool -> CondFrame
mkFrame Bool
outer Bool
cond =
  CondFrame
    { frameOuterActive :: Bool
frameOuterActive = Bool
outer,
      frameConditionTrue :: Bool
frameConditionTrue = Bool
cond,
      frameInElse :: Bool
frameInElse = Bool
False,
      frameCurrentActive :: Bool
frameCurrentActive = Bool
outer Bool -> Bool -> Bool
&& Bool
cond
    }

emitLine :: Text -> EngineState -> EngineState
emitLine :: Text -> EngineState -> EngineState
emitLine Text
line EngineState
st = EngineState
st {stOutputRev = line : stOutputRev st}

emitBlankLines :: Int -> EngineState -> EngineState
emitBlankLines :: Int -> EngineState -> EngineState
emitBlankLines Int
n EngineState
st
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = EngineState
st
  | Bool
otherwise = EngineState
st {stOutputRev = replicate n "" <> stOutputRev st}

addDiag :: Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag :: Severity -> Text -> FilePath -> Int -> EngineState -> EngineState
addDiag Severity
sev Text
msg FilePath
filePath Int
lineNo EngineState
st =
  EngineState
st
    { stDiagnosticsRev =
        Diagnostic
          { diagSeverity = sev,
            diagMessage = msg,
            diagFile = filePath,
            diagLine = lineNo
          }
          : stDiagnosticsRev st
    }

linePragma :: Int -> FilePath -> Text
linePragma :: Int -> FilePath -> Text
linePragma Int
n FilePath
path = Text
"#line " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

builderToText :: TB.Builder -> Text
builderToText :: Builder -> Text
builderToText = LazyText -> Text
TL.toStrict (LazyText -> Text) -> (Builder -> LazyText) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
TB.toLazyText

trimSpacesText :: Text -> Text
trimSpacesText :: Text -> Text
trimSpacesText = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace

data LineSpan = LineSpan
  { LineSpan -> Bool
lineSpanInBlockComment :: !Bool,
    LineSpan -> Text
lineSpanText :: !Text
  }

data LineScan = LineScan
  { LineScan -> [LineSpan]
lineScanSpans :: ![LineSpan],
    LineScan -> Int
lineScanFinalHsDepth :: !Int,
    LineScan -> Int
lineScanFinalCDepth :: !Int
  }

expandLineBySpan :: EngineState -> [LineSpan] -> Text
expandLineBySpan :: EngineState -> [LineSpan] -> Text
expandLineBySpan EngineState
st =
  [Text] -> Text
T.concat ([Text] -> Text) -> ([LineSpan] -> [Text]) -> [LineSpan] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSpan -> Text) -> [LineSpan] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map LineSpan -> Text
expandSpan
  where
    expandSpan :: LineSpan -> Text
expandSpan LineSpan
lineChunk
      | LineSpan -> Bool
lineSpanInBlockComment LineSpan
lineChunk = LineSpan -> Text
lineSpanText LineSpan
lineChunk
      | Bool
otherwise = EngineState -> Text -> Text
expandMacros EngineState
st (LineSpan -> Text
lineSpanText LineSpan
lineChunk)

scanLine :: Int -> Int -> Text -> LineScan
scanLine :: Int -> Int -> Text -> LineScan
scanLine Int
hsDepth0 Int
cDepth0 Text
input =
  let ([LineSpan]
spansRev, Builder
currentBuilder, Bool
hasCurrent, Bool
currentInComment, Int
finalHsDepth, Int
finalCDepth) =
        Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth0 Int
cDepth0 Bool
False Bool
False Bool
False [] Builder
forall a. Monoid a => a
mempty Bool
False (Int
hsDepth0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Int
cDepth0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) Text
input
      spans :: [LineSpan]
spans = [LineSpan] -> [LineSpan]
forall a. [a] -> [a]
reverse ([LineSpan] -> Builder -> Bool -> Bool -> [LineSpan]
flushSpan [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment)
   in LineScan
        { lineScanSpans :: [LineSpan]
lineScanSpans = [LineSpan]
spans,
          lineScanFinalHsDepth :: Int
lineScanFinalHsDepth = Int
finalHsDepth,
          lineScanFinalCDepth :: Int
lineScanFinalCDepth = Int
finalCDepth
        }
  where
    flushSpan :: [LineSpan] -> TB.Builder -> Bool -> Bool -> [LineSpan]
    flushSpan :: [LineSpan] -> Builder -> Bool -> Bool -> [LineSpan]
flushSpan [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
inComment =
      if Bool -> Bool
not Bool
hasCurrent
        then [LineSpan]
spansRev
        else LineSpan {lineSpanInBlockComment :: Bool
lineSpanInBlockComment = Bool
inComment, lineSpanText :: Text
lineSpanText = Builder -> Text
builderToText Builder
currentBuilder} LineSpan -> [LineSpan] -> [LineSpan]
forall a. a -> [a] -> [a]
: [LineSpan]
spansRev

    appendWithMode ::
      [LineSpan] ->
      TB.Builder ->
      Bool ->
      Bool ->
      Bool ->
      Text ->
      ([LineSpan], TB.Builder, Bool, Bool)
    appendWithMode :: [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
newInComment Text
chunk
      | Text -> Bool
T.null Text
chunk = ([LineSpan]
spansRev, Builder
currentBuilder, Bool
hasCurrent, Bool
currentInComment)
      | Bool -> Bool
not Bool
hasCurrent = ([LineSpan]
spansRev, Text -> Builder
TB.fromText Text
chunk, Bool
True, Bool
newInComment)
      | Bool
currentInComment Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
newInComment = ([LineSpan]
spansRev, Builder
currentBuilder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText Text
chunk, Bool
True, Bool
currentInComment)
      | Bool
otherwise =
          let spansRev' :: [LineSpan]
spansRev' = [LineSpan] -> Builder -> Bool -> Bool -> [LineSpan]
flushSpan [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment
           in ([LineSpan]
spansRev', Text -> Builder
TB.fromText Text
chunk, Bool
True, Bool
newInComment)

    go ::
      Int ->
      Int ->
      Bool ->
      Bool ->
      Bool ->
      [LineSpan] ->
      TB.Builder ->
      Bool ->
      Bool ->
      Text ->
      ([LineSpan], TB.Builder, Bool, Bool, Int, Int)
    go :: Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
inString Bool
inChar Bool
escaped [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Text
remaining =
      case Text -> Maybe (Char, Text)
T.uncons Text
remaining of
        Maybe (Char, Text)
Nothing -> ([LineSpan]
spansRev, Builder
currentBuilder, Bool
hasCurrent, Bool
currentInComment, Int
hsDepth, Int
cDepth)
        Just (Char
c1, Text
rest1) ->
          case Text -> Maybe (Char, Text)
T.uncons Text
rest1 of
            Maybe (Char, Text)
Nothing ->
              let outChar :: Text
outChar = if Int
cDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Text
" " else Char -> Text
T.singleton Char
c1
                  inCommentNow :: Bool
inCommentNow = Int
hsDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Int
cDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                  ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                    [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
inCommentNow Text
outChar
               in ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment', Int
hsDepth, Int
cDepth)
            Just (Char
c2, Text
rest2) ->
              if Int
cDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then
                  if Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
                    then
                      let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                            [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
"  "
                       in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
0 Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' Text
rest2
                    else
                      let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                            [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
" "
                       in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                else
                  if Bool -> Bool
not Bool
inString Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inChar Bool -> Bool -> Bool
&& Int
hsDepth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
                    then
                      let lineTail :: Text
lineTail = Char -> Text -> Text
T.cons Char
c1 (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                          ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                            [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
lineTail
                       in ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment', Int
hsDepth, Int
cDepth)
                    else
                      if Bool
inString
                        then
                          let escaped' :: Bool
escaped' = Bool -> Bool
not Bool
escaped Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
                              inString' :: Bool
inString' = Bool
escaped Bool -> Bool -> Bool
|| Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'
                              ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment (Int
hsDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Char -> Text
T.singleton Char
c1)
                           in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
inString' Bool
False Bool
escaped' [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                        else
                          if Bool
inChar
                            then
                              let escaped' :: Bool
escaped' = Bool -> Bool
not Bool
escaped Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
                                  inChar' :: Bool
inChar' = Bool
escaped Bool -> Bool -> Bool
|| Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\''
                                  ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                    [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment (Int
hsDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Char -> Text
T.singleton Char
c1)
                               in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
False Bool
inChar' Bool
escaped' [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                            else
                              if Int
hsDepth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'
                                then
                                  let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                        [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
False (Char -> Text
T.singleton Char
c1)
                                   in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
True Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                                else
                                  if Int
hsDepth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
                                    then
                                      let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                            [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
False (Char -> Text
T.singleton Char
c1)
                                       in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
False Bool
True Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)
                                    else
                                      if Int
hsDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}'
                                        then
                                          let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                                [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
"-}"
                                              hsDepth' :: Int
hsDepth' = Int
hsDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                           in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth' Int
cDepth Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' Text
rest2
                                        else
                                          if Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'{' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
rest2)
                                            then
                                              let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                                    [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
"{-"
                                               in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go (Int
hsDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
cDepth Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' Text
rest2
                                            else
                                              if Int
hsDepth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*'
                                                then
                                                  let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                                        [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment Bool
True Text
"  "
                                                   in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
1 Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' Text
rest2
                                                else
                                                  let ([LineSpan]
spansRev', Builder
currentBuilder', Bool
hasCurrent', Bool
currentInComment') =
                                                        [LineSpan]
-> Builder
-> Bool
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool)
appendWithMode [LineSpan]
spansRev Builder
currentBuilder Bool
hasCurrent Bool
currentInComment (Int
hsDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Char -> Text
T.singleton Char
c1)
                                                   in Int
-> Int
-> Bool
-> Bool
-> Bool
-> [LineSpan]
-> Builder
-> Bool
-> Bool
-> Text
-> ([LineSpan], Builder, Bool, Bool, Int, Int)
go Int
hsDepth Int
cDepth Bool
False Bool
False Bool
False [LineSpan]
spansRev' Builder
currentBuilder' Bool
hasCurrent' Bool
currentInComment' (Char -> Text -> Text
T.cons Char
c2 Text
rest2)

data Directive
  = DirDefineObject !Text !Text
  | DirDefineFunction !Text ![Text] !Text
  | DirUndef !Text
  | DirInclude !IncludeKind !Text
  | DirIf !Text
  | DirIfDef !Text
  | DirIfNDef !Text
  | DirElif !Text
  | DirElse
  | DirEndIf
  | DirLine !Int !(Maybe FilePath)
  | DirWarning !Text
  | DirError !Text
  | DirUnsupported !Text

parseDirective :: Text -> Maybe Directive
parseDirective :: Text -> Maybe Directive
parseDirective Text
raw =
  let trimmed :: Text
trimmed = Text -> Text
T.stripStart Text
raw
   in if Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
trimmed
        then
          let body :: Text
body = Text -> Text
T.stripStart (Int -> Text -> Text
T.drop Int
1 Text
trimmed)
           in case Text -> Maybe (Char, Text)
T.uncons Text
body of
                Just (Char
c, Text
_) | Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c -> Text -> Maybe Directive
parseDirectiveBody Text
body
                Maybe (Char, Text)
_ -> Maybe Directive
forall a. Maybe a
Nothing
        else Maybe Directive
forall a. Maybe a
Nothing

parseDirectiveBody :: Text -> Maybe Directive
parseDirectiveBody :: Text -> Maybe Directive
parseDirectiveBody Text
body =
  let (Text
name, Text
rest0) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
body
      rest :: Text
rest = Text -> Text
T.stripStart Text
rest0
   in if Text -> Bool
T.null Text
name
        then case Text -> Maybe (Char, Text)
T.uncons Text
body of
          Just (Char
c, Text
_) | Char -> Bool
isDigit Char
c -> Text -> Maybe Directive
parseLineDirective Text
body
          Maybe (Char, Text)
_ -> Maybe Directive
forall a. Maybe a
Nothing
        else case Text
name of
          Text
"define" -> Text -> Maybe Directive
parseDefine Text
rest
          Text
"undef" -> Text -> Directive
DirUndef (Text -> Directive) -> Maybe Text -> Maybe Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
parseIdentifier Text
rest
          Text
"include" -> Text -> Maybe Directive
parseInclude Text
rest
          Text
"if" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirIf Text
rest)
          Text
"ifdef" -> Text -> Directive
DirIfDef (Text -> Directive) -> Maybe Text -> Maybe Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
parseIdentifier Text
rest
          Text
"ifndef" -> Text -> Directive
DirIfNDef (Text -> Directive) -> Maybe Text -> Maybe Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
parseIdentifier Text
rest
          Text
"isndef" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirUnsupported Text
"isndef")
          Text
"elif" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirElif Text
rest)
          Text
"elseif" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirElif Text
rest)
          Text
"else" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just Directive
DirElse
          Text
"endif" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just Directive
DirEndIf
          Text
"line" -> Text -> Maybe Directive
parseLineDirective Text
rest
          Text
"warning" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirWarning Text
rest)
          Text
"error" -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirError Text
rest)
          Text
_ -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirUnsupported Text
name)

parseLineDirective :: Text -> Maybe Directive
parseLineDirective :: Text -> Maybe Directive
parseLineDirective Text
body =
  case Reader Int
forall a. Integral a => Reader a
TR.decimal Text
body of
    Left FilePath
_ -> Maybe Directive
forall a. Maybe a
Nothing
    Right (Int
lineNumber, Text
rest0) ->
      let rest :: Text
rest = Text -> Text
T.stripStart Text
rest0
       in case Text -> Maybe Text
parseQuotedText Text
rest of
            Maybe Text
Nothing -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Int -> Maybe FilePath -> Directive
DirLine Int
lineNumber Maybe FilePath
forall a. Maybe a
Nothing)
            Just Text
path -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Int -> Maybe FilePath -> Directive
DirLine Int
lineNumber (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Text -> FilePath
T.unpack Text
path)))

parseDefine :: Text -> Maybe Directive
parseDefine :: Text -> Maybe Directive
parseDefine Text
rest = do
  let (Text
name, Text
rest0) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
rest
  if Text -> Bool
T.null Text
name
    then Maybe Directive
forall a. Maybe a
Nothing
    else case Text -> Maybe (Char, Text)
T.uncons Text
rest0 of
      Just (Char
'(', Text
afterOpen) ->
        let (Maybe [Text]
params, Text
restAfterParams) = Text -> (Maybe [Text], Text)
parseDefineParams Text
afterOpen
         in case Maybe [Text]
params of
              Maybe [Text]
Nothing -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Directive
DirUnsupported Text
"define-function-macro")
              Just [Text]
names -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> [Text] -> Text -> Directive
DirDefineFunction Text
name [Text]
names (Text -> Text
T.stripStart Text
restAfterParams))
      Maybe (Char, Text)
_ -> Directive -> Maybe Directive
forall a. a -> Maybe a
Just (Text -> Text -> Directive
DirDefineObject Text
name (Text -> Text
T.stripStart Text
rest0))

parseDefineParams :: Text -> (Maybe [Text], Text)
parseDefineParams :: Text -> (Maybe [Text], Text)
parseDefineParams Text
input =
  let (Text
inside, Text
suffix) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
")" Text
input
   in if Text -> Bool
T.null Text
suffix
        then (Maybe [Text]
forall a. Maybe a
Nothing, Text
"")
        else
          let rawParams :: [Text]
rawParams = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," Text
inside
              params :: [Text]
params = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isIdentChar (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) [Text]
rawParams
           in if Text -> Bool
T.null (Text -> Text
T.strip Text
inside)
                then ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [], Int -> Text -> Text
T.drop Int
1 Text
suffix)
                else
                  if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
T.null [Text]
params
                    then (Maybe [Text]
forall a. Maybe a
Nothing, Int -> Text -> Text
T.drop Int
1 Text
suffix)
                    else ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
params, Int -> Text -> Text
T.drop Int
1 Text
suffix)

parseIdentifier :: Text -> Maybe Text
parseIdentifier :: Text -> Maybe Text
parseIdentifier Text
txt =
  let ident :: Text
ident = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isIdentChar (Text -> Text
T.stripStart Text
txt)
   in if Text -> Bool
T.null Text
ident then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ident

parseInclude :: Text -> Maybe Directive
parseInclude :: Text -> Maybe Directive
parseInclude Text
txt =
  case Text -> Maybe (Char, Text)
T.uncons (Text -> Text
T.stripStart Text
txt) of
    Just (Char
'"', Text
rest) ->
      let (Text
path, Text
suffix) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"\"" Text
rest
       in if Text -> Bool
T.null Text
suffix then Maybe Directive
forall a. Maybe a
Nothing else Directive -> Maybe Directive
forall a. a -> Maybe a
Just (IncludeKind -> Text -> Directive
DirInclude IncludeKind
IncludeLocal Text
path)
    Just (Char
'<', Text
rest) ->
      let (Text
path, Text
suffix) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
">" Text
rest
       in if Text -> Bool
T.null Text
suffix then Maybe Directive
forall a. Maybe a
Nothing else Directive -> Maybe Directive
forall a. a -> Maybe a
Just (IncludeKind -> Text -> Directive
DirInclude IncludeKind
IncludeSystem Text
path)
    Maybe (Char, Text)
_ -> Maybe Directive
forall a. Maybe a
Nothing

parseQuotedText :: Text -> Maybe Text
parseQuotedText :: Text -> Maybe Text
parseQuotedText Text
txt = do
  ('"', rest) <- Text -> Maybe (Char, Text)
T.uncons Text
txt
  let (path, suffix) = T.breakOn "\"" rest
  if T.null suffix then Nothing else Just path

expandMacros :: EngineState -> Text -> Text
expandMacros :: EngineState -> Text -> Text
expandMacros EngineState
st = Int -> Text -> Text
forall {t}. (Eq t, Num t) => t -> Text -> Text
applyDepth (Int
32 :: Int)
  where
    applyDepth :: t -> Text -> Text
applyDepth t
0 Text
t = Text
t
    applyDepth t
n Text
t =
      let next :: Text
next = EngineState -> Text -> Text
expandOnce EngineState
st Text
t
       in if Text
next Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t then Text
t else t -> Text -> Text
applyDepth (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Text
next

expandOnce :: EngineState -> Text -> Text
expandOnce :: EngineState -> Text -> Text
expandOnce EngineState
st = Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False
  where
    macros :: Map Text MacroDef
macros = EngineState -> Map Text MacroDef
stMacros EngineState
st
    go :: Bool -> Bool -> Bool -> Text -> Text
    go :: Bool -> Bool -> Bool -> Text -> Text
go Bool
_ Bool
_ Bool
_ Text
txt
      | Text -> Bool
T.null Text
txt = Text
""
    go Bool
inString Bool
inChar Bool
escaped Text
txt =
      case Text -> Maybe (Char, Text)
T.uncons Text
txt of
        Maybe (Char, Text)
Nothing -> Text
""
        Just (Char
c, Text
rest)
          | Bool
inString ->
              let escaped' :: Bool
escaped' = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
escaped
                  inString' :: Bool
inString' = Bool -> Bool
not (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
escaped)
               in Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
inString' Bool
False Bool
escaped' Text
rest)
          | Bool
inChar ->
              let escaped' :: Bool
escaped' = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
escaped
                  inChar' :: Bool
inChar' = Bool -> Bool
not (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
escaped)
               in Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
inChar' Bool
escaped' Text
rest)
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
False Bool
False Text
rest)
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
True Bool
False Text
rest)
          | Char -> Bool
isIdentStart Char
c ->
              Text -> Text
expandIdentifier Text
txt
          | Bool
otherwise ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest)

    expandIdentifier :: Text -> Text
    expandIdentifier :: Text -> Text
expandIdentifier Text
input =
      let (Text
ident, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
input
       in case Text
ident of
            Text
"__LINE__" -> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (EngineState -> Int
stCurrentLine EngineState
st)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest
            Text
"__FILE__" -> FilePath -> Text
T.pack (ShowS
forall a. Show a => a -> FilePath
show (EngineState -> FilePath
stCurrentFile EngineState
st)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest
            Text
_ ->
              case Text -> Map Text MacroDef -> Maybe MacroDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ident Map Text MacroDef
macros of
                Just (ObjectMacro Text
replacement) ->
                  Text
replacement Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest
                Just (FunctionMacro [Text]
params Text
body) ->
                  case Text -> Maybe ([Text], Text)
parseCallArgs Text
rest of
                    Maybe ([Text], Text)
Nothing -> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest
                    Just ([Text]
args, Text
restAfter)
                      | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
params ->
                          let body' :: Text
body' = Map Text Text -> Text -> Text
substituteParams ([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
params [Text]
args)) Text
body
                           in Text
body' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
restAfter
                      | Bool
otherwise -> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest
                Maybe MacroDef
Nothing -> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest

    parseCallArgs :: Text -> Maybe ([Text], Text)
    parseCallArgs :: Text -> Maybe ([Text], Text)
parseCallArgs Text
input = do
      ('(', rest) <- Text -> Maybe (Char, Text)
T.uncons Text
input
      parseArgs 0 [] mempty rest

    parseArgs :: Int -> [Text] -> TB.Builder -> Text -> Maybe ([Text], Text)
    parseArgs :: Int -> [Text] -> Builder -> Text -> Maybe ([Text], Text)
parseArgs Int
depth [Text]
argsRev Builder
current Text
remaining =
      case Text -> Maybe (Char, Text)
T.uncons Text
remaining of
        Maybe (Char, Text)
Nothing -> Maybe ([Text], Text)
forall a. Maybe a
Nothing
        Just (Char
ch, Text
rest)
          | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' ->
              Int -> [Text] -> Builder -> Text -> Maybe ([Text], Text)
parseArgs (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
argsRev (Builder
current Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
ch) Text
rest
          | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&& Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
              Int -> [Text] -> Builder -> Text -> Maybe ([Text], Text)
parseArgs (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Text]
argsRev (Builder
current Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
ch) Text
rest
          | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&& Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
              let arg :: Text
arg = Text -> Text
trimSpacesText (Builder -> Text
builderToText Builder
current)
                  argsRev' :: [Text]
argsRev' =
                    if Text -> Bool
T.null Text
arg Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
argsRev
                      then [Text]
argsRev
                      else Text
arg Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
argsRev
               in ([Text], Text) -> Maybe ([Text], Text)
forall a. a -> Maybe a
Just ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
argsRev', Text
rest)
          | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
&& Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
              let arg :: Text
arg = Text -> Text
trimSpacesText (Builder -> Text
builderToText Builder
current)
               in Int -> [Text] -> Builder -> Text -> Maybe ([Text], Text)
parseArgs Int
depth (Text
arg Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
argsRev) Builder
forall a. Monoid a => a
mempty Text
rest
          | Bool
otherwise ->
              Int -> [Text] -> Builder -> Text -> Maybe ([Text], Text)
parseArgs Int
depth [Text]
argsRev (Builder
current Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
ch) Text
rest

substituteParams :: Map Text Text -> Text -> Text
substituteParams :: Map Text Text -> Text -> Text
substituteParams Map Text Text
subs = Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False
  where
    go :: Bool -> Bool -> Bool -> Text -> Text
    go :: Bool -> Bool -> Bool -> Text -> Text
go Bool
_ Bool
_ Bool
_ Text
txt
      | Text -> Bool
T.null Text
txt = Text
""
    go Bool
inDouble Bool
inSingle Bool
escaped Text
txt =
      case Text -> Maybe (Char, Text)
T.uncons Text
txt of
        Maybe (Char, Text)
Nothing -> Text
""
        Just (Char
c, Text
rest)
          | Bool
inDouble ->
              Char -> Text -> Text
T.cons Char
c (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                case Char
c of
                  Char
'\\' ->
                    if Bool
escaped
                      then Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
inSingle Bool
False Text
rest
                      else Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
inSingle Bool
True Text
rest
                  Char
'"' ->
                    if Bool
escaped
                      then Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
inSingle Bool
False Text
rest
                      else Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
inSingle Bool
False Text
rest
                  Char
_ -> Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
inSingle Bool
False Text
rest
          | Bool
inSingle ->
              Char -> Text -> Text
T.cons Char
c (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                case Char
c of
                  Char
'\\' ->
                    if Bool
escaped
                      then Bool -> Bool -> Bool -> Text -> Text
go Bool
inDouble Bool
True Bool
False Text
rest
                      else Bool -> Bool -> Bool -> Text -> Text
go Bool
inDouble Bool
True Bool
True Text
rest
                  Char
'\'' ->
                    if Bool
escaped
                      then Bool -> Bool -> Bool -> Text -> Text
go Bool
inDouble Bool
True Bool
False Text
rest
                      else Bool -> Bool -> Bool -> Text -> Text
go Bool
inDouble Bool
False Bool
False Text
rest
                  Char
_ -> Bool -> Bool -> Bool -> Text -> Text
go Bool
inDouble Bool
True Bool
False Text
rest
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
True Bool
False Bool
False Text
rest)
          | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
True Bool
False Text
rest)
          | Char -> Bool
isIdentStart Char
c ->
              let (Text
ident, Text
rest') = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
txt
               in Text -> Text -> Map Text Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Text
ident Text
ident Map Text Text
subs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest'
          | Bool
otherwise ->
              Char -> Text -> Text
T.cons Char
c (Bool -> Bool -> Bool -> Text -> Text
go Bool
False Bool
False Bool
False Text
rest)

isIdentStart :: Char -> Bool
isIdentStart :: Char -> Bool
isIdentStart Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isLetter Char
c

isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c

--------------------------------------------------------------------------------
-- Expression Evaluation
--------------------------------------------------------------------------------

evalCondition :: EngineState -> Text -> Bool
evalCondition :: EngineState -> Text -> Bool
evalCondition EngineState
st Text
expr = Text -> Integer
eval Text
expr Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  where
    macros :: Map Text MacroDef
macros = EngineState -> Map Text MacroDef
stMacros EngineState
st
    eval :: Text -> Integer
eval = Text -> Integer
evalNumeric (Text -> Integer) -> (Text -> Text) -> Text -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
replaceRemainingWithZero (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EngineState -> Text -> Text
expandMacros EngineState
st (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text MacroDef -> Text -> Text
replaceDefined Map Text MacroDef
macros

evalNumeric :: Text -> Integer
evalNumeric :: Text -> Integer
evalNumeric Text
input =
  let tokens :: [Token]
tokens = Text -> [Token]
tokenize Text
input
   in case [Token] -> (Integer, [Token])
parseExpr [Token]
tokens of
        (Integer
val, [Token]
_) -> Integer
val

data Token = TOp Text | TNum Integer | TIdent Text | TOpenParen | TCloseParen deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> FilePath
(Int -> Token -> ShowS)
-> (Token -> FilePath) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> FilePath
show :: Token -> FilePath
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show)

tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
input =
  case Text -> Maybe (Char, Text)
T.uncons Text
input of
    Maybe (Char, Text)
Nothing -> []
    Just (Char
c, Text
rest)
      | Char -> Bool
isSpace Char
c ->
          Text -> [Token]
tokenize ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest)
      | Char -> Bool
isDigit Char
c ->
          let (Text
num, Text
remaining) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isDigit Text
input
           in case Reader Integer
forall a. Integral a => Reader a
TR.decimal Text
num of
                Right (Integer
value, Text
_) -> Integer -> Token
TNum Integer
value Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
remaining
                Left FilePath
_ -> Text -> [Token]
tokenize Text
remaining
      | Char -> Bool
isIdentStart Char
c ->
          let (Text
ident, Text
remaining) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
input
           in Text -> Token
TIdent Text
ident Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
remaining
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' ->
          Token
TOpenParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' ->
          Token
TCloseParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest
      | Bool
otherwise ->
          let (Text
op, Text
remaining) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isOpChar Text
input
           in if Text -> Bool
T.null Text
op
                then Text -> [Token]
tokenize Text
rest
                else Text -> Token
TOp Text
op Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
remaining

isOpChar :: Char -> Bool
isOpChar :: Char -> Bool
isOpChar Char
c =
  Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'&'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<'
    Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>'

parseExpr :: [Token] -> (Integer, [Token])
parseExpr :: [Token] -> (Integer, [Token])
parseExpr = [Token] -> (Integer, [Token])
parseOr

binary :: ([Token] -> (Integer, [Token])) -> [Text] -> [Token] -> (Integer, [Token])
binary :: ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
next [Text]
ops [Token]
ts =
  let (Integer
v1, [Token]
ts1) = [Token] -> (Integer, [Token])
next [Token]
ts
   in Integer -> [Token] -> (Integer, [Token])
go Integer
v1 [Token]
ts1
  where
    go :: Integer -> [Token] -> (Integer, [Token])
go Integer
v1 (TOp Text
op : [Token]
ts2)
      | Text
op Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ops =
          let (Integer
v2, [Token]
ts3) = [Token] -> (Integer, [Token])
next [Token]
ts2
           in Integer -> [Token] -> (Integer, [Token])
go (Text -> Integer -> Integer -> Integer
forall {a} {a}. (IsString a, Eq a, Integral a) => a -> a -> a -> a
apply Text
op Integer
v1 Integer
v2) [Token]
ts3
    go Integer
v1 [Token]
ts2 = (Integer
v1, [Token]
ts2)

    apply :: a -> a -> a -> a
apply a
"||" a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
|| a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 then a
1 else a
0
    apply a
"&&" a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 then a
1 else a
0
    apply a
"==" a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b then a
1 else a
0
    apply a
"!=" a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b then a
1 else a
0
    apply a
"<" a
a a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b then a
1 else a
0
    apply a
">" a
a a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
b then a
1 else a
0
    apply a
"<=" a
a a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b then a
1 else a
0
    apply a
">=" a
a a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
b then a
1 else a
0
    apply a
"+" a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
b
    apply a
"-" a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
b
    apply a
"*" a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
b
    apply a
"/" a
a a
b = if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
0 else a
a a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
b
    apply a
"%" a
a a
b = if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
0 else a
a a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
b
    apply a
_ a
a a
_ = a
a

parseOr, parseAnd, parseEq, parseRel, parseAdd, parseMul :: [Token] -> (Integer, [Token])
parseOr :: [Token] -> (Integer, [Token])
parseOr = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseAnd [Text
"||"]
parseAnd :: [Token] -> (Integer, [Token])
parseAnd = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseEq [Text
"&&"]
parseEq :: [Token] -> (Integer, [Token])
parseEq = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseRel [Text
"==", Text
"!="]
parseRel :: [Token] -> (Integer, [Token])
parseRel = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseAdd [Text
"<", Text
">", Text
"<=", Text
">="]
parseAdd :: [Token] -> (Integer, [Token])
parseAdd = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseMul [Text
"+", Text
"-"]
parseMul :: [Token] -> (Integer, [Token])
parseMul = ([Token] -> (Integer, [Token]))
-> [Text] -> [Token] -> (Integer, [Token])
binary [Token] -> (Integer, [Token])
parseUnary [Text
"*", Text
"/", Text
"%"]

parseUnary :: [Token] -> (Integer, [Token])
parseUnary :: [Token] -> (Integer, [Token])
parseUnary (TOp Text
"!" : [Token]
ts) = let (Integer
v, [Token]
ts') = [Token] -> (Integer, [Token])
parseUnary [Token]
ts in (if Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Integer
1 else Integer
0, [Token]
ts')
parseUnary (TOp Text
"-" : [Token]
ts) = let (Integer
v, [Token]
ts') = [Token] -> (Integer, [Token])
parseUnary [Token]
ts in (-Integer
v, [Token]
ts')
parseUnary [Token]
ts = [Token] -> (Integer, [Token])
parseAtom [Token]
ts

parseAtom :: [Token] -> (Integer, [Token])
parseAtom :: [Token] -> (Integer, [Token])
parseAtom (TNum Integer
n : [Token]
ts) = (Integer
n, [Token]
ts)
parseAtom (TIdent Text
_ : [Token]
ts) = (Integer
0, [Token]
ts)
parseAtom (Token
TOpenParen : [Token]
ts) =
  let (Integer
v, [Token]
ts1) = [Token] -> (Integer, [Token])
parseExpr [Token]
ts
   in case [Token]
ts1 of
        Token
TCloseParen : [Token]
ts2 -> (Integer
v, [Token]
ts2)
        [Token]
_ -> (Integer
v, [Token]
ts1)
parseAtom [Token]
ts = (Integer
0, [Token]
ts)

replaceDefined :: Map Text MacroDef -> Text -> Text
replaceDefined :: Map Text MacroDef -> Text -> Text
replaceDefined Map Text MacroDef
macros = Text -> Text
go
  where
    go :: Text -> Text
go Text
txt =
      case Text -> Maybe (Char, Text)
T.uncons Text
txt of
        Maybe (Char, Text)
Nothing -> Text
""
        Just (Char
c, Text
rest)
          | Text
"defined" Text -> Text -> Bool
`T.isPrefixOf` Text
txt Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
nextCharIsIdent (Int -> Text -> Text
T.drop Int
7 Text
txt)) ->
              Text -> Text
expandDefined ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace (Int -> Text -> Text
T.drop Int
7 Text
txt))
          | Bool
otherwise ->
              Char -> Text -> Text
T.cons Char
c (Text -> Text
go Text
rest)

    expandDefined :: Text -> Text
expandDefined Text
rest =
      case Text -> Maybe (Char, Text)
T.uncons Text
rest of
        Just (Char
'(', Text
restAfterOpen) ->
          let rest' :: Text
rest' = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
restAfterOpen
              (Text
name, Text
restAfterName0) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
rest'
              restAfterName :: Text
restAfterName = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
restAfterName0
           in case Text -> Maybe (Char, Text)
T.uncons Text
restAfterName of
                Just (Char
')', Text
restAfterClose) ->
                  Bool -> Text
forall {a}. IsString a => Bool -> a
boolLiteral (Text -> Map Text MacroDef -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
name Map Text MacroDef
macros) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
restAfterClose
                Maybe (Char, Text)
_ ->
                  Bool -> Text
forall {a}. IsString a => Bool -> a
boolLiteral Bool
False Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
restAfterName
        Maybe (Char, Text)
_ ->
          let (Text
name, Text
restAfterName) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
rest
           in if Text -> Bool
T.null Text
name
                then Bool -> Text
forall {a}. IsString a => Bool -> a
boolLiteral Bool
False Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
rest
                else Bool -> Text
forall {a}. IsString a => Bool -> a
boolLiteral (Text -> Map Text MacroDef -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
name Map Text MacroDef
macros) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
restAfterName

    boolLiteral :: Bool -> a
boolLiteral Bool
True = a
" 1 "
    boolLiteral Bool
False = a
" 0 "

    nextCharIsIdent :: Text -> Bool
nextCharIsIdent Text
remaining =
      case Text -> Maybe (Char, Text)
T.uncons Text
remaining of
        Just (Char
c, Text
_) -> Char -> Bool
isIdentChar Char
c
        Maybe (Char, Text)
Nothing -> Bool
False

replaceRemainingWithZero :: Text -> Text
replaceRemainingWithZero :: Text -> Text
replaceRemainingWithZero = Text -> Text
go
  where
    go :: Text -> Text
go Text
txt =
      case Text -> Maybe (Char, Text)
T.uncons Text
txt of
        Maybe (Char, Text)
Nothing -> Text
""
        Just (Char
c, Text
rest)
          | Char -> Bool
isIdentStart Char
c ->
              let (Text
_, Text
remaining) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isIdentChar Text
txt
               in Text
" 0 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
remaining
          | Bool
otherwise ->
              Char -> Text -> Text
T.cons Char
c (Text -> Text
go Text
rest)