
splitOn :: Char -> String -> [String]
splitOn    ch      str    =  splitOnRec ch str "" []

-- ssf = String So Far
-- lsf = List   So Far
splitOnRec :: Char -> String -> String -> [String] -> [String]
splitOnRec    ch      ""        ""        lsf      =  reverse lsf
splitOnRec    ch      ""        ssf       lsf      =  reverse ( ssf:lsf )
splitOnRec    ch      (x:xs)    ssf       lsf      =
  if ch == x
    then splitOnRec ch xs ""      (rssf:lsf)
    else splitOnRec ch xs (x:ssf) lsf
  where rssf = (reverse ssf)


isEmptyLine :: String -> Bool
isEmptyLine    ""     =  True
isEmptyLine    _      =  False

isNotEmptyLine :: String -> Bool
isNotEmptyLine    str    =  not (isEmptyLine str)

data Token = TokLParen
           | TokRParen
           | TokZero
           | TokIf
           | TokThen
           | TokElse
           | TokFalse
           | TokTrue
           | TokIszero
           | TokSucc
           | TokPred
  deriving (Show)

-- does this character split up 'tokens'
isDivider :: Char -> Bool
isDivider    ' '  =  True
isDivider    '('  =  True
isDivider    ')'  =  True
isDivider    _    =  False

-- should this character be thrown away
-- or should it be kept in final output
isThrowaway :: Char -> Bool
isThrowaway    ' '  =  True
isThrowaway    _    =  False

tokenizer :: String -> [Token]
tokenizer    str    =  tokenizer_inner str "" []

--                 input       current unit    output so far  final output
tokenizer_inner :: String   -> String       -> [Token]     -> [Token]
tokenizer_inner    ""          ""              osf         = reverse osf
tokenizer_inner    ""          ssf             osf         = tokenizer_inner "" "" ((tokenize (reverse ssf)):osf)
tokenizer_inner    (s:str)     ""              osf         =
  if isDivider(s)
    then
      if isThrowaway(s)
        then tokenizer_inner str   ""              osf
        else tokenizer_inner str   ""              ((tokenize [s]):osf)
    else     tokenizer_inner str   [s]             osf
tokenizer_inner    (s:str)     ssf             osf         =
  if isDivider(s)
    then
      if isThrowaway(s)
        then tokenizer_inner str   ""              ((tokenize (reverse ssf)):osf)
        else tokenizer_inner str   ""              ((tokenize [s]):(tokenize (reverse ssf)):osf)
    else     tokenizer_inner str   (s:ssf)         osf

tokenize :: String   -> Token
tokenize    "("      =  TokLParen
tokenize    ")"      =  TokRParen
tokenize    "0"      =  TokZero
tokenize    "if"     =  TokIf
tokenize    "then"   =  TokThen
tokenize    "else"   =  TokElse
tokenize    "true"   =  TokTrue
tokenize    "false"  =  TokFalse
tokenize    "iszero" =  TokIszero
tokenize    "pred"   =  TokPred
tokenize    "succ"   =  TokSucc

parse :: [Token]          -> (T,               [Token])
parse    (TokZero:  rest) =  (TZero,           rest)
parse    (TokTrue:  rest) =  (TTrue,           rest)
parse    (TokFalse: rest) =  (TFalse,          rest)

parse    (TokSucc:  rest) =  ((TSucc inner),   inner_rest)
  where (inner, inner_rest) = parse rest
parse    (TokPred:  rest) =  ((TPred inner),   inner_rest)
  where (inner, inner_rest) = parse rest
parse    (TokIszero:rest) =  ((TIszero inner), inner_rest)
  where (inner, inner_rest) = parse rest

parse    (TokIf:rest)     =  ((TIf a b c),     crest)
  where (a, arest) = parse  rest
        (b, brest) = parse arest
        (c, crest) = parse brest


-- scrub out useless tokens
clean_token_list :: [Token] -> [Token]
clean_token_list tokens = clean_token_list_inner tokens []

clean_token_list_inner :: [Token] -> [Token] -> [Token]
clean_token_list_inner []               tokens = reverse tokens
clean_token_list_inner (TokThen:rest)   tokens = clean_token_list_inner rest tokens
clean_token_list_inner (TokElse:rest)   tokens = clean_token_list_inner rest tokens
clean_token_list_inner (TokLParen:rest) tokens = clean_token_list_inner rest tokens
clean_token_list_inner (TokRParen:rest) tokens = clean_token_list_inner rest tokens
clean_token_list_inner (x:xs)           tokens = clean_token_list_inner xs (x:tokens)

-- t  ::=
--      true
--      false
--      if t then t else t
--      0
--      succ t
--      pred t
--      iszero t
data T = TTrue
       | TFalse
       | TIf     T T T
       | TZero
       | TSucc   T
       | TPred   T
       | TIszero T
  deriving (Show)

isNV :: T         -> Bool
isNV    TZero     =  True
isNV    (TSucc n) =  isNV n
isNV    _         =  False

isV  :: T      -> Bool
isV     TTrue  =  True
isV     TFalse =  True
isV     t      =  isNV t

isError :: Either T String -> Bool
isError    (Right _) = True
isError    (Left  _) = False


eval :: T -> Either T String

-- if true  then t2 else t3 -> t2 (E iftrue)
-- if false then t2 else t3 -> t3 (E iffalse)
eval   (TIf TFalse _ c) =  eval c
eval   (TIf TTrue  b _) =  eval b

-- t1 -> t1'
--  if t1 then t2 else t3
--  -> if tl' then t2 else t3
--  (E if)
eval (TIf a b c) =
  case ea of
       (Left  t) -> eval (TIf t b c)
       (Right s) -> Right s
  where ea = (eval a)

-- t1 -> t1'
--  succ t1 -> succ t1' (E succ)
eval (TSucc t) | not (isV t) =
  case (eval  t) of
       (Left  t) -> Left (TSucc t)
       (Right s) -> Right s

-- pred 0 -> 0 (E predzero)
eval (TPred TZero) = Left TZero

-- pred (succ nv1) -> nv1 (E predsucc)
eval (TPred (TSucc TZero)) = Left TZero

-- t1 -> t1'
--  pred t1 -> pred t1' (E pred)
eval (TPred t) | not (isV t) =
  case (eval  t) of
       (Left  t) -> Left (TPred t)
       (Right s) -> Right s

-- iszero 0 -> true (E iszerozero)
eval (TIszero TZero) = Left TTrue

-- iszero (succ nv1) -> false (E iszerosucc)
eval (TIszero t) | isNV t = Left TFalse

-- t1 -> t1'
--  iszero t1 -> iszero t1' (E iszero)
eval (TIszero t) | not (isV t) =
  case (eval  t) of
       (Left  t) -> eval (TIszero t)
       (Right s) -> Right s

-- allow values through
eval t | isV t = Left t

-- no match found
eval t = Right ("No eval rule match found for " ++ show t)

parse_and_eval tokens = do
  let (t, rest) = parse tokens
  if 0 == (length rest)
    then print (eval t)
    else print ("Failed to parse tokens, remaining: " ++ show rest)

main = do
  let filename = "simple.in"
  str <- readFile filename

  let lines = splitOn '\n' str

  let cleaned_lines = filter isNotEmptyLine lines

  let token_list = map tokenizer cleaned_lines
  let strs = map show token_list
  mapM_ putStrLn strs

  print "------"

  let cleaned_token_list = map clean_token_list token_list

  mapM_ parse_and_eval cleaned_token_list

  print "------"

