module Hpp.Expansion (expandLine) where
import Control.Monad (forM)
import Data.Bool (bool)
import Data.Foldable (foldl', traverse_)
import Data.List (delete)
import Data.Maybe (listToMaybe, mapMaybe)
import Hpp.Config (Config, curFileName,
getDateString, getTimeString, prepDate, prepTime)
import Hpp.Env (lookupKey, deleteKey)
import Hpp.Streamer (source, mapTil)
import Hpp.Parser (Parser, awaitP, liftP, precede, zoomParse,
droppingWhile, awaitJust, replace, parse)
import Hpp.String (stringify)
import Hpp.Tokens (Token(..), notImportant, isImportant, detokenize)
import Hpp.Types (HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..))
unscan :: Scan -> Maybe Token
unscan (Scan t) = Just t
unscan (Rescan t) = Just t
unscan _ = Nothing
isSpaceScan :: Scan -> Bool
isSpaceScan = maybe False notImportant . unscan
isImportantScan :: Scan -> Bool
isImportantScan = maybe False isImportant . unscan
expandLine :: (HasError m, Monad m, HasEnv m)
=> Config -> Int -> Parser m Token [Token]
expandLine cfg lineNum = fmap (mapMaybe unscan) $
zoomParse (mapTil Scan)
(expandLine' True cfg lineNum)
expandLine' :: forall m. (HasError m, Monad m, HasEnv m)
=> Bool -> Config -> Int -> Parser m Scan [Scan]
expandLine' oneLine cfg lineNum = go id []
where go :: ([Scan] -> [Scan]) -> [String] -> Parser m Scan [Scan]
go acc mask = awaitP >>= maybe (return $ acc []) aux
where aux :: Scan -> Parser m Scan [Scan]
aux tok = case tok of
Unmask name -> go (acc . (tok:)) (delete name mask)
Mask name -> go (acc . (tok:)) (name : mask)
Scan (Important t) -> do ts <- expandMacro cfg lineNum t tok
if ts == [tok]
then go (acc . (tok:)) mask
else do precede $ source ts
go acc mask
Rescan (Important t) ->
do oldEnv <- liftP $
do env <- getEnv
setEnv $ foldl' (flip deleteKey) env mask
return env
ts <- expandMacro cfg lineNum t tok
liftP $ setEnv oldEnv
if ts == [tok]
then go (acc . (tok:)) mask
else precede (source ts) >> go acc mask
Scan (Other "\n")
| oneLine -> return (acc [tok])
| otherwise -> go (acc . (tok:)) mask
Rescan (Other "\n")
| oneLine -> return (acc [tok])
| otherwise -> go (acc . (tok:)) mask
_ -> go (acc . (tok:)) mask
appParse :: (Monad m, HasError m) => Parser m Scan (Maybe [[Scan]])
appParse = droppingWhile isSpaceScan >> checkApp
where imp = maybe True notImportant . unscan
checkApp = do tok <- droppingWhile imp >> awaitP
case tok >>= unscan of
Just (Important "(") -> goApp
_ -> traverse_ replace tok >> return Nothing
getArg acc = do arg <- fmap trimScan argParse
tok <- awaitJust "appParse getArg"
case unscan tok of
Just (Important ")") -> return (acc [arg])
_ -> replace tok >> getArg (acc . (arg:))
goApp = fmap Just (getArg id)
argParse :: (Monad m, HasError m) => Parser m Scan [Scan]
argParse = go id
where go acc = do tok <- awaitJust "argParse"
case unscan tok of
Just (Important s)
| s == ")" -> replace tok >> return (acc [])
| s == "," -> return (acc [])
| s == "(" -> do ts <- fmap (tok:) parenthetical
go (acc . (ts++))
| otherwise -> go (acc . (tok:))
_ -> go (acc . (tok:))
parenthetical :: (Monad m, HasError m) => Parser m Scan [Scan]
parenthetical = go id (1::Int)
where go acc 0 = return (acc [])
go acc n = do tok <- awaitJust "parenthetical"
case unscan tok of
Just (Important "(") -> go (acc . (tok:)) (n+1)
Just (Important ")") -> go (acc . (tok:)) (n1)
_ -> go (acc . (tok:)) n
argError :: Int -> String -> Int -> [String] -> Error
argError lineNum name arity args =
TooFewArgumentsToMacro lineNum $ name++"<"++show arity++">"++show args
expandFunction :: (Monad m, HasError m)
=> String -> Int -> ([([Scan],String)] -> [Scan])
-> (forall r'. [String] -> Parser m Scan r')
-> Parser m Scan [Scan]
-> Parser m Scan (Maybe [Scan])
expandFunction name arity f mkErr expand =
do margs <- appParse
case margs of
Nothing -> return Nothing
Just args
| length args /= arity -> mkErr $
map (detokenize . mapMaybe unscan) args
| otherwise ->
do args' <- forM args $ \arg -> liftP (parse expand (source arg))
let raw = map (detokenize . mapMaybe unscan) args
return . Just $ Mask name : f (zip args' raw) ++ [Unmask name]
lookupEnv :: (Monad m, HasEnv m)
=> String -> Parser m i (Maybe Macro)
lookupEnv s = liftP $ getEnv >>= traverse aux . lookupKey s
where aux (m, env') = setEnv env' >> return m
expandMacro :: (Monad m, HasError m, HasEnv m)
=> Config -> Int -> String -> Scan -> Parser m Scan [Scan]
expandMacro cfg lineNum name tok =
case name of
"__LINE__" -> simple $ show lineNum
"__FILE__" -> simple . stringify $ curFileName cfg
"__DATE__" -> simple . stringify . getDateString $ prepDate cfg
"__TIME__" -> simple . stringify . getTimeString $ prepTime cfg
_ -> do mm <- lookupEnv name
case mm of
Nothing -> return [tok]
Just m ->
case m of
Object t' ->
return $ Mask name : map Rescan (spaced t') ++ [Unmask name]
Function arity f ->
let ex = expandLine' False cfg lineNum
err = liftP . throwError
. argError lineNum name arity
in do mts <- expandFunction name arity f err ex
case mts of
Nothing -> return [tok]
Just ts -> return ts
where simple s = return [Rescan (Important s)]
spaced xs = pre ++ pos
where importantChar (Important [c]) = elem c oops
importantChar _ = False
pre = bool xs (Other " ":xs)$
(maybe False importantChar $ listToMaybe xs)
pos = bool [] [Other " "] $
(maybe False importantChar $ listToMaybe (reverse xs))
oops = "-+*.><"
trimScan :: [Scan] -> [Scan]
trimScan [] = []
trimScan (t:ts) | isSpaceScan t = trimScan ts
| isImportantScan t = t : trimScanAux Nothing ts
| otherwise = t : trimScan ts
trimScanAux :: Maybe Scan -> [Scan] -> [Scan]
trimScanAux _ [] = []
trimScanAux spc (t : ts)
| isSpaceScan t = trimScanAux (Just (Scan (Other " "))) ts
| isImportantScan t = maybe [] (:[]) spc ++ (t : trimScanAux Nothing ts)
| otherwise = t : trimScanAux spc ts