{-|
Module      : IRTS.JavaScript.Specialize
Description : The JavaScript specializer.

License     : BSD3
Maintainer  : The Idris Community.
-}

{-# 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

-- special-cased constructors
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
    -- , item "Prelude.List" "::" cons fillList uncons
    -- , item "Prelude.List" "Nil" nil emptyList cantProj
    -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
    -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj
    ]
    -- constructors
  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)
    -- projections
    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

-- special functions
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