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