module DSL.Parsing where

import Data.Char (isDigit, isSpace)

import DSL.Types
import DSL.BaseParsers

buildDSLLexer :: Parser Char [Char] -> TokenTag -> DSLLexer
buildDSLLexer p t = do
  str <- p
  return Token { tStr=str, tTag=t }

fromStringL :: String -> TokenTag -> DSLLexer
fromStringL s t = buildDSLLexer (list s) t <* peek (() <$ satisfy isSpace `alt` eof)

fromTableL :: [(String, TokenTag)] -> DSLLexer
fromTableL table = firstOf $ map (uncurry fromStringL) table

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

keywordL :: DSLLexer
keywordL = fromTableL [ ("PROC",  T_PROC)
                      , ("IF",    T_IF)
                      , ("ELSE",  T_ELSE)
                      , ("WHILE", T_WHILE)
                      , ("DO",    T_DO)
                      , ("END",   T_END)
                      ]

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

boolLiteralL :: DSLLexer
boolLiteralL = f "true" `alt` f "false"
  where
    f s = fromStringL s T_BOOL_LITERAL

stringLiteralL :: DSLLexer
stringLiteralL = buildDSLLexer go T_STRING_LITERAL
  where
    go = token '"' *> strChars <* token '"'
    strChars = concat <$> mult strChar
    strChar = list ['\\', '"'] `alt` (pure <$> satisfy (/='"'))

literalL :: DSLLexer
literalL = firstOf [ intLiteralL
                   , boolLiteralL
                   , stringLiteralL
                   ]

identifierL :: DSLLexer
identifierL = buildDSLLexer go T_IDENTIFIER
  where
    go = mult1 $ satisfy $ not . isSpace

intrinsicL :: DSLLexer
intrinsicL = fromTableL [ (".",    T_INTRINSIC I_DUMP)
                        , ("DROP", T_INTRINSIC I_DROP)
                        , ("SWAP", T_INTRINSIC I_SWAP)
                        , ("DUP",  T_INTRINSIC I_DUP)
                        , ("OVER", T_INTRINSIC I_OVER)
                        , ("ROT",  T_INTRINSIC I_ROT)
                        , ("+",    T_INTRINSIC I_PLUS)
                        , ("-",    T_INTRINSIC I_MINUS)
                        , ("*",    T_INTRINSIC I_TIMES)
                        , ("/%",   T_INTRINSIC I_DIVMOD)
                        , ("!",    T_INTRINSIC I_NOT)
                        , ("&&",   T_INTRINSIC I_AND)
                        , ("||",   T_INTRINSIC I_OR)
                        , ("^",    T_INTRINSIC I_XOR)
                        , ("==",   T_INTRINSIC I_EQUAL)
                        , ("<",    T_INTRINSIC I_LESSTHAN)
                        , (">",    T_INTRINSIC I_GREATERTHAN)
                        ]

lexemeL :: DSLLexer
lexemeL = firstOf [ keywordL
                  , literalL
                  , intrinsicL
                  , identifierL
                  ]

tokenizer :: Parser Char [Token]
tokenizer = optional wsL *> lexemeL `sepBy` wsL <* optional wsL

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

tagP :: TokenTag -> DSLParser Token
tagP t = satisfy $ (==t) . tTag

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

dataLiteralP :: DSLParser StackData
dataLiteralP = do
  Token { tTag=t, tStr=s } <- anyToken
  case (t, s) of
    (T_BOOL_LITERAL, "true")  -> result $ StackBool True
    (T_BOOL_LITERAL, "false") -> result $ StackBool False
    (T_INT_LITERAL, _)        -> result $ StackInt $ read s
    (T_STRING_LITERAL, _)     -> result $ StackString s
    _                         -> flunk

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

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

callP :: DSLParser Operation
callP = OpCall . tStr <$> tagP T_IDENTIFIER

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

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

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

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

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

procP :: DSLParser ProcSpec
procP = front `plus` back
  where
    front = tagP T_PROC >> tStr <$> tagP T_IDENTIFIER
    back  = mult blockP <* tagP T_END

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

programP :: DSLParser ([ProcSpec], Program)
programP = phrase $ procs `plus` code
  where
    procs = mult procP
    code  = mult1 blockP

stringToProgram :: String -> Maybe ([ProcSpec], Program)
stringToProgram = fmap snd . parse (tokenizer `chain` programP)