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