Skip to content

Instantly share code, notes, and snippets.

@camilstaps camilstaps/IKS.icl
Last active Aug 3, 2016

Embed
What would you like to do?
IKS Interpreter
module IKS
import StdArray, StdFile, StdList, StdOverloaded, StdString
from StdFunc import o
import StdDynamic
import Data.Functor
import Control.Applicative
import Control.Monad
import Data.Either
from Data.Func import $
:: Error = Parse String | Runtime String
instance toString Error
where
toString (Parse s) = "parse error: " +++ s
toString (Runtime s) = "runtime error: " +++ s
:: IKS = I | K | S | D Dynamic | App IKS IKS
instance toString IKS
where
toString I = "I"
toString K = "K"
toString S = "S"
toString (D (i :: Int)) = toString i
toString (D (c :: Char)) = "'" +++ toString c +++ "'"
toString (D (s :: String)) = "\"" +++ s +++ "\""
toString (App a b) = paren a +++ paren b
where
paren :: IKS -> String
paren iks=:(D _) = "(" +++ toString iks +++ ")"
paren iks=:(App _ _) = "(" +++ toString iks +++ ")"
paren iks = toString iks
parse :: !String -> Either Error IKS
parse s = p (fromString s) >>= appify
where
appify :: ![IKS] -> Either Error IKS
appify [] = Left $ Parse "cannot parse the empty string"
appify [a] = Right a
appify [a:b:c] = appify [App a b:c]
p :: ![Char] -> Either Error [IKS]
p [] = Right []
p ['I':iks] = (\iks -> [I:iks]) <$> p iks
p ['K':iks] = (\iks -> [K:iks]) <$> p iks
p ['S':iks] = (\iks -> [S:iks]) <$> p iks
p [')':iks] = Left $ Parse "unmatched parentheses"
p ['(':iks]
| isEmpty rest = Left $ Parse "unmatched parentheses"
| otherwise = liftA2 (\a b -> [a:b]) this (p $ tl rest)
where
this = p encaps >>= appify
(encaps,rest) = span_paren 0 iks
span_paren :: Int [Char] -> ([Char], [Char])
span_paren _ [] = ([], [])
span_paren 0 cs=:[')':_] = ([], cs)
span_paren i [')':cs] = let (a,b) = span_paren (i-1) cs in ([')':a],b)
span_paren i ['(':cs] = let (a,b) = span_paren (i+1) cs in (['(':a],b)
span_paren i [c:cs] = let (a,b) = span_paren i cs in ([c:a], b)
p iks=:[d:_]
| isDigit d = if (isEmpty rest) (Right [v]) ((\iks -> [v:iks]) <$> p rest)
where
v = let i = (toInt (toString digits)) in D (dynamic i)
(digits,rest) = span isDigit iks
p ['"':iks]
| isEmpty rest = Left $ Parse "unmatched '\"'"
| otherwise = (\iks -> [v:iks]) <$> p (tl rest)
where
v = let s = toString string in D (dynamic s)
(string,rest) = span ((<>) '"') iks
p ['\'':c:'\'':rest] = if (isEmpty rest) (Right [v]) ((\iks -> [v:iks]) <$> p rest)
where v = D (dynamic c)
p [' ':iks] = p iks
p ['+':iks] = (\iks -> [D (dynamic (+) :: Int Int -> Int):iks]) <$> p iks
p ['-':iks] = (\iks -> [D (dynamic (-) :: Int Int -> Int):iks]) <$> p iks
p iks = Left $ Parse $ "couldn't parse: ..." +++ toString iks
interp :: IKS -> Dynamic
interp I = dynamic (\x -> x) :: A.a: a -> a
interp K = dynamic (\x y -> x) :: A.a b: a b -> a
interp S = dynamic (\x y z -> x z (y z)) :: A.a b c: (a b -> c) (a -> b) a -> c
interp (D d) = d
interp (App a b) = dynApply (interp a) (interp b)
where
dynApply :: Dynamic Dynamic -> Dynamic
dynApply (f :: a -> b) (x :: a) = dynamic f x :: b
dynApply a b
= dynamic (Runtime $ "cannot apply " +++ tb +++ " to " +++ ta)
where
ta = toString (typeCodeOfDynamic a)
tb = toString (typeCodeOfDynamic b)
Start :: *World -> *World
Start w
# (io,w) = stdio w
# io = loop io
# (ok,w) = fclose io w
= w
where
loop :: *File -> *File
loop f
# f = f <<< "λ: "
# (line,f) = freadline f
| line == "" = f <<< "\n"
| line == "\n" = loop (f <<< "Use Ctrl-D to exit\n")
# line = line % (0, size line - 2)
# iks = parse line
# msg = case iks of
(Left err) = toString err
(Right iks) = show iks
# f = f <<< msg <<< "\n"
= loop f
show :: IKS -> String
show iks = showD 0 $ interp iks
where
showD :: Int Dynamic -> String
showD _ (i :: Int) = toString i
showD _ (c :: Char) = "'" +++ toString c +++ "'"
showD _ (s :: String) = "\"" +++ s +++ "\""
showD _ (e :: Error) = toString e
showD _ f = "function :: " +++ toString (typeCodeOfDynamic f)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.