git.iko.soy/elk
on f76a22e help sign in
elk/src/Initialize.hs
163 lines 5.1 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 subs <- unify (liftM2 (++) hints hints') (rename expr)
21 return (seq subs expr)
23{--
24initialize' str = do
25 expr <- toDefs =<< tokenize str
26-- let rexpr = rename expr
27-- let init = simp_loop rexpr
28-- return $ if depth init < depth rexpr then init else rexpr
29 return $ rename expr
30--}
31{--
32simp_loop exp = if exp == exp' then exp' else simp_loop exp'
33 where exp' = simp exp
35simp expr =
36 let f = simp in
37 case expr of
38 Range e1 e2 -> simp_range (f e1) (f e2)
39 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
40 Lambda x e -> Lambda x (f e)
41 App e1 e2 -> simp_app (f e1) (f e2)
42 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
43 Lift e es -> Lift (f e) $ map f es
44 Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
45 Async e -> Async (f e)
46 Let x e1 e2 -> simp_let x (f e1) (f e2)
47 Data name es -> Data name (map f es)
48 Case e cases -> simp_case (f e) cases
49 _ -> expr
51data Status = NoMatch | Quit deriving (Show,Eq)
53simp_case v cases =
54 case v of
55 Data _ _ -> case rights $ map (\(p,e) -> match p v e) cases of
56 { v:_ -> v; _ -> Case v cases }
57 _ -> Case v cases
59match p v hole =
60 case p of PAnything -> return hole
61 PVar x -> return $ Let x v hole
62 PData pn ps ->
63 case v of
64 Data vn vs -> if pn /= vn then Left NoMatch else
65 foldM (flip ($)) hole (zipWith match ps vs)
66 _ -> Left Quit
68simp_let x e1 e2
69 | not (x `freeIn` e2) = e2
70 | isValue e1 = Let x e1 (replace x e1 e2)
71 | otherwise = Let x e1 e2
73simp_app e1 e2 =
74 case e1 of
75 Let x s e -> if x `freeIn` e2 then error "Overlapping names!" else
76 Let x s (App e e2)
77 Lambda x e -> Let x e2 e
78{--
79 Var "constant" -> App (Lambda "v" (Lift (Var "v") [])) e2
80 Var "async" -> Async e2
81 Var "foldp" -> Lambda "b" . Lambda "s" $ (Fold e2 (Var "b") (Var "s"))
82 Var "lift" -> Lambda "s" (Lift e2 [Var "s"])
83 Var "lift2" -> Lambda "s1" . Lambda "s2" $ (Lift e2 [Var "s1",Var "s2"])
84--}
85 _ -> App e1 e2
87simp_if (Boolean b) e2 e3 = if b then e2 else e3
88simp_if a b c = If a b c
90isValue expr =
91 case expr of
92 Number _ -> True
93 Chr _ -> True
94 Boolean _ -> True
95 Range _ _ -> True
96 Lambda _ _ -> True
97 Data _ _ -> True
98 Var _ -> True
99 _ -> False
101simp_range lo hi = toAST (parse code)
102 where toAST = either (error "Compilation Failure") (\f -> App (App f lo) hi)
103 parse str = toExpr =<< tokenize str
104 code = "let range xs lo hi = \
105 \if hi < lo then xs else range (hi:xs) lo (hi-1) in\
106 \ \\x y -> range [] x y"
108simp_binop "mod" (Number n) (Number m) = Number (mod n m)
109simp_binop "mod" e1 e2 = Binop "mod" e1 e2
110simp_binop str e1 e2
111 | isAlpha (head str) || '_' == head str =
112 App (App (Var str) e1) e2
113 | otherwise = binop str e1 e2
115binop op (Number n) (Number m) = f n m
116 where f a b = case op of
117 { "+" -> Number $ (+) a b
118 ; "-" -> Number $ (-) a b
119 ; "*" -> Number $ (*) a b
120 --; "/" -> Number $ div a b
121 ; "<" -> Boolean $ a < b
122 ; ">" -> Boolean $ a < b
123 ; "<=" -> Boolean $ a <= b
124 ; ">=" -> Boolean $ a >= b
125 ; "==" -> Boolean $ a == b
126 ; "/=" -> Boolean $ a /= b
127 ; _ -> Binop op (Number n) (Number m) }
129binop "-" e (Number 0) = e
130binop "+" (Number 0) e = e
131binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
132binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
134binop "/" e (Number 1) = e
135binop "*" (Number 0) e = Number 0
136binop "*" (Number 1) e = e
137binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
138binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
140binop "+" e (Number n) = binop "+" (Number n) e
141binop "*" e (Number n) = binop "*" (Number n) e
143binop op (Boolean n) (Boolean m) = f n m
144 where f a b = case op of { "&&" -> Boolean $ (&&) n m
145 ; "||" -> Boolean $ (||) n m
146 ; _ -> Binop op (Boolean n) (Boolean m) }
148binop "&&" (Boolean True) e = e
149binop "&&" (Boolean False) e = Boolean False
150binop "||" (Boolean True) e = Boolean True
151binop "||" (Boolean False) e = e
153binop op e (Boolean n) = binop op (Boolean n) e
155binop ":" h t = cons h t
156binop "++" (Data "Nil" []) e = e
157binop "++" e (Data "Nil" []) = e
158binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
160binop "$" e1 e2 = App e1 e2
162binop op e1 e2 = Binop op e1 e2
163--}