module Theme where

import List (intersperse)

import Text.ParserCombinators.Parsec
--import Text.ParserCombinators.Parsec.Token as P hiding (lexeme)
import qualified Data.Map as M

data ADT = Atom String
         | Tuple ADT [ADT]
         | Def String ADT
         | Lam [ADT] ADT
         | Variable String
         | Comp ADT ADT
         | Call ADT [ADT]
           deriving (Eq)

instance Show ADT where
    show (Atom s) = s
    show (Tuple t a) = (show t) ++ "(" ++ (concat $ intersperse ", " (map show a)) ++ ")"
    show (Def n b) = n ++ " = " ++ (show b)
    show (Lam a b) = "(" ++ (concat $ intersperse ", " (map show a)) ++ ")" ++ " -> " ++ (show b)
    show (Variable v) = v
    show (Comp a b) = (show a) ++ " . " ++ (show b)
    show (Call a args) = (show a) ++ "(" ++ (concat $ intersperse ", " (map show args)) ++ ")"
                         

type ThemeParser = Parser ADT

lexeme p = do x <- string p
              spaces
              return x

parser = do terms <- term `sepBy` (lexeme ";")
            eof
            return terms

run s = case parse parser "<code>" s of
          Left err -> show err
          Right ast -> show $ evall ast M.empty

term :: ThemeParser
term = try(def)
       <|> term' `chainr1` comp

term' =    try(adt)
       <|> try(lam)
       <|> app
       <|> between (lexeme "(") (lexeme ")") term

def :: ThemeParser
def = do m <- methodname
         args <- lamargs
         lexeme "="
         body <- term
         return (Def m body)

comp = do lexeme "."
          return (\a b -> Comp a b)

lam = do args <- lamargs
         lexeme "->"
         body <- term
         return (Lam args body)

lamargs = do lexeme "("
             args <- adt' `sepBy` (lexeme ",")
             lexeme ")"
             return args
          <|>
          do arg <- adt'
             return [arg]
          <|>
          return []

app = do m <- variable
         args <- appargs
         return (Call m args)

appargs = do lexeme "("
             args <- term `sepBy` (lexeme ",")
             lexeme ")"
             return args
          <|>
          return []

--call = do m <- methodname
--          argument <- term
--          return (Call m argument)

adt :: ThemeParser
adt = do t <- adt'
         notFollowedBy $ (char '-' >> char '>')
         notFollowedBy $ (char '=')
         return t

adt' =    try(tuple)
      <|> atom
      <|> do v <- variable
             notFollowedBy $ char '('
             return v

atom :: ThemeParser
atom = do first <- upper
          others <- many letter
          spaces
          return (Atom (first:others))

methodname = do first <- lower
                others <- many letter
                spaces
                return (first:others)

variable = do m <- methodname
              return (Variable m)
           <|>
           do lexeme "_"
              return (Variable "_")

tuple :: ThemeParser
tuple = do a <- atom
           lexeme "("
           elts <- term `sepBy1` (lexeme ",")
           lexeme ")"
           return (Tuple a elts)

main' = parseTest adt " Foo(Bar, Quux(Meh))"
main = run "iseven = (Z -> True) . (S(n) -> not(iseven(n))); not = (True -> False) . (False -> True); List(iseven(Z), iseven(S(Z)), iseven(S(S(Z))))"

match pat arg = match' pat arg M.empty

match' (pat:pats) (arg:args) bindings = do b <- match1 pat arg bindings
                                           match' pats args b
match' []         []         bindings = Just bindings
match' _          _          _        = Nothing

match1 (Atom p) (Atom a) b | p == a    = Just M.empty
                           | otherwise = Nothing

match1 (Tuple t1 p) (Tuple t2 a) b | t1 == t2  = match' p a b
                                   | otherwise = Nothing

match1 (Variable p) a    b = if M.findWithDefault a p b == a then
                                Just $ M.insert p a b
                             else
                                Nothing

match1 _           _             _ = Nothing

beta (Atom a) b          = (Atom a)
beta (Tuple n elts) b    = Tuple n (map (\e -> beta e b) elts)
beta (Def n body) b      = Def n (beta body b')
    where b' = M.delete n b
beta l@(Lam args body) b = Lam args (beta body b')
    where b' = M.filterWithKey (\k _ -> notElem k v) b
          v  = vars l
beta (Variable v) b      = case M.lookup v b of
                             Just r  -> r
                             Nothing -> (Variable v)
beta (Comp v1 v2) b      = Comp (beta v1 b) (beta v2 b)
beta (Call v args) b     = Call (beta v b) (map (\e -> beta e b) args)

vars (Lam args body) = concatMap vars args
vars (Variable v) = [v]
vars _ = []


evall ((Def n body):terms) env = evall terms (M.insert n (eval body env) env)
evall (term:[]) env = eval term env
evall (_:terms) env = evall terms env
evall [] env = error "empty program"

eval (Call (Lam pat body) args) env = case match pat args of
                                        Just b -> eval (beta body b) env
                                        Nothing -> body
eval (Call (Variable v) args) env = case M.lookup v env of
                                      Just r -> eval (Call r (map (\e -> eval e env) args)) env
                                      Nothing -> error $ "undefined call variable " ++ v

eval (Call (Comp (Lam p1 b1) o) args) env =
      case match p1 args of
        Just b -> eval (beta b1 b) env
        Nothing -> eval (Call o args) env

eval (Call x y) env = error $ show x

eval (Variable v) env =  case M.lookup v env of
                           Just r -> eval r env
                           Nothing -> error $ "undefined variable " ++ v

eval (Comp a b) env = Comp (eval a env) (eval b env)

eval (Tuple t a) env = Tuple t (map (\e -> eval e env) a)

eval o env = o