Commit 39fa3252f47d86dbda28ab3beea3a1aff5b213b9 - Argyle

+1

-6

src/Language/Argyle/ABT.hs less more

55	55	in Binder freshVar (substitute newBody v replacement)
56	56
57	57	performSubstitution :: BaseABT v -> String -> BaseABT v -> BaseABT v
58		performSubstitution m n k
59		\| occursFree n m = performSubstitution' m n k
60		\| otherwise = m -- TODO: should be an error?
61
62		performSubstitution' :: BaseABT v -> String -> BaseABT v -> BaseABT v
63		performSubstitution' m n k = case m of
	58	performSubstitution m n k = case m of
64	59	-- Base cases
65	60	Var x \| x == n -> k
66	61	\| otherwise -> Var x

+4

-2

src/Language/Argyle/AST2ABT.hs less more

68	68	freeVars = Set.union (freeVars scope)
69	69	(Set.difference (freeVars bodyScope) declaredFreeVarsSet)
70	70	}
71		undeclaredFreeVars = Set.difference (collectUnboundVars bodyABT) declaredFreeVarsSet
	71	undeclaredFreeVars =
	72	Set.difference (collectUnboundVars bodyABT)
	73	(Set.union (boundVars scope) declaredFreeVarsSet)
72	74	in
73	75	if Set.null undeclaredFreeVars
74		then return $ Right (Literal $ VABT bodyABT, finalScope)
	76	then return $ Right (Literal $ VABT declaredFreeVars bodyABT, finalScope)
75	77	else return $ Left $ "Unbound variables in quoted ABT: " ++ (show undeclaredFreeVars)
76	78
77	79	Op name args -> do

+23

-7

src/Language/Argyle/Interpreter.hs less more

31	31	env <- ask
32	32	return $ VClosure param body env
33	33
34		Literal (VABT abt) -> do
	34	Literal (VABT fvs abt) -> do
35	35	-- We need to extract the ABT so that the bindings from the
36	36	-- current environment are captured in the ABT.
37	37	env <- ask
38	38	-- Build bindings for all unbound vars in the quoted ABT
39		let unboundVars = Set.elems $ collectUnboundVars abt
	39	let unboundVars = Set.elems $ Set.difference
	40	(collectUnboundVars abt)
	41	(Set.fromList $ fvs)
40	42	bindings <- mapM (\name -> do
41	43	case Map.lookup name env of
42	44	Just value -> return (name, Literal value)
43	45	Nothing -> throwError $ "Required binding not found in environment: " ++ name)
44	46	-- (traceShow ("literal-unbound-vars", unboundVars) unboundVars)
45	47	unboundVars
46		return $ VABT $
	48	return $ VABT fvs $
47	49	if null bindings
48	50	then abt
49	51	else Operator "let"

110	112
111	113	-- Core homoiconic functions
112	114	, ("eval", VBuiltin "eval" $ \case
113		[VABT abt] -> runEval abt
114		_ -> Left "'eval' expects an ABT")
	115	[VABT [] abt] ->
	116	runEval abt
	117	[VABT fvs abt] ->
	118	Left $ "eval: Cannot evaluate ABT with declared free variables (" ++ (show fvs) ++ ")"
	119	_ ->
	120	Left "'eval' expects an ABT")
115	121
116	122	, ("subst", VBuiltin "subst" $ \case
117		[VABT m] -> Right $ VBuiltin "subst" $ \case
	123	[VABT mfvs m] -> Right $ VBuiltin "subst" $ \case
118	124	[VString n] -> Right $ VBuiltin "subst" $ \case
119		[VABT k] -> Right $ VABT $ performSubstitution m n k
	125	[VABT kfvs k] -> Right $ performVABTSubstitution mfvs m n kfvs k
120	126	_ -> Left "subst: third argument must be an ABT"
121	127	_ -> Left "subst: second argument must be a string"
122	128	_ -> Left "subst: first argument must be an ABT")
123	129	]
124	130
	131	performVABTSubstitution mfvs m n kfvs k =
	132	-- FIXME: is this wrong? The tests pass but I'm suspicious.
	133	let
	134	abt = performSubstitution m n k
	135	fvs = Set.elems $ Set.union
	136	(Set.difference (Set.fromList mfvs) (Set.singleton n))
	137	(Set.fromList kfvs)
	138	in
	139	VABT fvs abt
	140
125	141	-- \| Run evaluation in the initial environment
126	142	runEval :: ABT -> Either String Value
127	143	runEval expr = runReaderT (eval expr) initialEnv

+8

-17

src/Language/Argyle/REPL.hs less more

18	18	return $ Just val
19	19
20	20	showParses source = do
	21	--
	22	-- FIXME: if there is an error, show the error
	23	-- FIXME: unify this with the version in Main
	24	--
21	25	conslist <- parseUsing (sexprToConsList) source
22		putStrLn $ show conslist
	26	putStrLn $ "ConsList: " ++ show conslist
23	27	ast <- parseUsing (sexprToAST) source
24		putStrLn $ show ast
	28	putStrLn $ "AST: " ++ show ast
25	29	abt <- parseUsing (sexprToABT) source
26		putStrLn $ show abt
	30	putStrLn $ "ABT: " ++ show abt
27	31	case abt of
28	32	Just theAbt -> do
29		putStrLn $ unparseABT theAbt
	33	putStrLn $ unparseABT [] theAbt
30	34	return abt
31	35	Nothing -> do
32	36	return abt
33
34		-- putStrLn "Parse output:"
35		-- case sexprToConsList input of
36		-- Left err -> putStrLn $ "ConsList parse error: " ++ err
37		-- Right conslist -> do
38		-- putStrLn $ "ConsList: " ++ show conslist
39		-- case sexprToAST input of
40		-- Left err -> putStrLn $ "AST parse error: " ++ err
41		-- Right ast -> do
42		-- putStrLn $ "AST: " ++ show ast
43		-- case sexprToABT input of
44		-- Left err -> putStrLn $ "ABT conversion error: " ++ err
45		-- Right abt -> putStrLn $ "ABT: " ++ show abt
46	37
47	38
48	39	data ReplState = ReplState

+11

-13

src/Language/Argyle/Value.hs less more

12	12	data Value
13	13	= VNum Integer
14	14	\| VString String
15		\| VABT ABT
	15	\| VABT [String] ABT
16	16	\| VClosure String ABT Environment
17	17	\| VBuiltin String ([Value] -> Either String Value)
18	18
19	19	instance Eq Value where
20		VNum n1 == VNum n2 = n1 == n2
21		VString s1 == VString s2 = s1 == s2
22		VABT a1 == VABT a2 = a1 == a2
	20	VNum n1 == VNum n2 = n1 == n2
	21	VString s1 == VString s2 = s1 == s2
	22	VABT fvs1 a1 == VABT fvs2 a2 = a1 == a2 && fvs1 == fvs2 -- FIXME this is laughable
23	23	VClosure s1 a1 e1 == VClosure s2 a2 e2 = s1 == s2 && a1 == a2 && e1 == e2
24		VBuiltin s1 _ == VBuiltin s2 _ = s1 == s2
	24	VBuiltin s1 _ == VBuiltin s2 _ = s1 == s2
25	25
26	26	instance Show Value where
27	27	show (VNum n) = show n
28	28	show (VString s) = show s
29		show (VABT abt) = unparseABT abt
	29	show (VABT fvs abt) = unparseABT fvs abt
30	30	show (VClosure {}) = "<closure>"
31	31	show (VBuiltin name _) = "<builtin:" ++ name ++ ">"
32	32
33	33	type Environment = Map.Map String Value
34	34
35	35	-- \| Convert an ABT back to Argyle syntax
36		unparseABT :: ABT -> String
37		unparseABT abt =
38		let freeVars = collectUnboundVars abt
39		in if Set.null freeVars
40		then "(quote " ++ unparseABTExpr abt ++ ")"
41		else "(abt (" ++ unwords (Set.toList freeVars) ++ ") " ++
42		unparseABTExpr abt ++ ")"
	36	unparseABT :: [String] -> ABT -> String
	37	unparseABT [] abt =
	38	"(quote " ++ unparseABTExpr abt ++ ")"
	39	unparseABT freeVars abt =
	40	"(abt (" ++ unwords freeVars ++ ") " ++ unparseABTExpr abt ++ ")"
43	41
44	42	-- \| Convert an ABT expression to Argyle syntax
45	43	unparseABTExpr :: ABT -> String

+1

-1

src/Main.hs less more

46	46	ast <- parseUsing (sexprToAST) source
47	47	putStrLn $ show ast
48	48	abt <- parseUsing (sexprToABT) source
49		putStrLn $ unparseABT abt
	49	putStrLn $ unparseABT [] abt
50	50	putStrLn $ show abt
51	51
52	52	parseUsing :: (String -> Either String x) -> String -> IO x