TypeNode.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where

import Control.Monad
import Control.Monad.ST
import Data.Proxy
import Data.STRef
import Data.Typeable
import GHC.Exts


main :: IO ()
main = print $ outs (Proxy :: Proxy Qux)

data Qux deriving Typeable -- sink
instance Node Qux where
    type Ins Qux = '[Bar, Baz]

data Bar deriving Typeable -- intermediate
instance Node Bar where
    type Ins Bar = '[Foo]

data Baz deriving Typeable -- intermediate
instance Node Baz where
    type Ins Baz = '[Foo]

data Foo deriving Typeable -- source
instance Node Foo where
    type Ins Foo = '[]



-- nodes, defined with their "in" edges

class (Typeable n, All Node (Ins n)) => Node n where
    type Ins n :: [*]

outs :: Node snk => Proxy snk -> [(TypeRep, [TypeRep])]
outs snkp = runST $ do
    ref <- newSTRef []
    go ref snkp
    readSTRef ref
  where
    go :: Node n => STRef s [(TypeRep, [TypeRep])] -> Proxy n -> ST s ()
    go ref np = void $ sequence $ tmap (go' ref np) (insProxy np)
      where
        insProxy :: Node n => Proxy n -> Proxy '(Node, Ins n)
        insProxy _ = Proxy
    go' :: (Node n, Node i) => STRef s [(TypeRep, [TypeRep])] -> Proxy n -> Proxy i -> ST s ()
    go' ref np inp = do
        modifySTRef ref (update (++) (typeRep inp) [typeRep np])
        go ref inp

-- list as k/v store for this demo

update :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
update _ k v [] = [(k, v)]
update f k v (kv@(k', v') : kvs)
    | k == k' = (k, f v v') : kvs
    | otherwise = kv : update f k v kvs

-- fold and map over type-level lists

class All (c :: * -> Constraint) (ts :: [*]) where
    tfold :: (forall a. c a => Proxy a -> b -> b) -> b -> Proxy '(c, ts) -> b
instance All c '[] where
    tfold _ x _ = x
instance (c t, All c ts)  => All c (t ': ts) where
    tfold f x _ = (Proxy :: Proxy t) `f` tfold f x (Proxy :: Proxy '(c, ts))

tmap :: All c ts => (forall a. c a => Proxy a -> b) -> Proxy '(c, ts) -> [b]
tmap f lp = tfold (\p xs -> f p : xs) [] lp