module DSL.Parsing where

import Data.Char (isDigit, isSpace)

import DSL.Types
import DSL.BaseParsers

buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer
buildDSLLexer p f = do
  str <- p
  return DSLToken { tStr=str
                  , tData=f str
                  }

keywordL :: String -> TokenData -> DSLLexer
keywordL s d = buildDSLLexer (list s) (const d)

intrinsicL :: String -> Intrinsic -> DSLLexer
intrinsicL s i = keywordL s $ T_INTRINSIC i

wsL :: DSLLexer
wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)

boolLiteralL :: DSLLexer
boolLiteralL = t `alt` f
  where
    t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True)
    f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False)

intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer go (T_INT_LITERAL . read)
  where
    go = do
      sign   <- optional $ token '-'
      digits <- mult1 $ satisfy isDigit
      result $ maybe digits (:digits) sign

mainLexer :: Parser Char [DSLToken]
mainLexer = phrase $ mult1 $ firstOf subLexers
  where
    subLexers = [wsL]
             ++ keywords
             ++ literals
             ++ intrinsics
    keywords = map (uncurry keywordL) [ ("IF",    T_IF)
                                      , ("ELSE",  T_ELSE)
                                      , ("WHILE", T_WHILE)
                                      , ("DO",    T_DO)
                                      , ("END",   T_END)
                                      ]
    literals = [ boolLiteralL
               , intLiteralL
               ]
    intrinsics = map (uncurry intrinsicL) [ (".",    I_DUMP)
                                          , ("DROP", I_DROP)
                                          , ("SWAP", I_SWAP)
                                          , ("DUP",  I_DUP)
                                          , ("OVER", I_OVER)
                                          , ("ROT",  I_ROT)
                                          , ("+",    I_PLUS)
                                          , ("-",    I_MINUS)
                                          , ("*",    I_TIMES)
                                          , ("/%",   I_DIVMOD)
                                          , ("!",    I_NOT)
                                          , ("&&",   I_AND)
                                          , ("||",   I_OR)
                                          , ("^",    I_XOR)
                                          , ("==",   I_EQUAL)
                                          , ("<",    I_LESSTHAN)
                                          , (">",    I_GREATERTHAN)
                                          ]

stripWhitespace :: [DSLToken] -> [DSLToken]
stripWhitespace = filter $ not . (==T_WHITESPACE) . tData

------------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------------

tokenDataP :: TokenData -> DSLParser DSLToken
tokenDataP t = satisfy $ (==t) . tData

wsP :: DSLParser ()
wsP = () <$ tokenDataP T_WHITESPACE

dataLiteralP :: DSLParser StackData
dataLiteralP = do
  t <- anyToken
  case tData t of
    T_INT_LITERAL x  -> result $ StackInt x
    T_BOOL_LITERAL x -> result $ StackBool x
    _                -> flunk

pushDataP :: DSLParser Operation
pushDataP = OpPushData <$> dataLiteralP

intrinsicP :: DSLParser Operation
intrinsicP = do
  t <- anyToken
  case tData t of
    T_INTRINSIC i -> result $ OpIntrinsic i
    _             -> flunk

operationP :: DSLParser Operation
operationP = firstOf [ pushDataP
                     , intrinsicP
                     ]

linearP :: DSLParser Block
linearP = BLinear <$> mult1 operationP

ifP :: DSLParser Block
ifP = do
  c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO
  b <- mult blockP <* tokenDataP T_END
  return $ BIf c b

ifElseP :: DSLParser Block
ifElseP = do
  c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO
  b1 <- mult blockP <* tokenDataP T_ELSE
  b2 <- mult blockP <* tokenDataP T_END
  return $ BIfElse c b1 b2

whileP :: DSLParser Block
whileP = do
  c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO
  b <- mult blockP <* tokenDataP T_END
  return $ BWhile c b

blockP :: DSLParser Block
blockP = firstOf [ whileP
                 , ifElseP
                 , ifP
                 , linearP
                 ]

programP :: DSLParser Program
programP = phrase $ mult1 blockP

stringToProgram :: String -> Maybe Program
stringToProgram str = do
  (_, tokens)  <- parse mainLexer str
  (_, program) <- parse programP $ stripWhitespace tokens
  return program