git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/IRTS/JavaScript/Specialize.hs
109 lines 3.1 kB history raw
1{-|
2Module : IRTS.JavaScript.Specialize
3Description : The JavaScript specializer.
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 qualified Data.Map.Strict as Map
21import qualified Data.Text as T
22import Idris.Core.TT
23import IRTS.JavaScript.AST
25split :: Char -> String -> [String]
26split c "" = [""]
27split c (x:xs)
28 | c == x = "" : split c xs
29 | otherwise =
30 let ~(h:t) = split c xs
31 in ((x : h) : t)
33qualify :: String -> Name -> Name
34qualify "" n = n
35qualify ns n = sNS n (reverse $ split '.' ns)
37qualifyN :: String -> String -> Name
38qualifyN ns n = qualify ns $ sUN n
40-- special-cased constructors
41type SCtor = [JsExpr] -> JsExpr
43type STest = JsExpr -> JsExpr
45type SProj = JsExpr -> Int -> JsExpr
47constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj)
48constructorOptimizeDB =
49 Map.fromList
50 [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj
51 , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj
52 , item "Prelude.Interfaces" "LT" (const $ JsInt (0-1)) ltTest cantProj
53 , item "Prelude.Interfaces" "EQ" (const $ JsInt 0) eqTest cantProj
54 , item "Prelude.Interfaces" "GT" (const $ JsInt 1) gtTest cantProj
55 -- , item "Prelude.List" "::" cons fillList uncons
56 -- , item "Prelude.List" "Nil" nil emptyList cantProj
57 -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
58 -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj
59 ]
60 -- constructors
61 where
62 trueTest = id
63 falseTest e = JsUniOp (T.pack "!") e
64 ltTest e = JsBinOp "<" e (JsInt 0)
65 eqTest e = JsBinOp "===" e (JsInt 0)
66 gtTest e = JsBinOp ">" e (JsInt 0)
67 -- projections
68 cantProj x j = error $ "This type should be projected"
69 item :: String
70 -> String
71 -> SCtor
72 -> STest
73 -> SProj
74 -> (Name, (SCtor, STest, SProj))
75 item ns n ctor test match = (qualifyN ns n, (ctor, test, match))
77specialCased :: Name -> Maybe (SCtor, STest, SProj)
78specialCased n = Map.lookup n constructorOptimizeDB
80-- special functions
81type SSig = (Int, [JsExpr] -> JsExpr)
83callSpecializeDB :: Map.Map Name (SSig)
84callSpecializeDB =
85 Map.fromList
86 [ qb "Eq" "Int" "==" "==="
87 , qb "Ord" "Int" "<" "<"
88 , qb "Ord" "Int" ">" ">"
89 , qb "Ord" "Int" "<=" "<="
90 , qb "Ord" "Int" ">=" ">="
91 , qb "Eq" "Double" "==" "==="
92 , qb "Ord" "Double" "<" "<"
93 , qb "Ord" "Double" ">" ">"
94 , qb "Ord" "Double" "<=" "<="
95 , qb "Ord" "Double" ">=" ">="
96 ]
97 where
98 qb intf ty op jsop =
99 ( qualify "Prelude.Interfaces" $
100 SN $
101 WhereN
102 0
103 (qualify "Prelude.Interfaces" $
104 SN $ ImplementationN (qualifyN "Prelude.Interfaces" intf) [ty])
105 (SN $ MethodN $ UN op)
106 , (2, \[x, y] -> JsBinOp jsop x y))
108specialCall :: Name -> Maybe SSig
109specialCall n = Map.lookup n callSpecializeDB