Skip to content

Instantly share code, notes, and snippets.

@LukaHorvat
Created September 5, 2015 00:42
Show Gist options
  • Save LukaHorvat/04d00e75a9504fdd2015 to your computer and use it in GitHub Desktop.
Save LukaHorvat/04d00e75a9504fdd2015 to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment