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

-- 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 =
  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
    -- , 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 = 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 = 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

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