content: module Lisp.Builtins where
  
  import Control.Lens
  import Control.Monad.Trans (liftIO)
  import qualified Data.Map as M
  import qualified Data.Set as S
  import Lisp.Evaluator
  import Lisp.Parser
  import Lisp.Printer
  import Lisp.Reader
  import Lisp.Types
  
  dSum :: [Double] -> Double
  dSum = sum
  
  plus :: LispFunction
  plus = liftFunction dSum Nothing "+"
  
  dMinus :: [Double] -> Double
  dMinus [] = 0
  dMinus [d1] = -d1
  dMinus (d1:ds) = d1 - (sum ds)
  
  minus :: LispFunction
  minus = liftFunction dMinus Nothing "-"
  
  dProd :: [Double] -> Double
  dProd = product
  
  times :: LispFunction
  times = liftFunction dProd Nothing "*"
  
  dDiv :: [Double] -> Double
  dDiv [] = 1
  dDiv [d1] = 1 / d1
  dDiv (d1:ds) = d1 / (product ds)
  
  divide :: LispFunction
  divide = liftFunction dDiv Nothing "/"
  
  dCmp :: (Double -> Double -> Bool) -> [Double] -> Bool
  dCmp f [d1, d2] = d1 `f` d2
  dCmp _ _ = error "arity error in dCmp"
  
  numCmp :: (Double -> Double -> Bool) -> String -> LispValue
  numCmp f str = LVFunction $ liftFunction (dCmp f) (Just 2) str
  
  lispNot :: LispFunction
  lispNot = LFPrimitive "not" $ \vs ->
    case vs of
     [(LVBool False)] -> Right $ LVBool True
     [_]              -> Right $ LVBool False
     _                -> Left $ LispError $ LVString "not requires one argument"
  
  eq :: LispValue -> LispValue -> Bool
  eq (LVString v1) (LVString v2) = v1 == v2
  eq (LVSymbol v1) (LVSymbol v2) = v1 == v2
  eq (LVNumber v1) (LVNumber v2) = v1 == v2
  eq (LVBool   v1) (LVBool   v2) = v1 == v2
  eq (LVList   l1) (LVList   l2) =
    (length l1 == length l2) && (and $ zipWith eq l1 l2)
  eq _             _             = False
  
  lispEq :: LispFunction
  lispEq = LFPrimitive "eq" $ \vs ->
    case vs of
      [v1, v2] -> Right (LVBool $ eq v1 v2)
      _        -> Left  (LispError $ LVString "eq: requires two arguments")
  
  atom :: LispValue -> Bool
  atom (LVSymbol   _) = True
  atom (LVString   _) = True
  atom (LVNumber   _) = True
  atom (LVBool     _) = True
  atom (LVFunction _) = True
  atom (LVList    []) = True
  atom _              = False
  
  lispAtom :: LispFunction
  lispAtom = LFPrimitive "atom" $ \vs ->
    case vs of
     [v] -> Right $ LVBool $ atom v
     _   -> Left  $ LispError $ LVString "atom: requires one argument"
  
  lispCar :: LispFunction
  lispCar = LFPrimitive "car" $ \vs ->
    case vs of
     [(LVList (x:_))] -> Right x
     _                 -> Left $ LispError $ LVString "car: requires a non-empty list"
  
  lispCdr :: LispFunction
  lispCdr = LFPrimitive "cdr" $ \vs ->
    case vs of
     [(LVList (_:xs))] -> Right $ LVList xs
     _                 -> Left $ LispError $ LVString "cdr: requires a non-empty list"
  
  lispCons :: LispFunction
  lispCons = LFPrimitive "cons" $ \vs ->
    case vs of
     [x, LVList xs] -> Right $ LVList (x:xs)
     _              -> Left $ LispError $ LVString "cons: requires 2 args, 2nd must be list"
  
  quit :: LispFunction
  quit = LFAction "quit" $ \_ -> error "user quit"
  
  gensym :: LispFunction
  gensym = LFAction "gensym" $ \_ -> fmap LVSymbol genStr
  
  setMacroAction :: [LispValue] -> Lisp LispValue
  setMacroAction vals =
    case vals of
      [(LVSymbol name)] -> do
        macros . at name .= Just ()
        return $ LVBool True
      _                 -> failWithString "set-macro! requires one symbol"
  
  setMacro :: LispFunction
  setMacro = LFAction "set-macro!" $ setMacroAction
  
  macroexpand1Action :: LispFunction
  macroexpand1Action = LFAction "macroexpand-1" $ \vs ->
    case vs of
     [v] -> macroexpand1 v
     _   -> failWithString "macroexpand-1 requires 1 value"
  
  macroexpandAction :: LispFunction
  macroexpandAction = LFAction "macroexpand" $ \vs ->
    case vs of
     [v] -> macroexpand v
     _   -> failWithString "macroexpand requires 1 value"
  
  macroexpandAllAction :: LispFunction
  macroexpandAllAction = LFAction "macroexpand-all" $ \vs ->
    case vs of
     [v] -> macroexpandAll v
     _   -> failWithString "macroexpand-all requires 1 value"
  
  evalAction :: LispFunction
  evalAction = LFAction "eval" $ \vs ->
    case vs of
      [v] -> eval v
      _   -> failWithString "eval requires 1 value"
  
  printActionCore :: [LispValue] -> Lisp LispValue
  printActionCore vs = do
    mapM_ (liftIO . lispPrint) vs
    case vs of
      [v] -> return v
      _   -> return $ LVList vs
  
  printAction :: LispFunction
  printAction = LFAction "print" printActionCore
  
  execFile :: String -> Lisp LispValue
  execFile filename = do
    parsedSExps <- liftIO $ loadSExps filename
    case parsedSExps of
     Left anError -> failWithString anError
     Right sexps  -> do
       mapM_ (eval . readSExp) sexps
       return $ LVBool True
  
  loadFileAction :: LispFunction
  loadFileAction = LFAction "load-file" $ \vs ->
    case vs of
     [(LVString filename)] -> execFile filename
     _                     -> failWithString "load-file: requires 1 string"
  
  throwLispError :: LispFunction
  throwLispError = LFAction "error" $ \vs ->
    case vs of
     [v] -> lispFail $ LispError v
     _   -> lispFail $ LispError $ LVList vs
  
  globalBuiltins :: M.Map String LispValue
  globalBuiltins = M.fromList [("+", LVFunction plus),
                               ("-", LVFunction minus),
                               ("*", LVFunction times),
                               ("/", LVFunction divide),
                               ("==", numCmp (==) "=="),
                               ("<=", numCmp (<=) "<="),
                               (">=", numCmp (>=) ">="),
                               ("/=", numCmp (/=) "/="),
                               ("<" , numCmp (<)  "<"),
                               (">" , numCmp (>)  ">"),
                               ("atom", LVFunction lispAtom),
                               ("car", LVFunction lispCar),
                               ("cdr", LVFunction lispCdr),
                               ("cons", LVFunction lispCons),
                               ("eq", LVFunction lispEq),
                               ("error", LVFunction throwLispError),
                               ("eval", LVFunction evalAction),
                               ("gensym", LVFunction gensym),
                               ("load-file", LVFunction loadFileAction),
                               ("macroexpand", LVFunction macroexpandAction),
                               ("macroexpand-1", LVFunction macroexpand1Action),
                               ("macroexpand-all", LVFunction macroexpandAllAction),
                               ("not", LVFunction lispNot),
                               ("pi", LVNumber pi),
                               ("print", LVFunction printAction),
                               ("quit", LVFunction quit),
                               ("set-macro!", LVFunction setMacro)]
  
  initEnv :: LispEnv
  initEnv = LispEnv [] globalBuiltins 1 S.empty
  
  withPreludeEnv :: IO LispEnv
  withPreludeEnv = fmap snd $ execFile "prelude.lisp" `runLisp` initEnv
  