Hs2Js.hs

{-# LANGUAGE ScopedTypeVariables, TypeFamilies, GADTs, DataKinds, MultiParamTypeClasses
           , FlexibleInstances, FlexibleContexts, PolyKinds #-}
module Main where

import Data.Proxy
import Prelude hiding ((+))
import qualified Prelude

data Nat = Zero | Succ Nat

type One = Succ Zero

class TypeNum (a :: Nat) where
    intRep :: proxy a -> Int

instance TypeNum Zero where
    intRep _ = 0

instance TypeNum a => TypeNum (Succ a) where
    intRep _ = intRep (Proxy :: Proxy a) Prelude.+ 1

type family Max (x :: Nat) (y :: Nat) :: Nat where
    Max Zero x = x
    Max x Zero = x
    Max (Succ x) (Succ y) = Succ (Max x y)

data JNumber
data JString
data JBool
data JArray (t :: *)

data NormalArgument (n :: Nat) t
data TupleMember (n :: Nat) (i :: Nat) t

data Zip (freshName :: Nat) c1 c2 where
    Zip :: (Collection c1, Collection c2) => c1 -> c2 -> Zip (Max (FreshName c1) (FreshName c2)) c1 c2

data Map (freshName :: Nat) f c t2 where
    Map :: (Collection c, n ~ FreshName c, t1 ~ Element c, Expr t2) => (LambdaArg (Succ n) (Element c) -> t2) -> c -> Map (Succ (Succ n)) (LambdaArg (Succ n) (Element c) -> t2) c (ExprType t2)

data Add a b (t :: *) where
    Add :: (Addable a b, t ~ SumType a b) => a -> b -> Add a b t

class Argument a where
    argName :: proxy a -> String

instance TypeNum n => Argument (NormalArgument n t) where
    argName _ = "arg" ++ show (intRep (Proxy :: Proxy n))

instance (TypeNum n, TypeNum i) => Argument (TupleMember n i t) where
    argName _ = "arg" ++ show (intRep (Proxy :: Proxy n)) ++ "[" ++ show (intRep (Proxy :: Proxy i)) ++ "]"

instance TypeNum n => Argument (TupleMember n i1 t1, TupleMember n i2 t2) where
    argName _ = "arg" ++ show (intRep (Proxy :: Proxy n))

class HasFreshName a where
    type FreshName a :: Nat

class Collection c where
    type Element c :: *

instance Collection (JArray t) where
    type Element (JArray t) = t

class HasFreshName f => Transform f where

instance HasFreshName (Zip n c1 c2) where
    type FreshName (Zip n c1 c2) = n

instance Collection (Zip n c1 c2) where
    type Element (Zip n c1 c2) = (Element c1, Element c2)

instance HasFreshName (Map n f c t) where
    type FreshName (Map n f c t) = n

instance Collection (Map n f c t) where
    type Element (Map n f c t) = t

instance HasFreshName (NormalArgument n t) where
    type FreshName (NormalArgument n t) = n

instance HasFreshName (TupleMember n i t) where
    type FreshName (TupleMember n i t) = n

instance Collection t => Collection (NormalArgument n t) where
    type Element (NormalArgument n t) = Element t

instance Collection t => Collection (TupleMember n i t) where
    type Element (TupleMember n i t) = Element t

type family LambdaArg (n :: Nat) t :: * where
    LambdaArg n (t1, t2) = (TupleMember n Zero t1, TupleMember n One t2)
    LambdaArg n t = NormalArgument n t

class Addable a b where
    type SumType a b :: k

class NativeAddable (a :: k) (b :: k) where
    type NativeSumType a b :: k

instance NativeAddable JNumber JNumber where
    type NativeSumType JNumber JNumber = JNumber

instance NativeAddable JString JString where
    type NativeSumType JString JString = JString

instance NativeAddable t1 t2 => Addable (NormalArgument n1 t1) (NormalArgument n2 t2) where
    type SumType (NormalArgument n1 t1) (NormalArgument n2 t2) = NativeSumType t1 t2

instance NativeAddable t1 t2 => Addable (TupleMember n1 i1 t1) (NormalArgument n2 t2) where
    type SumType (TupleMember n1 i1 t1) (NormalArgument n2 t2) = NativeSumType t1 t2

instance NativeAddable t1 t2 => Addable (NormalArgument n2 t2) (TupleMember n1 i1 t1) where
    type SumType (NormalArgument n2 t2) (TupleMember n1 i1 t1) = NativeSumType t1 t2

instance NativeAddable t1 t2 => Addable (TupleMember n2 i2 t2) (TupleMember n1 i1 t1) where
    type SumType (TupleMember n2 i2 t2) (TupleMember n1 i1 t1) = NativeSumType t1 t2

class Expr t where
    type ExprType t :: *

instance Expr (Add a b t) where
    type ExprType (Add a b t) = t

instance Expr (Map n f c t) where
    type ExprType (Map n f c t) = JArray t

instance Expr (Zip n c1 c2) where
    type ExprType (Zip n c1 c2) = JArray (Element c1, Element c2)

toProxy :: a -> Proxy a
toProxy _ = Proxy

type P = Proxy

p :: Proxy a
p = Proxy

class Compilable a where
    compile :: proxy a -> String

instance (Compilable b, Argument a) => Compilable (a -> b) where
    compile _ = "function (" ++ argName (p :: P a) ++ ") { return " ++ compile (p :: P b) ++ "; }"

instance (Compilable f, Compilable c) => Compilable (Map n f c t) where
    compile _ = "map(" ++ compile (p :: P f) ++ ", " ++ compile (p :: P c) ++ ")"

instance (Compilable c1, Compilable c2) => Compilable (Zip n c1 c2) where
    compile _ = "zip(" ++ compile (p :: P c1) ++ ", " ++ compile (p :: P c2) ++ ")"

instance (Compilable a, Compilable b) => Compilable (Add a b t) where
    compile _ = "(" ++ compile (p :: P a) ++ " + " ++ compile (p :: P b) ++ ")"

instance TypeNum n => Compilable (NormalArgument n t) where
    compile = argName

instance (TypeNum n, TypeNum i) => Compilable (TupleMember n i t) where
    compile = argName

(+) :: (Addable a b, t ~ SumType a b) => a -> b -> Add a b t
(+) = Add

arg0 :: proxy a -> NormalArgument Zero a
arg0 = undefined

arg1 :: proxy a -> NormalArgument One a
arg1 = undefined

jnumber :: Proxy JNumber
jnumber = Proxy

jstring :: Proxy JString
jstring = Proxy

jbool :: Proxy JBool
jbool = Proxy

jarray :: Proxy a -> Proxy (JArray a)
jarray _ = Proxy

sampleFunc = Map (\(x, y) -> x + y) $ Zip (arg0 $ jarray jnumber) (arg1 $ jarray jnumber)

main :: IO ()
main = undefined