git.iko.soy/elk
on 54edea7 help sign in
elk/src/Initialize.hs
164 lines 5.2 kB history raw
1module Initialize (initialize) where
3import Ast
4import Control.Arrow (first)
5import Control.Monad
6import Data.Char (isAlpha)
7import Data.Maybe (mapMaybe)
8import Data.Either (rights)
9import FreeVar
10import Lexer
11import Parser (toExpr,toDefs)
12import Rename (rename)
13import Replace
15import Unify
16import Hints
18initialize str = do
19 (expr, hints') <- toDefs =<< tokenize str
20 let expr' = rename expr
21 subs <- unify (liftM2 (++) hints hints') expr'
22 return (seq subs expr')
24{--
25initialize' str = do
26 expr <- toDefs =<< tokenize str
27-- let rexpr = rename expr
28-- let init = simp_loop rexpr
29-- return $ if depth init < depth rexpr then init else rexpr
30 return $ rename expr
31--}
32{--
33simp_loop exp = if exp == exp' then exp' else simp_loop exp'
34 where exp' = simp exp
36simp expr =
37 let f = simp in
38 case expr of
39 Range e1 e2 -> simp_range (f e1) (f e2)
40 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
41 Lambda x e -> Lambda x (f e)
42 App e1 e2 -> simp_app (f e1) (f e2)
43 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
44 Lift e es -> Lift (f e) $ map f es
45 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
46 Async e -> Async (f e)
47 Let x e1 e2 -> simp_let x (f e1) (f e2)
48 Data name es -> Data name (map f es)
49 Case e cases -> simp_case (f e) cases
50 _ -> expr
52data Status = NoMatch | Quit deriving (Show,Eq)
54simp_case v cases =
55 case v of
56 Data _ _ -> case rights $ map (\(p,e) -> match p v e) cases of
57 { v:_ -> v; _ -> Case v cases }
58 _ -> Case v cases
60match p v hole =
61 case p of PAnything -> return hole
62 PVar x -> return $ Let x v hole
63 PData pn ps ->
64 case v of
65 Data vn vs -> if pn /= vn then Left NoMatch else
66 foldM (flip ($)) hole (zipWith match ps vs)
67 _ -> Left Quit
69simp_let x e1 e2
70 | not (x `freeIn` e2) = e2
71 | isValue e1 = Let x e1 (replace x e1 e2)
72 | otherwise = Let x e1 e2
74simp_app e1 e2 =
75 case e1 of
76 Let x s e -> if x `freeIn` e2 then error "Overlapping names!" else
77 Let x s (App e e2)
78 Lambda x e -> Let x e2 e
79{--
80 Var "constant" -> App (Lambda "v" (Lift (Var "v") [])) e2
81 Var "async" -> Async e2
82 Var "foldp" -> Lambda "b" . Lambda "s" $ (Fold e2 (Var "b") (Var "s"))
83 Var "lift" -> Lambda "s" (Lift e2 [Var "s"])
84 Var "lift2" -> Lambda "s1" . Lambda "s2" $ (Lift e2 [Var "s1",Var "s2"])
85--}
86 _ -> App e1 e2
88simp_if (Boolean b) e2 e3 = if b then e2 else e3
89simp_if a b c = If a b c
91isValue expr =
92 case expr of
93 Number _ -> True
94 Chr _ -> True
95 Boolean _ -> True
96 Range _ _ -> True
97 Lambda _ _ -> True
98 Data _ _ -> True
99 Var _ -> True
100 _ -> False
102simp_range lo hi = toAST (parse code)
103 where toAST = either (error "Compilation Failure") (\f -> App (App f lo) hi)
104 parse str = toExpr =<< tokenize str
105 code = "let range xs lo hi = \
106 \if hi < lo then xs else range (hi:xs) lo (hi-1) in\
107 \ \\x y -> range [] x y"
109simp_binop "mod" (Number n) (Number m) = Number (mod n m)
110simp_binop "mod" e1 e2 = Binop "mod" e1 e2
111simp_binop str e1 e2
112 | isAlpha (head str) || '_' == head str =
113 App (App (Var str) e1) e2
114 | otherwise = binop str e1 e2
116binop op (Number n) (Number m) = f n m
117 where f a b = case op of
118 { "+" -> Number $ (+) a b
119 ; "-" -> Number $ (-) a b
120 ; "*" -> Number $ (*) a b
121 --; "/" -> Number $ div a b
122 ; "<" -> Boolean $ a < b
123 ; ">" -> Boolean $ a < b
124 ; "<=" -> Boolean $ a <= b
125 ; ">=" -> Boolean $ a >= b
126 ; "==" -> Boolean $ a == b
127 ; "/=" -> Boolean $ a /= b
128 ; _ -> Binop op (Number n) (Number m) }
130binop "-" e (Number 0) = e
131binop "+" (Number 0) e = e
132binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
133binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
135binop "/" e (Number 1) = e
136binop "*" (Number 0) e = Number 0
137binop "*" (Number 1) e = e
138binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
139binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
141binop "+" e (Number n) = binop "+" (Number n) e
142binop "*" e (Number n) = binop "*" (Number n) e
144binop op (Boolean n) (Boolean m) = f n m
145 where f a b = case op of { "&&" -> Boolean $ (&&) n m
146 ; "||" -> Boolean $ (||) n m
147 ; _ -> Binop op (Boolean n) (Boolean m) }
149binop "&&" (Boolean True) e = e
150binop "&&" (Boolean False) e = Boolean False
151binop "||" (Boolean True) e = Boolean True
152binop "||" (Boolean False) e = e
154binop op e (Boolean n) = binop op (Boolean n) e
156binop ":" h t = cons h t
157binop "++" (Data "Nil" []) e = e
158binop "++" e (Data "Nil" []) = e
159binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
161binop "$" e1 e2 = App e1 e2
163binop op e1 e2 = Binop op e1 e2
164--}