Vinyl.hs

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE 
    DataKinds
  , FlexibleContexts
  , FlexibleInstances
  , GADTs
  , PolyKinds
  , ScopedTypeVariables
  , TypeOperators 
  #-}

{-|
Module      : Graphics.QML.DataModel.Vinyl
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

HsQML DataModel instances recursively defined for all 'Rec's.
'SetupColumns' requires the field labels to be instances of 'Showtype', which can be automatically declared using "Graphics.QML.DataModel.Vinyl.TH" module.
-}

module Graphics.QML.DataModel.Vinyl where

import Graphics.QML.DataModel.Generic
import Graphics.QML.DataModel.FFI

import Control.Exception
import Data.Vinyl
import Data.Type.List
import GHC.TypeLits
import Type.Showtype

instance CountFields (Rec f '[]) where
  countFields _ = 0

instance CountFields (Rec f xs) => CountFields (Rec f (x ': xs)) where
  countFields _ = 1 + countFields (undefined :: sing (Rec f xs))

instance Mock (Rec f '[]) where
  mock = RNil

instance (Mock (f x), Mock (Rec f xs)) => Mock (Rec f (x ': xs)) where
  mock = mock :& mock

instance QtTable (Rec f '[]) where
  getColumn i _ = throwIO $ ColumnIndexOutOfBounds i 0

instance ( KnownNat (Length xs)
         , QtField (f x)
         , QtTable (Rec f xs)
         ) => QtTable (Rec f (x ': xs)) where
  getColumn i (r :& rs) = if i >= end then qtField r else getColumn i rs
    where end = lengthVal (undefined :: sing xs)

instance SetupColumns (Rec f '[]) where
  setupColumns _ _ = return ()

instance ( KnownNat (Length xs)
         , Showtype x
         , SetupColumns (Rec f xs)
         ) => SetupColumns (Rec f (x ': xs)) where
  setupColumns hndl _ = do
       addHaskellModelRole hndl ix $ showtype (undefined :: sing x)
       setupColumns hndl (undefined :: sing (Rec f xs))
    where ix = lengthVal (undefined :: sing xs)

lengthVal 
  :: forall sing xs a.
   ( KnownNat (Length xs) 
   , Integral a
   )
  => sing xs -> a
-- |Integral value of the length of a type-level list.
lengthVal _ = fromIntegral $ natVal (undefined :: proxy (Length xs))