knockout.hs

{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, PolyKinds, TypeOperators, FlexibleInstances, TypeFamilies, UndecidableInstances #-}

import GHC.TypeLits

module Knockout where

data PrimType = String | Number

data Model
  = ObsPrim { primType :: PrimType }
  | ObsModel { modelType :: Props }
  | ObsArray { arrayType :: Props }

data Props = PropCollection [Named Model]

data Named x = Name Symbol x

data PropsContext
  = Top
  | PartOfModel Symbol [Named Model] [Named Model] PropsContext
  | PartOfArray Symbol [Named Model] [Named Model] PropsContext

data PropsInContext = PIC Props PropsContext

data Repr x = Repr

class Has x xs 

instance (Name x y ~ x1) => Has x (x1 ': xs)
instance (Has x xs) => Has x (x1 ': xs)

type family (:++) (xs :: [Named Model]) (ys :: [Named Model]) :: [Named Model] 

type instance '[] :++ xs = xs
type instance (x ': xs) :++ ys = x ': (xs :++ ys)

infixl :++

type family Parent (pic :: PropsInContext) :: PropsInContext

type instance Parent (PIC p (PartOfModel name lefts rights ctx)) = PIC (PropCollection (lefts :++ '[Name name (ObsModel p)] :++ rights)) ctx
type instance Parent (PIC p (PartOfArray name lefts rights ctx)) = PIC (PropCollection (lefts :++ '[Name name (ObsArray p)] :++ rights)) ctx

infixr :!

type family (:!) (pic :: PropsInContext) p :: PropsInContext

type instance PIC (PropCollection ((Name p (ObsModel props)) ': ps)) ctx :! p = PIC props (PartOfModel p '[] ps ctx)
type instance PIC (PropCollection ((Name p (ObsArray props)) ': ps)) ctx :! p = PIC props (PartOfArray p '[] ps ctx)

infixr :.

data Expr pic where
  ExprPrim :: (Has p props) => Repr p -> Expr (PIC props ctx)
  ExprParent :: Expr (Parent pic) -> Expr pic
  (:.) :: Repr p -> Expr (pic :! p) -> Expr pic

type TaskModel = '[Name '"Title" (ObsPrim String)]

toExprString :: Expr pic -> String
toExprString (ExprPrim repr) = "Prim"
toExprString (ExprParent rest) = "$parent" ++ toExprString rest
toExprString (p :. rest) = "Child." ++ toExprString rest