{-# LANGUAGE CPP, OverloadedStrings, ViewPatterns #-}
module Hpp.Macro (parseDefinition) where
import Data.Char (isSpace)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup ((<>))
#endif
import Hpp.StringSig
import Hpp.Tokens (trimUnimportant, importants, Token(..), isImportant)
import Hpp.Types (Macro(..), String, TOKEN, Scan(..))
import Prelude hiding (String)

-- * TOKEN Splices

-- | Deal with the two-character '##' token pasting/splicing
-- operator. We do so eliminating spaces around the @##@
-- operator.
prepTOKENSplices :: [TOKEN] -> [TOKEN]
prepTOKENSplices :: [TOKEN] -> [TOKEN]
prepTOKENSplices = (TOKEN -> TOKEN) -> [TOKEN] -> [TOKEN]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString) -> TOKEN -> TOKEN
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
forall s. Stringy s => s -> s
copy) ([TOKEN] -> [TOKEN]) -> ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TOKEN] -> [TOKEN] -> [TOKEN]
forall s. (Eq s, IsString s) => [Token s] -> [Token s] -> [Token s]
dropSpaces [] ([TOKEN] -> [TOKEN]) -> ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TOKEN] -> [TOKEN] -> [TOKEN]
forall s. (Eq s, IsString s) => [Token s] -> [Token s] -> [Token s]
mergeTOKENs []
  where -- Merges ## tokens, and reverses the input list
        mergeTOKENs :: [Token s] -> [Token s] -> [Token s]
mergeTOKENs [Token s]
acc [] = [Token s]
acc
        mergeTOKENs [Token s]
acc (Important s
"#" : Important s
"#" : [Token s]
ts) =
          [Token s] -> [Token s] -> [Token s]
mergeTOKENs (s -> Token s
forall s. s -> Token s
Important s
"##" Token s -> [Token s] -> [Token s]
forall a. a -> [a] -> [a]
: [Token s]
acc) ((Token s -> Bool) -> [Token s] -> [Token s]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Token s -> Bool) -> Token s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token s -> Bool
forall s. Token s -> Bool
isImportant) [Token s]
ts)
        mergeTOKENs [Token s]
acc (Token s
t:[Token s]
ts) = [Token s] -> [Token s] -> [Token s]
mergeTOKENs (Token s
t Token s -> [Token s] -> [Token s]
forall a. a -> [a] -> [a]
: [Token s]
acc) [Token s]
ts
        -- Drop trailing spaces and re-reverse the list
        dropSpaces :: [Token s] -> [Token s] -> [Token s]
dropSpaces [Token s]
acc [] = [Token s]
acc
        dropSpaces [Token s]
acc (t :: Token s
t@(Important s
"##") : [Token s]
ts) =
          [Token s] -> [Token s] -> [Token s]
dropSpaces (Token s
t Token s -> [Token s] -> [Token s]
forall a. a -> [a] -> [a]
: [Token s]
acc) ((Token s -> Bool) -> [Token s] -> [Token s]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Token s -> Bool) -> Token s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token s -> Bool
forall s. Token s -> Bool
isImportant) [Token s]
ts)
        dropSpaces [Token s]
acc (Token s
t:[Token s]
ts) = [Token s] -> [Token s] -> [Token s]
dropSpaces (Token s
t Token s -> [Token s] -> [Token s]
forall a. a -> [a] -> [a]
: [Token s]
acc) [Token s]
ts

-- | Parse the definition of an object-like or function macro.
parseDefinition :: [TOKEN] -> Maybe (String, Macro)
parseDefinition :: [TOKEN] -> Maybe (ByteString, Macro)
parseDefinition [TOKEN]
toks =
  case (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (TOKEN -> Bool) -> TOKEN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOKEN -> Bool
forall s. Token s -> Bool
isImportant) [TOKEN]
toks of
    (Important ByteString
name:Important ByteString
"(":[TOKEN]
rst) ->
      let params :: [ByteString]
params = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
")") ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
",") ([TOKEN] -> [ByteString]
forall s. [Token s] -> [s]
importants [TOKEN]
rst)
          body :: [TOKEN]
body = [TOKEN] -> [TOKEN]
forall s. [Token s] -> [Token s]
trimUnimportant ([TOKEN] -> [TOKEN]) -> ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TOKEN] -> [TOKEN]
forall a. [a] -> [a]
tail ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall a b. (a -> b) -> a -> b
$ (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TOKEN -> TOKEN -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
")") [TOKEN]
toks
          macro :: Macro
macro = Int -> ([([Scan], ByteString)] -> [Scan]) -> Macro
Function ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
params) ([ByteString] -> [TOKEN] -> [([Scan], ByteString)] -> [Scan]
functionMacro [ByteString]
params [TOKEN]
body)
      in (ByteString, Macro) -> Maybe (ByteString, Macro)
forall a. a -> Maybe a
Just (ByteString
name, Macro
macro)
    (Important ByteString
name:[TOKEN]
_) ->
      let rhs :: [TOKEN]
rhs = case (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TOKEN -> TOKEN -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
name) [TOKEN]
toks of
                  [] -> [ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
""]
                  str :: [TOKEN]
str@(TOKEN
_:[TOKEN]
t)
                    | (TOKEN -> Bool) -> [TOKEN] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (TOKEN -> Bool) -> TOKEN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOKEN -> Bool
forall s. Token s -> Bool
isImportant) [TOKEN]
str -> [ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
""]
                    | Bool
otherwise -> [TOKEN] -> [TOKEN]
forall s. [Token s] -> [Token s]
trimUnimportant [TOKEN]
t
      in (ByteString, Macro) -> Maybe (ByteString, Macro)
forall a. a -> Maybe a
Just (ByteString -> ByteString
forall s. Stringy s => s -> s
copy ByteString
name, [TOKEN] -> Macro
Object ((TOKEN -> TOKEN) -> [TOKEN] -> [TOKEN]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString) -> TOKEN -> TOKEN
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
forall s. Stringy s => s -> s
copy) [TOKEN]
rhs))
    [TOKEN]
_ -> Maybe (ByteString, Macro)
forall a. Maybe a
Nothing

-- * Function-like macros as Haskell functions

-- | Drop spaces following @'#'@ characters.
prepStringify :: [TOKEN] -> [TOKEN]
prepStringify :: [TOKEN] -> [TOKEN]
prepStringify [] = []
prepStringify (Important ByteString
"#" : [TOKEN]
ts) =
  case (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (TOKEN -> Bool) -> TOKEN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOKEN -> Bool
forall s. Token s -> Bool
isImportant) [TOKEN]
ts of
    (Important ByteString
t : [TOKEN]
ts') -> ByteString -> TOKEN
forall s. s -> Token s
Important (Char -> ByteString -> ByteString
forall s. Stringy s => Char -> s -> s
cons Char
'#' ByteString
t) TOKEN -> [TOKEN] -> [TOKEN]
forall a. a -> [a] -> [a]
: [TOKEN] -> [TOKEN]
prepStringify [TOKEN]
ts'
    [TOKEN]
_ -> ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
"#" TOKEN -> [TOKEN] -> [TOKEN]
forall a. a -> [a] -> [a]
: [TOKEN]
ts
prepStringify (TOKEN
t:[TOKEN]
ts) = TOKEN
t TOKEN -> [TOKEN] -> [TOKEN]
forall a. a -> [a] -> [a]
: [TOKEN] -> [TOKEN]
prepStringify [TOKEN]
ts

-- | Concatenate tokens separated by @'##'@.
paste :: [Scan] -> [Scan]
paste :: [Scan] -> [Scan]
paste [] = []
paste (Rescan (Important ByteString
s) : Rescan (Important ByteString
"##") : Rescan (Important ByteString
t) : [Scan]
ts) =
  [Scan] -> [Scan]
paste (TOKEN -> Scan
Rescan (ByteString -> TOKEN
forall s. s -> Token s
Important (ByteString -> ByteString
forall s. Stringy s => s -> s
trimSpaces ByteString
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> ByteString -> ByteString
forall s. Stringy s => (Char -> Bool) -> s -> s
sdropWhile Char -> Bool
isSpace ByteString
t)) Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [Scan]
ts)
paste (Scan
t:[Scan]
ts) = Scan
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [Scan] -> [Scan]
paste [Scan]
ts

-- | @functionMacro parameters body arguments@ substitutes @arguments@
-- for @parameters@ in @body@ and performs stringification for uses of
-- the @#@ operator and token concatenation for the @##@ operator.
functionMacro :: [String] -> [TOKEN] -> [([Scan],String)] -> [Scan]
functionMacro :: [ByteString] -> [TOKEN] -> [([Scan], ByteString)] -> [Scan]
functionMacro [ByteString]
params [TOKEN]
body = [Scan] -> [Scan]
paste
                          ([Scan] -> [Scan])
-> ([([Scan], ByteString)] -> [Scan])
-> [([Scan], ByteString)]
-> [Scan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TOKEN] -> [(ByteString, ([Scan], ByteString))] -> [Scan]
subst [TOKEN]
body'
                          -- . M.fromList
                          ([(ByteString, ([Scan], ByteString))] -> [Scan])
-> ([([Scan], ByteString)] -> [(ByteString, ([Scan], ByteString))])
-> [([Scan], ByteString)]
-> [Scan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString]
-> [([Scan], ByteString)] -> [(ByteString, ([Scan], ByteString))]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
params'
  where params' :: [ByteString]
params' = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
forall s. Stringy s => s -> s
copy [ByteString]
params
        subst :: [TOKEN] -> [(ByteString, ([Scan], ByteString))] -> [Scan]
subst [TOKEN]
toks [(ByteString, ([Scan], ByteString))]
gamma = [TOKEN] -> [Scan]
go [TOKEN]
toks
          where go :: [TOKEN] -> [Scan]
go [] = []
                go (p :: TOKEN
p@(Important ByteString
"##"):t :: TOKEN
t@(Important ByteString
s):[TOKEN]
ts) =
                  case ByteString
-> [(ByteString, ([Scan], ByteString))]
-> Maybe ([Scan], ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
s [(ByteString, ([Scan], ByteString))]
gamma of
                    Maybe ([Scan], ByteString)
Nothing -> TOKEN -> Scan
Rescan TOKEN
p Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                    Just ([Scan]
_,ByteString
arg) ->
                      TOKEN -> Scan
Rescan TOKEN
p Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: TOKEN -> Scan
Rescan (ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
arg) Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                go (t :: TOKEN
t@(Important ByteString
s):p :: TOKEN
p@(Important ByteString
"##"):[TOKEN]
ts) =
                  case ByteString
-> [(ByteString, ([Scan], ByteString))]
-> Maybe ([Scan], ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
s [(ByteString, ([Scan], ByteString))]
gamma of
                    Maybe ([Scan], ByteString)
Nothing -> TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go (TOKEN
pTOKEN -> [TOKEN] -> [TOKEN]
forall a. a -> [a] -> [a]
:[TOKEN]
ts)
                    Just ([Scan]
_,ByteString
arg) -> TOKEN -> Scan
Rescan (ByteString -> TOKEN
forall s. s -> Token s
Important ByteString
arg) Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go (TOKEN
pTOKEN -> [TOKEN] -> [TOKEN]
forall a. a -> [a] -> [a]
:[TOKEN]
ts)
                go (t :: TOKEN
t@(Important ByteString
"##"):[TOKEN]
ts) = TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                go (t :: TOKEN
t@(Important (ByteString -> Maybe (Char, ByteString)
forall s. Stringy s => s -> Maybe (Char, s)
uncons -> Just (Char
'#',ByteString
s))) : [TOKEN]
ts) =
                  case ByteString
-> [(ByteString, ([Scan], ByteString))]
-> Maybe ([Scan], ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
s [(ByteString, ([Scan], ByteString))]
gamma of
                    Maybe ([Scan], ByteString)
Nothing -> TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                    Just ([Scan]
_,ByteString
arg) ->
                      TOKEN -> Scan
Rescan (ByteString -> TOKEN
forall s. s -> Token s
Important (ByteString -> ByteString
forall s. Stringy s => s -> s
stringify ByteString
arg)) Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                go (t :: TOKEN
t@(Important ByteString
s) : [TOKEN]
ts) =
                  case ByteString
-> [(ByteString, ([Scan], ByteString))]
-> Maybe ([Scan], ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
s [(ByteString, ([Scan], ByteString))]
gamma of
                    Maybe ([Scan], ByteString)
Nothing -> TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
                    Just ([Scan]
arg,ByteString
_) -> [Scan]
arg [Scan] -> [Scan] -> [Scan]
forall a. [a] -> [a] -> [a]
++ [TOKEN] -> [Scan]
go [TOKEN]
ts
                go (TOKEN
t:[TOKEN]
ts) = TOKEN -> Scan
Rescan TOKEN
t Scan -> [Scan] -> [Scan]
forall a. a -> [a] -> [a]
: [TOKEN] -> [Scan]
go [TOKEN]
ts
        body' :: [TOKEN]
body' = [TOKEN] -> [TOKEN]
prepStringify ([TOKEN] -> [TOKEN]) -> ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TOKEN] -> [TOKEN]
prepTOKENSplices ([TOKEN] -> [TOKEN]) -> [TOKEN] -> [TOKEN]
forall a b. (a -> b) -> a -> b
$
                (TOKEN -> Bool) -> [TOKEN] -> [TOKEN]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (TOKEN -> Bool) -> TOKEN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOKEN -> Bool
forall s. Token s -> Bool
isImportant) [TOKEN]
body