add tuples
This commit is contained in:
parent
6d904fdfc4
commit
8b41c05b94
3 changed files with 44 additions and 4 deletions
1
ast.hs
1
ast.hs
|
@ -17,6 +17,7 @@ data AST = Add AST AST
|
||||||
| Call String [AST]
|
| Call String [AST]
|
||||||
| UnitConst
|
| UnitConst
|
||||||
| Cons AST AST
|
| Cons AST AST
|
||||||
|
| TupleConst [AST]
|
||||||
| ListConst [AST]
|
| ListConst [AST]
|
||||||
| StrConst String
|
| StrConst String
|
||||||
| IntConst Integer
|
| IntConst Integer
|
||||||
|
|
32
interp.hs
32
interp.hs
|
@ -5,6 +5,7 @@
|
||||||
module Interp where
|
module Interp where
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import Data.List (intercalate)
|
||||||
import Control.Monad.State (State, runState, evalState, get, put)
|
import Control.Monad.State (State, runState, evalState, get, put)
|
||||||
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
@ -20,6 +21,7 @@ data Value = IntV Integer
|
||||||
| StrV String
|
| StrV String
|
||||||
| UnitV
|
| UnitV
|
||||||
| StreamV Int
|
| StreamV Int
|
||||||
|
| TupleV [Value]
|
||||||
| ListV [Value]
|
| ListV [Value]
|
||||||
| Builtin BIF
|
| Builtin BIF
|
||||||
| FnV [(Pattern, AST)] -- pattern->body bindings
|
| FnV [(Pattern, AST)] -- pattern->body bindings
|
||||||
|
@ -37,6 +39,7 @@ bind env name value = M.insert name value env
|
||||||
instance Show Value where
|
instance Show Value where
|
||||||
show (IntV i) = show i
|
show (IntV i) = show i
|
||||||
show (StrV s) = show s
|
show (StrV s) = show s
|
||||||
|
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
||||||
show (ListV v) = show v
|
show (ListV v) = show v
|
||||||
show (FnV _) = "<fn>"
|
show (FnV _) = "<fn>"
|
||||||
show (StreamV _) = "<stream>"
|
show (StreamV _) = "<stream>"
|
||||||
|
@ -113,6 +116,8 @@ eval (ListConst v) =
|
||||||
mapM eval v >>= \xs ->
|
mapM eval v >>= \xs ->
|
||||||
return $ ListV xs
|
return $ ListV xs
|
||||||
|
|
||||||
|
eval (TupleConst v) = mapM eval v >>= return . TupleV
|
||||||
|
|
||||||
eval (Var var) = get >>= \(_,env) ->
|
eval (Var var) = get >>= \(_,env) ->
|
||||||
case lookup env var of
|
case lookup env var of
|
||||||
Just v -> return v
|
Just v -> return v
|
||||||
|
@ -125,10 +130,31 @@ eval (Defun name fn) = do
|
||||||
eval fn >>= \fn' ->
|
eval fn >>= \fn' ->
|
||||||
put (s, bind env name fn') >> return fn'
|
put (s, bind env name fn') >> return fn'
|
||||||
Just oldfn -> -- add pattern to old fn
|
Just oldfn -> -- add pattern to old fn
|
||||||
let FnV oldpats = oldfn
|
let FnV oldpatterns = oldfn
|
||||||
Lambda [(pat, body)] = fn
|
newfn = merge fn (Lambda oldpatterns) in
|
||||||
newfn = FnV (oldpats ++ [(pat, body)]) in
|
|
||||||
put (s, bind env name newfn) >> return newfn
|
put (s, bind env name newfn) >> return newfn
|
||||||
|
-- newfn = FnV (oldpats ++ [(pat, body)]) in
|
||||||
|
where
|
||||||
|
-- takes a lambda and a list of patterns and merges their
|
||||||
|
------- patterns recursively, forming a new function
|
||||||
|
mergePatterns :: AST -> AST -> Value
|
||||||
|
mergePatterns (Lambda [newpat]) (Lambda oldpatterns@(oldpat:oldpats)) =
|
||||||
|
if fst newpat /= fst oldpat then
|
||||||
|
-- we've diverged, so let's add it here
|
||||||
|
FnV (oldpatterns ++ [newpat])
|
||||||
|
else
|
||||||
|
-- we're still equal, keep going
|
||||||
|
mergePatterns (snd newpat) (snd oldpat)
|
||||||
|
mergePatterns _ (Lambda b) = FnV b
|
||||||
|
mergePatterns a@(Lambda _) _ = error "k"
|
||||||
|
|
||||||
|
merge = mergePatterns
|
||||||
|
|
||||||
|
{-
|
||||||
|
mergePatterns(a, b):
|
||||||
|
if any pats(b) == pat(a),
|
||||||
|
just \(pats(b) ++ (pat(a) -> bod(a)))
|
||||||
|
else, nothing -}
|
||||||
|
|
||||||
eval (Def name v') = do
|
eval (Def name v') = do
|
||||||
v <- eval v'
|
v <- eval v'
|
||||||
|
|
13
parser.hs
13
parser.hs
|
@ -67,6 +67,17 @@ listSeq p cons = do
|
||||||
symbol "]"
|
symbol "]"
|
||||||
return $ cons lst
|
return $ cons lst
|
||||||
|
|
||||||
|
tupleSeq p cons = do
|
||||||
|
symbol "("
|
||||||
|
lst <- sepBy1 p (symbol ",")
|
||||||
|
symbol ")"
|
||||||
|
return $ cons lst
|
||||||
|
|
||||||
|
emptyTuple cons = do
|
||||||
|
symbol "("
|
||||||
|
symbol ")"
|
||||||
|
return $ cons []
|
||||||
|
|
||||||
intPattern = fmap IntP integer
|
intPattern = fmap IntP integer
|
||||||
varPattern = fmap VarP identifier
|
varPattern = fmap VarP identifier
|
||||||
listPattern = listSeq pattern ListP
|
listPattern = listSeq pattern ListP
|
||||||
|
@ -119,6 +130,8 @@ consExpr = do
|
||||||
expr' = try block
|
expr' = try block
|
||||||
<|> try funDef
|
<|> try funDef
|
||||||
<|> try call
|
<|> try call
|
||||||
|
<|> try (emptyTuple TupleConst)
|
||||||
|
<|> try (tupleSeq exprparser TupleConst)
|
||||||
<|> parens exprparser
|
<|> parens exprparser
|
||||||
<|> listSeq exprparser ListConst
|
<|> listSeq exprparser ListConst
|
||||||
<|> fmap Var identifier
|
<|> fmap Var identifier
|
||||||
|
|
Loading…
Reference in a new issue