{-# LANGUAGE OverloadedStrings, PatternGuards #-}
module IRTS.JavaScript.Specialize
( SCtor
, STest
, SProj
, specialCased
, specialCall
, qualifyN
) where
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Idris.Core.TT
import IRTS.JavaScript.AST
split :: Char -> String -> [String]
split :: Char -> String -> [String]
split Char
c String
"" = [String
""]
split Char
c (Char
x:String
xs)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
x = String
"" forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
xs
| Bool
otherwise =
let ~(String
h:[String]
t) = Char -> String -> [String]
split Char
c String
xs
in ((Char
x forall a. a -> [a] -> [a]
: String
h) forall a. a -> [a] -> [a]
: [String]
t)
qualify :: String -> Name -> Name
qualify :: String -> Name -> Name
qualify String
"" Name
n = Name
n
qualify String
ns Name
n = Name -> [String] -> Name
sNS Name
n (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Char -> String -> [String]
split Char
'.' String
ns)
qualifyN :: String -> String -> Name
qualifyN :: String -> String -> Name
qualifyN String
ns String
n = String -> Name -> Name
qualify String
ns forall a b. (a -> b) -> a -> b
$ String -> Name
sUN String
n
type SCtor = [JsExpr] -> JsExpr
type STest = JsExpr -> JsExpr
type SProj = JsExpr -> Int -> JsExpr
constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj)
constructorOptimizeDB :: Map Name (SCtor, STest, SProj)
constructorOptimizeDB =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Bool" String
"True" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Bool -> JsExpr
JsBool Bool
True) forall {a}. a -> a
trueTest forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Bool" String
"False" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Bool -> JsExpr
JsBool Bool
False) STest
falseTest forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"LT" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt (Int
0forall a. Num a => a -> a -> a
-Int
1)) STest
ltTest forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"EQ" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
0) STest
eqTest forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"GT" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
1) STest
gtTest forall {p} {p} {a}. p -> p -> a
cantProj
]
where
trueTest :: a -> a
trueTest = forall {a}. a -> a
id
falseTest :: STest
falseTest JsExpr
e = Text -> STest
JsUniOp (String -> Text
T.pack String
"!") JsExpr
e
ltTest :: STest
ltTest JsExpr
e = Text -> JsExpr -> STest
JsBinOp Text
"<" JsExpr
e (Int -> JsExpr
JsInt Int
0)
eqTest :: STest
eqTest JsExpr
e = Text -> JsExpr -> STest
JsBinOp Text
"===" JsExpr
e (Int -> JsExpr
JsInt Int
0)
gtTest :: STest
gtTest JsExpr
e = Text -> JsExpr -> STest
JsBinOp Text
">" JsExpr
e (Int -> JsExpr
JsInt Int
0)
cantProj :: p -> p -> a
cantProj p
x p
j = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"This type should be projected"
item :: String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item :: String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
ns String
n SCtor
ctor STest
test SProj
match = (String -> String -> Name
qualifyN String
ns String
n, (SCtor
ctor, STest
test, SProj
match))
specialCased :: Name -> Maybe (SCtor, STest, SProj)
specialCased :: Name -> Maybe (SCtor, STest, SProj)
specialCased Name
n = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (SCtor, STest, SProj)
constructorOptimizeDB
type SSig = (Int, [JsExpr] -> JsExpr)
callSpecializeDB :: Map.Map Name (SSig)
callSpecializeDB :: Map Name SSig
callSpecializeDB =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Eq" Text
"Int" Text
"==" Text
"==="
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
"<" Text
"<"
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
">" Text
">"
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
"<=" Text
"<="
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
">=" Text
">="
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Eq" Text
"Double" Text
"==" Text
"==="
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
"<" Text
"<"
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
">" Text
">"
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
"<=" Text
"<="
, forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
">=" Text
">="
]
where
qb :: String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
intf Text
ty Text
op Text
jsop =
( String -> Name -> Name
qualify String
"Prelude.Interfaces" forall a b. (a -> b) -> a -> b
$
SpecialName -> Name
SN forall a b. (a -> b) -> a -> b
$
Int -> Name -> Name -> SpecialName
WhereN
Int
0
(String -> Name -> Name
qualify String
"Prelude.Interfaces" forall a b. (a -> b) -> a -> b
$
SpecialName -> Name
SN forall a b. (a -> b) -> a -> b
$ Name -> [Text] -> SpecialName
ImplementationN (String -> String -> Name
qualifyN String
"Prelude.Interfaces" String
intf) [Text
ty])
(SpecialName -> Name
SN forall a b. (a -> b) -> a -> b
$ Name -> SpecialName
MethodN forall a b. (a -> b) -> a -> b
$ Text -> Name
UN Text
op)
, (a
2, \[JsExpr
x, JsExpr
y] -> Text -> JsExpr -> STest
JsBinOp Text
jsop JsExpr
x JsExpr
y))
specialCall :: Name -> Maybe SSig
specialCall :: Name -> Maybe SSig
specialCall Name
n = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name SSig
callSpecializeDB