module DSL where

import Data.Char (isDigit, isSpace)
import Data.Foldable (foldlM)

import Parsers

------------------------------------------------------------------------------
-- Data types / instances
------------------------------------------------------------------------------

data StackData
  = StackInt Integer
  | StackBool Bool

instance Show StackData where
  show (StackInt x)      = show x
  show (StackBool True)  = "true"
  show (StackBool False) = "false"

type Stack = [StackData]

data Intrinsic
  -- core stack operations
  = I_DUMP
  | I_DROP
  | I_SWAP
  | I_DUP
  | I_OVER
  | I_ROT
  -- core arithmetic operations
  | I_PLUS
    deriving (Show, Eq)

data Operation
  = OpPushData StackData
  | OpIntrinsic Intrinsic
    deriving (Show)

type Program = [Operation]

data Machine = Machine { ok :: Bool
                       , stack :: Stack
                       }

data TokenData
  = T_WHITESPACE
  | T_INT_LITERAL Integer
  | T_INTRINSIC Intrinsic
    deriving (Show, Eq)

data DSLToken = DSLToken { tStr :: String -- original text
                         , tData :: TokenData -- actual data
                         } deriving (Show)

type DSLLexer  = Parser Char DSLToken
type DSLParser = Parser DSLToken

------------------------------------------------------------------------------
-- Lexing
------------------------------------------------------------------------------

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

intrinsicL :: String -> Intrinsic -> DSLLexer
intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i)

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

intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer (mult1 $ satisfy isDigit) (T_INT_LITERAL . read)

mainLexer :: Parser Char [DSLToken]
mainLexer = phrase $ mult1 $ firstOf subLexers
  where
    subLexers = [wsL] ++ literals ++ intrinsics
    literals = [ intLiteralL
               ]
    intrinsics = map (uncurry intrinsicL) [ (".",    I_DUMP)
                                          , ("DROP", I_DROP)
                                          , ("SWAP", I_SWAP)
                                          , ("DUP",  I_DUP)
                                          , ("OVER", I_OVER)
                                          , ("ROT",  I_ROT)
                                          , ("+",    I_PLUS)
                                          ]

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

wsP :: DSLParser ()
wsP = do
  t <- anyToken
  case tData t of
    T_WHITESPACE -> result ()
    _            -> flunk

dataLiteralP :: DSLParser StackData
dataLiteralP = do
  t <- anyToken
  case tData t of
    T_INT_LITERAL x -> result $ StackInt 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
                     ]

programP :: DSLParser Program
programP = do
  optional wsP
  ops <- operationP `sepBy1` wsP
  optional wsP
  eof
  return ops

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

------------------------------------------------------------------------------
-- Intrinsics
------------------------------------------------------------------------------

dump :: Machine -> IO Machine
dump m@Machine{ stack=x:xs } = putStrLn (show x) >> return m{ stack=xs }
dump m                       = hcf m "DUMP: stack underflow"

drop' :: Machine -> IO Machine
drop' m@Machine{ stack=_:xs } = return m{ stack=xs }
drop' m                       = hcf m "DROP: stack underflow"

swap :: Machine -> IO Machine
swap m@Machine{ stack=x:y:xs } = return m{ stack=y:x:xs }
swap m                         = hcf m "SWAP: stack underflow"

dup :: Machine -> IO Machine
dup m@Machine{ stack=x:xs } = return m{ stack=x:x:xs }
dup m                       = hcf m "DUP: stack underflow"

over :: Machine -> IO Machine
over m@Machine{ stack=x:y:xs } = return m{ stack=y:x:y:xs }
over m                         = hcf m "OVER: stack underflow"

rot :: Machine -> IO Machine
rot m@Machine{ stack=x:y:z:xs } = return m{ stack=y:z:x:xs }
rot m                           = hcf m "ROT: stack underflow"

plus :: Machine -> IO Machine
plus m@Machine{ stack=StackInt x:StackInt y:xs } = return m{ stack=StackInt (x + y):xs }
plus m@Machine{ stack=_:_:_ }                    = hcf m "PLUS: type mis-match"
plus m                                           = hcf m "PLUS: stack underflow"

------------------------------------------------------------------------------
-- Core operations
------------------------------------------------------------------------------

-- "halt and catch fire"
hcf :: Machine -> String -> IO Machine
hcf m msg = putStrLn msg >> return m{ ok=False }

pushData :: Machine -> StackData -> Machine
pushData m@Machine{ stack=xs } x = m{ stack=x:xs }

applyIntrinsic :: Intrinsic -> Machine -> IO Machine
applyIntrinsic I_DUMP = dump
applyIntrinsic I_DROP = drop'
applyIntrinsic I_SWAP = swap
applyIntrinsic I_DUP  = dup
applyIntrinsic I_OVER = over
applyIntrinsic I_ROT  = rot
applyIntrinsic I_PLUS = plus

------------------------------------------------------------------------------
-- Interpretation
------------------------------------------------------------------------------

newMachine :: Machine
newMachine = Machine { ok=True, stack=[] }

applyOperation :: Machine -> Operation -> IO Machine
-- take no action if a previous step failed
applyOperation m@Machine{ ok=False } _   = return m
applyOperation m (OpPushData x)          = return $ pushData m x
applyOperation m (OpIntrinsic i)         = applyIntrinsic i m

applyLinear :: Machine -> [Operation] -> IO Machine
applyLinear = foldlM applyOperation

interpret :: Program -> IO ()
interpret p = applyLinear newMachine p >> return ()

interpretFromString :: String -> IO ()
interpretFromString = maybe err interpret . stringToProgram
  where
    err = putStrLn "Unable to parse program"

interpretFromFile :: FilePath -> IO ()
interpretFromFile path = readFile path >>= interpretFromString