{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Jikka.CPlusPlus.Convert.BundleRuntime
-- Description : bundles runtime headers to C++ code. / C++ コードにランタイムヘッダーを埋め込みます。
-- Copyright   : (c) Kimiyuki Onaka, 2020
-- License     : Apache License 2.0
-- Maintainer  : kimiyuki95@gmail.com
-- Stability   : experimental
-- Portability : portable
module Jikka.CPlusPlus.Convert.BundleRuntime
  ( run,
  )
where

import Control.Monad.State.Strict
import Data.Char
import qualified Data.Set as S
import qualified Data.Text as T
import Jikka.Common.Error

#ifdef JIKKA_EMBED_RUNTIME
import Jikka.Common.FileEmbed (embedDir)
#else
import qualified Data.Text.IO as T
import Paths_Jikka
import System.IO.Error
#endif

-- Pragmas needs type annotations when OverloadedStrings is used. See https://github.com/ndmitchell/hlint/issues/372
{-# ANN module ("HLint: ignore Unused LANGUAGE pragma" :: String) #-}

#ifdef JIKKA_EMBED_RUNTIME
embeddedRuntimeFiles :: [(FilePath, T.Text)]
embeddedRuntimeFiles = $(embedDir "runtime/include")

readRuntimeFile :: MonadError Error m => FilePath -> m T.Text
readRuntimeFile path =
  case lookup ("runtime/include/" ++ path) embeddedRuntimeFiles of
    Just file -> return file
    Nothing -> throwInternalError $ "failed to open file. It may need recompile the binary?: " ++ path

#else
readRuntimeFile :: (MonadIO m, MonadError Error m) => FilePath -> m T.Text
readRuntimeFile :: FilePath -> m Text
readRuntimeFile FilePath
path = do
  FilePath
resolvedPath <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getDataFileName (FilePath
"runtime/include/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path)
  Either IOError Text
file <- IO (Either IOError Text) -> m (Either IOError Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError Text) -> m (Either IOError Text))
-> IO (Either IOError Text) -> m (Either IOError Text)
forall a b. (a -> b) -> a -> b
$ IO Text -> IO (Either IOError Text)
forall a. IO a -> IO (Either IOError a)
tryIOError (FilePath -> IO Text
T.readFile FilePath
resolvedPath)
  case Either IOError Text
file of
    Left IOError
err -> FilePath -> m Text
forall (m :: * -> *) a. MonadError Error m => FilePath -> m a
throwInternalError (FilePath -> m Text) -> FilePath -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath
"faild to open file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
err
    Right Text
file -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
file
#endif

data PreprocessorState = PreprocessorState
  { PreprocessorState -> Set FilePath
definedMacros :: S.Set String,
    PreprocessorState -> [Bool]
ifdefStack :: [Bool]
  }
  deriving (PreprocessorState -> PreprocessorState -> Bool
(PreprocessorState -> PreprocessorState -> Bool)
-> (PreprocessorState -> PreprocessorState -> Bool)
-> Eq PreprocessorState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreprocessorState -> PreprocessorState -> Bool
$c/= :: PreprocessorState -> PreprocessorState -> Bool
== :: PreprocessorState -> PreprocessorState -> Bool
$c== :: PreprocessorState -> PreprocessorState -> Bool
Eq, Eq PreprocessorState
Eq PreprocessorState
-> (PreprocessorState -> PreprocessorState -> Ordering)
-> (PreprocessorState -> PreprocessorState -> Bool)
-> (PreprocessorState -> PreprocessorState -> Bool)
-> (PreprocessorState -> PreprocessorState -> Bool)
-> (PreprocessorState -> PreprocessorState -> Bool)
-> (PreprocessorState -> PreprocessorState -> PreprocessorState)
-> (PreprocessorState -> PreprocessorState -> PreprocessorState)
-> Ord PreprocessorState
PreprocessorState -> PreprocessorState -> Bool
PreprocessorState -> PreprocessorState -> Ordering
PreprocessorState -> PreprocessorState -> PreprocessorState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PreprocessorState -> PreprocessorState -> PreprocessorState
$cmin :: PreprocessorState -> PreprocessorState -> PreprocessorState
max :: PreprocessorState -> PreprocessorState -> PreprocessorState
$cmax :: PreprocessorState -> PreprocessorState -> PreprocessorState
>= :: PreprocessorState -> PreprocessorState -> Bool
$c>= :: PreprocessorState -> PreprocessorState -> Bool
> :: PreprocessorState -> PreprocessorState -> Bool
$c> :: PreprocessorState -> PreprocessorState -> Bool
<= :: PreprocessorState -> PreprocessorState -> Bool
$c<= :: PreprocessorState -> PreprocessorState -> Bool
< :: PreprocessorState -> PreprocessorState -> Bool
$c< :: PreprocessorState -> PreprocessorState -> Bool
compare :: PreprocessorState -> PreprocessorState -> Ordering
$ccompare :: PreprocessorState -> PreprocessorState -> Ordering
$cp1Ord :: Eq PreprocessorState
Ord, Int -> PreprocessorState -> FilePath -> FilePath
[PreprocessorState] -> FilePath -> FilePath
PreprocessorState -> FilePath
(Int -> PreprocessorState -> FilePath -> FilePath)
-> (PreprocessorState -> FilePath)
-> ([PreprocessorState] -> FilePath -> FilePath)
-> Show PreprocessorState
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [PreprocessorState] -> FilePath -> FilePath
$cshowList :: [PreprocessorState] -> FilePath -> FilePath
show :: PreprocessorState -> FilePath
$cshow :: PreprocessorState -> FilePath
showsPrec :: Int -> PreprocessorState -> FilePath -> FilePath
$cshowsPrec :: Int -> PreprocessorState -> FilePath -> FilePath
Show, ReadPrec [PreprocessorState]
ReadPrec PreprocessorState
Int -> ReadS PreprocessorState
ReadS [PreprocessorState]
(Int -> ReadS PreprocessorState)
-> ReadS [PreprocessorState]
-> ReadPrec PreprocessorState
-> ReadPrec [PreprocessorState]
-> Read PreprocessorState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PreprocessorState]
$creadListPrec :: ReadPrec [PreprocessorState]
readPrec :: ReadPrec PreprocessorState
$creadPrec :: ReadPrec PreprocessorState
readList :: ReadS [PreprocessorState]
$creadList :: ReadS [PreprocessorState]
readsPrec :: Int -> ReadS PreprocessorState
$creadsPrec :: Int -> ReadS PreprocessorState
Read)

initialPreprocessorState :: PreprocessorState
initialPreprocessorState :: PreprocessorState
initialPreprocessorState =
  PreprocessorState :: Set FilePath -> [Bool] -> PreprocessorState
PreprocessorState
    { definedMacros :: Set FilePath
definedMacros = Set FilePath
forall a. Set a
S.empty,
      ifdefStack :: [Bool]
ifdefStack = [Bool
True]
    }

throwInternalErrorAt'' :: MonadError Error m => FilePath -> Integer -> String -> m a
throwInternalErrorAt'' :: FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path Integer
lineno FilePath
msg = FilePath -> m a -> m a
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> m a -> m a
wrapError' (FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (line " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
lineno FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")") (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ FilePath -> m a
forall (m :: * -> *) a. MonadError Error m => FilePath -> m a
throwInternalError FilePath
msg

runLine :: (MonadError Error m, MonadState PreprocessorState m) => (FilePath -> m T.Text) -> FilePath -> Integer -> T.Text -> m [T.Text]
runLine :: (FilePath -> m Text) -> FilePath -> Integer -> Text -> m [Text]
runLine FilePath -> m Text
readRuntimeFile FilePath
path Integer
lineno Text
line
  | Text
"#include \"" Text -> Text -> Bool
`T.isPrefixOf` Text
line = case Text -> Text -> [Text]
T.splitOn Text
"\"" Text
line of
    [Text
"#include ", Text
path', Text
""] -> do
      [Text]
lines <- (FilePath -> m Text) -> FilePath -> m [Text]
forall (m :: * -> *).
(MonadError Error m, MonadState PreprocessorState m) =>
(FilePath -> m Text) -> FilePath -> m [Text]
runFile FilePath -> m Text
readRuntimeFile (Text -> FilePath
T.unpack Text
path')
      [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text]
lines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [FilePath -> Text
T.pack (FilePath
"#line " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer
lineno Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"")])
    [Text]
_ -> FilePath -> Integer -> FilePath -> m [Text]
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path Integer
lineno FilePath
"invalid #include \"...\""
  | Bool
otherwise = do
    [Bool]
stk <- (PreprocessorState -> [Bool]) -> m [Bool]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PreprocessorState -> [Bool]
ifdefStack
    case [Bool]
stk of
      Bool
True : [Bool]
_ -> [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
line]
      Bool
False : [Bool]
_ -> [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      [] -> FilePath -> m [Text]
forall (m :: * -> *) a. MonadError Error m => FilePath -> m a
throwInternalError FilePath
"there are more #endif than #ifdef and #ifndef"

runLines :: (MonadError Error m, MonadState PreprocessorState m) => (FilePath -> m T.Text) -> FilePath -> Integer -> [T.Text] -> m [T.Text]
runLines :: (FilePath -> m Text) -> FilePath -> Integer -> [Text] -> m [Text]
runLines FilePath -> m Text
readRuntimeFile FilePath
path Integer
lineno [Text]
lines = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> m [[Text]] -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Text -> m [Text]) -> [Integer] -> [Text] -> m [[Text]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ((FilePath -> m Text) -> FilePath -> Integer -> Text -> m [Text]
forall (m :: * -> *).
(MonadError Error m, MonadState PreprocessorState m) =>
(FilePath -> m Text) -> FilePath -> Integer -> Text -> m [Text]
runLine FilePath -> m Text
readRuntimeFile FilePath
path) [Integer
lineno ..] [Text]
lines

runFile :: (MonadError Error m, MonadState PreprocessorState m) => (FilePath -> m T.Text) -> FilePath -> m [T.Text]
runFile :: (FilePath -> m Text) -> FilePath -> m [Text]
runFile FilePath -> m Text
readRuntimeFile FilePath
path = do
  Text
file <- FilePath -> m Text
readRuntimeFile FilePath
path
  let lines :: [Text]
lines = Text -> [Text]
T.lines Text
file
  let macro :: FilePath
macro = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char -> Bool
isAlphaNum Char
c then Char -> Char
toUpper Char
c else Char
'_') FilePath
path
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
lines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> Integer -> FilePath -> m ()
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path Integer
1 FilePath
"file has too few lines"
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> FilePath
T.unpack ([Text] -> Text
forall a. [a] -> a
head [Text]
lines) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"#ifndef " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> Integer -> FilePath -> m ()
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path Integer
1 (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"the first line must be: #ifndef " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> FilePath
T.unpack ([Text]
lines [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
1) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"#define " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> Integer -> FilePath -> m ()
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path Integer
2 (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"the second line must be: #define " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> FilePath
T.unpack ([Text] -> Text
forall a. [a] -> a
last [Text]
lines) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"#endif // " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> Integer -> FilePath -> m ()
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> Integer -> FilePath -> m a
throwInternalErrorAt'' FilePath
path (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
lines Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"the last line must be: #ifndef " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
macro
  Set FilePath
macros <- (PreprocessorState -> Set FilePath) -> m (Set FilePath)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PreprocessorState -> Set FilePath
definedMacros
  if FilePath
macro FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set FilePath
macros
    then [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      (PreprocessorState -> PreprocessorState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PreprocessorState
s -> PreprocessorState
s {definedMacros :: Set FilePath
definedMacros = FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
macro Set FilePath
macros})
      (FilePath -> Text
T.pack (FilePath
"#line 3 \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> m [Text] -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> m Text) -> FilePath -> Integer -> [Text] -> m [Text]
forall (m :: * -> *).
(MonadError Error m, MonadState PreprocessorState m) =>
(FilePath -> m Text) -> FilePath -> Integer -> [Text] -> m [Text]
runLines FilePath -> m Text
readRuntimeFile FilePath
path Integer
3 (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
2 ([Text] -> [Text]
forall a. [a] -> [a]
init [Text]
lines))

removeConsecutiveLineDirectives :: [T.Text] -> [T.Text]
removeConsecutiveLineDirectives :: [Text] -> [Text]
removeConsecutiveLineDirectives = \case
  (Text
l1 : Text
l2 : [Text]
lines) | Text
"#line" Text -> Text -> Bool
`T.isPrefixOf` Text
l1 Bool -> Bool -> Bool
&& Text
"#line" Text -> Text -> Bool
`T.isPrefixOf` Text
l2 -> [Text] -> [Text]
removeConsecutiveLineDirectives (Text
l2 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
lines)
  (Text
line : [Text]
lines) -> Text
line Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
removeConsecutiveLineDirectives [Text]
lines
  [] -> []

-- | `run` bundles runtime headers to C++ code like <https://github.com/online-judge-tools/verification-helper `oj-bundle` command>.
#ifdef JIKKA_EMBED_RUNTIME
run :: MonadError Error m => T.Text -> m T.Text
#else
run :: (MonadIO m, MonadError Error m) => T.Text -> m T.Text
#endif
run :: Text -> m Text
run Text
prog = FilePath -> m Text -> m Text
forall (m :: * -> *) a.
MonadError Error m =>
FilePath -> m a -> m a
wrapError' FilePath
"Jikka.CPlusPlus.Convert.BundleRuntime" (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
  [Text]
lines <- StateT PreprocessorState m [Text] -> PreprocessorState -> m [Text]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((FilePath -> StateT PreprocessorState m Text)
-> FilePath
-> Integer
-> [Text]
-> StateT PreprocessorState m [Text]
forall (m :: * -> *).
(MonadError Error m, MonadState PreprocessorState m) =>
(FilePath -> m Text) -> FilePath -> Integer -> [Text] -> m [Text]
runLines FilePath -> StateT PreprocessorState m Text
forall (m :: * -> *).
(MonadIO m, MonadError Error m) =>
FilePath -> m Text
readRuntimeFile FilePath
"main.cpp" Integer
1 (Text -> [Text]
T.lines Text
prog)) PreprocessorState
initialPreprocessorState
  Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> [Text]
removeConsecutiveLineDirectives [Text]
lines)