Parser.hs

module Parser where

import Data.Char

data Token = OpenPar
           | ClosPar
           | Fun String
           | Value String
           | Error
           deriving (Show)

tokenize :: String -> [Token]
tokenize s
  | checkPars s 0 = tokenize' s False
  | otherwise     = [Error]
  where
    checkPars "" n      = n == 0
    checkPars ('(':s) n = checkPars s (n+1)
    checkPars (')':s) n = checkPars s (n-1)
    checkPars (_:s) n   = checkPars s n

    tokenize' "" b      = []
    tokenize' ('(':s) b = OpenPar : tokenize' s True
    tokenize' (')':s) b = ClosPar : tokenize' s b
    tokenize' s b 
      | isDigit $ head word =
          (Value word) : tokenize' rst b
      | b                   =
          (Fun word) : tokenize' rst False
      | otherwise           = [Error]
      where
        (word,rst)        = nextW s ""
        nextW "" acc      = (acc,"")
        nextW (' ':s) acc = (acc,s)
        nextW (')':s) acc = (acc,(')':s')) where
          s' = case s of
            (' ':rst) -> rst --
            _         -> s
        nextW (c:s) acc   = nextW s (acc ++ [c])

data AST = Vid String
         | Fid String
         | Exp [AST]
         deriving (Eq,Show)
                  
toAST :: [Token] -> AST
toAST ls = toAST' ls ([],Exp [])
  where
    toAST' [] (a,b)
      | a == []   = b
      | otherwise = Exp $ a
    toAST' (Error:_) _ = Fid $ "invalid expression"
    toAST' (OpenPar:s) (a,b) =
      case rst of
       [] -> ast
       _  -> toAST' rst (a++[ast],b)
      where (rans,rst) = nextClos s 0 --
            ast        = toAST' rans ([],b)
    toAST' (ClosPar:s) (a,b) = toAST' s (a,b)
    -- only ever preceded by an open par
    toAST' ((Fun x):s) (a,b) = toAST' s (a++[(Fid x)], b)
    -- can appear without par
    toAST' ((Value x):s) (a,b)
      | a == []   = toAST' s ([], (Vid x))
      | otherwise = toAST' s (a++[(Vid x)],b)

    nextClos [] _ = ([],[])
    nextClos (ClosPar:ts) n
      | n == 0    = ([ClosPar],ts)
      | otherwise = (ClosPar:ts', rst)
      where (ts',rst) = nextClos ts (n-1)
    nextClos (OpenPar:ts) n = (OpenPar:ts', rst)
      where (ts',rst) = nextClos ts (n+1)
    nextClos (t:ts) n = (t:ts', rst)
      where (ts',rst) = nextClos ts n

test = toAST . tokenize

data Haskell = N Int
             | L [Haskell]
             | F String

instance Show Haskell where
  show (N x)  = show x
  show (L xs) = show xs
  show (F s)  = s

stringToInt :: String -> Int
stringToInt cs = stringToInt' $ reverse cs
  where
    stringToInt' ""     = 0
    stringToInt' (c:cs) =
      (digitToInt c) + (10 * (stringToInt' cs))

interp :: AST -> Haskell
interp (Vid s)    = N $ stringToInt $ s
interp (Fid s)    = F $ s
interp (Exp asts) =
  case asts of
   ((Fid "first"):ls:[]) -> head ls'
     where (L ls') = interp ls
   ((Fid "list"):rans)   -> L $ rans'
     where rans' = map interp rans
   ((Fid "+"):x:y:[])    ->
     let N x' = interp x
         N y' = interp y
     in N $ x' + y'
   _                     -> F $ ""

main :: IO ()
main =
  do putStr "> "
     exp <- getLine
     putStrLn $ show $ interp $ test exp
     main