module DSL.Parsing where

import Data.Char (isDigit, isSpace)

import DSL.Types
import DSL.Util
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 = prependError "wsL:" $ buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE

commentL :: DSLLexer
commentL = prependError "commentL" $ buildDSLLexer go T_COMMENT
  where
    delim = list "'''"
    go = delim *> (fmap fst $ stopAfter delim)

keywordL :: DSLLexer
keywordL = prependError "keywordL:" $ fromTableL t
  where
    t = [ ("PROC",  T_PROC)
        , ("IF",    T_IF)
        , ("ELIF",  T_ELIF)
        , ("ELSE",  T_ELSE)
        , ("WHILE", T_WHILE)
        , ("DO",    T_DO)
        , ("END",   T_END)
        ]

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

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

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

literalL :: DSLLexer
literalL = prependError "literalL:" $ firstOf ps
  where
    ps = [ intLiteralL
         , boolLiteralL
         , stringLiteralL
         ]

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

intrinsicL :: DSLLexer
intrinsicL = prependError "intrinsicL:" $ fromTableL t
  where
    t = [ (".",    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_STRCAT)
        , ("==",   T_INTRINSIC I_EQUAL)
        , ("<",    T_INTRINSIC I_LESSTHAN)
        , (">",    T_INTRINSIC I_GREATERTHAN)
        ]

lexemeL :: DSLLexer
lexemeL = prependError "lexemeL:" $ firstOf ls
  where
    ls = [ commentL
         , keywordL
         , literalL
         , intrinsicL
         , identifierL
         ]

tokenizer :: Parser Char [Token]
tokenizer = prependError "tokenizer:" $ filter f <$> go
  where
    go = optional wsL *> lexemeL `sepBy` wsL <* optional wsL
    f Token { tTag=t } = t /= T_COMMENT

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

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

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

dataLiteralP :: DSLParser StackData
dataLiteralP = prependError "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 = prependError "pushDataP:" $ OpPushData <$> dataLiteralP

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

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

operationP :: DSLParser Operation
operationP = prependError "operationP:" $ firstOf ops
  where
    ops = [ pushDataP
          , intrinsicP
          , callP
          ]

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

ifP :: DSLParser Block
ifP = prependError "ifP:" $ do
  first <- (tagP T_IF *> bp <* tagP T_DO) `plus` bp
  elifs <- mult $ (tagP T_ELIF *> bp <* tagP T_DO) `plus` bp
  elze  <- optionalMaybe $ tagP T_ELSE >> bp
  _     <- tagP T_END
  return $ go $ first:elifs ++ [elseToPair elze]
  where
    bp = mult blockP
    go []          = BLinear []
    go ((c, b):xs) = BIf c b $ [go xs]
    elseToPair Nothing   = ([BLinear [OpPushData $ StackBool True]], [])
    elseToPair (Just bs) = ([BLinear [OpPushData $ StackBool True]], bs)

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

blockP :: DSLParser Block
blockP = prependError "blockP:" $ firstOf bs
  where
    bs = [ whileP
         , ifP
         , linearP
         ]

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

programP :: DSLParser [ProcSpec]
programP = prependError "programP:" $ phrase $ mult procP

stringToProgram :: String -> Either String ProcTable
stringToProgram s = case parse (tokenizer `chain` programP) s of
  Left e       -> Left $ nicePrintParserError e
  Right (_, x) -> buildProcTable x