git.iko.soy/Idris-dev
on ea65347 help sign in
Idris-dev/src/IRTS/JavaScript/Specialize.hs
123 lines 3.6 kB history raw
1{-|
2Module : IRTS.JavaScript.Specialize
3Description : The JavaScript specializer.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
9{-# LANGUAGE OverloadedStrings, PatternGuards #-}
11module IRTS.JavaScript.Specialize
12 ( SCtor
13 , STest
14 , SProj
15 , specialCased
16 , specialCall
17 , qualifyN
18 ) where
20import Data.Char
21import Data.List
22import qualified Data.Map.Strict as Map
23import Data.Text (Text)
24import qualified Data.Text as T
25import Idris.Core.TT
26import IRTS.JavaScript.AST
28split :: Char -> String -> [String]
29split c "" = [""]
30split c (x:xs)
31 | c == x = "" : split c xs
32 | otherwise =
33 let ~(h:t) = split c xs
34 in ((x : h) : t)
36qualify :: String -> Name -> Name
37qualify "" n = n
38qualify ns n = sNS n (reverse $ split '.' ns)
40qualifyN :: String -> String -> Name
41qualifyN ns n = qualify ns $ sUN n
43-- special-cased constructors
44type SCtor = [JsExpr] -> JsExpr
46type STest = JsExpr -> JsExpr
48type SProj = JsExpr -> Int -> JsExpr
50constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj)
51constructorOptimizeDB =
52 Map.fromList
53 [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj
54 , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj
55 , item "Prelude.Interfaces" "LT" (const $ JsInt (0-1)) ltTest cantProj
56 , item "Prelude.Interfaces" "EQ" (const $ JsInt 0) eqTest cantProj
57 , item "Prelude.Interfaces" "GT" (const $ JsInt 1) gtTest cantProj
58 -- , item "Prelude.List" "::" cons fillList uncons
59 -- , item "Prelude.List" "Nil" nil emptyList cantProj
60 -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
61 -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj
62 ]
63 -- constructors
64 where
65 nil = const $ JsArray []
66 cons [h, t] = JsMethod (JsArray [h]) "concat" [t]
67 -- tests
68 --trueTest e = JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") e
69 trueTest = id
70 falseTest e = JsUniOp (T.pack "!") e
71 emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0)
72 fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0)
73 ltTest e = JsBinOp "<" e (JsInt 0)
74 eqTest e = JsBinOp "===" e (JsInt 0)
75 gtTest e = JsBinOp ">" e (JsInt 0)
76 noneTest e = JsBinOp "===" e JsUndefined
77 notNoneTest e = JsBinOp "!==" e JsUndefined
78 -- projections
79 justProj x n = x
80 uncons x 1 = JsArrayProj (JsInt 0) x
81 uncons x 2 = JsMethod x "slice" [JsInt 1]
82 cantProj x j = error $ "This type should be projected"
83 item :: String
84 -> String
85 -> SCtor
86 -> STest
87 -> SProj
88 -> (Name, (SCtor, STest, SProj))
89 item ns n ctor test match = (qualifyN ns n, (ctor, test, match))
91specialCased :: Name -> Maybe (SCtor, STest, SProj)
92specialCased n = Map.lookup n constructorOptimizeDB
94-- special functions
95type SSig = (Int, [JsExpr] -> JsExpr)
97callSpecializeDB :: Map.Map Name (SSig)
98callSpecializeDB =
99 Map.fromList
100 [ qb "Eq" "Int" "==" "==="
101 , qb "Ord" "Int" "<" "<"
102 , qb "Ord" "Int" ">" ">"
103 , qb "Ord" "Int" "<=" "<="
104 , qb "Ord" "Int" ">=" ">="
105 , qb "Eq" "Double" "==" "==="
106 , qb "Ord" "Double" "<" "<"
107 , qb "Ord" "Double" ">" ">"
108 , qb "Ord" "Double" "<=" "<="
109 , qb "Ord" "Double" ">=" ">="
110 ]
111 where
112 qb intf ty op jsop =
113 ( qualify "Prelude.Interfaces" $
114 SN $
115 WhereN
116 0
117 (qualify "Prelude.Interfaces" $
118 SN $ ImplementationN (qualifyN "Prelude.Interfaces" intf) [ty])
119 (SN $ MethodN $ UN op)
120 , (2, \[x, y] -> JsBinOp jsop x y))
122specialCall :: Name -> Maybe SSig
123specialCall n = Map.lookup n callSpecializeDB