content: {-# OPTIONS_GHC -Wno-warnings-deprecations #-}
  module Parser(loadSchemeFile,loadSchemeFile',loadSourceCode, loadSchemeFileWithCode) where
  
  import           Prelude hiding (fail)
  
  import           Control.Monad.State hiding (fail)
  import           Control.Monad.Except
  
  import           Data.Label
  import           Data.Text (Text, pack)
  import           Data.IORef
  import qualified Data.Map.Lazy as Map
  
  import           Language.Scheme.Types as LT hiding (body)
  import           Language.Scheme.Parser
  import           Language.Scheme.Core
  import qualified Language.Scheme.Macro as Macro
  
  import           Paths_sturdy_scheme
  
  import           Syntax as S
  
  import           Text.Printf
  
  loadSchemeFile :: String -> IO LExpr
  loadSchemeFile file = do
    contents <- readFile =<< getDataFileName (printf "scheme_files/%s" file)
    case readExprList contents of
      Left err -> throwLispError err
      Right val -> do
       expanded <- macroExpand (List val)
       let expr = parseTopLevelSExpr expanded
       return expr
  
  loadSchemeFile' :: String -> IO Expr
  loadSchemeFile' file = do
    lexpr <- loadSchemeFile file
    return $ generate lexpr
  
  loadSourceCode :: String -> IO FilePath
  loadSourceCode file = readFile =<< getDataFileName (printf "scheme_files/%s" file)
  
  loadSchemeFileWithCode :: String -> IO LExpr
  loadSchemeFileWithCode code = do
    case readExprList code of
      Left err -> throwLispError err
      Right val -> do
        expanded <- macroExpand (List val)
        let expr = parseTopLevelSExpr expanded
        return expr
  
  
  macroExpand :: LispVal -> IO LispVal
  macroExpand program = do
    env <- r7rsEnv
    removeMacros env
    addMacros env
    runErrorIO (Macro.expand env True program apply)
    where
      removeMacros :: Env -> IO ()
      removeMacros env = do
        bnds <- readIORef (bindings env)
        writeIORef (bindings env) (foldr Map.delete bnds ["m_begin","m_or","m_let","m_letrec","m_letrec*"])
  
      addMacros :: Env -> IO ()
      addMacros env = do
        macrosFile <- getDataFileName "scheme_files/macros.scm"
        _ <- evalString env (printf "(load \"%s\")" macrosFile)
        return ()
  
  runErrorIO :: IOThrowsError a -> IO a
  runErrorIO m = do
    e <- runExceptT m
    case e of
      Right val -> return val
      Left err  -> throwLispError err
  
  throwLispError :: LispError -> IO a
  throwLispError err = do
    str <- showLispError err
    fail str
  
  parseTopLevelSExpr :: LispVal -> LExpr
  parseTopLevelSExpr (LT.List prog) =
    let (defs,body) = parseDefinitions prog
    in let_rec defs body
  parseTopLevelSExpr expr = error $ "cannot parse s-expression: " ++ show expr
  
  parseDefinitions :: [LispVal] -> ([(Text,LExpr)],[LExpr])
  parseDefinitions (LT.List [Atom "define", Atom var, body] : defs) =
    (pack var, parseSExpr body) <+ parseDefinitions defs
  parseDefinitions (LT.List (Atom "define": Atom var: body) : defs) =
    (pack var, begin (map parseSExpr body)) <+ parseDefinitions defs
  parseDefinitions (LT.List (Atom "define": LT.List (Atom var: args): body) : defs) =
    (pack var, lam [ pack x | Atom x <- args ] (map parseSExpr body)) <+ parseDefinitions defs
  parseDefinitions (sexpr : defs) =
    parseSExpr sexpr +> parseDefinitions defs
  parseDefinitions [] = ([],[])
  
  parseSExpr :: LispVal -> LExpr
  parseSExpr val = case val of
    LT.Number x -> lit $ S.Int $ fromIntegral x
    LT.Float x -> lit $ S.Float x
    LT.Rational x -> lit $ S.Rational x
    LT.Bool x -> lit $ S.Bool x
    LT.Char x -> lit $ S.Char x
    LT.String x -> lit $ S.String (pack x)
    LT.Atom "#t" -> lit $ S.Bool True
    LT.Atom "#f" -> lit $ S.Bool False
    LT.Atom "null" -> list []
    LT.Atom x -> var_ (pack x)
    LT.List [Atom "define", Atom var, body] ->
      define (pack var) (parseSExpr body)
    LT.List (Atom "define": Atom var: body) ->
      define (pack var) (begin (map parseSExpr body))
    LT.List (Atom "define": LT.List (Atom var: args): body) ->
      define (pack var) (lam [ pack x | Atom x <- args ] (map parseSExpr body))
    -- TODO : add lambdas with variable amount of arguments if only one arguement is given
    LT.List (Atom "lambda": Atom var: body_) ->
      lam [ pack var ] (map parseSExpr body_)
    LT.List (Atom "lambda": LT.List args: body_) ->
      lam [ pack x | Atom x <- args ] (map parseSExpr body_)
    -- case lambda
    LT.List [Atom "if", cond, then_branch, else_branch] ->
      if_ (parseSExpr cond) (parseSExpr then_branch) (parseSExpr else_branch)
    LT.List [Atom "if", cond, then_branch] ->
      if_ (parseSExpr cond) (parseSExpr then_branch) (list [])
    -- begin
    LT.List (Atom "begin": body_) ->
      begin (map parseSExpr body_)
    -- begin0
    LT.List (Atom "let": LT.List params_: body_) ->
      let bnds = map extractBinding params_
      in let_ bnds (map parseSExpr body_)
    LT.List (Atom "letrec": LT.List params_: body_) ->
      let bnds = map extractBinding params_
      in let_rec bnds (map parseSExpr body_)
    LT.List [Atom "set!", Atom var, body_] ->
      set (pack var) (parseSExpr body_)
    LT.List (Atom "set!": _) -> error $ "cannot parse set!: " ++ show val
    LT.List [Atom "quote", LT.List xs] -> list (map quoteListHelp xs)
    LT.List [Atom "quote", val_] -> lit $ parseLits val_
    LT.List (LT.List(Atom "lambda": rest): args) ->
      app (parseSExpr (LT.List(Atom "lambda" : rest))) (map parseSExpr args)
    -- LT.List [Atom "call-with-values", generator, _] ->
    --   app (parseSExpr generator) []
    LT.List [Atom "number?", e] -> op1_ IsNumber (parseSExpr e)
    LT.List [Atom "integer?", e] -> op1_ IsInteger (parseSExpr e)
    LT.List [Atom "float?", e] -> op1_ IsFloat (parseSExpr e)
    LT.List [Atom "rational?", e] -> op1_ IsRational (parseSExpr e)
    LT.List [Atom "zero?", e] -> op1_ IsZero (parseSExpr e)
    LT.List [Atom "positive?", e] -> op1_ IsPositive (parseSExpr e)
    LT.List [Atom "negative?", e] -> op1_ IsNegative (parseSExpr e)
    LT.List [Atom "even?", e] -> op1_ IsEven (parseSExpr e)
    LT.List [Atom "odd?", e] -> op1_ IsOdd (parseSExpr e)
    LT.List [Atom "boolean?", e] -> op1_ IsBoolean (parseSExpr e)
    LT.List [Atom "null?", e] -> op1_ IsNull (parseSExpr e)
    LT.List [Atom "pair?", e] -> op1_ IsCons (parseSExpr e)
    LT.List [Atom "cons?", e] -> op1_ IsCons (parseSExpr e)
    LT.List [Atom "abs", e] -> op1_ Abs (parseSExpr e)
    LT.List [Atom "floor", e] -> op1_ Floor (parseSExpr e)
    LT.List [Atom "ceiling", e] -> op1_ Ceiling (parseSExpr e)
    LT.List [Atom "log", e] -> op1_ Log (parseSExpr e)
    LT.List [Atom "not", e] -> op1_ Not (parseSExpr e)
    LT.List [Atom "car", e] -> op1_ Car (parseSExpr e)
    LT.List [Atom "cdr", e] -> op1_ Cdr (parseSExpr e)
    LT.List [Atom "caar", e] -> op1_ Caar (parseSExpr e)
    LT.List [Atom "cadr", e] -> op1_ Cadr (parseSExpr e)
    LT.List [Atom "cddr", e] -> op1_ Cddr (parseSExpr e)
    LT.List [Atom "caddr", e] -> op1_ Caddr (parseSExpr e)
    LT.List [Atom "cadddr", e] -> op1_ Cadddr (parseSExpr e)
    LT.List [Atom "random", e] -> op1_ Random (parseSExpr e)
    LT.List [Atom "string->symbol", e] -> op1_ StringToSymbol (parseSExpr e)
    LT.List [Atom "symbol->string", e] -> op1_ SymbolToString (parseSExpr e)
    LT.List [Atom "number->string", e] -> op1_ NumberToString (parseSExpr e)
    -- op2
    LT.List [Atom "eq?", e1, e2] -> op2_ Eqv (parseSExpr e1) (parseSExpr e2)
    LT.List [Atom "quotient", e1, e2] -> op2_ Quotient (parseSExpr e1) (parseSExpr e2)
    LT.List [Atom "remainder", e1, e2] -> op2_ Remainder (parseSExpr e1) (parseSExpr e2)
    LT.List [Atom "modulo", e1, e2] -> op2_ Modulo (parseSExpr e1) (parseSExpr e2)
    LT.List [Atom "string-ref", e1, e2] -> op2_ StringRef (parseSExpr e1) (parseSExpr e2)
    LT.List [Atom "cons", e1, e2] -> cons (parseSExpr e1) (parseSExpr e2)
    -- opvar
    LT.List (Atom "=": args) -> opvar_ Equal (map parseSExpr args)
    LT.List (Atom "<": args) -> opvar_ Smaller (map parseSExpr args)
    LT.List (Atom ">": args) -> opvar_ Greater (map parseSExpr args)
    LT.List (Atom "<=": args) -> opvar_ SmallerEqual (map parseSExpr args)
    LT.List (Atom ">=": args) -> opvar_ GreaterEqual (map parseSExpr args)
    LT.List (Atom "max": args) -> opvar_ Max (map parseSExpr args)
    LT.List (Atom "min": args) -> opvar_ Min (map parseSExpr args)
    LT.List (Atom "+": args) -> opvar_ Add (map parseSExpr args)
    LT.List (Atom "*": args) -> opvar_ Mul (map parseSExpr args)
    LT.List (Atom "-": args) -> opvar_ Sub (map parseSExpr args)
    LT.List (Atom "/": args) -> opvar_ Div (map parseSExpr args)
    LT.List (Atom "gcd": args) -> opvar_ Gcd (map parseSExpr args)
    LT.List (Atom "lcm": args) -> opvar_ Lcm (map parseSExpr args)
    LT.List (Atom "string-append": args) -> opvar_ StringAppend (map parseSExpr args)
    LT.List (Atom "list": args) -> list (map parseSExpr args)
    LT.List [Atom "error", LT.String err] -> error_ err
    LT.List [Atom "breakpoint", e] -> breakpoint (parseSExpr e)
  
    LT.List (Atom x: args) -> app (var_ (pack x)) (map parseSExpr args)
    LT.List (fun: args) -> app (parseSExpr fun) (map parseSExpr args)
    _ -> error $ "cannot parse s-expression: " ++ show val
  
  extractBinding :: LispVal -> (Text, State Label Expr)
  extractBinding (LT.List [Atom var, val]) = (pack var, parseSExpr val)
  extractBinding _ = error "Error when extracting tuple"
  
  --TODO: resolve remaining lispvals
  parseLits :: LispVal -> Literal
  parseLits val = case val of
    LT.Number x -> S.Int $ fromIntegral x
    LT.Float x -> S.Float x
    LT.Rational x -> S.Rational x
    LT.Bool x -> S.Bool x
    LT.Char x -> S.Char x
    LT.String x -> S.String (pack x)
    LT.Atom "#t" -> S.Bool True
    LT.Atom "#f" -> S.Bool False
    LT.Atom x -> S.Quote $ S.Symbol (pack x)
    -- LT.List xs -> list (map parseSExpr xs)
    -- LT.DottedList xs x -> S.DottedList (map parseLits xs) (parseLits x)
    _ -> error "type not supported"
  
  quoteListHelp :: LispVal -> LExpr
  quoteListHelp val = case val of
    LT.Number x -> lit $ S.Int $ fromIntegral x
    LT.Float x -> lit $ S.Float x
    LT.Rational x -> lit $ S.Rational x
    LT.Bool x -> lit $ S.Bool x
    LT.Char x -> lit $ S.Char x
    LT.String x -> lit $ S.String (pack x)
    LT.Atom "#t" -> lit $ S.Bool True
    LT.Atom "#f" -> lit $ S.Bool False
    LT.Atom x -> lit $ S.Quote $ S.Symbol (pack x)
    LT.List xs -> list (map quoteListHelp xs)
    -- LT.DottedList xs x -> S.DottedList (map parseLits xs) (parseLits x)
    _ -> error "type not supported"
  
  (<+) :: a -> ([a],[b]) -> ([a],[b])
  a1 <+ (a2,b2) = (a1 : a2, b2)
  
  (+>) :: b -> ([a],[b]) -> ([a],[b])
  b1 +> (a2,b2) = (a2, b1 : b2)
  