{-# 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x = String
"" String -> [String] -> [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 Char -> String -> String
forall a. a -> [a] -> [a]
: String
h) String -> [String] -> [String]
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 ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
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 (Name -> Name) -> Name -> Name
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 =
[(Name, (SCtor, STest, SProj))] -> Map Name (SCtor, STest, SProj)
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" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Bool -> JsExpr
JsBool Bool
True) STest
forall {a}. a -> a
trueTest SProj
forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Bool" String
"False" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Bool -> JsExpr
JsBool Bool
False) STest
falseTest SProj
forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"LT" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt (Int
0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) STest
ltTest SProj
forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"EQ" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
0) STest
eqTest SProj
forall {p} {p} {a}. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item String
"Prelude.Interfaces" String
"GT" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
1) STest
gtTest SProj
forall {p} {p} {a}. p -> p -> a
cantProj
]
where
trueTest :: a -> a
trueTest = a -> a
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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
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 = Name
-> Map Name (SCtor, STest, SProj) -> Maybe (SCtor, STest, SProj)
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 =
[(Name, SSig)] -> Map Name SSig
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Eq" Text
"Int" Text
"==" Text
"==="
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
"<" Text
"<"
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
">" Text
">"
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
"<=" Text
"<="
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Int" Text
">=" Text
">="
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Eq" Text
"Double" Text
"==" Text
"==="
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
"<" Text
"<"
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
">" Text
">"
, String -> Text -> Text -> Text -> (Name, SSig)
forall {a}.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb String
"Ord" Text
"Double" Text
"<=" Text
"<="
, String -> Text -> Text -> Text -> (Name, SSig)
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" (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
SpecialName -> Name
SN (SpecialName -> Name) -> SpecialName -> Name
forall a b. (a -> b) -> a -> b
$
Int -> Name -> Name -> SpecialName
WhereN
Int
0
(String -> Name -> Name
qualify String
"Prelude.Interfaces" (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
SpecialName -> Name
SN (SpecialName -> Name) -> SpecialName -> Name
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 (SpecialName -> Name) -> SpecialName -> Name
forall a b. (a -> b) -> a -> b
$ Name -> SpecialName
MethodN (Name -> SpecialName) -> Name -> SpecialName
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 = Name -> Map Name SSig -> Maybe SSig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name SSig
callSpecializeDB