module Main where
import System.Environment
import Control.Monad.Error
import Data.IORef
import Text.Parsec hiding (spaces)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef)
import IO hiding (try)

main :: IO ()
main = do args <- getArgs
          case length args of
              0 -> do flushStr "Egison, version 0.2.1.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"
                      defsRef <- newIORef []
                      runRepl defsRef
              _ -> putStrLn "Program takes only 0 argument!"

type Definitions = IORef [(String, Expression)]
              
runRepl :: Definitions -> IO ()
runRepl defs = do input <- (readPrompt "> ")
                  case input of
                    Eof -> flushStr "\nLeaving Egison.\nByebye. See you again! (^^)/\n"
                    Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs
--                    Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs
                    
readPrompt :: String -> IO Input
readPrompt prompt = flushStr prompt >> getExpression

flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout

data Input = Input String
           | Eof

getExpression :: IO Input
getExpression = catch (do str <- getExpressionHelper False 0
                          return (Input str))
                      (\_ -> return Eof)

getExpressionHelper :: Bool -> Integer -> IO String
getExpressionHelper b n = do c <- getChar
                             case c of
                               '(' -> do l <- getExpressionHelper True (n + 1)
                                         return (c : l)
                               '<' -> do l <- getExpressionHelper True (n + 1)
                                         return (c : l)
                               '[' -> do l <- getExpressionHelper True (n + 1)
                                         return (c : l)
                               '{' -> do l <- getExpressionHelper True (n + 1)
                                         return (c : l)
                               ')' -> do l <- getExpressionHelper True (n - 1)
                                         return (c : l)
                               '>' -> do l <- getExpressionHelper True (n - 1)
                                         return (c : l)
                               ']' -> do l <- getExpressionHelper True (n - 1)
                                         return (c : l)
                               '}' -> do l <- getExpressionHelper True (n - 1)
                                         return (c : l)
                               '\n' -> if n > 0
                                         then do l <- getExpressionHelper b n
                                                 return (c : l)
                                         else if b
                                                then return "\n"
                                                else getExpressionHelper b n
                               ' ' -> do l <- getExpressionHelper b n
                                         return (c : l)
                               '\t' -> do l <- getExpressionHelper b n
                                          return (c : l)
                               _ -> do l <- getExpressionHelper True n
                                       return (c : l)
                   

type IOThrowsError = ErrorT EgiError IO

data EgiError = Parser ParseError
              | UnboundVariable String
              | WithTopExpression String Expression
              | WithExpression String Expression
              | Default String

showError :: EgiError -> String
showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n"
showError (UnboundVariable name) = "Error : unbound variable : " ++ name ++ "\n"
showError (WithTopExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"
showError (WithExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"
showError (Default str) = "Error : " ++ str ++ "\n"

instance Show EgiError where show = showError

instance Error EgiError where
     noMsg = Default "An error has occured"
     strMsg = Default

type ThrowsError = Either EgiError

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runErrorT (trapError action) >>= return . extractValue

trapError :: (MonadError e m, Show e) => m String -> m String
trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

readTopExpression :: String -> IOThrowsError TopExpression
readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)

--readTopExpressionList :: String -> IOThrowsError [TopExpression]
--readTopExpressionList = liftThrows (readOrThrow (sepBy parseTopExpression spaces))
    
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "egison" input of
    Left err -> throwError (Parser err)
    Right val -> return val

executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String
executeTopExpression defs (Define name expr) = do
  liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))
  return (name ++ "\n")
executeTopExpression defs (Test expr) = do
  topFrame <- makeTopFrame defs
  val <- eval (Environment [topFrame]) expr
  ret <- liftIO (showValue val)
  return (ret ++ "\n")
executeTopExpression defs Execute = do
  topFrame <- makeTopFrame defs
  mainFn <- eval (Environment [topFrame]) (SymbolExp "main")
  args <- liftIO (newIORef (Value (World [])))
  case mainFn of
    Function funEnv fpat body
      -> do frame <- makeFrame fpat args
            iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)
            forceRecursively iValRef
            return ""
    _ -> throwError (Default "main is not function" )


--
-- Data Types
--

data TopExpression = Define String Expression
                   | Test Expression
                   | Execute

data Expression = CharacterExp Char
                | StringExp String
                | IntegerExp Integer
                | DoubleExp Double
                | SymbolExp String
                | InductiveDataExp String [Expression]
                | TupleExp [Expression]
                | CollectionExp [InnerExp]
                | PatternExp PatternExp
                | FunctionExp FunPat Expression
                | WithExp String Expression
                | DoExp Bind Expression
                | LetExp RecursiveBind Expression
                | TypeExp RecursiveBind
                | TypeRefExp Expression String
                | DeconstructorExp DeconsInfoExp
                | MatchExp Expression Expression [MatchClause]
                | MatchAllExp Expression Expression MatchClause
                | ApplyExp Expression Expression

data InnerExp = ElementExp Expression
              | SubCollectionExp Expression

data PatternExp = WildCardExp
                | PatVarExp String
                | CutPatExp Expression
                | AsPatExp String Expression
                | OfPatExp Expression
                | ValPatExp Expression

data FunPat = FunPatVar String
            | FunPatTuple [FunPat]

type Bind = [(FunPat, Expression)]

type RecursiveBind = [(String, Expression)]

type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])]

data MatchClause = MatchClause Expression Expression

data PrimePat = PrimeWildCard
              | PrimePatCharacter Char
              | PrimePatInteger Integer
              | PrimePatDouble Double
              | PrimePatVar String
              | InductivePrimePat String [PrimePat]
              | TuplePrimePat [PrimePat]
              | EmptyPat
              | ConsPat PrimePat PrimePat
              | SnocPat PrimePat PrimePat

type Association = (String, IORef IntermidiateValue)

data Frame = Frame [Association]

data Environment = Environment [Frame]

data IntermidiateValue = Closure Environment Expression
                       | Value Value

data Value = World [Action]
           | Character Char
           | Integer Integer
           | Double Double
           | InductiveData String [IORef IntermidiateValue]
           | Tuple [IORef IntermidiateValue]
           | Collection [InnerValue]
           | Pattern Pattern
           | Function Environment FunPat Expression
           | Type Frame
           | Deconstructor (IORef IntermidiateValue) DeconsInfo
           | DeconstructorFunction DeconsInfo
           | BuiltinFunction ([Value] -> IOThrowsError Value)

data Action = Read Value
            | Write Value
            | Memorize Value
            | Remember Value
           
data InnerValue = Element (IORef IntermidiateValue)
                | SubCollection (IORef IntermidiateValue)

data Pattern = WildCard
             | PatVar String
             | CutPat (IORef IntermidiateValue)
             | AsPat String (IORef IntermidiateValue)
             | OfPat [IORef IntermidiateValue]
             | ValPat Environment Expression

type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])]

--
-- Parser
--

lexer = P.makeTokenParser haskellDef

charLiteral = P.charLiteral lexer
stringLiteral = P.stringLiteral lexer
integer = P.integer lexer
float = P.float lexer
parens = P.parens lexer
angles = P.angles lexer
brackets = P.brackets lexer
braces = P.braces lexer

headSymbol :: Parser Char
headSymbol = oneOf ":+-*/="

restSymbol :: Parser Char
restSymbol = oneOf "!?:+-*/="

word :: Parser String
word = do first <- (letter <|> headSymbol)
          rest <- many (letter <|> digit <|> restSymbol)
          return (first:rest)

spaces :: Parser ()
spaces = skipMany (oneOf " \n\t")
             
spaces1 :: Parser ()
spaces1 = skipMany1 (oneOf " \n\t")
             
parseTopExpression :: Parser TopExpression
parseTopExpression = do spaces
                        parens (do try (string "define")
                                   spaces
                                   char '$'
                                   name <- word
                                   spaces
                                   expr <- parseExpression
                                   return (Define name expr)
                            <|> do try (string "test")
                                   spaces
                                   expr <- parseExpression
                                   spaces
                                   return (Test expr)
                            <|> do try (string "execute")
                                   return Execute) <?> "top expression"

parseExpression :: Parser Expression
parseExpression = do ws <- word
                     return (SymbolExp ws)
              <|> do c <- charLiteral
                     return (CharacterExp c)
              <|> do str <- stringLiteral
                     return (StringExp str)
              <|> do d <- try float
                     return (DoubleExp d)
              <|> do n <- try integer
                     return (IntegerExp n)
              <|> angles (do c <- word
                             spaces
                             vs <- sepEndBy parseExpression spaces
                             return (InductiveDataExp c vs))
              <|> brackets (do vs <- sepEndBy parseExpression spaces
                               return (TupleExp vs))
              <|> braces (do vs <- sepEndBy parseInnerExp spaces
                             return (CollectionExp vs))
              <|> try (do pat <- parsePatternExp
                          return (PatternExp pat))
              <|> parens (do try (do string "lambda"
                                     spaces1)
                             args <- parseFunPat
                             spaces
                             body <- parseExpression
                             return (FunctionExp args body)
                      <|> do try (do string "with"
                                     spaces1)
                             char '$'
                             name <- word
                             spaces
                             expr <- parseExpression
                             return (WithExp name expr)
                      <|> do try (do string "do"
                                     spaces1)
                             bind <- parseBind
                             spaces
                             body <- parseExpression
                             return (DoExp bind body)
                      <|> do try (do string "let"
                                     spaces1)
                             bind <- parseRecursiveBind
                             spaces
                             body <- parseExpression
                             return (LetExp bind body)
                      <|> do try (do string "type"
                                     spaces1)
                             bind <- parseRecursiveBind
                             return (TypeExp bind)
                      <|> do try (do string "type-ref"
                                     spaces1)
                             typ <- parseExpression
                             spaces
                             name <- word
                             return (TypeRefExp typ name)
                      <|> do try (do string "deconstructor"
                                     spaces1)
                             deconsInfo <- parseDeconsInfoExp
                             return (DeconstructorExp deconsInfo)
                      <|> do try (do string "match"
                                     spaces1)
                             tgt <- parseExpression
                             spaces
                             typ <- parseExpression
                             spaces
                             clss <- braces (sepEndBy parseMatchClause spaces)
                             return (MatchExp tgt typ clss)
                      <|> do try (do string "match-all"
                                     spaces1)
                             tgt <- parseExpression
                             spaces
                             typ <- parseExpression
                             spaces
                             cls <- parseMatchClause
                             spaces
                             return (MatchAllExp tgt typ cls)
                      <|> do try (do string "apply"
                                     spaces1)
                             fn <- parseExpression
                             spaces
                             args <- parseExpression
                             return (ApplyExp fn args)
                      <|> do fn <- parseExpression
                             spaces
                             args <- sepEndBy parseExpression spaces
                             return (ApplyExp fn (TupleExp args)))

parseInnerExp :: Parser InnerExp
parseInnerExp =  do v <- parseExpression
                    return (ElementExp v)
             <|> do char '@'
                    v <- parseExpression
                    return (SubCollectionExp v)

parseFunPat :: Parser FunPat
parseFunPat = do char '$'
                 name <- word
                 return (FunPatVar name)
          <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces))
                           case fpats of
                             [fpat] -> return fpat
                             _ -> return (FunPatTuple fpats))
                    
parseBind :: Parser Bind
parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat
                                                    spaces
                                                    expr <- parseExpression
                                                    return (fpat, expr)))
                                      spaces
                       return bs)
                       
parseRecursiveBind :: Parser RecursiveBind
parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$'
                                                             var <- word
                                                             spaces
                                                             expr <- parseExpression
                                                             return (var, expr)))
                                               spaces
                                return bs)

parseDeconsInfoExp :: Parser DeconsInfoExp
parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces)

parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)])                     
parseDeconsClause = brackets (do patCons <- word
                                 spaces
                                 typExpr <- parseExpression
                                 spaces
                                 dc2s <- braces (sepEndBy parseDeconsClause2 spaces)
                                 return (patCons, typExpr, dc2s))

parseDeconsClause2 :: Parser (PrimePat, Expression)
parseDeconsClause2 = brackets (do datPat <- parsePrimePat
                                  spaces
                                  expr <- parseExpression 
                                  return (datPat, expr))

parsePrimePat :: Parser PrimePat
parsePrimePat = do char '_'
                   return PrimeWildCard
            <|> do c <- try charLiteral
                   return (PrimePatCharacter c)
            <|> do d <- try float
                   return (PrimePatDouble d)
            <|> do n <- try integer
                   return (PrimePatInteger n)
            <|> do char '$'
                   name <- word
                   return (PrimePatVar name)
            <|> angles (do c <- word
                           spaces
                           ps <- sepEndBy parsePrimePat spaces
                           return (InductivePrimePat c ps))
            <|> brackets (do ps <- sepEndBy parsePrimePat spaces
                             return (TuplePrimePat ps))
            <|> try (do char '{'
                        spaces
                        char '}'
                        return EmptyPat)
            <|> try (do char '{'
                        spaces
                        a <- parsePrimePat
                        spaces
                        char '.'
                        b <- parsePrimePat
                        char '}'
                        return (ConsPat a b))
            <|> try (do char '{'
                        spaces
                        char '.'
                        a <- parsePrimePat
                        spaces
                        b <- parsePrimePat
                        char '}'
                        return (SnocPat a b))
              
parseMatchClause :: Parser MatchClause
parseMatchClause = brackets (do pat <- parseExpression
                                spaces
                                body <- parseExpression
                                return (MatchClause pat body))

parsePatternExp :: Parser PatternExp
parsePatternExp = do char '_'
                     return WildCardExp
              <|> do char '$'
                     name <- word
                     return (PatVarExp name)
              <|> do char '!'
                     expr <- parseExpression
                     return (CutPatExp expr)
              <|> do char ','
                     expr <- parseExpression
                     return (ValPatExp expr)
              <|> parens (do try (do string "as"
                                     spaces1)
                             char '$'
                             name <- word
                             spaces
                             expr <- parseExpression
                             return (AsPatExp name expr)
                      <|> do try (do string "of"
                                     spaces1)
                             expr <- parseExpression
                             return (OfPatExp expr)
                          )

--
-- Environment
--
getValueFromFrame :: Frame -> String -> Maybe (IORef IntermidiateValue)
getValueFromFrame (Frame []) _ = Nothing
getValueFromFrame (Frame ((var, iValRef):rest)) name =
  if name == var
    then Just iValRef
    else getValueFromFrame (Frame rest) name

getValue :: Environment -> String -> Maybe (IORef IntermidiateValue)
getValue (Environment []) name = Nothing
getValue (Environment (frame : env)) name =
  let mValRef = getValueFromFrame frame name in
  case mValRef of
    Nothing -> getValue (Environment env) name
    Just iValRef -> Just iValRef

makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue)
makeClosure env expr = newIORef (Closure env expr)
    
makeClosureList :: Environment -> [Expression] -> IO [IORef IntermidiateValue]
makeClosureList _ [] = return []
makeClosureList env (expr : exprs) = do
  iVal <- makeClosure env expr
  iVals <- makeClosureList env exprs
  return (iVal:iVals)

makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue]
makeClosureInnerVals _ [] = return []
makeClosureInnerVals env (ElementExp expr : rest) = do
  iValRef <- makeClosure env expr
  innerValRefs <- makeClosureInnerVals env rest
  return (Element iValRef : innerValRefs)
makeClosureInnerVals env (SubCollectionExp expr : rest) = do  
  iValRef <- makeClosure env expr
  innerValRefs <- makeClosureInnerVals env rest
  return (SubCollection iValRef : innerValRefs)

makeDeconsInfo :: Environment -> DeconsInfoExp -> IO DeconsInfo
makeDeconsInfo _ [] = return []
makeDeconsInfo env ((cons, typeExp, dcs):deconsInfoExp) = do
  typeIValRef <- makeClosure env typeExp
  let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in
    do deconsInfo <- makeDeconsInfo env deconsInfoExp
       return ((cons, typeIValRef, dcs2):deconsInfo)
  
makeFrame :: FunPat -> IORef IntermidiateValue -> IOThrowsError Frame
makeFrame (FunPatVar name) iValRef = do
  return (Frame [(name, iValRef)])
makeFrame (FunPatTuple []) iValRef = do
  val <- force iValRef
  case val of
    Tuple [] -> return (Frame [])
    _ -> throwError (Default "invalid number of argument")
makeFrame (FunPatTuple fpats) iValRef = do
  val <- force iValRef
  let loop fpats2 iValRefs2 = case (fpats2, iValRefs2) of
                                ([], []) -> return (Frame [])
                                ((fpat2:fps), (iValRef2:ivrs)) -> do frame1 <- makeFrame fpat2 iValRef2
                                                                     frame2 <- loop fps ivrs
                                                                     return (appendFrames frame1 frame2)
                                (_, _) -> throwError (Default "invalid number of argument") in
    case val of
      Tuple iValRefs2 -> loop fpats iValRefs2
      _ -> loop fpats [iValRef]

makeFrameMap :: FunPat -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
makeFrameMap _ [] = return []
makeFrameMap fpat (iValRef:iValRefs) = do
  frame <- makeFrame fpat iValRef
  frames <- makeFrameMap fpat iValRefs
  return (frame:frames)
      
appendFrames :: Frame -> Frame -> Frame
appendFrames (Frame frame1) (Frame frame2) = Frame (frame1 ++ frame2)
      
makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame
makeRecursiveFrame env bind =
  let vars = map fst bind in
    let exprs = map snd bind in
      do iValRefs <- liftIO (makeClosureList (Environment []) exprs)
         let newFrame = Frame (zip vars iValRefs) in
           do liftIO (makeRecursiveFrameHelper env newFrame newFrame)
              return newFrame

makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()
makeRecursiveFrameHelper _ _ (Frame []) = return ()
makeRecursiveFrameHelper env newFrame (Frame ((_, iValRef):assocs)) = do
  iVal <- readIORef iValRef
  case iVal of
    (Closure _ expr) -> writeIORef iValRef (Closure (addFrame newFrame env) expr)
  makeRecursiveFrameHelper env newFrame (Frame assocs)

makeTopFrame :: Definitions -> IOThrowsError Frame
makeTopFrame defsRef = do
  defs <- liftIO (readIORef defsRef)
  makeRecursiveFrame (Environment []) defs

addFrame :: Frame -> Environment -> Environment
addFrame frame (Environment frames) = Environment (frame:frames)
  
--
-- read and show Value
--

readValue :: String -> IOThrowsError Value
readValue exprStr = do
  expr <- readExpression exprStr
  expressionToValue expr

readExpression :: String -> IOThrowsError Expression
readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr)

expressionToValue :: Expression -> IOThrowsError Value
expressionToValue (CharacterExp c) = return (Character c)
expressionToValue (StringExp str) = do
  val <- liftIO (makeCollectionFromValueList (map Character str))
  return val
expressionToValue (IntegerExp n) = return (Integer n)
expressionToValue (DoubleExp d) = return (Double d)
expressionToValue (InductiveDataExp con exprs) = do
  vals <- expressionToValueMap exprs
  iValRefs <- liftIO (valListToIValRefList vals)
  return (InductiveData con iValRefs)
expressionToValue (TupleExp exprs) = do
  vals <- expressionToValueMap exprs
  case vals of
    [val] -> return val
    _ -> do iValRefs <- liftIO (valListToIValRefList vals)
            return (Tuple iValRefs)
expressionToValue (CollectionExp innerExps) = do
  innerVals <- innerExpToInnerValueMap innerExps
  return (Collection innerVals)
expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet :" expr)
expressionToValue expr = throwError (WithExpression "read expression is not value :" expr)

expressionToValueMap :: [Expression] -> IOThrowsError [Value]
expressionToValueMap [] = return []
expressionToValueMap (expr:exprs) = do
  val <- expressionToValue expr
  vals <- expressionToValueMap exprs
  return (val:vals)

innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue]
innerExpToInnerValueMap [] = return []
innerExpToInnerValueMap (ElementExp expr:rest) = do
  val <- expressionToValue expr
  iValRef <- liftIO (newIORef (Value val))
  innerVals <- innerExpToInnerValueMap rest
  return (Element iValRef:innerVals)
innerExpToInnerValueMap (SubCollectionExp expr:rest) = do
  val <- expressionToValue expr
  iValRef <- liftIO (newIORef (Value val))
  innerVals <- innerExpToInnerValueMap rest
  return (SubCollection iValRef:innerVals)
  
showValue :: Value -> IO String
showValue (World _) = return "#<world>"
showValue (Character c) = return (show c)
showValue (Integer n) = return (show n)
showValue (Double d) = return (show d)
showValue (InductiveData cons []) = do
  return ("<" ++ cons ++ ">")
showValue (InductiveData cons iValRefs) = do
  vals <- iValRefListToValueList iValRefs
  str <- unwordsVals vals
  return ("<" ++ cons ++ " " ++ str ++ ">")
showValue (Tuple []) = do
  return ("[]")
showValue (Tuple iValRefs) = do
  vals <- iValRefListToValueList iValRefs
  str <- unwordsVals vals
  return ("[" ++ str ++ "]")
showValue (Collection []) = do
  return ("{}")
showValue (Collection innerVals) = do
  vals <- collectionToValueList (Collection innerVals)
  str <- unwordsVals vals
  return ("{" ++ str ++ "}")
showValue (Pattern patVal) = do
  showPattern patVal
showValue (Function _ _ _) = do
  return "#<function>"
showValue (Type _) = do
  return "#<type>"
showValue (DeconstructorFunction _) = do
  return "#<deconstructor-function>"
showValue (Deconstructor _ _) = do
  return "#<deconstructor>"
showValue (BuiltinFunction _) = do
  return "#<builtin-function>"

showPattern :: Pattern -> IO String
showPattern WildCard = return "_"
showPattern (PatVar name) = return ("$" ++ name)
showPattern (CutPat _) = return "#<cut-pat>"
showPattern (AsPat _ _) = return "#<as-pat>"
showPattern (OfPat _) = return "#<of-pat>"
showPattern (ValPat _ _) = return "#<val-pat>"

unwordsList :: Show a => [a] -> String
unwordsList = unwords . map show

unwordsVals :: [Value] -> IO String
unwordsVals [] = return ""
unwordsVals (val:vals) = do
  s1 <- showValue val
  s2 <- unwordsValsHelper vals
  return (s1 ++ s2)
  
unwordsValsHelper :: [Value] -> IO String
unwordsValsHelper [] = return ""
unwordsValsHelper (val:vals) = do
  s1 <- showValue val
  s2 <- unwordsValsHelper vals
  return (" " ++ s1 ++ s2)

--
-- Eval
--

force :: IORef IntermidiateValue -> IOThrowsError Value
force iValRef = do
  iVal <- liftIO (readIORef iValRef)
  case iVal of
    Closure env expr -> do val <- eval1 env expr
                           liftIO (writeIORef iValRef (Value val))
                           return val
    Value val -> return val

eval1 :: Environment -> Expression -> IOThrowsError Value
eval1 _ (CharacterExp c) = return (Character c)
eval1 _ (StringExp str) = do
  val <- liftIO (makeCollectionFromValueList (map Character str))
  return val
eval1 _ (IntegerExp n) = return (Integer n)
eval1 _ (DoubleExp d) = return (Double d)
eval1 env (SymbolExp name) =
  let mIValRef = getValue env name in
    case mIValRef of
      Just iValRef -> force iValRef
      Nothing -> let mBuiltinFn = getBuiltin name in
                   case mBuiltinFn of
                     Just builtinFn -> return (BuiltinFunction builtinFn)
                     Nothing -> throwError (UnboundVariable name)
eval1 env (InductiveDataExp con exprs) = do
  iValRefs <- liftIO (makeClosureList env exprs)
  return (InductiveData con iValRefs)
eval1 env (TupleExp exprs) = do
  iValRefs <- liftIO (makeClosureList env exprs)
  case iValRefs of
    [iValRef] -> do force iValRef
    _ -> return (Tuple iValRefs)
eval1 env (CollectionExp innerExps) = do
  innerVals <- liftIO (makeClosureInnerVals env innerExps)
  return (Collection innerVals)
eval1 env (PatternExp patExp) = evalPattern1 env patExp
eval1 env (FunctionExp args body) = return (Function env args body)
eval1 env (WithExp name expr) = eval1 env (LetExp [(name, expr)] (SymbolExp name))
eval1 env (DoExp [] body) = eval1 env body
eval1 env (DoExp ((fpat,expr):assocs) body) = do
  iValRef <- liftIO (makeClosure env expr)
  frame <- makeFrame fpat iValRef
  eval1 (addFrame frame env) (DoExp assocs body)
eval1 env (LetExp bind body) = do
  frame <- makeRecursiveFrame env bind
  iValRef <- liftIO (newIORef (Closure (addFrame frame env) body))
  force iValRef
eval1 env (TypeExp bind) = do
  frame <- makeRecursiveFrame env bind
  return (Type frame)
eval1 env expr@(TypeRefExp typExp name) = do
  typVal <- eval1 env typExp
  case typVal of
    (Type frame) -> let mIValRef = getValueFromFrame frame name in
                      case mIValRef of
                        Nothing -> throwError (WithExpression ("no method in type : " ++ name) expr)
                        Just iValRef -> do val <- force iValRef
                                           return val
    _ -> throwError (WithExpression "first arg of typeref is not type :" expr)
eval1 env (DeconstructorExp deconsInfoExp) = do
  deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp)
  return (DeconstructorFunction deconsInfo)
eval1 env (MatchExp tgtExp typExp mCs) = do
  typIVal <- liftIO (makeClosure env typExp)
  tgtIVal <- liftIO (makeClosure env tgtExp)
  forceMatchExp env typIVal tgtIVal mCs
eval1 env (MatchAllExp tgtExp typExp mC) = do
  typIVal <- liftIO (makeClosure env typExp)
  tgtIVal <- liftIO (makeClosure env tgtExp)
  forceMatchAllExp env typIVal tgtIVal mC  
eval1 env expr@(ApplyExp fnExp argsExp) = do
  fnVal <- eval1 env fnExp
  argsIValRef <- liftIO (makeClosure env argsExp)
  case fnVal of
    BuiltinFunction builtinFn -> do argsVal <- forceRecursively argsIValRef
                                    argsVals <- liftIO (tupleToValueList argsVal)
                                    builtinFn argsVals
    Function funEnv fpat body -> do frame <- makeFrame fpat argsIValRef
                                    iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)
                                    force iValRef
    DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo)
    _ -> throwError (WithExpression "applying non-functional object :" expr)

evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value
evalPattern1 _ WildCardExp = return (Pattern WildCard)
evalPattern1 _ (PatVarExp name) = return (Pattern (PatVar name))
evalPattern1 env (CutPatExp expr) = do
  iValRef <- liftIO (makeClosure env expr)
  return (Pattern (CutPat iValRef))
evalPattern1 env (AsPatExp var expr) = do
  iValRef <- liftIO (makeClosure env expr)
  return (Pattern (AsPat var iValRef))
evalPattern1 env (OfPatExp expr) = do
  iValRef <- liftIO (makeClosure env expr)
  iValRefs <- collectionToList iValRef
  return (Pattern (OfPat iValRefs))
evalPattern1 env (ValPatExp expr) = do
  return (Pattern (ValPat env expr))

eval :: Environment -> Expression -> IOThrowsError Value
eval env expr = do
  iValRef <- liftIO (makeClosure env expr)
  val <- force iValRef
  forceValue val
  return val

forceValue :: Value -> IOThrowsError Value
forceValue (InductiveData cons iValRefs) = do
  forceRecursivelyList iValRefs
  return (InductiveData cons iValRefs)
forceValue (Tuple iValRefs) = do
  forceRecursivelyList iValRefs
  return (Tuple iValRefs)
forceValue (Collection innerVals) = do
  forceRecursivelyInnerVals innerVals
  return (Collection innerVals)
forceValue (Pattern pat) = do
  forceRecursivelyPattern pat
  return (Pattern pat)
forceValue val = return val
   
forceRecursively :: IORef IntermidiateValue -> IOThrowsError Value
forceRecursively iValRef = do
  val <- force iValRef
  forceValue val
   
forceRecursivelyList :: [IORef IntermidiateValue] -> IOThrowsError ()
forceRecursivelyList [] = return ()
forceRecursivelyList (iValRef:iValRefs) = do
  forceRecursively iValRef
  forceRecursivelyList iValRefs
                                
forceRecursivelyInnerVals :: [InnerValue] -> IOThrowsError ()
forceRecursivelyInnerVals [] = return ()
forceRecursivelyInnerVals (Element iValRef : rest) = do
  forceRecursively iValRef
  forceRecursivelyInnerVals rest
forceRecursivelyInnerVals (SubCollection iValRef : rest) = do
  forceRecursively iValRef
  forceRecursivelyInnerVals rest

forceRecursivelyPattern :: Pattern -> IOThrowsError Pattern
forceRecursivelyPattern WildCard = return WildCard
forceRecursivelyPattern (PatVar var) = return (PatVar var)
forceRecursivelyPattern (CutPat iValRef) = do
  forceRecursively iValRef
  return (CutPat iValRef)
forceRecursivelyPattern (AsPat var iValRef) = do
  forceRecursively iValRef
  return (AsPat var iValRef)
forceRecursivelyPattern (OfPat iValRefs) = do
  forceRecursivelyList iValRefs
  return (OfPat iValRefs)
forceRecursivelyPattern (ValPat onEnv expr) = do
  return (ValPat onEnv expr)
  
---
---
---

forceMatchExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> [MatchClause] -> IOThrowsError Value
forceMatchExp env typIValRef tgtIValRef (MatchClause pat expr:rest) = do
  typVals <- tupleToList typIValRef
  tgtVals <- tupleToList tgtIValRef
  patIValRef <- liftIO (makeClosure env pat)
  patVals <- tupleToList patIValRef
  matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals
  case matchs of
    [] -> forceMatchExp env typIValRef tgtIValRef rest
    (frame:_) -> do iValRef <- liftIO (makeClosure (addFrame frame env) expr)
                    force iValRef
forceMatchExp _ _ _ _ = throwError (Default "end of match clause")

forceMatchAllExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value
forceMatchAllExp env typIValRef tgtIValRef (MatchClause pat expr) = do
  typVals <- tupleToList typIValRef
  tgtVals <- tupleToList tgtIValRef
  patIValRef <- liftIO (makeClosure env pat)
  patVals <- tupleToList patIValRef
  matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals
  innerVals <- forceMatchAllExpHelper env matchs expr
  return (Collection innerVals)

forceMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue]
forceMatchAllExpHelper _ [] _ = return []
forceMatchAllExpHelper env (frame:frames) expr = do
  iValRef <- liftIO (makeClosure (addFrame frame env) expr)
  force iValRef
  rest <- forceMatchAllExpHelper env frames expr
  return (Element iValRef:rest)

patternMatchList :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
patternMatchList [] _ _ _ = return []
patternMatchList frames [] [] [] = return frames
patternMatchList frames (typRef:typRefs) (patRef:patRefs) (tgtRef:tgtRefs) = do
  typVal <- force typRef
  patVal <- force patRef
  newFrames <- patternMatch frames typVal patVal tgtRef
  patternMatchList newFrames typRefs patRefs tgtRefs
patternMatchList _ _ _ _ = throwError (Default "numbers of type, pattern, and target are different")  

patternMatch :: [Frame] -> Value -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]
patternMatch [] _ _ _ = return []
patternMatch frames _ (Pattern WildCard) _ = return frames
patternMatch frames (Type bind) (Pattern (PatVar var)) tgtIValRef = do
  case getValueFromFrame bind "var-match" of
    Nothing -> throwError (Default "no var-match")
    Just varMatchFnRef -> do varMatchFn <- force varMatchFnRef
                             case varMatchFn of
                               Function funEnv fpat body -> do argsFrame <- makeFrame fpat tgtIValRef
                                                               iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
                                                               iValRefs <- collectionToList iValRef
                                                               newFrames <- makeFrameMap (FunPatVar var) iValRefs
                                                               return (connectFrames frames newFrames)
                               _ -> throwError (Default "not function : var-match")
patternMatch frames (Type bind) (InductiveData cons patIValRefs) tgtIValRef =
  case getValueFromFrame bind "inductive-match" of
    Nothing -> throwError (Default "no inductive-match")
    Just inductiveMatchFnRef
      -> do inductiveMatchFn <- force inductiveMatchFnRef
            case inductiveMatchFn of
              DeconstructorFunction deconsInfo
                -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef
              Function funEnv fpat body
                -> do argsFrame <- makeFrame fpat tgtIValRef
                      iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
                      val <- force iValRef
                      case val of
                        Deconstructor tgtIValRef2 deconsInfo
                          -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef2
              _ -> throwError (Default "not function : inductive-match")
patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do
  patVal <- force patIValRef
  patternMatch [frame] typVal patVal tgtIValRef
patternMatch frames typVal (Pattern (AsPat name patIValRef)) tgtIValRef = undefined
patternMatch frames typVal (Pattern (OfPat patIValRefs)) tgtIValRef =
  let loop patIValRefs2 = case patIValRefs2 of
                            [] -> return []
                            patIValRef:rests -> do patVal <- force patIValRef
                                                   newFrames1 <- patternMatch frames typVal patVal tgtIValRef
                                                   newFrames2 <- loop rests
                                                   return (newFrames1 ++ newFrames2) in
    loop patIValRefs
patternMatch frames (Type bind) (Pattern (ValPat onEnv expr)) tgtIValRef = do
  case getValueFromFrame bind "equal?" of
    Nothing -> throwError (Default "no equal? function")
    Just equalFnRef -> do equalFn <- force equalFnRef
                          case equalFn of
                            Function funEnv fpat body
                              -> let loop frames2 = case frames2 of
                                                      [] -> return []
                                                      (frame:rests)
                                                        -> do iValPatRef <- liftIO (makeClosure (addFrame frame onEnv) expr)
                                                              argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef])))      
                                                              argsFrame <- makeFrame fpat argsIValRef
                                                              iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
                                                              val <- force iValRef
                                                              restFrames <- loop rests
                                                              case val of
                                                                (InductiveData "true" []) -> return (frame:restFrames)
                                                                (InductiveData "false" []) -> return restFrames
                                                                _ -> throwError (Default "invalid return value from equal? function") in
                                   loop frames
                            _ -> throwError (Default "equal? is not function")
patternMatch _ _ _ _ = throwError (Default "invalid pattern : you shold add ',' to the head of value")

doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]
doDeconstruct [] _ _ _ = throwError (Default "no match decons clause")
doDeconstruct ((pCons, innerTypeIValRef, dcs):deconsInfo) frames (InductiveData cons pats) tgtIValRef =
  if pCons == cons
    then do innerTypeIValRefs <- tupleToList innerTypeIValRef
            let loop dcs2 = case dcs2 of
                             [] -> throwError (Default "no match primitive pattern")
                             (env, primePat, expr):rest -> do mFrame <- primitivePatternMatch primePat tgtIValRef
                                                              case mFrame of
                                                                Nothing -> loop rest
                                                                Just pFrame -> do retIValRef <- liftIO (makeClosure (addFrame pFrame env) expr)
                                                                                  retIValRefs <- collectionToList retIValRef
                                                                                  patternMatchListMap frames innerTypeIValRefs pats retIValRefs in
              loop dcs
    else doDeconstruct deconsInfo frames (InductiveData cons pats) tgtIValRef
doDeconstruct _ _ _ _ = throwError (Default "at doDeconstruct : number of types, patterns, and targets are different")

patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
patternMatchListMap _ _ _ [] = return []
patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do
  tgtIValRefs <- tupleToList tgtIValRef
  frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs
  frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest
  return (frames1 ++ frames2)
  
connectFrames :: [Frame] -> [Frame] -> [Frame]
connectFrames [] _ = []
connectFrames (frame:frames) newFrames =
  (map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames)

--extractAssocs :: Frame -> [String] -> IOThrowsError Frame
--extractAssocs _ [] = return (Frame [])
--extractAssocs frame (var:vars) =
--  let mValRef = getValueFromFrame frame var in
--    case mValRef of
--      Nothing -> throwError (Default "extractAssocs")
--      Just iValRef -> do newFrame <- extractAssocs frame vars
--                         case newFrame of
--                           Frame assocs -> return (Frame ((var, iValRef):assocs))
  
---
---
---
  
primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame)
primitivePatternMatch PrimeWildCard _ = return (Just (Frame []))
primitivePatternMatch (PrimePatCharacter c) iValRef = do
  val <- force iValRef
  case val of
    Character c2 -> if c == c2
                      then return (Just (Frame []))
                      else return Nothing
    _ -> throwError (Default "primitive : not character to primitive character pat")
primitivePatternMatch (PrimePatInteger n) iValRef = do
  val <- force iValRef
  case val of
    Integer n2 -> if n == n2
                    then return (Just (Frame []))
                    else return Nothing
    _ -> throwError (Default "primitive : not integer to primitive integer pat")
--primitivePatternMatch (PrimePatDouble d) iValRef = do
--  val <- force iValRef
--  case val of
--    Integer d2 -> if d == d2
--                    then return (Just (Frame []))
--                    else return Nothing
--    _ -> throwError (Default "primitive : not double to primitive double pat")
primitivePatternMatch (PrimePatVar name) iValRef = return (Just (Frame [(name, iValRef)]))
primitivePatternMatch (InductivePrimePat pCons pPats) iValRef =  do
  val <- force iValRef
  case val of
    InductiveData cons iValRefs -> if pCons == cons
                                     then primitivePatternMatchAll pPats iValRefs
                                     else return Nothing
    _ -> throwError (Default "primitive : not inductive value to primitive inductive pattern")
primitivePatternMatch (TuplePrimePat pPats) iValRef =  do
  val <- force iValRef
  case val of
    Tuple iValRefs -> primitivePatternMatchAll pPats iValRefs
    _ -> throwError (Default "primitive : not tuple value to primitive tuple pattern")
primitivePatternMatch EmptyPat iValRef = do
  val <- force iValRef
  b <- isEmptyCollection val
  if b
    then return (Just (Frame []))
    else return Nothing
primitivePatternMatch (ConsPat carPat cdrPat) iValRef = do
  val <- force iValRef
  b <- isEmptyCollection val
  if b
    then return Nothing
    else do (carIValRef, cdrIValRef) <- consDeconstruct val
            mCarFrame <- primitivePatternMatch carPat carIValRef
            case mCarFrame of
              Nothing -> return Nothing
              Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrIValRef
                                  case mCdrFrame of
                                    Nothing -> return Nothing
                                    Just cdrFrame -> return (Just (appendFrames carFrame cdrFrame))
primitivePatternMatch (SnocPat rdcPat racPat) iValRef = do
  val <- force iValRef
  b <- isEmptyCollection val
  if b
    then return Nothing
    else do (racIValRef, rdcIValRef) <- snocDeconstruct val
            mRacFrame <- primitivePatternMatch racPat racIValRef
            case mRacFrame of
              Nothing -> return Nothing
              Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcIValRef
                                  case mRdcFrame of
                                    Just rdcFrame -> return (Just (appendFrames racFrame rdcFrame))
                                    Nothing -> return Nothing
            
primitivePatternMatchAll :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame)
primitivePatternMatchAll [] [] = return (Just (Frame []))
primitivePatternMatchAll (pat:pats) (iValRef:iValRefs) = do
  mFrame <- primitivePatternMatch pat iValRef
  case mFrame of
    Nothing -> return Nothing
    Just frame -> do mRestFrame <- primitivePatternMatchAll pats iValRefs
                     case mRestFrame of
                       Nothing -> return Nothing
                       Just restFrame -> return (Just (appendFrames frame restFrame))
primitivePatternMatchAll _ _ = throwError (Default "primitivePatternMatchAll : number of patterns and targets are different")

isEmptyCollection :: Value -> IOThrowsError Bool
isEmptyCollection (Collection []) = return True
isEmptyCollection (Collection (Element _:_)) = return False
isEmptyCollection (Collection (SubCollection subRef:rest)) = do
  subVal <- force subRef
  b <- isEmptyCollection subVal
  if b
    then isEmptyCollection (Collection rest)
    else return False
isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection")

consDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)
consDeconstruct (Collection (Element eRef:rest)) = do
  restRef <- liftIO (newIORef (Value (Collection rest)))
  return (eRef, restRef)
consDeconstruct (Collection (SubCollection subRef:rest)) = do
  subVal <- force subRef
  b <- isEmptyCollection subVal
  if b
    then consDeconstruct (Collection rest)
    else do (carRef, cdrRef) <- consDeconstruct subVal
            cdrVal <- force cdrRef
            case cdrVal of
              Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest))))
                                       return (carRef, restRef)
consDeconstruct (Collection []) = throwError (Default "empty collection")
consDeconstruct _ = throwError (Default "consDeconstruct : not collection")

snocDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)
snocDeconstruct (Collection innerVals) =
  case reverse innerVals of
    Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest))))
                            return (eRef, restRef)
    SubCollection subRef:rest
      -> do subVal <- force subRef
            b <- isEmptyCollection subVal
            if b
              then snocDeconstruct (Collection (reverse rest))
              else do (racRef, rdcRef) <- snocDeconstruct subVal
                      rdcVal <- force rdcRef
                      case rdcVal of
                        Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs))))
                                                 return (racRef, restRef)
snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection")

---
---
---

valListToIValRefList :: [Value] -> IO [IORef IntermidiateValue]
valListToIValRefList [] = return []
valListToIValRefList (val:vals) = do
  iValRef <- newIORef (Value val)
  iValRefs <- valListToIValRefList vals
  return (iValRef:iValRefs)

iValRefListToValueList :: [IORef IntermidiateValue] -> IO [Value]
iValRefListToValueList [] = return []
iValRefListToValueList (iValRef:iValRefs) = do
  iVal <- readIORef iValRef
  case iVal of
    Value val -> do vals <- iValRefListToValueList iValRefs
                    return (val:vals)
                    
tupleToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]
tupleToList iValRef = do
  val <- force iValRef
  case val of
    (Tuple iValRefs) -> return iValRefs
    val -> return [iValRef]

tupleToValueList :: Value -> IO [Value]
tupleToValueList (Tuple []) = return []
tupleToValueList (Tuple (iValRef:iValRefs)) = do
  val <- readIORef iValRef
  case val of
    Value val -> do vals <- tupleToValueList (Tuple iValRefs)
                    return (val:vals)
tupleToValueList val = return [val]  

makeTupleFromValueList :: [Value] -> IO Value
makeTupleFromValueList vals = do
  iValRefs <- makeIValRefList vals
  return (Tuple iValRefs)

makeIValRefList :: [Value] -> IO [IORef IntermidiateValue]
makeIValRefList [] = return []
makeIValRefList (val:vals) = do
  iValRef <- newIORef (Value val)
  iValRefs <- makeIValRefList vals
  return (iValRef:iValRefs)

collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]
collectionToList iValRef = do
  val <- force iValRef
  let loop val = case val of
                   (Collection []) -> return []
                   (Collection (Element eRef:rest)) -> do restRefs <- loop (Collection rest)
                                                          return (eRef : restRefs)
                   (Collection (SubCollection subRef:rest)) -> do valRefs1 <- collectionToList subRef
                                                                  valRefs2 <- loop (Collection rest)
                                                                  return (valRefs1 ++ valRefs2)
                   _ -> throwError (Default "collectionToList : not collection") in
    loop val

collectionToValueList :: Value -> IO [Value]
collectionToValueList (Collection []) = return []
collectionToValueList (Collection (Element eRef : rest)) = do
  eIVal <- readIORef eRef
  case eIVal of
    Value e -> do rest <- collectionToValueList (Collection rest)
                  return (e : rest)
collectionToValueList (Collection (SubCollection subRef : rest)) = do
  subIVal <- readIORef subRef
  case subIVal of
    Value subVal -> do vals1 <- collectionToValueList subVal
                       vals2 <- collectionToValueList (Collection rest)
                       return (vals1 ++ vals2)

makeCollectionFromValueList :: [Value] -> IO Value
makeCollectionFromValueList vals =
  let loop vals2 = case vals2 of
                    [] -> return []
                    (val:rest) -> do iValRef <- newIORef (Value val)
                                     restRefs <- loop rest
                                     return ((Element iValRef):restRefs) in
    do innerVals <- loop vals
       return (Collection innerVals)

---
--- Builtin Function
---

getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value)
getBuiltin name =
  case name of
    "read" -> Just builtinRead
    "write" -> Just builtinWrite
    "read-char" -> Just builtinReadChar
    "write-char" -> Just builtinWriteChar
    "=" -> Just builtinEqual
    "+" -> Just builtinPlus
    "-" -> Just builtinMinus
    "*" -> Just builtinMultiply
    "/" -> Just builtinDevide
    "mod" -> Just builtinMod
    "=f" -> Just builtinEqualFloat
    "+f" -> Just builtinPlusFloat
    "-f" -> Just builtinMinusFloat
    "*f" -> Just builtinMultiplyFloat
    "/f" -> Just builtinDevideFloat
--    "pi" -> Just builtinPi
    "exp" -> Just builtinExp
    "log" -> Just builtinLog
    "sqrt" -> Just builtinSqrt
    "**" -> Just builtinPower
    "log-base" -> Just builtinLogBase
    "sin" -> Just builtinSin
    "cos" -> Just builtinCos
    "tan" -> Just builtinTan
    "asin" -> Just builtinAsin
    "acos" -> Just builtinAcos
    "atan" -> Just builtinAtan
    "sinh" -> Just builtinSinh
    "cosh" -> Just builtinCosh
    "tanh" -> Just builtinTanh
    "asinh" -> Just builtinAsinh
    "acosh" -> Just builtinAcosh
    "atanh" -> Just builtinAtanh
    _ -> Nothing

builtinRead :: [Value] -> IOThrowsError Value
builtinRead [(World actions)] = do
  str <- liftIO (getExpressionHelper False 0)
  val <- readValue str
  ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])
  return ret
builtinRead _ = throwError (Default "invalid args to read")
    
builtinWrite :: [Value] -> IOThrowsError Value
builtinWrite [(World actions), val] = do
  valStr <- liftIO (showValue val)
  liftIO (flushStr valStr)
  return (World ((Write val):actions))
builtinWrite _ = throwError (Default "invalid args to write")
    
builtinReadChar :: [Value] -> IOThrowsError Value
builtinReadChar [(World actions)] = do
  c <- liftIO getChar
  ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])
  return ret
builtinReadChar _ = throwError (Default "invalid args to read-char")

builtinWriteChar :: [Value] -> IOThrowsError Value
builtinWriteChar [(World actions), (Character c)] = do
  liftIO (putChar c)
  return (World ((Write (Character c)):actions))
builtinWriteChar _ = throwError (Default "invalid args to write-char")


builtinEqual :: [Value] -> IOThrowsError Value
builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2)
                                              then return (InductiveData "true" [])
                                              else return (InductiveData "false" [])
builtinEqual _ = throwError (Default "invalid args to =")

builtinPlus :: [Value] -> IOThrowsError Value
builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2))
builtinPlus _ = throwError (Default "invalid args to +")

builtinMinus :: [Value] -> IOThrowsError Value
builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2))
builtinMinus _ = throwError (Default "invalid args to -")

builtinMultiply :: [Value] -> IOThrowsError Value
builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2))
builtinMultiply _ = throwError (Default "invalid args to *")

builtinDevide :: [Value] -> IOThrowsError Value
builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2))
builtinDevide _ = throwError (Default "invalid args to /")

builtinMod :: [Value] -> IOThrowsError Value
builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2))
builtinMod _ = throwError (Default "invalid args to mod")


builtinEqualFloat :: [Value] -> IOThrowsError Value
builtinEqualFloat [(Double n1), (Double n2)] =  if (n1 == n2)
                                                  then return (InductiveData "true" [])
                                                  else return (InductiveData "false" [])
builtinEqualFloat _ = throwError (Default "invalid args to =f")

builtinPlusFloat :: [Value] -> IOThrowsError Value
builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2))
builtinPlusFloat _ = throwError (Default "invalid args to +f")

builtinMinusFloat :: [Value] -> IOThrowsError Value
builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2))
builtinMinusFloat _ = throwError (Default "invalid args to -f")

builtinMultiplyFloat :: [Value] -> IOThrowsError Value
builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2))
builtinMultiplyFloat _ = throwError (Default "invalid args to *f")

builtinDevideFloat :: [Value] -> IOThrowsError Value
builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2))
builtinDevideFloat _ = throwError (Default "invalid args to /f")


builtinExp :: [Value] -> IOThrowsError Value
builtinExp [Double d] = return (Double (exp d))
builtinExp _ = throwError (Default "invalid args to exp")

builtinLog :: [Value] -> IOThrowsError Value
builtinLog [Double d] = return (Double (log d))
builtinLog _ = throwError (Default "invalid args to log")

builtinSqrt :: [Value] -> IOThrowsError Value
builtinSqrt [Double d] = return (Double (sqrt d))
builtinSqrt _ = throwError (Default "invalid args to sqrt")

builtinPower :: [Value] -> IOThrowsError Value
builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2))
builtinPower _ = throwError (Default "invalid args to **")

builtinLogBase :: [Value] -> IOThrowsError Value
builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2))
builtinLogBase _ = throwError (Default "invalid args to log-base")

builtinSin :: [Value] -> IOThrowsError Value
builtinSin [Double d] = return (Double (sin d))
builtinSin _ = throwError (Default "invalid args to sin")

builtinCos :: [Value] -> IOThrowsError Value
builtinCos [Double d] = return (Double (cos d))
builtinCos _ = throwError (Default "invalid args to cos")

builtinTan :: [Value] -> IOThrowsError Value
builtinTan [Double d] = return (Double (tan d))
builtinTan _ = throwError (Default "invalid args to tan")

builtinAsin :: [Value] -> IOThrowsError Value
builtinAsin [Double d] = return (Double (asin d))
builtinAsin _ = throwError (Default "invalid args to asin")

builtinAcos :: [Value] -> IOThrowsError Value
builtinAcos [Double d] = return (Double (acos d))
builtinAcos _ = throwError (Default "invalid args to acos")

builtinAtan :: [Value] -> IOThrowsError Value
builtinAtan [Double d] = return (Double (atan d))
builtinAtan _ = throwError (Default "invalid args to atan")

builtinSinh :: [Value] -> IOThrowsError Value
builtinSinh [Double d] = return (Double (sinh d))
builtinSinh _ = throwError (Default "invalid args to sinh")

builtinCosh :: [Value] -> IOThrowsError Value
builtinCosh [Double d] = return (Double (cosh d))
builtinCosh _ = throwError (Default "invalid args to cosh")

builtinTanh :: [Value] -> IOThrowsError Value
builtinTanh [Double d] = return (Double (tanh d))
builtinTanh _ = throwError (Default "invalid args to tanh")

builtinAsinh :: [Value] -> IOThrowsError Value
builtinAsinh [Double d] = return (Double (asinh d))
builtinAsinh _ = throwError (Default "invalid args to asinh")

builtinAcosh :: [Value] -> IOThrowsError Value
builtinAcosh [Double d] = return (Double (acosh d))
builtinAcosh _ = throwError (Default "invalid args to acosh")

builtinAtanh :: [Value] -> IOThrowsError Value
builtinAtanh [Double d] = return (Double (atanh d))
builtinAtanh _ = throwError (Default "invalid args to atanh")

---
--- for Debug : show Expression
---

showTopExpression :: TopExpression -> String
showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")"
showTopExpression (Test expr) = "(test " ++ show expr ++ ")"
showTopExpression Execute = "(execute)"

instance Show TopExpression where show = showTopExpression

showExpression :: Expression -> String
showExpression (CharacterExp c) = show c
showExpression (IntegerExp n) = show n
showExpression (SymbolExp name) = name
showExpression (InductiveDataExp s []) =  "<" ++ s ++ ">"
showExpression (InductiveDataExp s vs) =  "<" ++ s ++ " " ++ unwordsList vs ++ ">"
showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]"
showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}"
showExpression (PatternExp pat) = show pat
showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"
showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")"
showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")"
showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++  name ++ ")"
showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")"
showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"
showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")"
showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")"

instance Show Expression where show = showExpression

showInnerExp :: InnerExp -> String
showInnerExp (ElementExp v) = show v
showInnerExp (SubCollectionExp v) = "@" ++ show v

instance Show InnerExp where show = showInnerExp

showPatternExp :: PatternExp -> String
showPatternExp WildCardExp = "_"
showPatternExp (PatVarExp s) = "$" ++ s
showPatternExp (CutPatExp p) = "!" ++ show p
showPatternExp (AsPatExp s p) = "(as " ++ s ++ " " ++ show p ++ ")"
showPatternExp (OfPatExp ps) = "(of " ++ show ps ++ ")"
showPatternExp (ValPatExp expr) = "," ++ show expr

instance Show PatternExp where show = showPatternExp

showRecursiveBind :: RecursiveBind -> String
showRecursiveBind [] = "{}"
showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}"

showRecursiveBindHelper :: (String, Expression) -> String
showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]"

showFunPat :: FunPat -> String
showFunPat (FunPatVar name) = "$" ++ name
showFunPat (FunPatTuple []) = "[]"
showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]"

instance Show FunPat where show = showFunPat

showDeconsInfoExp :: DeconsInfoExp -> String
showDeconsInfoExp dcs = "{" ++ unwords (map showDeconsClause dcs) ++ "}"

showDeconsClause :: (String, Expression, [(PrimePat, Expression)]) -> String
showDeconsClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDeconsClause2 dc2s) ++ "})"

showDeconsClause2 :: (PrimePat, Expression) -> String
showDeconsClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"

showPrimePat :: PrimePat -> String
showPrimePat PrimeWildCard = "_"
showPrimePat (PrimePatVar name) = "$" ++ name
showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">"
showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"
showPrimePat (TuplePrimePat vs) = "[" ++ unwordsList vs ++ "]"
showPrimePat EmptyPat = "{}"
showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}"
showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"

instance Show PrimePat where show = showPrimePat

showMatchClause :: MatchClause -> String
showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"

instance Show MatchClause where show = showMatchClause

showFrame :: Frame -> String
showFrame (Frame assocs) =
  let vars = map fst assocs in
    "[" ++ unwords vars ++ "]"

instance Show Frame where show = showFrame

showFrames :: [Frame] -> String
showFrames frames = "[" ++ unwordsList frames ++ "]"