{-# 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 c :: Char
c "" = [""]
split c :: Char
c (x :: Char
x:xs :: String
xs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x = "" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
xs
| Bool
otherwise =
let ~(h :: String
h:t :: [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 "" n :: Name
n = Name
n
qualify ns :: String
ns n :: 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 '.' String
ns)
qualifyN :: String -> String -> Name
qualifyN :: String -> String -> Name
qualifyN ns :: String
ns n :: 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 "Prelude.Bool" "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 "Prelude.Bool" "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 "Prelude.Interfaces" "LT" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt (0Int -> Int -> Int
forall a. Num a => a -> a -> a
-1)) STest
ltTest SProj
forall p p a. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item "Prelude.Interfaces" "EQ" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt 0) STest
eqTest SProj
forall p p a. p -> p -> a
cantProj
, String
-> String
-> SCtor
-> STest
-> SProj
-> (Name, (SCtor, STest, SProj))
item "Prelude.Interfaces" "GT" (JsExpr -> SCtor
forall a b. a -> b -> a
const (JsExpr -> SCtor) -> JsExpr -> SCtor
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt 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 e :: JsExpr
e = Text -> STest
JsUniOp (String -> Text
T.pack "!") JsExpr
e
ltTest :: STest
ltTest e :: JsExpr
e = Text -> JsExpr -> STest
JsBinOp "<" JsExpr
e (Int -> JsExpr
JsInt 0)
eqTest :: STest
eqTest e :: JsExpr
e = Text -> JsExpr -> STest
JsBinOp "===" JsExpr
e (Int -> JsExpr
JsInt 0)
gtTest :: STest
gtTest e :: JsExpr
e = Text -> JsExpr -> STest
JsBinOp ">" JsExpr
e (Int -> JsExpr
JsInt 0)
cantProj :: p -> p -> a
cantProj x :: p
x j :: p
j = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "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 ns :: String
ns n :: String
n ctor :: SCtor
ctor test :: STest
test match :: 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 n :: 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 "Eq" "Int" "==" "==="
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Int" "<" "<"
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Int" ">" ">"
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Int" "<=" "<="
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Int" ">=" ">="
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Eq" "Double" "==" "==="
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Double" "<" "<"
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Double" ">" ">"
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Double" "<=" "<="
, String -> Text -> Text -> Text -> (Name, SSig)
forall a.
Num a =>
String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb "Ord" "Double" ">=" ">="
]
where
qb :: String -> Text -> Text -> Text -> (Name, (a, SCtor))
qb intf :: String
intf ty :: Text
ty op :: Text
op jsop :: Text
jsop =
( String -> Name -> Name
qualify "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
0
(String -> Name -> Name
qualify "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 "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)
, (2, \[x :: JsExpr
x, y :: JsExpr
y] -> Text -> JsExpr -> STest
JsBinOp Text
jsop JsExpr
x JsExpr
y))
specialCall :: Name -> Maybe SSig
specialCall :: Name -> Maybe SSig
specialCall n :: 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