{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-}
-- | Preprocessor Configuration
module Hpp.Config where
import Data.Functor.Identity
import Data.Time.Clock (getCurrentTime, UTCTime)
import Data.Time.Format

-- | A 'String' representing a time.
newtype TimeString = TimeString { TimeString -> String
getTimeString :: String }
  deriving (TimeString -> TimeString -> Bool
(TimeString -> TimeString -> Bool)
-> (TimeString -> TimeString -> Bool) -> Eq TimeString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeString -> TimeString -> Bool
$c/= :: TimeString -> TimeString -> Bool
== :: TimeString -> TimeString -> Bool
$c== :: TimeString -> TimeString -> Bool
Eq, Eq TimeString
Eq TimeString
-> (TimeString -> TimeString -> Ordering)
-> (TimeString -> TimeString -> Bool)
-> (TimeString -> TimeString -> Bool)
-> (TimeString -> TimeString -> Bool)
-> (TimeString -> TimeString -> Bool)
-> (TimeString -> TimeString -> TimeString)
-> (TimeString -> TimeString -> TimeString)
-> Ord TimeString
TimeString -> TimeString -> Bool
TimeString -> TimeString -> Ordering
TimeString -> TimeString -> TimeString
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 :: TimeString -> TimeString -> TimeString
$cmin :: TimeString -> TimeString -> TimeString
max :: TimeString -> TimeString -> TimeString
$cmax :: TimeString -> TimeString -> TimeString
>= :: TimeString -> TimeString -> Bool
$c>= :: TimeString -> TimeString -> Bool
> :: TimeString -> TimeString -> Bool
$c> :: TimeString -> TimeString -> Bool
<= :: TimeString -> TimeString -> Bool
$c<= :: TimeString -> TimeString -> Bool
< :: TimeString -> TimeString -> Bool
$c< :: TimeString -> TimeString -> Bool
compare :: TimeString -> TimeString -> Ordering
$ccompare :: TimeString -> TimeString -> Ordering
$cp1Ord :: Eq TimeString
Ord, Int -> TimeString -> ShowS
[TimeString] -> ShowS
TimeString -> String
(Int -> TimeString -> ShowS)
-> (TimeString -> String)
-> ([TimeString] -> ShowS)
-> Show TimeString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeString] -> ShowS
$cshowList :: [TimeString] -> ShowS
show :: TimeString -> String
$cshow :: TimeString -> String
showsPrec :: Int -> TimeString -> ShowS
$cshowsPrec :: Int -> TimeString -> ShowS
Show)

-- | A 'String' representing a date.
newtype DateString = DateString { DateString -> String
getDateString :: String }
  deriving (DateString -> DateString -> Bool
(DateString -> DateString -> Bool)
-> (DateString -> DateString -> Bool) -> Eq DateString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DateString -> DateString -> Bool
$c/= :: DateString -> DateString -> Bool
== :: DateString -> DateString -> Bool
$c== :: DateString -> DateString -> Bool
Eq, Eq DateString
Eq DateString
-> (DateString -> DateString -> Ordering)
-> (DateString -> DateString -> Bool)
-> (DateString -> DateString -> Bool)
-> (DateString -> DateString -> Bool)
-> (DateString -> DateString -> Bool)
-> (DateString -> DateString -> DateString)
-> (DateString -> DateString -> DateString)
-> Ord DateString
DateString -> DateString -> Bool
DateString -> DateString -> Ordering
DateString -> DateString -> DateString
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 :: DateString -> DateString -> DateString
$cmin :: DateString -> DateString -> DateString
max :: DateString -> DateString -> DateString
$cmax :: DateString -> DateString -> DateString
>= :: DateString -> DateString -> Bool
$c>= :: DateString -> DateString -> Bool
> :: DateString -> DateString -> Bool
$c> :: DateString -> DateString -> Bool
<= :: DateString -> DateString -> Bool
$c<= :: DateString -> DateString -> Bool
< :: DateString -> DateString -> Bool
$c< :: DateString -> DateString -> Bool
compare :: DateString -> DateString -> Ordering
$ccompare :: DateString -> DateString -> Ordering
$cp1Ord :: Eq DateString
Ord, Int -> DateString -> ShowS
[DateString] -> ShowS
DateString -> String
(Int -> DateString -> ShowS)
-> (DateString -> String)
-> ([DateString] -> ShowS)
-> Show DateString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DateString] -> ShowS
$cshowList :: [DateString] -> ShowS
show :: DateString -> String
$cshow :: DateString -> String
showsPrec :: Int -> DateString -> ShowS
$cshowsPrec :: Int -> DateString -> ShowS
Show)

-- | Pre-processor configuration parameterized over a functor. This is
-- used to normalize partial configurations, @ConfigF Maybe@, and
-- configurations suitable for the pre-processor logic, @ConfigF
-- Identity@. Specifically, the source file name of the file being
-- processed /must/ be set.
data ConfigF f = Config { ConfigF f -> f String
curFileNameF        :: f FilePath
                          -- ^ Name of the file being
                          -- preprocessed. Hpp will update this as new
                          -- files are included. The user must set it
                          -- manually for the starting input file.
                        , ConfigF f -> f [String]
includePathsF       :: f [FilePath]
                        -- ^ Paths to be searched for included files.
                        , ConfigF f -> f Bool
spliceLongLinesF    :: f Bool
                        -- ^ A backslash as the last character of a
                        -- line causes the next line to be appended to
                        -- the current one eliding the newline
                        -- character present in the source input.
                        , ConfigF f -> f Bool
eraseCCommentsF     :: f Bool
                        -- ^ Erase line comments (starting with @//@)
                        -- and block comments (delimited by @/*@ and
                        -- @*/@).
                        , ConfigF f -> f Bool
inhibitLinemarkersF :: f Bool
                        -- ^ Do not emit @#line@ directives.
                        , ConfigF f -> f Bool
replaceTrigraphsF   :: f Bool
                        -- ^ Replace trigraph sequences (each of which
                        -- starts with two consecutive question marks
                        -- (@\"??\"@) with the characters they encode.
                        , ConfigF f -> f DateString
prepDateF           :: f DateString
                        -- ^ Format string for @\_\_DATE\_\_@.
                        , ConfigF f -> f TimeString
prepTimeF           :: f TimeString
                        -- ^ Format string for @\_\_TIME\_\_@.
                       }

-- | A fully-populated configuration for the pre-processor.
type Config = ConfigF Identity

deriving instance Show (ConfigF Identity)

-- | Ensure that required configuration fields are supplied.
realizeConfig :: ConfigF Maybe -> Maybe Config
realizeConfig :: ConfigF Maybe -> Maybe (ConfigF Identity)
realizeConfig (Config (Just String
fileName)
                      (Just [String]
paths)
                      (Just Bool
spliceLines)
                      (Just Bool
comments)
                      (Just Bool
inhibitLines)
                      (Just Bool
trigraphs)
                      (Just DateString
pdate)
                      (Just TimeString
ptime)) =
  ConfigF Identity -> Maybe (ConfigF Identity)
forall a. a -> Maybe a
Just (Identity String
-> Identity [String]
-> Identity Bool
-> Identity Bool
-> Identity Bool
-> Identity Bool
-> Identity DateString
-> Identity TimeString
-> ConfigF Identity
forall (f :: * -> *).
f String
-> f [String]
-> f Bool
-> f Bool
-> f Bool
-> f Bool
-> f DateString
-> f TimeString
-> ConfigF f
Config (String -> Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
fileName) ([String] -> Identity [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
paths) (Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
spliceLines) (Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
comments)
               (Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
inhibitLines) (Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
trigraphs) (DateString -> Identity DateString
forall (f :: * -> *) a. Applicative f => a -> f a
pure DateString
pdate) (TimeString -> Identity TimeString
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeString
ptime))
realizeConfig ConfigF Maybe
_ = Maybe (ConfigF Identity)
forall a. Maybe a
Nothing

-- | Extract the current file name from a configuration.
curFileName :: Config -> FilePath
curFileName :: ConfigF Identity -> String
curFileName = Identity String -> String
forall a. Identity a -> a
runIdentity (Identity String -> String)
-> (ConfigF Identity -> Identity String)
-> ConfigF Identity
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity String
forall (f :: * -> *). ConfigF f -> f String
curFileNameF

-- | Extract the include paths name from a configuration.
includePaths :: Config -> [FilePath]
includePaths :: ConfigF Identity -> [String]
includePaths = Identity [String] -> [String]
forall a. Identity a -> a
runIdentity (Identity [String] -> [String])
-> (ConfigF Identity -> Identity [String])
-> ConfigF Identity
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity [String]
forall (f :: * -> *). ConfigF f -> f [String]
includePathsF

-- | Determine if continued long lines should be spliced.
spliceLongLines :: Config -> Bool
spliceLongLines :: ConfigF Identity -> Bool
spliceLongLines = Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (ConfigF Identity -> Identity Bool) -> ConfigF Identity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity Bool
forall (f :: * -> *). ConfigF f -> f Bool
spliceLongLinesF

-- | Determine if C-style comments should be erased.
eraseCComments :: Config -> Bool
eraseCComments :: ConfigF Identity -> Bool
eraseCComments = Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (ConfigF Identity -> Identity Bool) -> ConfigF Identity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity Bool
forall (f :: * -> *). ConfigF f -> f Bool
eraseCCommentsF

-- | Determine if generation of linemarkers should be inhibited.
inhibitLinemarkers :: Config -> Bool
inhibitLinemarkers :: ConfigF Identity -> Bool
inhibitLinemarkers = Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (ConfigF Identity -> Identity Bool) -> ConfigF Identity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity Bool
forall (f :: * -> *). ConfigF f -> f Bool
inhibitLinemarkersF

-- | Determine if trigraph sequences should be replaced.
replaceTrigraphs :: Config -> Bool
replaceTrigraphs :: ConfigF Identity -> Bool
replaceTrigraphs = Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (ConfigF Identity -> Identity Bool) -> ConfigF Identity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity Bool
forall (f :: * -> *). ConfigF f -> f Bool
replaceTrigraphsF

-- | The date the pre-processor was run on.
prepDate :: Config -> DateString
prepDate :: ConfigF Identity -> DateString
prepDate = Identity DateString -> DateString
forall a. Identity a -> a
runIdentity (Identity DateString -> DateString)
-> (ConfigF Identity -> Identity DateString)
-> ConfigF Identity
-> DateString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity DateString
forall (f :: * -> *). ConfigF f -> f DateString
prepDateF

-- | The time of the active pre-processor invocation.
prepTime :: Config -> TimeString
prepTime :: ConfigF Identity -> TimeString
prepTime = Identity TimeString -> TimeString
forall a. Identity a -> a
runIdentity (Identity TimeString -> TimeString)
-> (ConfigF Identity -> Identity TimeString)
-> ConfigF Identity
-> TimeString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigF Identity -> Identity TimeString
forall (f :: * -> *). ConfigF f -> f TimeString
prepTimeF

-- | A default configuration with no current file name set. Note that
-- long line splicing is enabled, C++-style comments are erased, #line
-- markers are inhibited, and trigraph replacement is disabled.
defaultConfigF :: ConfigF Maybe
defaultConfigF :: ConfigF Maybe
defaultConfigF = Maybe String
-> Maybe [String]
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe DateString
-> Maybe TimeString
-> ConfigF Maybe
forall (f :: * -> *).
f String
-> f [String]
-> f Bool
-> f Bool
-> f Bool
-> f Bool
-> f DateString
-> f TimeString
-> ConfigF f
Config Maybe String
forall a. Maybe a
Nothing ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [])
                        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
                        (DateString -> Maybe DateString
forall a. a -> Maybe a
Just (String -> DateString
DateString String
"??? ?? ????"))
                        (TimeString -> Maybe TimeString
forall a. a -> Maybe a
Just (String -> TimeString
TimeString String
"??:??:??"))

-- | Format a date according to the C spec.
formatPrepDate :: UTCTime -> DateString
formatPrepDate :: UTCTime -> DateString
formatPrepDate = String -> DateString
DateString (String -> DateString)
-> (UTCTime -> String) -> UTCTime -> DateString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%b %e %Y"

-- | Format a time according to the C spec.
formatPrepTime :: UTCTime -> TimeString
formatPrepTime :: UTCTime -> TimeString
formatPrepTime = String -> TimeString
TimeString (String -> TimeString)
-> (UTCTime -> String) -> UTCTime -> TimeString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%T"

-- | A default preprocessor configuration with date and time stamps
-- taken from the current system time.
defaultConfigFNow :: IO (ConfigF Maybe)
defaultConfigFNow :: IO (ConfigF Maybe)
defaultConfigFNow = do UTCTime
now <- IO UTCTime
getCurrentTime
                       let d :: DateString
d = UTCTime -> DateString
formatPrepDate UTCTime
now
                           t :: TimeString
t = UTCTime -> TimeString
formatPrepTime UTCTime
now
                       ConfigF Maybe -> IO (ConfigF Maybe)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigF Maybe -> IO (ConfigF Maybe))
-> ConfigF Maybe -> IO (ConfigF Maybe)
forall a b. (a -> b) -> a -> b
$ ConfigF Maybe
defaultConfigF { prepDateF :: Maybe DateString
prepDateF = DateString -> Maybe DateString
forall a. a -> Maybe a
Just DateString
d
                                               , prepTimeF :: Maybe TimeString
prepTimeF = TimeString -> Maybe TimeString
forall a. a -> Maybe a
Just TimeString
t }

-- * Lens-like accessors for Config

-- | Lens for the "splice long lines" option (prepend a line ending
-- with a backslash to the next line).
spliceLongLinesL :: Functor f => (Bool -> f Bool) -> Config -> f Config
spliceLongLinesL :: (Bool -> f Bool) -> ConfigF Identity -> f (ConfigF Identity)
spliceLongLinesL Bool -> f Bool
f ConfigF Identity
cfg = (\Bool
x -> ConfigF Identity
cfg { spliceLongLinesF :: Identity Bool
spliceLongLinesF = Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x })
                         (Bool -> ConfigF Identity) -> f Bool -> f (ConfigF Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f (ConfigF Identity -> Bool
spliceLongLines ConfigF Identity
cfg)

-- | Lens for the "erase C-style comments" option (comments delimited
-- by @/*@ and @*/@).
eraseCCommentsL :: Functor f => (Bool -> f Bool) -> Config -> f Config
eraseCCommentsL :: (Bool -> f Bool) -> ConfigF Identity -> f (ConfigF Identity)
eraseCCommentsL Bool -> f Bool
f ConfigF Identity
cfg = (\Bool
x -> ConfigF Identity
cfg { eraseCCommentsF :: Identity Bool
eraseCCommentsF = Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x })
                        (Bool -> ConfigF Identity) -> f Bool -> f (ConfigF Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f (ConfigF Identity -> Bool
eraseCComments ConfigF Identity
cfg)

-- | Lens for the "inhibit line markers" option. Option to disable the
-- emission of #line pragmas in the output.
inhibitLinemarkersL :: Functor f => (Bool -> f Bool) -> Config -> f Config
inhibitLinemarkersL :: (Bool -> f Bool) -> ConfigF Identity -> f (ConfigF Identity)
inhibitLinemarkersL Bool -> f Bool
f ConfigF Identity
cfg = (\Bool
x -> ConfigF Identity
cfg { inhibitLinemarkersF :: Identity Bool
inhibitLinemarkersF = Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x })
                            (Bool -> ConfigF Identity) -> f Bool -> f (ConfigF Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f (ConfigF Identity -> Bool
inhibitLinemarkers ConfigF Identity
cfg)

-- | Lens for the "replace trigraphs" option.
replaceTrigraphsL :: Functor f => (Bool -> f Bool) -> Config -> f Config
replaceTrigraphsL :: (Bool -> f Bool) -> ConfigF Identity -> f (ConfigF Identity)
replaceTrigraphsL Bool -> f Bool
f ConfigF Identity
cfg = (\Bool
x -> ConfigF Identity
cfg { replaceTrigraphsF :: Identity Bool
replaceTrigraphsF = Bool -> Identity Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x })
                          (Bool -> ConfigF Identity) -> f Bool -> f (ConfigF Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f (ConfigF Identity -> Bool
replaceTrigraphs ConfigF Identity
cfg)