add tuples
This commit is contained in:
parent
6d904fdfc4
commit
8b41c05b94
1
ast.hs
1
ast.hs
|
@ -17,6 +17,7 @@ data AST = Add AST AST
|
|||
| Call String [AST]
|
||||
| UnitConst
|
||||
| Cons AST AST
|
||||
| TupleConst [AST]
|
||||
| ListConst [AST]
|
||||
| StrConst String
|
||||
| IntConst Integer
|
||||
|
|
34
interp.hs
34
interp.hs
|
@ -5,6 +5,7 @@
|
|||
module Interp where
|
||||
import Prelude hiding (lookup)
|
||||
import qualified Data.Map as M
|
||||
import Data.List (intercalate)
|
||||
import Control.Monad.State (State, runState, evalState, get, put)
|
||||
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
@ -20,6 +21,7 @@ data Value = IntV Integer
|
|||
| StrV String
|
||||
| UnitV
|
||||
| StreamV Int
|
||||
| TupleV [Value]
|
||||
| ListV [Value]
|
||||
| Builtin BIF
|
||||
| FnV [(Pattern, AST)] -- pattern->body bindings
|
||||
|
@ -37,6 +39,7 @@ bind env name value = M.insert name value env
|
|||
instance Show Value where
|
||||
show (IntV i) = show i
|
||||
show (StrV s) = show s
|
||||
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
||||
show (ListV v) = show v
|
||||
show (FnV _) = "<fn>"
|
||||
show (StreamV _) = "<stream>"
|
||||
|
@ -113,6 +116,8 @@ eval (ListConst v) =
|
|||
mapM eval v >>= \xs ->
|
||||
return $ ListV xs
|
||||
|
||||
eval (TupleConst v) = mapM eval v >>= return . TupleV
|
||||
|
||||
eval (Var var) = get >>= \(_,env) ->
|
||||
case lookup env var of
|
||||
Just v -> return v
|
||||
|
@ -125,10 +130,31 @@ eval (Defun name fn) = do
|
|||
eval fn >>= \fn' ->
|
||||
put (s, bind env name fn') >> return fn'
|
||||
Just oldfn -> -- add pattern to old fn
|
||||
let FnV oldpats = oldfn
|
||||
Lambda [(pat, body)] = fn
|
||||
newfn = FnV (oldpats ++ [(pat, body)]) in
|
||||
put (s, bind env name newfn) >> return newfn
|
||||
let FnV oldpatterns = oldfn
|
||||
newfn = merge fn (Lambda oldpatterns) in
|
||||
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
|
||||
v <- eval v'
|
||||
|
|
13
parser.hs
13
parser.hs
|
@ -67,6 +67,17 @@ listSeq p cons = do
|
|||
symbol "]"
|
||||
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
|
||||
varPattern = fmap VarP identifier
|
||||
listPattern = listSeq pattern ListP
|
||||
|
@ -119,6 +130,8 @@ consExpr = do
|
|||
expr' = try block
|
||||
<|> try funDef
|
||||
<|> try call
|
||||
<|> try (emptyTuple TupleConst)
|
||||
<|> try (tupleSeq exprparser TupleConst)
|
||||
<|> parens exprparser
|
||||
<|> listSeq exprparser ListConst
|
||||
<|> fmap Var identifier
|
||||
|
|
Loading…
Reference in New Issue