packages feed

hsqml-datamodel-vinyl (empty) → 0.0.0.0

raw patch · 6 files changed

+190/−0 lines, 6 filesdep +basedep +exceptionsdep +hsqml-datamodelsetup-changed

Dependencies added: base, exceptions, hsqml-datamodel, show-type, template-haskell, type-list, vinyl

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Marcin Mrotek++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marcin Mrotek nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# hsqml-datamodel-vinyl
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsqml-datamodel-vinyl.cabal view
@@ -0,0 +1,41 @@+-- Initial hsqml-datamodel-vinyl.cabal generated by cabal init.  For +-- further documentation, see http://haskell.org/cabal/users-guide/++name:                hsqml-datamodel-vinyl+version:             0.0.0.0+synopsis:            HsQML DataModel instances for Vinyl Rec.+-- description:         +license:             BSD3+license-file:        LICENSE+author:              Marcin Mrotek+maintainer:          marcin.jan.mrotek@gmail.com+-- copyright:           +category:            Graphics+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+homepage:        https://github.com/marcinmrotek/hsqml-datamodel-vinyl+source-repository head+   type: git+   location: https://github.com/marcinmrotek/hsqml-datamodel-vinyl.git++flag devel+  description:         Development mode (-Werror)+  default:             False+  manual:              True+  +library+  exposed-modules:     Graphics.QML.DataModel.Vinyl.TH+                       Graphics.QML.DataModel.Vinyl+  build-depends:       base >=4.8 && <4.9+                     , hsqml-datamodel+                     , exceptions+                     , show-type+                     , template-haskell+                     , type-list+                     , vinyl+  hs-source-dirs:      src+  ghc-options:       -Wall+  if flag(devel)+    ghc-options:     -Werror+  default-language:    Haskell2010
+ src/Graphics/QML/DataModel/Vinyl.hs view
@@ -0,0 +1,76 @@+{-# 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))
+ src/Graphics/QML/DataModel/Vinyl/TH.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE TemplateHaskell #-}++{-|+Module      : Graphics.QML.DataModel.Vinyl.TH+Copyright   : (c) Marcin Mrotek, 2015+License     : BSD3+Maintainer  : marcin.jan.mrotek@gmail.com+Stability   : experimental++-}++module Graphics.QML.DataModel.Vinyl.TH +  ( module Graphics.QML.DataModel.Vinyl.TH+  , module Graphics.QML.DataModel.Vinyl+  ) +  where++import Graphics.QML.DataModel.Vinyl()++import Control.Monad+import Language.Haskell.TH+import Type.Showtype++showTypes :: TypeQ -> DecsQ+-- |Declare 'Showtype' instances for all labels in a given type-level list. Only works for explicit literals, unfortunately type synonyms and families aren't expanded.+showTypes types = return.concat =<< mapM inst =<< unwrapTypeList =<< types+  where +    inst t = [d| instance Showtype $(return t) where showtype _ = $(name t) |]+    name (PromotedT n) = stringE $ nameBase n+    name n = fail $ show n ++ " is not a promoted name."++unwrapTypeList :: Type -> Q [Type]+-- |Unwraps a type-level list into a TH list of types.+unwrapTypeList (AppT PromotedConsT a) = return [a]+unwrapTypeList (AppT a b) = (++) <$> unwrapTypeList a <*> unwrapTypeList b+unwrapTypeList PromotedNilT = return []+unwrapTypeList a = fail $ "not a type list: " ++ show a+