fork download 
  1. module Main where
  2.  
  3. import qualified Data.Map as M
  4. import Data.Foldable (foldlM)
  5. import System.IO (hFlush, stdout)
  6.  
  7. main = repl newEnvironment
  8.  
  9. flush :: IO ()
  10. flush = hFlush stdout
  11.  
  12. putStrLnF :: String -> IO ()
  13. putStrLnF s = putStrLn s >> flush
  14.  
  15. putStrF :: String -> IO ()
  16. putStrF s = putStr s >> flush
  17.  
  18. printErr :: Env -> String -> IO Env
  19. printErr env err = putStrLnF err >> return env
  20.  
  21. lisp :: Env -> String -> IO Env
  22. lisp env xs = do
  23.     case tokenize xs of
  24.         Left err     -> printErr env err
  25.         Right tokens -> lisp' (parse tokens) env
  26.  
  27. lisp' :: ParseResult -> Env -> IO Env
  28. lisp' (Left err)            env = putStrLnF err >> return env
  29. lisp' (Right (Just cd, rm)) env = either (printErr env) (lisp'' rm) $ run cd env
  30. lisp' (Right (Nothing, _))  env = putStrLnF "err?" >> return env
  31.  
  32. lisp'' :: [Token] -> (LispData, Env) -> IO Env
  33. lisp'' [] (ld, env) = putStrLnF (toString ld) >> return env
  34. lisp'' rm (ld, env) = putStrLnF (toString ld) >> lisp' (parse rm) env
  35.  
  36.  
  37. repl :: Env -> IO ()
  38. repl env = do
  39.     putStrF ">>> "
  40.     s <- getLine
  41.     case s of
  42.         ""       -> repl env
  43.         ":quit"  -> putStrLnF "bye"
  44.         ":reset" -> putStrLnF "reset" >> repl newEnvironment
  45.         ":{"     -> getMultilines "" >>= lisp env >>= repl
  46.         (':':_)  -> putStrLnF "error (invalid command):"  >> repl env
  47.         _        -> lisp env s >>= repl
  48.  
  49.  
  50. getMultilines :: String -> IO String
  51. getMultilines s = do
  52.     putStrF "==| "
  53.     t <- getLine
  54.     if t == ":}" then
  55.         return s
  56.     else
  57.         getMultilines $ s ++ " " ++ t
  58.  
  59.  
  60.  
  61. data Token = OpenBracketToken
  62.            | CloseBracketToken
  63.            | WordToken    String
  64.            | StringToken  String
  65.            | BooleanToken Bool
  66.            | IntegerToken Integer
  67.            | CommaToken
  68.            | CommaAtToken
  69.            | ConsToken
  70.            | QuoteToken
  71.            | BackQuoteToken
  72.            | CommentToken String
  73.            deriving (Show, Eq)
  74.  
  75. trueToken :: Token
  76. trueToken = BooleanToken True
  77.  
  78. falseToken :: Token
  79. falseToken = BooleanToken False
  80.  
  81. untoken :: Token -> String
  82. untoken ConsToken         = "."
  83. untoken CommaToken        = ","
  84. untoken CommaAtToken      = ",@"
  85. untoken QuoteToken        = "'"
  86. untoken BackQuoteToken    = "`"
  87. untoken OpenBracketToken  = "("
  88. untoken CloseBracketToken = ")"
  89. untoken (WordToken s)     = s
  90. untoken (StringToken s)   = "\"" ++ escape s ++ "\""
  91. untoken (CommentToken s)  = ';' : s
  92. untoken (BooleanToken b)  = if b then "#t" else "#f"
  93. untoken (IntegerToken i)  = show i
  94.  
  95. escape :: String -> String
  96. escape = ($"") . foldl escapeChar id
  97.  
  98. escapeChar :: (String -> String) -> Char -> (String -> String)
  99. escapeChar f '\n' =  f.('\\':).('n':)
  100. escapeChar f '\r' =  f.('\\':).('r':)
  101. escapeChar f '\t' =  f.('\\':).('t':)
  102. escapeChar f '\\' =  f.('\\':).('\\':)
  103. escapeChar f '"'  =  f.('\\':).('"':)
  104. escapeChar f ch   =  f.(ch:)
  105.  
  106. isDigit :: (Char -> Bool)
  107. isDigit = (`elem` "0123456789")
  108.  
  109. isWordChar :: (Char -> Bool)
  110. isWordChar = not . (`elem` " ;()\"'`,\n\r\t")
  111.  
  112. isWhiteSpace :: (Char -> Bool)
  113. isWhiteSpace = (`elem` " \n\r\t")
  114.  
  115. ltrim :: (String -> String)
  116. ltrim = dropWhile isWhiteSpace
  117.  
  118.  
  119. type TokenizeResult = Either String [Token]
  120.  
  121. tokenize :: String -> TokenizeResult
  122. tokenize [] = Right []
  123. tokenize xs = scan tokenize xs
  124.  
  125. scan :: ((String -> TokenizeResult) -> String -> TokenizeResult)
  126. scan = connect scanOpenBracket
  127.      . connect scanCloseBracket
  128.      . connect scanString
  129.      . connect scanComment
  130.      . connect scanQuote
  131.      . connect scanWord
  132.  
  133. type ScanResult = Either String (Maybe Token, String)
  134.  
  135. connect :: (String -> ScanResult)
  136.         -> (String -> TokenizeResult)
  137.         -> (String -> TokenizeResult)
  138. connect f g = next g . f . ltrim 
  139.  
  140. next :: (String -> TokenizeResult) -> ScanResult -> TokenizeResult
  141. next _ (Left  err)      = Left err
  142. next g (Right (tk, zs)) = maybe id (:) tk <$> g zs
  143.  
  144.  
  145. scanOpenBracket :: String -> ScanResult
  146. scanOpenBracket ('(':xs) = Right (Just OpenBracketToken, xs)
  147. scanOpenBracket xs       = Right (Nothing, xs)
  148.  
  149.  
  150. scanCloseBracket :: String -> ScanResult
  151. scanCloseBracket (')':xs) = Right (Just CloseBracketToken, xs)
  152. scanCloseBracket xs       = Right (Nothing, xs)
  153.  
  154.  
  155. scanString :: String -> ScanResult
  156. scanString ('"':xs) = takeString id xs
  157. scanString xs       = Right (Nothing, xs)
  158.  
  159. takeString :: (String -> String) ->  String -> ScanResult
  160. takeString f ('\\':ch:xs) = takeString (f.(transSpChar ch:)) xs
  161. takeString f ('\\':_)     = Left $ "string token error (illegal escape): " ++ f "\\"
  162. takeString f ('"':xs)     = Right (Just $ StringToken $ f "", xs)
  163. takeString f (ch:xs)      = takeString (f.(ch:)) xs
  164. takeString f []           = Left $ "string token error (not closed): " ++ f ""
  165.  
  166. transSpChar :: Char -> Char
  167. transSpChar 'n' = '\n'
  168. transSpChar 'r' = '\r'
  169. transSpChar 't' = '\t'
  170. transSpChar ch  = ch
  171.  
  172.  
  173. scanComment :: String -> ScanResult
  174. scanComment (';':xs) = takeComment $ break (== '\n') xs
  175. scanComment xs       = Right (Nothing, xs)
  176.  
  177. takeComment :: (String, String) -> ScanResult
  178. takeComment (msg, xs) = Right (Just $ CommentToken msg, xs)
  179.  
  180.  
  181. scanQuote :: String -> ScanResult
  182. scanQuote (',':'@':xs)            = takeQuote ",@" xs
  183. scanQuote (ch:xs) | elem ch "'`," = takeQuote [ch] xs
  184. scanQuote xs                      = Right (Nothing, xs)
  185.  
  186. takeQuote :: String -> String -> ScanResult
  187. takeQuote sg xs | validQuoteSyntax xs
  188.                 = Right (Just $ transQuoteToken sg, xs)
  189.                 | otherwise           
  190.                 = Left $ "quote token error (no quote target): " ++ sg ++ take 20 xs
  191.  
  192. transQuoteToken :: String -> Token
  193. transQuoteToken "'"  = QuoteToken
  194. transQuoteToken "`"  = BackQuoteToken
  195. transQuoteToken ","  = CommaToken
  196. transQuoteToken ",@" = CommaAtToken
  197. transQuoteToken _    = undefined
  198.  
  199. validQuoteSyntax :: String -> Bool
  200. validQuoteSyntax []     = False
  201. validQuoteSyntax (ch:_) = not $ elem ch "); \n\r\t"
  202.  
  203.  
  204. scanWord :: (String -> ScanResult)
  205. scanWord = takeWord . span isWordChar
  206.  
  207. takeWord :: (String, String) -> ScanResult
  208. takeWord ("",   ys)         = Right (Nothing, ys)
  209. takeWord (".",  ys)         = Right (Just ConsToken, ys)
  210. takeWord ("#t", ys)         = Right (Just trueToken, ys)
  211. takeWord ("#f", ys)         = Right (Just falseToken, ys)
  212. takeWord (w@('-':ch:_), ys) | isDigit ch
  213.                             = takeNumber w ys
  214. takeWord (w@(ch:_), ys)     | isDigit ch
  215.                             = takeNumber w ys
  216. takeWord (word, ys)         = Right (Just $ WordToken word, ys)
  217.  
  218.  
  219. takeNumber :: String -> String -> ScanResult
  220. takeNumber w@('-':ls) ys | all isDigit ls
  221.                          = Right (Just $ IntegerToken $ read w, ys)
  222. takeNumber w          ys | all isDigit w
  223.                          = Right (Just $ IntegerToken $ read w, ys)
  224.                          | otherwise
  225.                          = Left $ "token error (not number): " ++ w
  226.  
  227.  
  228.  
  229. data LispData = List  [LispData]
  230.               | Cons  [LispData] LispData
  231.               | Node  Token
  232. --              | Quote Token LispData
  233.               | Procedure LispData
  234.               | Syntax    LispData
  235.               deriving (Show, Eq)
  236.  
  237. emptyList :: LispData
  238. emptyList = List []
  239.  
  240. trueValue :: LispData
  241. trueValue = Node trueToken
  242.  
  243. falseValue :: LispData
  244. falseValue = Node falseToken
  245.  
  246. intZeroValue :: LispData
  247. intZeroValue = Node $ IntegerToken 0
  248.  
  249. intOneValue :: LispData
  250. intOneValue = Node $ IntegerToken 1
  251.  
  252. toString :: LispData -> String
  253. toString (List xs)     = untoken OpenBracketToken
  254.                       ++ (unwords $ map toString xs)
  255.                       ++ untoken CloseBracketToken
  256. toString (Cons xs ld)  = untoken OpenBracketToken
  257.                       ++ (unwords $ map toString xs)
  258.                       ++ " "
  259.                       ++ untoken ConsToken
  260.                       ++ " "
  261.                       ++ toString ld
  262.                       ++ untoken CloseBracketToken
  263. toString (Node tk)     = untoken tk
  264. -- toString (Quote qu ld) = untoken qu ++ toString ld
  265. toString (Procedure (Node (WordToken s))) = "#<procedure " ++ s ++ ">"
  266. toString (Procedure _)                    = "#<procedure (lambda)>"
  267. toString (Syntax (Node (WordToken s)))    = "#<syntax " ++ s ++ ">"
  268.  
  269. type ParseState  = (Maybe LispData, [Token])
  270. type ParseResult = Either String ParseState
  271.  
  272. parse :: [Token] -> ParseResult
  273. parse [] = Right (Nothing, [])
  274. parse xs = parseAll xs
  275.  
  276.  
  277. parseAll :: ([Token] -> ParseResult)
  278. parseAll = combine parseList
  279.          . combine parseNode
  280.          . combine parseQuote
  281.          $ const (Left "parse error (parser bug or syntax error):")
  282.  
  283. combine :: ([Token] -> ParseResult)
  284.         -> ([Token] -> ParseResult)
  285.         -> ([Token] -> ParseResult)
  286. combine f g = nextParse g . f . omit
  287.  
  288. nextParse :: ([Token] -> ParseResult) -> ParseResult -> ParseResult
  289. nextParse p (Right (Nothing, xs)) = p xs
  290. nextParse _ ret                   = ret 
  291.  
  292. isOmitToken :: Token -> Bool
  293. isOmitToken (CommentToken _) = True
  294. isOmitToken _                = False
  295.  
  296. omit :: ([Token] -> [Token])
  297. omit = dropWhile isOmitToken
  298.  
  299.  
  300. parseList :: [Token] -> ParseResult
  301. parseList (OpenBracketToken:xs) = takeList id xs
  302. parseList xs                    = Right (Nothing, xs)
  303.  
  304. takeList :: ([LispData] -> [LispData]) -> [Token] -> ParseResult
  305. takeList f []                     = Left "parse error (not closed):"
  306. takeList f (CloseBracketToken:xs) = Right (Just $ makeListData $ f [], xs)
  307. takeList f (ConsToken:xs)         = parse xs >>= takeCons f
  308. takeList f xs                     = parse xs >>= takeListItem f
  309.  
  310. makeListData :: [LispData] -> LispData
  311. makeListData [] = emptyList
  312. makeListData ls = List ls
  313.  
  314. takeListItem :: ([LispData] -> [LispData]) -> ParseState -> ParseResult
  315. takeListItem f (Just ld, xs) = takeList (f.(ld:)) xs
  316. takeListItem _ (Nothing, _)  = Left "parse error (no node):"
  317.  
  318. takeCons :: ([LispData] -> [LispData]) -> ParseState -> ParseResult
  319. takeCons f (Just ld, xs) = makeCons f (f []) ld (omit xs)
  320. takeCons _ (Nothing, _)  = Left "parse error (no cons data):"
  321.  
  322.  
  323. makeCons :: ([LispData] -> [LispData]) -> [LispData] -> LispData -> [Token] -> ParseResult
  324. makeCons _ [] _            _                      = Left "parse error (invalid cons):"
  325. makeCons f _  (List ls)    (CloseBracketToken:xs) = Right (Just $ List (f ls), xs)
  326. makeCons f _  (Cons ls ld) (CloseBracketToken:xs) = Right (Just $ Cons (f ls) ld, xs)
  327. makeCons _ ls ld           (CloseBracketToken:xs) = Right (Just $ Cons ls ld, xs)
  328. makeCons _ _  _            _                      = Left "parse error (invalid cons):"
  329.  
  330.  
  331. isNodeToken :: Token -> Bool
  332. isNodeToken (WordToken _)    = True
  333. isNodeToken (StringToken _)  = True
  334. isNodeToken (BooleanToken _) = True
  335. isNodeToken (IntegerToken _) = True
  336. isNodeToken _                = False
  337.  
  338. parseNode :: [Token] -> ParseResult
  339. parseNode (tk:xs) | isNodeToken tk
  340.                   = Right (Just $ Node tk, xs)
  341. parseNode xs      = Right (Nothing, xs)
  342.  
  343.  
  344. isQuoteToken :: Token -> Bool
  345. isQuoteToken QuoteToken     = True
  346. isQuoteToken BackQuoteToken = True
  347. isQuoteToken CommaToken     = True
  348. isQuoteToken CommaAtToken   = True
  349. isQuoteToken _              = False
  350.  
  351. quoteToWord :: Token -> String
  352. quoteToWord QuoteToken     = "quote"
  353. quoteToWord BackQuoteToken = "quasiquote"
  354. quoteToWord CommaToken     = "unquote"
  355. quoteToWord CommaAtToken   = "unquote-splicing"
  356. quoteToWord _              = undefined
  357.  
  358. quoteToNode :: (Token -> LispData)
  359. quoteToNode = Node . WordToken . quoteToWord
  360.  
  361. parseQuote :: [Token] -> ParseResult
  362. parseQuote (tk:xs) | isQuoteToken tk
  363.                    = parse xs >>= takeQuoteItem tk
  364. parseQuote xs      = Right (Nothing, xs)
  365.  
  366. takeQuoteItem :: Token -> ParseState -> ParseResult
  367. -- takeQuoteItem tk (Just ld, xs) = Right (Just $ Quote tk ld, xs)
  368. takeQuoteItem tk (Just ld, xs) = Right (Just $ List [quoteToNode tk, ld], xs)
  369. takeQuoteItem _  (Nothing, _)  = Left "parse error (no quote item):"
  370.  
  371.  
  372.  
  373. data Stock     = Stock {reserved::Bool, value::LispData} deriving Show
  374. type Env       = M.Map String Stock
  375. type RunState  = (LispData, Env)
  376. type RunResult = Either String RunState
  377.  
  378. procedures = map (\x -> (x, Stock True $ Procedure $ Node $ WordToken x))
  379.            $ ["car", "cdr", "cons" , "pair?", "eq?"
  380.              , "+", "*", "-"]
  381.  
  382. syntaxes = map (\x -> (x, Stock True $ Syntax $ Node $ WordToken x))
  383.          $ ["quote", "define", "if", "lambda"]
  384.  
  385.  
  386. newEnvironment :: Env
  387. newEnvironment = M.fromList $ procedures ++ syntaxes
  388.  
  389.  
  390. run :: LispData -> Env -> RunResult
  391. run (List ls)   env = runList ls env
  392. run ld@(Node _) env = runNode ld env
  393. run ld          _   = Left $ "cannot run code: " ++ toString ld
  394.  
  395.  
  396. runNode :: LispData -> Env -> RunResult
  397. runNode (Node (WordToken wd)) env = takeValue env wd $ M.lookup wd env
  398. runNode ld                    env = Right (ld, env)
  399.  
  400. takeValue :: Env -> String -> Maybe Stock -> RunResult
  401. takeValue _   ky Nothing   = Left $ "not found: " ++ ky
  402. takeValue env _  (Just st) = Right (value st, env)
  403.  
  404.  
  405. runList :: [LispData] -> Env -> RunResult
  406. runList []      _   = Left $ "cannot run emptylist:"
  407. runList (ld:xs) env = run ld env >>= takeExecutor xs 
  408.  
  409. takeExecutor :: [LispData] -> RunState -> RunResult
  410. takeExecutor ls (Procedure ld, env) = execute ld ls env
  411. takeExecutor ls (Syntax ld, env)    = execute ld ls env
  412. takeExecutor _  (ld, _)             = Left $ "cannot run code: " ++ toString ld
  413.  
  414.  
  415. execute :: LispData -> [LispData] -> Env -> RunResult
  416. execute (Node (WordToken "quote"))  ls env = callQuote   ls env
  417. execute (Node (WordToken "car"))    ls env = callCar     ls env
  418. execute (Node (WordToken "cdr"))    ls env = callCdr     ls env
  419. execute (Node (WordToken "cons"))   ls env = callCons    ls env
  420. execute (Node (WordToken "pair?"))  ls env = callPairQ   ls env
  421. execute (Node (WordToken "eq?"))    ls env = callEqQ     ls env
  422. execute (Node (WordToken "if"))     ls env = callIf      ls env
  423. execute (Node (WordToken "define")) ls env = callDefine  ls env
  424. execute (Node (WordToken "lambda")) ls env = callLambda  ls env
  425. execute (Node (WordToken "+"))      ls env = callPlusOp  ls env
  426. execute (Node (WordToken "*"))      ls env = callAstrOp  ls env
  427. execute (Node (WordToken "-"))      ls env = callMinusOp ls env
  428. execute (List (la:xs))              ls env = runAll ls env >>= doLambda la xs
  429. execute ld                         _  _   = Left $ "cannot run code: " ++ toString ld
  430.  
  431. type ArgState = ([LispData], Env)
  432.  
  433. callQuote :: [LispData] -> Env -> RunResult
  434. callQuote (ld:[]) env = Right (ld, env)
  435. callQuote ls      _   = Left $ "illigal arguments: " ++ toString (List ls)
  436.  
  437. takeAndRunArgs :: Int -> (ArgState -> RunResult) -> [LispData] -> Env -> RunResult
  438. takeAndRunArgs c f ls env
  439.     | length ls == c = takeAndRunAllArgs f ls env
  440.     | otherwise      = Left $ "illigal arguments: " ++ toString (List ls)
  441.  
  442. takeAndRunArgsWithMin :: Int -> (ArgState -> RunResult) -> [LispData] -> Env -> RunResult
  443. takeAndRunArgsWithMin c f ls env
  444.     | length ls >= c = takeAndRunAllArgs f ls env
  445.     | otherwise      = Left $ "illigal arguments: " ++ toString (List ls)
  446.  
  447. runAll :: [LispData] -> Env -> RunResult
  448. runAll ls env = (\(List xs, e) -> (List $ reverse xs, e)) <$> foldlM runArg (emptyList, env) ls
  449.  
  450. runArg :: RunState -> LispData -> RunResult
  451. runArg (List ls, env) ld = run ld env >>= takeArg ls
  452.  
  453.  
  454. takeArg :: [LispData] -> RunState -> RunResult
  455. takeArg ls (ld, env) = Right (List (ld:ls), env)
  456.  
  457. takeAndRunAllArgs :: (ArgState -> RunResult) -> [LispData] -> Env -> RunResult
  458. takeAndRunAllArgs f ls env = f . unwrapList =<< runAll ls env
  459.  
  460. unwrapList :: RunState -> ArgState
  461. unwrapList (List ls, env) = (ls, env)
  462.  
  463.  
  464. callCar :: ([LispData] -> Env -> RunResult)
  465. callCar = takeAndRunArgs 1 executeCar
  466.  
  467. executeCar :: ArgState -> RunResult
  468. executeCar (List (ld:_)  :_, env) = Right (ld, env)
  469. executeCar (Cons (ld:_) _:_, env) = Right (ld, env)
  470. executeCar (ld           :_, _  ) = Left $ "illigal argument: " ++ toString ld
  471.  
  472.  
  473. callCdr :: ([LispData] -> Env -> RunResult)
  474. callCdr = takeAndRunArgs 1 executeCdr
  475.  
  476. executeCdr :: ArgState -> RunResult
  477. executeCdr (List (_:[])   :_, env) = Right (emptyList, env)
  478. executeCdr (List (_:ls)   :_, env) = Right (List ls, env)
  479. executeCdr (Cons (_:[]) ld:_, env) = Right (ld, env)
  480. executeCdr (Cons (_:ls) ld:_, env) = Right (Cons ls ld, env)
  481. executeCdr (ld            :_, _  ) = Left $ "illigal argument: " ++ toString ld
  482.  
  483.  
  484. callCons :: ([LispData] -> Env -> RunResult)
  485. callCons = takeAndRunArgs 2 executeCons
  486.  
  487. executeCons :: ArgState -> RunResult
  488. executeCons (ld:Cons ls la:_, env) = Right (Cons (ld:ls) la, env)
  489. executeCons (ld:List ls   :_, env) = Right (List (ld:ls), env)
  490. executeCons (ld:la        :_, env) = Right (Cons [ld] la, env)
  491.  
  492.  
  493. callPairQ :: ([LispData] -> Env -> RunResult)
  494. callPairQ = takeAndRunArgs 1 executePairQ
  495.  
  496. executePairQ :: ArgState -> RunResult
  497. executePairQ (Cons _ _  :_, env) = Right (trueValue, env)
  498. executePairQ (List (_:_):_, env) = Right (trueValue, env)
  499. executePairQ (_           , env) = Right (falseValue, env)
  500.  
  501.  
  502. callEqQ :: ([LispData] -> Env -> RunResult)
  503. callEqQ = takeAndRunArgs 2 executeEqQ
  504.  
  505. executeEqQ :: ArgState -> RunResult
  506. executeEqQ (ld1:ld2:_, env) | ld1 == ld2 = Right (trueValue, env)
  507.                             | otherwise  = Right (falseValue, env)
  508.  
  509. callDefine :: [LispData] -> Env -> RunResult
  510. callDefine (Node (WordToken wd):ld:[]) env
  511.                 | canBind wd env
  512.                 = bindValue wd <$> run ld env
  513.                 | otherwise
  514.                 = Left $ "reserved word: " ++ wd
  515. callDefine ls _ = Left $ "illigal arguments: " ++ toString (List ls)
  516.  
  517. canBind :: (String -> Env -> Bool)
  518. canBind = (maybe True (not.reserved) .) . M.lookup
  519.  
  520. bindValue :: String -> RunState -> RunState
  521. bindValue wd (ld, env) = (ld, M.insert wd (Stock False ld) env)
  522.  
  523.  
  524. callIf :: [LispData] -> Env -> RunResult
  525. callIf (test:tv:fv:[]) env = run test env >>= executeIf tv fv
  526. callIf (test:tv:[])    env = run test env >>= executeIf tv falseValue
  527. callIf ls              _   = Left $ "invalid arguments: " ++ toString (List ls)
  528.  
  529. executeIf :: LispData -> LispData -> RunState -> RunResult
  530. executeIf _  fv (Node (BooleanToken False), env) = run fv env
  531. executeIf tv _  (_, env)                         = run tv env
  532.  
  533.  
  534. callLambda :: [LispData] -> Env -> RunResult
  535. callLambda ls@(Node (WordToken _):_:_) env = Right (Procedure (List ls), env)
  536. callLambda ls@(List xs           :_:_) env | checkArgsAllWord xs
  537.                                            = Right (Procedure (List ls), env)
  538. callLambda ls@(Cons xs ld        :_:_) env | checkArgsAllWord (ld:xs)
  539.                                            = Right (Procedure (List ls), env)
  540. callLambda ls                          _   = Left $ "invalid arguments: " ++ toString (List ls)
  541.  
  542. checkArgsAllWord :: ([LispData] -> Bool)
  543. checkArgsAllWord = all isWordTokenNode
  544.  
  545. isWordTokenNode (Node (WordToken _)) = True
  546. isWordTokenNode _                    = False
  547.  
  548. doLambda :: LispData -> [LispData] -> RunState -> RunResult
  549. doLambda (Node (WordToken wd)) xs st@(_, env) = bindOneLArg wd st >>= evalLambda env xs
  550. doLambda (List ls)             xs st@(_, env) = bindListLArg ls st >>= evalLambda env xs
  551. doLambda (Cons ls ed)          xs st@(_, env) = bindConsLArg ls ed st >>= evalLambda env xs
  552.  
  553. bindOneLArg :: String -> RunState -> RunResult
  554. bindOneLArg wd st@(_, env) | canBind wd env
  555.                            = Right $ bindValue wd st
  556.                            | otherwise
  557.                            = Left  $ "reserved word: " ++ wd
  558.  
  559. bindListLArg :: [LispData] -> RunState -> RunResult
  560. bindListLArg ls st@(List args, env) | length args == length ls
  561.                                     = foldlM fListBind st $ zip ls args
  562.                                     | otherwise
  563.                                     = Left $ "invalid number of arguments: "
  564.  
  565. fListBind :: RunState -> (LispData, LispData) -> RunResult
  566. fListBind (_, env) (Node (WordToken wd), ld) | canBind wd env
  567.                                              = Right $ bindValue wd (ld, env)
  568.                                              | otherwise
  569.                                              = Left $ "reserved word: " ++ wd
  570.  
  571. bindConsLArg :: [LispData] -> LispData -> RunState -> RunResult
  572. bindConsLArg ls (Node (WordToken wd)) (List args, env)
  573.     | length args >= length ls
  574.     = fConsBind ls wd env $ splitAt (length ls) args
  575.     | otherwise
  576.     = Left $ "invalid number of arguments: "
  577.  
  578. fConsBind :: [LispData] -> String -> Env -> ([LispData], [LispData]) -> RunResult    
  579. fConsBind ls wd env (args, []) = bindListLArg ls (List args, env) >>= \(_, e) -> bindOneLArg wd (emptyList, e)
  580. fConsBind ls wd env (args, rm) = bindListLArg ls (List args, env) >>= \(_, e) -> bindOneLArg wd (List rm, e)
  581.  
  582. evalLambda :: Env -> [LispData] -> RunState -> RunResult
  583. evalLambda env xs st = (\(res,_) -> (res, env)) <$> foldlM fLambda st xs
  584.  
  585. fLambda :: RunState -> LispData -> RunResult
  586. fLambda (_, env) code = run code env
  587.  
  588.  
  589. callPlusOp :: ([LispData] -> Env -> RunResult)
  590. callPlusOp = takeAndRunAllArgs executePlusOp
  591.  
  592. executePlusOp :: ArgState -> RunResult
  593. executePlusOp (ls, env) = foldlM sumNums (intZeroValue, env) ls
  594.  
  595. sumNums :: RunState -> LispData -> RunResult
  596. sumNums (Node (IntegerToken v1), env) (Node (IntegerToken v2)) = Right (Node $ IntegerToken $ v1 + v2, env)
  597. sumNums _                             ld                       = Left $ "invalid arguments: " ++ toString ld
  598.  
  599.  
  600. callAstrOp :: ([LispData] -> Env -> RunResult)
  601. callAstrOp = takeAndRunAllArgs executeAstrOp
  602.  
  603. executeAstrOp :: ArgState -> RunResult
  604. executeAstrOp (ls, env) = foldlM mulNums (intOneValue, env) ls
  605.  
  606. mulNums :: RunState -> LispData -> RunResult
  607. mulNums (Node (IntegerToken v1), env) (Node (IntegerToken v2)) = Right (Node $ IntegerToken $ v1 * v2, env)
  608. mulNums _                             ld                       = Left $ "invalid arguments: " ++ toString ld
  609.  
  610.  
  611.  
  612. callMinusOp :: ([LispData] -> Env -> RunResult)
  613. callMinusOp = takeAndRunArgsWithMin 1 executeMinusOp
  614.  
  615. executeMinusOp :: ArgState -> RunResult
  616. executeMinusOp (Node (IntegerToken v):[], env) = Right (Node $ IntegerToken (0 - v), env)
  617. executeMinusOp (fv:ls, env)                    = foldlM subNums (fv, env) ls
  618.  
  619. subNums :: RunState -> LispData -> RunResult
  620. subNums (Node (IntegerToken v1), env) (Node (IntegerToken v2)) = Right (Node $ IntegerToken $ v1 - v2, env)
  621. subNums _                             ld                       = Left $ "invalid arguments: " ++ toString ld
  622.  
  623.  
  624.  
  625.  
  626.  
  627.  
Success #stdin #stdout 0s 8388607KB
comments (?)
stdin 
(define f (lambda (x y) (cons (car x) (cdr y))))
(f '(a b c) '(x y z))
(if (pair? '(a b c)) 'hoge 'piyo)
(if (eq? 'a 'a) 'foo 'bar)
(* (+ 1 2 3) (- 10 4 3) 10)
:quit
stdout 
>>> #<procedure (lambda)>
>>> (a y z)
>>> hoge
>>> foo
>>> 180
>>> bye
https://ideone.com/kYgQxV
language:
Haskell (ghc 8.4.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!