From 013de64267545e8dbf19137125e6384b98700f14 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 30 Oct 2016 14:00:38 +0100 Subject: [PATCH 01/27] Start rewrite --- bookkeeper.cabal | 12 +- package.yaml | 2 +- src/Bookkeeper/Internal.hs | 250 +++++++++++++----------------- src/Bookkeeper/Internal/Errors.hs | 4 +- src/Bookkeeper/Internal/Sort.hs | 2 + src/Bookkeeper/Internal/Types.hs | 116 ++++++++++++++ 6 files changed, 238 insertions(+), 148 deletions(-) create mode 100644 src/Bookkeeper/Internal/Sort.hs create mode 100644 src/Bookkeeper/Internal/Types.hs diff --git a/bookkeeper.cabal b/bookkeeper.cabal index b989d32..469c585 100644 --- a/bookkeeper.cabal +++ b/bookkeeper.cabal @@ -33,12 +33,14 @@ library ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 - , type-level-sets + , mtl == 2.2.* , data-default-class exposed-modules: Bookkeeper Bookkeeper.Internal Bookkeeper.Internal.Errors + Bookkeeper.Internal.Sort + Bookkeeper.Internal.Types default-language: Haskell2010 executable readme @@ -48,7 +50,7 @@ executable readme ghc-options: -Wall -pgmL markdown-unlit -fno-warn-unused-top-binds build-depends: base >= 4.9 && < 4.10 - , type-level-sets + , mtl == 2.2.* , data-default-class , base >=4.9 && < 4.10 , bookkeeper , markdown-unlit default-language: Haskell2010 @@ -62,7 +64,7 @@ test-suite doctest ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 - , type-level-sets + , mtl == 2.2.* , data-default-class , doctest >= 0.9 && < 0.12 , Glob >= 0.7 && < 0.8 @@ -81,7 +83,7 @@ test-suite spec ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 - , type-level-sets + , mtl == 2.2.* , data-default-class , bookkeeper , hspec > 2 && < 3 @@ -100,7 +102,7 @@ benchmark bench ghc-options: -Wall -O2 build-depends: base >= 4.9 && < 4.10 - , type-level-sets + , mtl == 2.2.* , data-default-class , bookkeeper , criterion diff --git a/package.yaml b/package.yaml index 7edbe68..876c347 100644 --- a/package.yaml +++ b/package.yaml @@ -19,7 +19,7 @@ ghc-options: -Wall dependencies: - base >= 4.9 && < 4.10 - - type-level-sets + - mtl == 2.2.* - data-default-class diff --git a/src/Bookkeeper/Internal.hs b/src/Bookkeeper/Internal.hs index 55d8467..9aaff9a 100644 --- a/src/Bookkeeper/Internal.hs +++ b/src/Bookkeeper/Internal.hs @@ -1,86 +1,20 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Bookkeeper.Internal where -import GHC.OverloadedLabels -import GHC.Generics -import qualified Data.Type.Map as Map -import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) -import Data.Default.Class (Default(..)) -import Data.Kind (Type) -import Data.Type.Map (Map, Mapping((:->))) -import Data.Monoid ((<>)) -import Data.List (intercalate) +import GHC.TypeLits (CmpSymbol) +import Data.Type.Equality (type (==)) +import Data.Proxy +import Control.Monad.Identity -import Bookkeeper.Internal.Errors +import Bookkeeper.Internal.Types ------------------------------------------------------------------------------- --- Book ------------------------------------------------------------------------------- -- Using a type synonym allows the user to write the fields in any order, and -- yet have the underlying value always have sorted fields. -type Book a = Book' (Map.AsMap a) - --- | The internal representation of a Book. -newtype Book' (a :: [Mapping Symbol Type]) = Book { getBook :: Map a } - -instance ShowHelper (Book' a) => Show (Book' a) where - show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}" - where - go (k, v) = k <> " = " <> v - -class ShowHelper a where - showHelper :: a -> [(String, String)] - -instance ShowHelper (Book' '[]) where - showHelper _ = [] - -instance ( ShowHelper (Book' xs) - , KnownSymbol k - , Show v - ) => ShowHelper (Book' ((k :=> v) ': xs)) where - showHelper (Book (Map.Ext k v rest)) = (show k, show v):showHelper (Book rest) - -instance Eq (Book' '[]) where - _ == _ = True - -instance (Eq val, Eq (Book' xs)) => Eq (Book' ((field :=> val) ': xs) ) where - Book (Map.Ext _ a as) == Book (Map.Ext _ b bs) = a == b && Book as == Book bs - -instance Monoid (Book' '[]) where - mempty = emptyBook - _ `mappend` _ = emptyBook - -instance Default (Book' '[]) where - def = emptyBook - -instance ( Default (Book' xs) - , Default v - ) => Default (Book' ((k :=> v) ': xs)) where - def = Book (Map.Ext Map.Var def (getBook def)) +type Book xs = Book' Identity (Sort xs '[]) --- | A book with no records. You'll usually want to use this to construct --- books. -emptyBook :: Book '[] -emptyBook = Book Map.Empty - ------------------------------------------------------------------------------- --- Other types ------------------------------------------------------------------------------- - --- | An alias for ':->' because otherwise you'll have to tick your --- constructors. -type a :=> b = a ':-> b - - -instance (s ~ s') => IsLabel s (Key s') where - fromLabel _ = Key - --- | 'Key' is simply a proxy. You will usually not need to generate it --- directly, as it is generated by the OverlodadedLabels magic. -data Key (a :: Symbol) = Key - deriving (Eq, Show, Read, Generic) ------------------------------------------------------------------------------ -- Setters and getters @@ -90,7 +24,7 @@ data Key (a :: Symbol) = Key -- | @Gettable field val book@ is the constraint needed to get a value of type -- @val@ from the field @field@ in the book of type @Book book@. -type Gettable field book val = (Map.Submap '[field :=> val] book, Contains book field val) +type Gettable field book val = (Subset book '[ field :=> val ]) -- | Get a value by key, if it exists. -- @@ -106,16 +40,16 @@ type Gettable field book val = (Map.Submap '[field :=> val] book, Contains book -- ... • In the expression: get #moneyFrom julian -- ... get :: forall field book val. (Gettable field book val) - => Key field -> Book' book -> val -get _ (Book bk) = case (Map.submap bk :: Map '[field :=> val]) of - Map.Ext _ v Map.Empty -> v + => Key field -> Book' Identity book -> val +get _ bk = case (getSubset bk :: Book' Identity '[field :=> val]) of + BCons _ (Identity v) BNil -> v -- | Flipped and infix version of 'get'. -- -- >>> julian ?: #name -- "Julian K. Arni" (?:) :: forall field book val. (Gettable field book val) - => Book' book -> Key field -> val + => Book' Identity book -> Key field -> val (?:) = flip get infixl 3 ?: @@ -124,31 +58,19 @@ infixl 3 ?: -- | 'Settable field val old new' is a constraint needed to set the the field -- 'field' to a value of type 'val' in the book of type 'Book old'. The -- resulting book will have type 'Book new'. -type Settable field val old new = - ( - Map.Submap (Map.AsMap (old Map.:\ field)) old - , Map.Unionable '[ field :=> val] (Map.AsMap (old Map.:\ field)) - , new ~ Map.AsMap (( field :=> val) ': (Map.AsMap (old Map.:\ field))) - ) -- | Sets or updates a field to a value. -- -- >>> set #likesDoctest True julian -- Book {age = 28, likesDoctest = True, name = "Julian K. Arni"} -set :: forall field val old new . ( Settable field val old new) - => Key field -> val -> Book' old -> Book' new -set p v old = Book new - where - Book deleted = delete p old - added = Map.Ext (Map.Var :: Map.Var field) v deleted - new = Map.asMap added +set :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) +set key value = insert key (Identity value) -- | Infix version of 'set' -- -- >>> julian & #age =: 29 -- Book {age = 29, name = "Julian K. Arni"} -(=:) :: ( Settable field val old new) - => Key field -> val -> Book' old -> Book' new +(=:) :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) (=:) = set infix 3 =: @@ -157,11 +79,9 @@ infix 3 =: -- | @Modifiable field val val' old new@ is a constraint needed to apply a -- function of type @val -> val'@ to the field @field@ in the book of type -- @Book old@. The resulting book will have type @Book new@. -type Modifiable field val val' old new = - ( Settable field val' old new - , Map.AsMap new ~ new - , Contains old field val - , Map.Submap '[ field :=> val] old +type Modifiable field originalValue newValue originalBook = + ( Gettable field originalBook originalValue + , Insertable field newValue originalBook ) -- | Apply a function to a field. @@ -177,8 +97,9 @@ type Modifiable field val val' old new = -- ... '["age" ':-> Int, "name" ':-> String] -- ... • In the expression: modify #height (\ _ -> 132) julian -- ... -modify :: ( Modifiable field val val' old new) - => Key field -> (val -> val') -> Book' old -> Book new +modify :: (Modifiable key originalValue newValue originalBook) + => Key key -> (originalValue -> newValue) -> Book' Identity originalBook + -> Book' Identity (Insert key newValue originalBook) modify p f b = set p v b where v = f $ get p b @@ -186,12 +107,14 @@ modify p f b = set p v b -- -- >>> julian & #name %: fmap toUpper -- Book {age = 28, name = "JULIAN K. ARNI"} -(%:) :: ( Modifiable field val val' old new) - => Key field -> (val -> val') -> Book' old -> Book new +(%:) :: (Modifiable key originalValue newValue originalBook) + => Key key -> (originalValue -> newValue) -> Book' Identity originalBook + -> Book' Identity (Insert key newValue originalBook) (%:) = modify infixr 3 %: +type Deletable key oldBook = Subset oldBook (Delete key oldBook) -- | Delete a field from a 'Book', if it exists. If it does not, returns the -- @Book@ unmodified. -- @@ -202,45 +125,12 @@ infixr 3 %: -- ... '["age" ':-> Int] -- ... • In the expression: get #name -- ... -delete :: forall field old . - ( Map.Submap (Map.AsMap (old Map.:\ field)) old - ) => Key field -> Book' old -> Book (old Map.:\ field) -delete _ (Book bk) = Book $ Map.submap bk - - --- * Generics +delete :: forall key oldBook f . + ( Deletable key oldBook + ) => Key key -> Book' f oldBook -> Book' f (Delete key oldBook) +delete _ bk = getSubset bk -class FromGeneric a book | a -> book where - fromGeneric :: a x -> Book' book - -instance FromGeneric cs book => FromGeneric (D1 m cs) book where - fromGeneric (M1 xs) = fromGeneric xs - -instance FromGeneric cs book => FromGeneric (C1 m cs) book where - fromGeneric (M1 xs) = fromGeneric xs - -instance (v ~ Map.AsMap ('[name ':-> t])) - => FromGeneric (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) v where - fromGeneric (M1 (K1 t)) = (Key =: t) emptyBook - -instance - ( FromGeneric l lbook - , FromGeneric r rbook - , Map.Unionable lbook rbook - , book ~ Map.Union lbook rbook - ) => FromGeneric (l :*: r) book where - fromGeneric (l :*: r) - = Book $ Map.union (getBook (fromGeneric l)) (getBook (fromGeneric r)) - -type family Expected a where - Expected (l :+: r) = TypeError ('Text "Cannot convert sum types into Books") - Expected U1 = TypeError ('Text "Cannot convert non-record types into Books") - -instance (book ~ Expected (l :+: r)) => FromGeneric (l :+: r) book where - fromGeneric = error "impossible" - -instance (book ~ Expected U1) => FromGeneric U1 book where - fromGeneric = error "impossible" +{- -- | Generate a @Book@ from an ordinary Haskell record via GHC Generics. @@ -271,3 +161,83 @@ fromRecord = fromGeneric . from -- >>> import Data.Char (toUpper) -- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ] -- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni" +-} + +------------------------------------------------------------------------------ +-- Internal stuff +------------------------------------------------------------------------------ + +-- Insertion sort for simplicity. +type family Sort unsorted sorted where + Sort '[] sorted = sorted + Sort (key :=> value ': xs) sorted = Sort xs (Insert key value sorted) + +type family Insert key value oldMap where + Insert key value '[] = '[ key :=> value ] + Insert key value (key :=> someValue ': restOfMap) = (key :=> value ': restOfMap) + Insert key value (focusKey :=> someValue ': restOfMap) + = Ifte (CmpSymbol key focusKey == 'LT) + (key :=> value ': focusKey :=> someValue ': restOfMap) + (key :=> value ': focusKey :=> someValue ': restOfMap) + +type family Ifte cond iftrue iffalse where + Ifte 'True iftrue iffalse = iftrue + Ifte 'False iftrue iffalse = iffalse + +------------------------------------------------------------------------------ +-- Subset +------------------------------------------------------------------------------ + +class Subset set subset where + getSubset :: Book' f set -> Book' f subset + +instance Subset '[] '[] where getSubset = id +instance (Subset tail1 tail2) => Subset (head ': tail1) (head ': tail2) where + getSubset (BCons key value oldBook) = BCons key value $ getSubset oldBook +instance (Subset tail subset) => Subset (head ': tail) subset where + getSubset (BCons _key _value oldBook) = getSubset oldBook + +------------------------------------------------------------------------------ +-- Insertion +------------------------------------------------------------------------------ + +class Insertable key value oldMap where + insert :: Key key -> f value -> Book' f oldMap -> Book' f (Insert key value oldMap) + +instance Insertable key value '[] where + insert key value oldBook = BCons key value oldBook + +instance Insertable key value (key :=> someValue ': restOfMap) where + insert key value (BCons _ _ oldBook) = BCons key value oldBook + +instance + ( Insertable' (CmpSymbol key oldKey) key value + (oldKey :=> oldValue ': restOfMap) + (Insert key value (oldKey :=> oldValue ': restOfMap)) + ) => Insertable key value (oldKey :=> oldValue ': restOfMap) where + insert key value oldBook = insert' flag key value oldBook + where + flag :: Proxy (CmpSymbol key oldKey) + flag = Proxy + +class Insertable' flag key value oldMap newMap where + insert' :: Proxy flag -> Key key -> f value -> Book' f oldMap -> Book' f newMap + +instance Insertable' 'LT key value + oldMap + (key :=> value ': oldMap) where + insert' _ key value oldBook = BCons key value oldBook +instance Insertable' 'EQ key value + (oldKey :=> oldValue ': restOfMap) + (key :=> value ': restOfMap) where + insert' _ key value (BCons _ _ oldBook) = BCons key value oldBook +instance (newMap ~ Insert key value restOfMap, Insertable key value restOfMap) => Insertable' 'GT key value + (oldKey :=> oldValue ': restOfMap) + (oldKey :=> oldValue ': newMap) where + insert' _ key value (BCons oldKey oldValue oldBook) = BCons oldKey oldValue (insert key value oldBook) + +type family Delete keyToDelete oldBook where + Delete keyToDelete (keyToDelete :=> someValue ': xs) = xs + Delete keyToDelete (anotherKey :=> someValue ': xs) + = (anotherKey :=> someValue ': Delete keyToDelete xs) + Delete keyToDelete '[] = '[] diff --git a/src/Bookkeeper/Internal/Errors.hs b/src/Bookkeeper/Internal/Errors.hs index e0f2a90..07ba88d 100644 --- a/src/Bookkeeper/Internal/Errors.hs +++ b/src/Bookkeeper/Internal/Errors.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Bookkeeper.Internal.Errors where -import qualified Data.Type.Map as Map +{-import qualified Data.Type.Map as Map-} import GHC.TypeLits (TypeError, ErrorMessage(..)) import GHC.Exts @@ -16,5 +16,5 @@ type family Contains' book field orig exp :: Constraint where :$$: Text "Book type:" :$$: ShowType orig ) - Contains' ((k Map.:-> v) ': m) k orig exp = (v ~ exp) + {-Contains' ((k Map.:-> v) ': m) k orig exp = (v ~ exp)-} Contains' (any ': m) k orig exp = Contains' m k orig exp diff --git a/src/Bookkeeper/Internal/Sort.hs b/src/Bookkeeper/Internal/Sort.hs new file mode 100644 index 0000000..22a2400 --- /dev/null +++ b/src/Bookkeeper/Internal/Sort.hs @@ -0,0 +1,2 @@ +module Bookkeeper.Internal.Sort where + diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs new file mode 100644 index 0000000..a49e98b --- /dev/null +++ b/src/Bookkeeper/Internal/Types.hs @@ -0,0 +1,116 @@ +module Bookkeeper.Internal.Types where + +import Data.Kind (Type) +import GHC.Generics +import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..), CmpSymbol) +import GHC.OverloadedLabels +import Data.Default.Class (Default(..)) +import Control.Monad.Identity + +------------------------------------------------------------------------------ +-- :=> +------------------------------------------------------------------------------ + +data (a :: Symbol) :=> (b :: k) + +------------------------------------------------------------------------------ +-- Key +------------------------------------------------------------------------------ + +-- | 'Key' is simply a proxy. You will usually not need to create one +-- directly, as it is generated by the OverlodadedLabels magic. +data Key (a :: Symbol) = Key + deriving (Eq, Show, Read, Generic) + +instance (s ~ s') => IsLabel s (Key s') where + fromLabel _ = Key + +------------------------------------------------------------------------------ +-- Book +------------------------------------------------------------------------------ + +data Book' :: (k -> Type) -> [Type] -> Type where + BNil :: Book' f '[] + BCons :: Key key -> f a -> Book' f as -> Book' f (k :=> a ': as) + +instance Eq (Book' f '[]) where + _ == _ = True + +instance (Eq (f val), Eq (Book' f xs)) => Eq (Book' f ((field :=> val) ': xs)) where + BCons _ value1 rest1 == BCons _ value2 rest2 + = value1 == value2 && rest1 == rest2 + +instance Monoid (Book' Identity '[]) where + mempty = emptyBook + _ `mappend` _ = emptyBook + +instance Default (Book' Identity '[]) where + def = emptyBook + +instance ( Default (Book' f xs) + , Default (f v) + ) => Default (Book' f ((k :=> v) ': xs)) where + def = BCons Key def def + +-- | A book with no records. You'll usually want to use this to construct +-- books. +emptyBook :: Book' Identity '[] +emptyBook = BNil + +{- + +instance ShowHelper (Book' a) => Show (Book' a) where + show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}" + where + go (k, v) = k <> " = " <> v + +class ShowHelper a where + showHelper :: a -> [(String, String)] + +instance ShowHelper (Book' '[]) where + showHelper _ = [] + +instance ( ShowHelper (Book' xs) + , KnownSymbol k + , Show v + ) => ShowHelper (Book' ((k :=> v) ': xs)) where + showHelper (Book (Map.Ext k v rest)) = (show k, show v):showHelper (Book rest) + +-} + +-- * Generics + +{- +class FromGeneric a book | a -> book where + fromGeneric :: a x -> Book' Identity book + +instance FromGeneric cs book => FromGeneric (D1 m cs) book where + fromGeneric (M1 xs) = fromGeneric xs + +instance FromGeneric cs book => FromGeneric (C1 m cs) book where + fromGeneric (M1 xs) = fromGeneric xs + +instance (v ~ Book' Identity '[name :=> t]) + => FromGeneric (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) v where + fromGeneric (M1 (K1 t)) = (Key =: t) emptyBook + +instance + ( FromGeneric l lbook + , FromGeneric r rbook + , Map.Unionable lbook rbook + , book ~ Map.Union lbook rbook + ) => FromGeneric (l :*: r) book where + fromGeneric (l :*: r) + = Book $ Map.union (getBook (fromGeneric l)) (getBook (fromGeneric r)) + +type family Expected a where + Expected (l :+: r) = TypeError ('Text "Cannot convert sum types into Books") + Expected U1 = TypeError ('Text "Cannot convert non-record types into Books") + +instance (book ~ Expected (l :+: r)) => FromGeneric (l :+: r) book where + fromGeneric = error "impossible" + +instance (book ~ Expected U1) => FromGeneric U1 book where + fromGeneric = error "impossible" + + -} From 35fab1e3c61d4e7ad6d8f601921e4aa73c5fa217 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 17 Nov 2016 23:38:34 +0100 Subject: [PATCH 02/27] Compiling again --- bookkeeper.cabal | 3 +- src/Bookkeeper.hs | 6 + src/Bookkeeper/Internal.hs | 95 +-------------- src/Bookkeeper/Internal/Operations.hs | 16 +++ src/Bookkeeper/Internal/Types.hs | 163 ++++++++++++++++++++++---- stack.yaml | 4 +- 6 files changed, 171 insertions(+), 116 deletions(-) create mode 100644 src/Bookkeeper/Internal/Operations.hs diff --git a/bookkeeper.cabal b/bookkeeper.cabal index 469c585..a06edaa 100644 --- a/bookkeeper.cabal +++ b/bookkeeper.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.14.0. +-- This file has been generated from package.yaml by hpack version 0.14.1. -- -- see: https://github.com/sol/hpack @@ -39,6 +39,7 @@ library Bookkeeper Bookkeeper.Internal Bookkeeper.Internal.Errors + Bookkeeper.Internal.Operations Bookkeeper.Internal.Sort Bookkeeper.Internal.Types default-language: Haskell2010 diff --git a/src/Bookkeeper.hs b/src/Bookkeeper.hs index 7476583..2e7d66f 100644 --- a/src/Bookkeeper.hs +++ b/src/Bookkeeper.hs @@ -30,6 +30,10 @@ module Bookkeeper , modify , (%:) + -- * Union + , Unionable + , union + -- * Deleting , delete @@ -47,4 +51,6 @@ module Bookkeeper ) where import Bookkeeper.Internal +import Bookkeeper.Internal.Types import Data.Function + diff --git a/src/Bookkeeper/Internal.hs b/src/Bookkeeper/Internal.hs index 9aaff9a..3c6aee6 100644 --- a/src/Bookkeeper/Internal.hs +++ b/src/Bookkeeper/Internal.hs @@ -3,11 +3,8 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Bookkeeper.Internal where -import GHC.TypeLits (CmpSymbol) -import Data.Type.Equality (type (==)) -import Data.Proxy import Control.Monad.Identity - +import GHC.Generics import Bookkeeper.Internal.Types @@ -55,9 +52,9 @@ infixl 3 ?: -- * Setters --- | 'Settable field val old new' is a constraint needed to set the the field --- 'field' to a value of type 'val' in the book of type 'Book old'. The --- resulting book will have type 'Book new'. +-- | 'Settable field value old' is a constraint needed to set the the field +-- 'field' to a value of type 'value' in the book of type 'Book old'. +type Settable field value oldBook = Insertable field value oldBook -- | Sets or updates a field to a value. -- @@ -130,8 +127,6 @@ delete :: forall key oldBook f . ) => Key key -> Book' f oldBook -> Book' f (Delete key oldBook) delete _ bk = getSubset bk -{- - -- | Generate a @Book@ from an ordinary Haskell record via GHC Generics. -- @@ -153,7 +148,7 @@ delete _ bk = getSubset bk -- ... -- ... • Cannot convert non-record types into Books -- ... -fromRecord :: (Generic a, FromGeneric (Rep a) bookRep) => a -> Book' bookRep +fromRecord :: (Generic a, FromGeneric (Rep a) bookRep) => a -> Book' Identity bookRep fromRecord = fromGeneric . from -- $setup @@ -161,83 +156,3 @@ fromRecord = fromGeneric . from -- >>> import Data.Char (toUpper) -- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ] -- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni" --} - ------------------------------------------------------------------------------- --- Internal stuff ------------------------------------------------------------------------------- - --- Insertion sort for simplicity. -type family Sort unsorted sorted where - Sort '[] sorted = sorted - Sort (key :=> value ': xs) sorted = Sort xs (Insert key value sorted) - -type family Insert key value oldMap where - Insert key value '[] = '[ key :=> value ] - Insert key value (key :=> someValue ': restOfMap) = (key :=> value ': restOfMap) - Insert key value (focusKey :=> someValue ': restOfMap) - = Ifte (CmpSymbol key focusKey == 'LT) - (key :=> value ': focusKey :=> someValue ': restOfMap) - (key :=> value ': focusKey :=> someValue ': restOfMap) - -type family Ifte cond iftrue iffalse where - Ifte 'True iftrue iffalse = iftrue - Ifte 'False iftrue iffalse = iffalse - ------------------------------------------------------------------------------- --- Subset ------------------------------------------------------------------------------- - -class Subset set subset where - getSubset :: Book' f set -> Book' f subset - -instance Subset '[] '[] where getSubset = id -instance (Subset tail1 tail2) => Subset (head ': tail1) (head ': tail2) where - getSubset (BCons key value oldBook) = BCons key value $ getSubset oldBook -instance (Subset tail subset) => Subset (head ': tail) subset where - getSubset (BCons _key _value oldBook) = getSubset oldBook - ------------------------------------------------------------------------------- --- Insertion ------------------------------------------------------------------------------- - -class Insertable key value oldMap where - insert :: Key key -> f value -> Book' f oldMap -> Book' f (Insert key value oldMap) - -instance Insertable key value '[] where - insert key value oldBook = BCons key value oldBook - -instance Insertable key value (key :=> someValue ': restOfMap) where - insert key value (BCons _ _ oldBook) = BCons key value oldBook - -instance - ( Insertable' (CmpSymbol key oldKey) key value - (oldKey :=> oldValue ': restOfMap) - (Insert key value (oldKey :=> oldValue ': restOfMap)) - ) => Insertable key value (oldKey :=> oldValue ': restOfMap) where - insert key value oldBook = insert' flag key value oldBook - where - flag :: Proxy (CmpSymbol key oldKey) - flag = Proxy - -class Insertable' flag key value oldMap newMap where - insert' :: Proxy flag -> Key key -> f value -> Book' f oldMap -> Book' f newMap - -instance Insertable' 'LT key value - oldMap - (key :=> value ': oldMap) where - insert' _ key value oldBook = BCons key value oldBook -instance Insertable' 'EQ key value - (oldKey :=> oldValue ': restOfMap) - (key :=> value ': restOfMap) where - insert' _ key value (BCons _ _ oldBook) = BCons key value oldBook -instance (newMap ~ Insert key value restOfMap, Insertable key value restOfMap) => Insertable' 'GT key value - (oldKey :=> oldValue ': restOfMap) - (oldKey :=> oldValue ': newMap) where - insert' _ key value (BCons oldKey oldValue oldBook) = BCons oldKey oldValue (insert key value oldBook) - -type family Delete keyToDelete oldBook where - Delete keyToDelete (keyToDelete :=> someValue ': xs) = xs - Delete keyToDelete (anotherKey :=> someValue ': xs) - = (anotherKey :=> someValue ': Delete keyToDelete xs) - Delete keyToDelete '[] = '[] diff --git a/src/Bookkeeper/Internal/Operations.hs b/src/Bookkeeper/Internal/Operations.hs new file mode 100644 index 0000000..c799c21 --- /dev/null +++ b/src/Bookkeeper/Internal/Operations.hs @@ -0,0 +1,16 @@ +module Bookkeeper.Internal.Operations where + +import Bookkeeper.Internal.Types +import Data.Functor.Identity + +-- | Maps a natural transformation over every record. +bmap :: (forall x. f x -> g x) -> Book' f entries -> Book' g entries +bmap _ BNil = BNil +bmap nat (BCons key value rest) = BCons key (nat value) (bmap nat rest) + +bsequence :: Monad m => Book' m entries -> m (Book' Identity entries) +bsequence BNil = return BNil +bsequence (BCons key mvalue mrest) = do + value <- mvalue + rest <- bsequence mrest + return $ BCons key (return value) rest diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs index a49e98b..bd6fb18 100644 --- a/src/Bookkeeper/Internal/Types.hs +++ b/src/Bookkeeper/Internal/Types.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE UndecidableInstances #-} module Bookkeeper.Internal.Types where +import Control.Monad.Identity +import Data.Default.Class (Default(..)) import Data.Kind (Type) +import Data.Monoid ((<>)) +import Data.List (intercalate) +import Data.Proxy +import Data.Type.Equality (type (==)) import GHC.Generics -import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..), CmpSymbol) import GHC.OverloadedLabels -import Data.Default.Class (Default(..)) -import Control.Monad.Identity +import GHC.TypeLits (Symbol, TypeError, ErrorMessage(Text), CmpSymbol) ------------------------------------------------------------------------------ -- :=> @@ -31,7 +36,11 @@ instance (s ~ s') => IsLabel s (Key s') where data Book' :: (k -> Type) -> [Type] -> Type where BNil :: Book' f '[] - BCons :: Key key -> f a -> Book' f as -> Book' f (k :=> a ': as) + BCons :: {-# UNPACK #-} !(Key key) -> !(f a) -> !(Book' f as) -> Book' f (k :=> a ': as) + +-- * Instances + +-- ** Eq instance Eq (Book' f '[]) where _ == _ = True @@ -40,10 +49,14 @@ instance (Eq (f val), Eq (Book' f xs)) => Eq (Book' f ((field :=> val) ': xs)) w BCons _ value1 rest1 == BCons _ value2 rest2 = value1 == value2 && rest1 == rest2 +-- ** Monoid + instance Monoid (Book' Identity '[]) where mempty = emptyBook _ `mappend` _ = emptyBook +-- ** Default + instance Default (Book' Identity '[]) where def = emptyBook @@ -57,9 +70,9 @@ instance ( Default (Book' f xs) emptyBook :: Book' Identity '[] emptyBook = BNil -{- +-- ** Show -instance ShowHelper (Book' a) => Show (Book' a) where +instance ShowHelper (Book' Identity a) => Show (Book' Identity a) where show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}" where go (k, v) = k <> " = " <> v @@ -67,20 +80,24 @@ instance ShowHelper (Book' a) => Show (Book' a) where class ShowHelper a where showHelper :: a -> [(String, String)] -instance ShowHelper (Book' '[]) where +instance ShowHelper (Book' Identity '[]) where showHelper _ = [] -instance ( ShowHelper (Book' xs) - , KnownSymbol k +instance ( ShowHelper (Book' Identity xs) , Show v - ) => ShowHelper (Book' ((k :=> v) ': xs)) where - showHelper (Book (Map.Ext k v rest)) = (show k, show v):showHelper (Book rest) - --} + ) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where + showHelper (BCons k v rest) = (show k, show v):showHelper rest --- * Generics +-- ** MFunctor {- +instance MFunctor Book' where + hoist f book = case book of + BNil -> BNil + BCons key value rest -> BCons key (f value) (hoist f rest) +-} +-- ** Generics + class FromGeneric a book | a -> book where fromGeneric :: a x -> Book' Identity book @@ -90,18 +107,18 @@ instance FromGeneric cs book => FromGeneric (D1 m cs) book where instance FromGeneric cs book => FromGeneric (C1 m cs) book where fromGeneric (M1 xs) = fromGeneric xs -instance (v ~ Book' Identity '[name :=> t]) +instance (v ~ '[name :=> t]) => FromGeneric (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) v where - fromGeneric (M1 (K1 t)) = (Key =: t) emptyBook + fromGeneric (M1 (K1 t)) = BCons Key (Identity t) emptyBook instance - ( FromGeneric l lbook - , FromGeneric r rbook - , Map.Unionable lbook rbook - , book ~ Map.Union lbook rbook - ) => FromGeneric (l :*: r) book where + ( FromGeneric l leftBook + , FromGeneric r rightBook + , unionBook ~ (Union leftBook rightBook) + , Unionable leftBook rightBook + ) => FromGeneric (l :*: r) unionBook where fromGeneric (l :*: r) - = Book $ Map.union (getBook (fromGeneric l)) (getBook (fromGeneric r)) + = union (fromGeneric l) (fromGeneric r) type family Expected a where Expected (l :+: r) = TypeError ('Text "Cannot convert sum types into Books") @@ -113,4 +130,104 @@ instance (book ~ Expected (l :+: r)) => FromGeneric (l :+: r) book where instance (book ~ Expected U1) => FromGeneric U1 book where fromGeneric = error "impossible" - -} +------------------------------------------------------------------------------ +-- Internal stuff +------------------------------------------------------------------------------ + +-- Insertion sort for simplicity. +type family Sort unsorted sorted where + Sort '[] sorted = sorted + Sort (key :=> value ': xs) sorted = Sort xs (Insert key value sorted) + +type family Insert key value oldMap where + Insert key value '[] = '[ key :=> value ] + Insert key value (key :=> someValue ': restOfMap) = (key :=> value ': restOfMap) + Insert key value (focusKey :=> someValue ': restOfMap) + = Ifte (CmpSymbol key focusKey == 'LT) + (key :=> value ': focusKey :=> someValue ': restOfMap) + (key :=> value ': focusKey :=> someValue ': restOfMap) + +type family Ifte cond iftrue iffalse where + Ifte 'True iftrue iffalse = iftrue + Ifte 'False iftrue iffalse = iffalse + +------------------------------------------------------------------------------ +-- Subset +------------------------------------------------------------------------------ + +class Subset set subset where + getSubset :: Book' f set -> Book' f subset + +instance Subset '[] '[] where + getSubset = id + {-# INLINE getSubset #-} +instance {-# OVERLAPPING #-} (Subset tail1 tail2, value ~ value') + => Subset (key :=> value ': tail1) (key :=> value' ': tail2) where + getSubset (BCons key value oldBook) = BCons key value $ getSubset oldBook + {-# INLINE getSubset #-} +instance {-# OVERLAPPABLE #-} (Subset tail subset) => Subset (head ': tail) subset where + getSubset (BCons _key _value oldBook) = getSubset oldBook + {-# INLINE getSubset #-} + + +------------------------------------------------------------------------------ +-- Insertion +------------------------------------------------------------------------------ + +class Insertable key value oldMap where + insert :: Key key -> f value -> Book' f oldMap -> Book' f (Insert key value oldMap) + +instance Insertable key value '[] where + insert key value oldBook = BCons key value oldBook + +instance {-# OVERLAPPING #-} + Insertable key value (key :=> someValue ': restOfMap) where + insert key value (BCons _ _ oldBook) = BCons key value oldBook + +instance {-# OVERLAPPABLE #-} + ( Insertable' (CmpSymbol key oldKey) key value + (oldKey :=> oldValue ': restOfMap) + (Insert key value (oldKey :=> oldValue ': restOfMap)) + ) => Insertable key value (oldKey :=> oldValue ': restOfMap) where + insert key value oldBook = insert' flag key value oldBook + where + flag :: Proxy (CmpSymbol key oldKey) + flag = Proxy + +class Insertable' flag key value oldMap newMap + | flag key value oldMap -> newMap where + insert' :: Proxy flag -> Key key -> f value -> Book' f oldMap -> Book' f newMap + +instance Insertable' 'LT key value + oldMap + (key :=> value ': oldMap) where + insert' _ key value oldBook = BCons key value oldBook +instance Insertable' 'EQ key value + (oldKey :=> oldValue ': restOfMap) + (key :=> value ': restOfMap) where + insert' _ key value (BCons _ _ oldBook) = BCons key value oldBook +instance (newMap ~ Insert key value restOfMap, Insertable key value restOfMap) => Insertable' 'GT key value + (oldKey :=> oldValue ': restOfMap) + (oldKey :=> oldValue ': newMap) where + insert' _ key value (BCons oldKey oldValue oldBook) = BCons oldKey oldValue (insert key value oldBook) + +------------------------------------------------------------------------------ +-- Deletion +------------------------------------------------------------------------------ + +type family Delete keyToDelete oldBook where + Delete keyToDelete (keyToDelete :=> someValue ': xs) = xs + Delete keyToDelete (anotherKey :=> someValue ': xs) + = (anotherKey :=> someValue ': Delete keyToDelete xs) + Delete keyToDelete '[] = '[] + +------------------------------------------------------------------------------ +-- Union +------------------------------------------------------------------------------ + +type family Union leftBook rightBook where + Union leftBook '[] = leftBook + Union leftBook (key :=> value ': rest) = Union (Insert key value leftBook) rest + +class Unionable leftBook rightBook where + union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) diff --git a/stack.yaml b/stack.yaml index a06aa4b..0cb52b6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ resolver: nightly-2016-05-27 packages: - '.' -extra-deps: -- 'type-level-sets-0.7' +- '../Haskell-MMorph-Library' +extra-deps: [] flags: {} From d0075733c1904784d8d11494b0a57949331de557 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 17 Nov 2016 23:40:08 +0100 Subject: [PATCH 03/27] Fix benchmark --- bench/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bench/Main.hs b/bench/Main.hs index d4e03d7..2f4b774 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,7 +4,7 @@ import Bookkeeper import Criterion.Main type PersonB = Book '[ "name" :=> String, "age" :=> Int ] -data PersonR = PersonR { name :: String, age :: {-# NOUNPACK #-} Int } deriving (Eq, Show) +data PersonR = PersonR { name :: !String, age :: !Int } deriving (Eq, Show) pb :: PersonB pb = emptyBook From 3424e7a7eb3c804459edc2d48ce956cfd9bebcde Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 19 Nov 2016 17:03:31 +0100 Subject: [PATCH 04/27] Compile time checks --- bookkeeper.cabal | 13 +++++++++ exec/CompileTime.hs | 40 ++++++++++++++++++++++++++ package.yaml | 8 ++++++ src/Bookkeeper.hs | 1 - src/Bookkeeper/Internal.hs | 9 +++++- src/Bookkeeper/Internal/Operations.hs | 7 +++-- src/Bookkeeper/Internal/Types.hs | 41 +++++++++++++++++---------- 7 files changed, 99 insertions(+), 20 deletions(-) create mode 100644 exec/CompileTime.hs diff --git a/bookkeeper.cabal b/bookkeeper.cabal index a06edaa..8c2bacd 100644 --- a/bookkeeper.cabal +++ b/bookkeeper.cabal @@ -44,6 +44,19 @@ library Bookkeeper.Internal.Types default-language: Haskell2010 +executable compileTime + main-is: CompileTime.hs + hs-source-dirs: + exec + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash + ghc-options: -Wall -Wall + build-depends: + base >= 4.9 && < 4.10 + , mtl == 2.2.* + , data-default-class + , base >=4.9 && < 4.10 , bookkeeper + default-language: Haskell2010 + executable readme main-is: Readme.lhs hs-source-dirs: diff --git a/exec/CompileTime.hs b/exec/CompileTime.hs new file mode 100644 index 0000000..e227fe0 --- /dev/null +++ b/exec/CompileTime.hs @@ -0,0 +1,40 @@ +module Main where + +import Bookkeeper + +type LongRecord = Book + '[ "h" :=> Bool + , "b" :=> Bool + , "o" :=> Bool + , "n" :=> Bool + , "d" :=> Bool + , "c" :=> Bool + , "l" :=> Bool + , "g" :=> Bool + , "a" :=> Bool + , "f" :=> Bool + , "k" :=> Bool + , "m" :=> Bool + , "i" :=> Bool + , "j" :=> Bool + ] + +main :: IO () +main = print (t ?: #o) + where + t = emptyBook + & #a =: True + & #b =: True + & #c =: True + & #d =: True + & #e =: True + & #f =: True + & #g =: True + & #h =: True + & #i =: True + & #j =: True + & #k =: True + & #l =: True + & #m =: True + & #n =: True + & #o =: True diff --git a/package.yaml b/package.yaml index 876c347..abce9cc 100644 --- a/package.yaml +++ b/package.yaml @@ -90,3 +90,11 @@ executables: dependencies: base >=4.9 && < 4.10 , bookkeeper , markdown-unlit + compileTime: + main: CompileTime.hs + ghc-options: -Wall + source-dirs: exec + default-extensions: *allExts + other-modules: [] + dependencies: base >=4.9 && < 4.10 + , bookkeeper diff --git a/src/Bookkeeper.hs b/src/Bookkeeper.hs index 2e7d66f..afdedc2 100644 --- a/src/Bookkeeper.hs +++ b/src/Bookkeeper.hs @@ -53,4 +53,3 @@ module Bookkeeper import Bookkeeper.Internal import Bookkeeper.Internal.Types import Data.Function - diff --git a/src/Bookkeeper/Internal.hs b/src/Bookkeeper/Internal.hs index 3c6aee6..1c64f6c 100644 --- a/src/Bookkeeper/Internal.hs +++ b/src/Bookkeeper/Internal.hs @@ -39,7 +39,8 @@ type Gettable field book val = (Subset book '[ field :=> val ]) get :: forall field book val. (Gettable field book val) => Key field -> Book' Identity book -> val get _ bk = case (getSubset bk :: Book' Identity '[field :=> val]) of - BCons _ (Identity v) BNil -> v + BCons (Identity v) BNil -> v +{-# INLINE get #-} -- | Flipped and infix version of 'get'. -- @@ -49,6 +50,7 @@ get _ bk = case (getSubset bk :: Book' Identity '[field :=> val]) of => Book' Identity book -> Key field -> val (?:) = flip get infixl 3 ?: +{-# INLINE (?:) #-} -- * Setters @@ -62,6 +64,7 @@ type Settable field value oldBook = Insertable field value oldBook -- Book {age = 28, likesDoctest = True, name = "Julian K. Arni"} set :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) set key value = insert key (Identity value) +{-# INLINE set #-} -- | Infix version of 'set' -- @@ -70,6 +73,7 @@ set key value = insert key (Identity value) (=:) :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) (=:) = set infix 3 =: +{-# INLINE (=:) #-} -- * Modifiers @@ -99,6 +103,7 @@ modify :: (Modifiable key originalValue newValue originalBook) -> Book' Identity (Insert key newValue originalBook) modify p f b = set p v b where v = f $ get p b +{-# INLINE modify #-} -- | Infix version of 'modify'. -- @@ -109,6 +114,7 @@ modify p f b = set p v b -> Book' Identity (Insert key newValue originalBook) (%:) = modify infixr 3 %: +{-# INLINE (%:) #-} type Deletable key oldBook = Subset oldBook (Delete key oldBook) @@ -126,6 +132,7 @@ delete :: forall key oldBook f . ( Deletable key oldBook ) => Key key -> Book' f oldBook -> Book' f (Delete key oldBook) delete _ bk = getSubset bk +{-# INLINE delete #-} -- | Generate a @Book@ from an ordinary Haskell record via GHC Generics. diff --git a/src/Bookkeeper/Internal/Operations.hs b/src/Bookkeeper/Internal/Operations.hs index c799c21..981021e 100644 --- a/src/Bookkeeper/Internal/Operations.hs +++ b/src/Bookkeeper/Internal/Operations.hs @@ -6,11 +6,12 @@ import Data.Functor.Identity -- | Maps a natural transformation over every record. bmap :: (forall x. f x -> g x) -> Book' f entries -> Book' g entries bmap _ BNil = BNil -bmap nat (BCons key value rest) = BCons key (nat value) (bmap nat rest) +bmap nat (BCons value rest) = BCons (nat value) (bmap nat rest) +-- | Analogous to 'Data.Traversable.sequence'. bsequence :: Monad m => Book' m entries -> m (Book' Identity entries) bsequence BNil = return BNil -bsequence (BCons key mvalue mrest) = do +bsequence (BCons mvalue mrest) = do value <- mvalue rest <- bsequence mrest - return $ BCons key (return value) rest + return $ BCons (return value) rest diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs index bd6fb18..dbca075 100644 --- a/src/Bookkeeper/Internal/Types.hs +++ b/src/Bookkeeper/Internal/Types.hs @@ -29,6 +29,7 @@ data Key (a :: Symbol) = Key instance (s ~ s') => IsLabel s (Key s') where fromLabel _ = Key + {-# INLINE fromLabel #-} ------------------------------------------------------------------------------ -- Book @@ -36,7 +37,7 @@ instance (s ~ s') => IsLabel s (Key s') where data Book' :: (k -> Type) -> [Type] -> Type where BNil :: Book' f '[] - BCons :: {-# UNPACK #-} !(Key key) -> !(f a) -> !(Book' f as) -> Book' f (k :=> a ': as) + BCons :: !(f a) -> !(Book' f as) -> Book' f (k :=> a ': as) -- * Instances @@ -46,7 +47,7 @@ instance Eq (Book' f '[]) where _ == _ = True instance (Eq (f val), Eq (Book' f xs)) => Eq (Book' f ((field :=> val) ': xs)) where - BCons _ value1 rest1 == BCons _ value2 rest2 + BCons value1 rest1 == BCons value2 rest2 = value1 == value2 && rest1 == rest2 -- ** Monoid @@ -63,7 +64,7 @@ instance Default (Book' Identity '[]) where instance ( Default (Book' f xs) , Default (f v) ) => Default (Book' f ((k :=> v) ': xs)) where - def = BCons Key def def + def = BCons def def -- | A book with no records. You'll usually want to use this to construct -- books. @@ -86,7 +87,10 @@ instance ShowHelper (Book' Identity '[]) where instance ( ShowHelper (Book' Identity xs) , Show v ) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where - showHelper (BCons k v rest) = (show k, show v):showHelper rest + showHelper (BCons v rest) = (show k, show v):showHelper rest + where + k :: Key k + k = Key -- ** MFunctor @@ -109,7 +113,7 @@ instance FromGeneric cs book => FromGeneric (C1 m cs) book where instance (v ~ '[name :=> t]) => FromGeneric (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) v where - fromGeneric (M1 (K1 t)) = BCons Key (Identity t) emptyBook + fromGeneric (M1 (K1 t)) = BCons (Identity t) emptyBook instance ( FromGeneric l leftBook @@ -145,7 +149,7 @@ type family Insert key value oldMap where Insert key value (focusKey :=> someValue ': restOfMap) = Ifte (CmpSymbol key focusKey == 'LT) (key :=> value ': focusKey :=> someValue ': restOfMap) - (key :=> value ': focusKey :=> someValue ': restOfMap) + (focusKey :=> someValue ': Insert key value restOfMap) type family Ifte cond iftrue iffalse where Ifte 'True iftrue iffalse = iftrue @@ -163,10 +167,10 @@ instance Subset '[] '[] where {-# INLINE getSubset #-} instance {-# OVERLAPPING #-} (Subset tail1 tail2, value ~ value') => Subset (key :=> value ': tail1) (key :=> value' ': tail2) where - getSubset (BCons key value oldBook) = BCons key value $ getSubset oldBook + getSubset (BCons value oldBook) = BCons value $ getSubset oldBook {-# INLINE getSubset #-} instance {-# OVERLAPPABLE #-} (Subset tail subset) => Subset (head ': tail) subset where - getSubset (BCons _key _value oldBook) = getSubset oldBook + getSubset (BCons _value oldBook) = getSubset oldBook {-# INLINE getSubset #-} @@ -178,11 +182,13 @@ class Insertable key value oldMap where insert :: Key key -> f value -> Book' f oldMap -> Book' f (Insert key value oldMap) instance Insertable key value '[] where - insert key value oldBook = BCons key value oldBook + insert _key value oldBook = BCons value oldBook + {-# INLINE insert #-} instance {-# OVERLAPPING #-} Insertable key value (key :=> someValue ': restOfMap) where - insert key value (BCons _ _ oldBook) = BCons key value oldBook + insert _key value (BCons _ oldBook) = BCons value oldBook + {-# INLINE insert #-} instance {-# OVERLAPPABLE #-} ( Insertable' (CmpSymbol key oldKey) key value @@ -193,23 +199,28 @@ instance {-# OVERLAPPABLE #-} where flag :: Proxy (CmpSymbol key oldKey) flag = Proxy + {-# INLINE insert #-} class Insertable' flag key value oldMap newMap - | flag key value oldMap -> newMap where + {-| flag key value oldMap -> newMap -} + where insert' :: Proxy flag -> Key key -> f value -> Book' f oldMap -> Book' f newMap instance Insertable' 'LT key value oldMap (key :=> value ': oldMap) where - insert' _ key value oldBook = BCons key value oldBook + insert' _ _key value oldBook = BCons value oldBook + {-# INLINE insert' #-} instance Insertable' 'EQ key value - (oldKey :=> oldValue ': restOfMap) + (key :=> oldValue ': restOfMap) (key :=> value ': restOfMap) where - insert' _ key value (BCons _ _ oldBook) = BCons key value oldBook + insert' _ _key value (BCons _ oldBook) = BCons value oldBook + {-# INLINE insert' #-} instance (newMap ~ Insert key value restOfMap, Insertable key value restOfMap) => Insertable' 'GT key value (oldKey :=> oldValue ': restOfMap) (oldKey :=> oldValue ': newMap) where - insert' _ key value (BCons oldKey oldValue oldBook) = BCons oldKey oldValue (insert key value oldBook) + insert' _ key value (BCons oldValue oldBook) = BCons oldValue (insert key value oldBook) + {-# INLINE insert' #-} ------------------------------------------------------------------------------ -- Deletion From c5a9234b5ab19cbd642817eaea806894049914c8 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 16:49:39 +0100 Subject: [PATCH 05/27] Split --- src/Bookkeeper.hs | 11 +++++ src/Bookkeeper/Internal.hs | 1 + src/Bookkeeper/Internal/Errors.hs | 1 - src/Bookkeeper/Internal/Types.hs | 76 ++++++++++++++++++++++++++++++- test/BookkeeperSpec.hs | 21 ++++++++- 5 files changed, 107 insertions(+), 3 deletions(-) diff --git a/src/Bookkeeper.hs b/src/Bookkeeper.hs index afdedc2..24df0bd 100644 --- a/src/Bookkeeper.hs +++ b/src/Bookkeeper.hs @@ -37,6 +37,17 @@ module Bookkeeper -- * Deleting , delete + -- * Ledger + , Ledger + + -- ** Split + , Split + , getIf + + -- ** Option + , Optionable + , option + -- * Types , Book , (:=>) diff --git a/src/Bookkeeper/Internal.hs b/src/Bookkeeper/Internal.hs index 1c64f6c..88297ca 100644 --- a/src/Bookkeeper/Internal.hs +++ b/src/Bookkeeper/Internal.hs @@ -12,6 +12,7 @@ import Bookkeeper.Internal.Types -- yet have the underlying value always have sorted fields. type Book xs = Book' Identity (Sort xs '[]) +type Ledger ledger = Ledger' Identity (Sort ledger '[]) ------------------------------------------------------------------------------ -- Setters and getters diff --git a/src/Bookkeeper/Internal/Errors.hs b/src/Bookkeeper/Internal/Errors.hs index 07ba88d..5fc6550 100644 --- a/src/Bookkeeper/Internal/Errors.hs +++ b/src/Bookkeeper/Internal/Errors.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Bookkeeper.Internal.Errors where -{-import qualified Data.Type.Map as Map-} import GHC.TypeLits (TypeError, ErrorMessage(..)) import GHC.Exts diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs index dbca075..539d253 100644 --- a/src/Bookkeeper/Internal/Types.hs +++ b/src/Bookkeeper/Internal/Types.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Bookkeeper.Internal.Types where import Control.Monad.Identity @@ -134,6 +137,24 @@ instance (book ~ Expected (l :+: r)) => FromGeneric (l :+: r) book where instance (book ~ Expected U1) => FromGeneric U1 book where fromGeneric = error "impossible" +------------------------------------------------------------------------------ +-- Ledger +------------------------------------------------------------------------------ + + +data Ledger' :: (k -> Type) -> [Type] -> Type where + Here :: !(f value) -> Ledger' f ( field :=> value ': restOfLedger) + There :: Ledger' f restOfLedger -> Ledger' f ( field :=> value ': restOfLedger) + +instance Eq (Ledger' f '[]) where + _ == _ = True + +instance (Eq (f val), Eq (Ledger' f xs)) => Eq (Ledger' f ((field :=> val) ': xs)) where + a == b = case (a, b) of + (Here value1, Here value2) -> value1 == value2 + (There rest1, There rest2) -> rest1 == rest2 + (_ , _ ) -> False + ------------------------------------------------------------------------------ -- Internal stuff ------------------------------------------------------------------------------ @@ -202,7 +223,7 @@ instance {-# OVERLAPPABLE #-} {-# INLINE insert #-} class Insertable' flag key value oldMap newMap - {-| flag key value oldMap -> newMap -} + | flag key value oldMap -> newMap where insert' :: Proxy flag -> Key key -> f value -> Book' f oldMap -> Book' f newMap @@ -222,6 +243,51 @@ instance (newMap ~ Insert key value restOfMap, Insertable key value restOfMap) = insert' _ key value (BCons oldValue oldBook) = BCons oldValue (insert key value oldBook) {-# INLINE insert' #-} +------------------------------------------------------------------------------ +-- Option +------------------------------------------------------------------------------ + +class Optionable key value newMap | key newMap -> value where + option' :: Key key -> f value -> Ledger' f newMap + +instance {-# OVERLAPPING #-} Optionable key value (key :=> value ': restOfMap) where + option' _key value = Here value +instance {-# OVERLAPPABLE #-} + ( Optionable key value restOfMap + ) => Optionable key value (oldKey :=> oldValue ': restOfMap) where + option' key value = There (option' key value) + +option :: (Optionable key value newMap) => Key key -> value -> Ledger' Identity newMap +option key value = option' key (Identity value) + +------------------------------------------------------------------------------ +-- Split +------------------------------------------------------------------------------ + +class Split key map value | key map -> value where + split :: Key key -> Ledger' f map + -> Either (f value) (Ledger' f (Delete key map)) + +instance {-# OVERLAPPING #-} Split key (key :=> value ': restOfMap) value where + split _ ledger = case ledger of + Here x -> Left x + There y -> Right y + +instance {-# OVERLAPPABLE #-} + ( Delete key (otherKey :=> otherValue ': restOfMap) + ~ (otherKey :=> otherValue ': Delete key restOfMap) + , Split key restOfMap value + ) + => Split key (otherKey :=> otherValue ': restOfMap) value where + split key ledger = case ledger of + Here x -> Right (Here x) + There y -> There <$> split key y + +getIf :: (Split key map value) => Key key -> Ledger' Identity map -> Maybe value +getIf key ledger = case split key ledger of + Left e -> Just $ runIdentity e + Right _ -> Nothing + ------------------------------------------------------------------------------ -- Deletion ------------------------------------------------------------------------------ @@ -242,3 +308,11 @@ type family Union leftBook rightBook where class Unionable leftBook rightBook where union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) + +------------------------------------------------------------------------------ +-- TypeOf +------------------------------------------------------------------------------ + +{-type family TypeOf (key :: Symbol) (map :: [Type]) where-} + {-TypeOf key (key :=> value ': restOfMap) = value-} + {-TypeOf key (otherKey :=> otherValue ': restOfMap) = TypeOf key restOfMap-} diff --git a/test/BookkeeperSpec.hs b/test/BookkeeperSpec.hs index 3d17f1c..70263bc 100644 --- a/test/BookkeeperSpec.hs +++ b/test/BookkeeperSpec.hs @@ -7,7 +7,12 @@ import Test.QuickCheck import Bookkeeper spec :: Spec -spec = describe "books" $ do +spec = do + bookSpec + ledgerSpec + +bookSpec :: Spec +bookSpec = describe "books" $ do let p :: Person = emptyBook & #name =: "Julian K. Arni" @@ -61,5 +66,19 @@ spec = describe "books" $ do type Person = Book '[ "name" :=> String , "age" :=> Int] +ledgerSpec :: Spec +ledgerSpec = describe "ledger" $ do + + let aBool :: BaseType + aBool = option #bool True + anInt :: BaseType + anInt = option #int 5 + + it "allows getting" $ do + getIf #bool aBool `shouldBe` Just True + getIf #bool anInt `shouldBe` Nothing + +type BaseType = Ledger '[ "bool" :=> Bool, "int" :=> Int] + typeLevelTest :: Expectation typeLevelTest = True `shouldBe` True From 9a5d2caa5079631312fce7e03f83b1055de00f5e Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 17:49:09 +0100 Subject: [PATCH 06/27] Show instances --- src/Bookkeeper.hs | 2 ++ src/Bookkeeper/Internal/Types.hs | 54 +++++++++++++++++++------------- test/BookkeeperSpec.hs | 11 ++++++- 3 files changed, 44 insertions(+), 23 deletions(-) diff --git a/src/Bookkeeper.hs b/src/Bookkeeper.hs index 24df0bd..f00f602 100644 --- a/src/Bookkeeper.hs +++ b/src/Bookkeeper.hs @@ -42,8 +42,10 @@ module Bookkeeper -- ** Split , Split + , split , getIf + -- ** Option , Optionable , option diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs index 539d253..3fb3db2 100644 --- a/src/Bookkeeper/Internal/Types.hs +++ b/src/Bookkeeper/Internal/Types.hs @@ -2,9 +2,12 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} + module Bookkeeper.Internal.Types where import Control.Monad.Identity +import Data.Bifunctor (first) import Data.Default.Class (Default(..)) import Data.Kind (Type) import Data.Monoid ((<>)) @@ -13,7 +16,7 @@ import Data.Proxy import Data.Type.Equality (type (==)) import GHC.Generics import GHC.OverloadedLabels -import GHC.TypeLits (Symbol, TypeError, ErrorMessage(Text), CmpSymbol) +import GHC.TypeLits (Symbol, TypeError, ErrorMessage(Text), CmpSymbol, KnownSymbol, symbolVal) ------------------------------------------------------------------------------ -- :=> @@ -28,7 +31,10 @@ data (a :: Symbol) :=> (b :: k) -- | 'Key' is simply a proxy. You will usually not need to create one -- directly, as it is generated by the OverlodadedLabels magic. data Key (a :: Symbol) = Key - deriving (Eq, Show, Read, Generic) + deriving (Eq, Read, Generic) + +instance KnownSymbol key => Show (Key key) where + show _ = '#':(symbolVal (Proxy :: Proxy key)) instance (s ~ s') => IsLabel s (Key s') where fromLabel _ = Key @@ -89,6 +95,7 @@ instance ShowHelper (Book' Identity '[]) where instance ( ShowHelper (Book' Identity xs) , Show v + , KnownSymbol k ) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where showHelper (BCons v rest) = (show k, show v):showHelper rest where @@ -155,6 +162,14 @@ instance (Eq (f val), Eq (Ledger' f xs)) => Eq (Ledger' f ((field :=> val) ': xs (There rest1, There rest2) -> rest1 == rest2 (_ , _ ) -> False +instance (KnownSymbol key, Show value) + => Show (Ledger' Identity '[key :=> value]) where + show (Here x) = "option #" ++ show key ++ " " ++ show x + where + key :: Key key + key = Key + show (There _) = error "impossible" + ------------------------------------------------------------------------------ -- Internal stuff ------------------------------------------------------------------------------ @@ -265,13 +280,13 @@ option key value = option' key (Identity value) ------------------------------------------------------------------------------ class Split key map value | key map -> value where - split :: Key key -> Ledger' f map - -> Either (f value) (Ledger' f (Delete key map)) + split' :: Key key -> Ledger' f map + -> Either (Ledger' f (Delete key map)) (f value) instance {-# OVERLAPPING #-} Split key (key :=> value ': restOfMap) value where - split _ ledger = case ledger of - Here x -> Left x - There y -> Right y + split' _ ledger = case ledger of + Here x -> Right x + There y -> Left y instance {-# OVERLAPPABLE #-} ( Delete key (otherKey :=> otherValue ': restOfMap) @@ -279,14 +294,18 @@ instance {-# OVERLAPPABLE #-} , Split key restOfMap value ) => Split key (otherKey :=> otherValue ': restOfMap) value where - split key ledger = case ledger of - Here x -> Right (Here x) - There y -> There <$> split key y + split' key ledger = case ledger of + Here x -> Left (Here x) + There y -> first There (split' key y) + +split :: (Split key ledger value) => + Key key -> Ledger' Identity ledger -> Either (Ledger' Identity (Delete key ledger)) value +split key ledger = runIdentity <$> split' key ledger getIf :: (Split key map value) => Key key -> Ledger' Identity map -> Maybe value -getIf key ledger = case split key ledger of - Left e -> Just $ runIdentity e - Right _ -> Nothing +getIf key ledger = case split' key ledger of + Right e -> Just $ runIdentity e + Left _ -> Nothing ------------------------------------------------------------------------------ -- Deletion @@ -296,7 +315,6 @@ type family Delete keyToDelete oldBook where Delete keyToDelete (keyToDelete :=> someValue ': xs) = xs Delete keyToDelete (anotherKey :=> someValue ': xs) = (anotherKey :=> someValue ': Delete keyToDelete xs) - Delete keyToDelete '[] = '[] ------------------------------------------------------------------------------ -- Union @@ -308,11 +326,3 @@ type family Union leftBook rightBook where class Unionable leftBook rightBook where union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) - ------------------------------------------------------------------------------- --- TypeOf ------------------------------------------------------------------------------- - -{-type family TypeOf (key :: Symbol) (map :: [Type]) where-} - {-TypeOf key (key :=> value ': restOfMap) = value-} - {-TypeOf key (otherKey :=> otherValue ': restOfMap) = TypeOf key restOfMap-} diff --git a/test/BookkeeperSpec.hs b/test/BookkeeperSpec.hs index 70263bc..7d41877 100644 --- a/test/BookkeeperSpec.hs +++ b/test/BookkeeperSpec.hs @@ -1,6 +1,7 @@ module BookkeeperSpec (spec) where import Data.Char (toUpper) +import Data.Either (isLeft) import Test.Hspec import Test.QuickCheck @@ -55,7 +56,7 @@ bookSpec = describe "books" $ do p' ?: #child ?: #name `shouldBe` "JULIAN K. ARNI" it "has a decent show instance" $ do - show p `shouldBe` "Book {age = 28, name = \"Julian K. Arni\"}" + show p `shouldBe` "Book {#age = Identity 28, #name = Identity \"Julian K. Arni\"}" it "obeys the 'get . put' law" $ property $ \(x :: Int) -> do get #label (set #label x emptyBook) `shouldBe` x @@ -71,6 +72,7 @@ ledgerSpec = describe "ledger" $ do let aBool :: BaseType aBool = option #bool True + anInt :: BaseType anInt = option #int 5 @@ -78,7 +80,14 @@ ledgerSpec = describe "ledger" $ do getIf #bool aBool `shouldBe` Just True getIf #bool anInt `shouldBe` Nothing + it "allows splitting" $ do + split #bool aBool `shouldBe` Right True + split #bool anInt `shouldSatisfy` isLeft + type BaseType = Ledger '[ "bool" :=> Bool, "int" :=> Int] +type Error = '[ "err1" :=> String, "err2" :=> String] +type ErrOrVal = ("value" :=> Int ) ': Error + typeLevelTest :: Expectation typeLevelTest = True `shouldBe` True From 80c79bf3f0d7e3f8fb86db11494b6beeae7a3eb2 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 17:56:38 +0100 Subject: [PATCH 07/27] more Show work --- src/Bookkeeper/Internal/Types.hs | 14 ++++++++++++-- test/BookkeeperSpec.hs | 6 +++--- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Bookkeeper/Internal/Types.hs b/src/Bookkeeper/Internal/Types.hs index 3fb3db2..99c5e53 100644 --- a/src/Bookkeeper/Internal/Types.hs +++ b/src/Bookkeeper/Internal/Types.hs @@ -162,14 +162,24 @@ instance (Eq (f val), Eq (Ledger' f xs)) => Eq (Ledger' f ((field :=> val) ': xs (There rest1, There rest2) -> rest1 == rest2 (_ , _ ) -> False -instance (KnownSymbol key, Show value) +instance + (KnownSymbol key, Show value) => Show (Ledger' Identity '[key :=> value]) where - show (Here x) = "option #" ++ show key ++ " " ++ show x + show (Here x) = "option' " ++ show key ++ " (" ++ show x ++ ")" where key :: Key key key = Key show (There _) = error "impossible" +instance + (KnownSymbol key, Show value, Show (Ledger' Identity (next ': restOfMap))) + => Show (Ledger' Identity (key :=> value ': next ': restOfMap)) where + show (Here x) = "option' " ++ show key ++ " (" ++ show x ++ ")" + where + key :: Key key + key = Key + show (There x) = show x + ------------------------------------------------------------------------------ -- Internal stuff ------------------------------------------------------------------------------ diff --git a/test/BookkeeperSpec.hs b/test/BookkeeperSpec.hs index 7d41877..ba070e2 100644 --- a/test/BookkeeperSpec.hs +++ b/test/BookkeeperSpec.hs @@ -84,10 +84,10 @@ ledgerSpec = describe "ledger" $ do split #bool aBool `shouldBe` Right True split #bool anInt `shouldSatisfy` isLeft -type BaseType = Ledger '[ "bool" :=> Bool, "int" :=> Int] + it "has a decent show instance" $ do + show aBool `shouldBe` "option' #bool (Identity True)" -type Error = '[ "err1" :=> String, "err2" :=> String] -type ErrOrVal = ("value" :=> Int ) ': Error +type BaseType = Ledger '[ "bool" :=> Bool, "int" :=> Int] typeLevelTest :: Expectation typeLevelTest = True `shouldBe` True From c699c29a53f0f4b04f6378736e4f2bb04ce0659c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 17:59:52 +0100 Subject: [PATCH 08/27] Move sum-error to same repo --- Setup.hs => bookkeeper/Setup.hs | 0 .../bookkeeper.cabal | 0 {exec => bookkeeper/exec}/CompileTime.hs | 0 {exec => bookkeeper/exec}/Readme.lhs | 0 package.yaml => bookkeeper/package.yaml | 0 {src => bookkeeper/src}/Bookkeeper.hs | 0 .../src}/Bookkeeper/Internal.hs | 0 .../src}/Bookkeeper/Internal/Errors.hs | 0 .../src}/Bookkeeper/Internal/Operations.hs | 0 .../src}/Bookkeeper/Internal/Sort.hs | 0 .../src}/Bookkeeper/Internal/Types.hs | 0 {src => bookkeeper/src}/highlight.js | 0 {src => bookkeeper/src}/style.css | 0 {test => bookkeeper/test}/BookkeeperSpec.hs | 0 {test => bookkeeper/test}/Doctest.hs | 0 {test => bookkeeper/test}/Spec.hs | 0 cabal.project | 4 ++ sum-error/.ghci | 1 + sum-error/.gitignore | 4 ++ sum-error/LICENSE | 31 +++++++++ sum-error/Setup.hs | 2 + sum-error/package.yaml | 60 +++++++++++++++++ sum-error/src/SumError/Internal.hs | 20 ++++++ sum-error/stack.yaml | 8 +++ sum-error/sum-error.cabal | 65 +++++++++++++++++++ sum-error/test/Doctest.hs | 26 ++++++++ sum-error/test/Spec.hs | 1 + 27 files changed, 222 insertions(+) rename Setup.hs => bookkeeper/Setup.hs (100%) rename bookkeeper.cabal => bookkeeper/bookkeeper.cabal (100%) rename {exec => bookkeeper/exec}/CompileTime.hs (100%) rename {exec => bookkeeper/exec}/Readme.lhs (100%) rename package.yaml => bookkeeper/package.yaml (100%) rename {src => bookkeeper/src}/Bookkeeper.hs (100%) rename {src => bookkeeper/src}/Bookkeeper/Internal.hs (100%) rename {src => bookkeeper/src}/Bookkeeper/Internal/Errors.hs (100%) rename {src => bookkeeper/src}/Bookkeeper/Internal/Operations.hs (100%) rename {src => bookkeeper/src}/Bookkeeper/Internal/Sort.hs (100%) rename {src => bookkeeper/src}/Bookkeeper/Internal/Types.hs (100%) rename {src => bookkeeper/src}/highlight.js (100%) rename {src => bookkeeper/src}/style.css (100%) rename {test => bookkeeper/test}/BookkeeperSpec.hs (100%) rename {test => bookkeeper/test}/Doctest.hs (100%) rename {test => bookkeeper/test}/Spec.hs (100%) create mode 100644 cabal.project create mode 100644 sum-error/.ghci create mode 100644 sum-error/.gitignore create mode 100644 sum-error/LICENSE create mode 100644 sum-error/Setup.hs create mode 100644 sum-error/package.yaml create mode 100644 sum-error/src/SumError/Internal.hs create mode 100644 sum-error/stack.yaml create mode 100644 sum-error/sum-error.cabal create mode 100644 sum-error/test/Doctest.hs create mode 100644 sum-error/test/Spec.hs diff --git a/Setup.hs b/bookkeeper/Setup.hs similarity index 100% rename from Setup.hs rename to bookkeeper/Setup.hs diff --git a/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal similarity index 100% rename from bookkeeper.cabal rename to bookkeeper/bookkeeper.cabal diff --git a/exec/CompileTime.hs b/bookkeeper/exec/CompileTime.hs similarity index 100% rename from exec/CompileTime.hs rename to bookkeeper/exec/CompileTime.hs diff --git a/exec/Readme.lhs b/bookkeeper/exec/Readme.lhs similarity index 100% rename from exec/Readme.lhs rename to bookkeeper/exec/Readme.lhs diff --git a/package.yaml b/bookkeeper/package.yaml similarity index 100% rename from package.yaml rename to bookkeeper/package.yaml diff --git a/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs similarity index 100% rename from src/Bookkeeper.hs rename to bookkeeper/src/Bookkeeper.hs diff --git a/src/Bookkeeper/Internal.hs b/bookkeeper/src/Bookkeeper/Internal.hs similarity index 100% rename from src/Bookkeeper/Internal.hs rename to bookkeeper/src/Bookkeeper/Internal.hs diff --git a/src/Bookkeeper/Internal/Errors.hs b/bookkeeper/src/Bookkeeper/Internal/Errors.hs similarity index 100% rename from src/Bookkeeper/Internal/Errors.hs rename to bookkeeper/src/Bookkeeper/Internal/Errors.hs diff --git a/src/Bookkeeper/Internal/Operations.hs b/bookkeeper/src/Bookkeeper/Internal/Operations.hs similarity index 100% rename from src/Bookkeeper/Internal/Operations.hs rename to bookkeeper/src/Bookkeeper/Internal/Operations.hs diff --git a/src/Bookkeeper/Internal/Sort.hs b/bookkeeper/src/Bookkeeper/Internal/Sort.hs similarity index 100% rename from src/Bookkeeper/Internal/Sort.hs rename to bookkeeper/src/Bookkeeper/Internal/Sort.hs diff --git a/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs similarity index 100% rename from src/Bookkeeper/Internal/Types.hs rename to bookkeeper/src/Bookkeeper/Internal/Types.hs diff --git a/src/highlight.js b/bookkeeper/src/highlight.js similarity index 100% rename from src/highlight.js rename to bookkeeper/src/highlight.js diff --git a/src/style.css b/bookkeeper/src/style.css similarity index 100% rename from src/style.css rename to bookkeeper/src/style.css diff --git a/test/BookkeeperSpec.hs b/bookkeeper/test/BookkeeperSpec.hs similarity index 100% rename from test/BookkeeperSpec.hs rename to bookkeeper/test/BookkeeperSpec.hs diff --git a/test/Doctest.hs b/bookkeeper/test/Doctest.hs similarity index 100% rename from test/Doctest.hs rename to bookkeeper/test/Doctest.hs diff --git a/test/Spec.hs b/bookkeeper/test/Spec.hs similarity index 100% rename from test/Spec.hs rename to bookkeeper/test/Spec.hs diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..6905e29 --- /dev/null +++ b/cabal.project @@ -0,0 +1,4 @@ +packages: */*.cabal +with-compiler: /opt/ghc/8.0.1/bin/ghc +benchmarks: False +allow-newer: hackage-security:Cabal diff --git a/sum-error/.ghci b/sum-error/.ghci new file mode 100644 index 0000000..ae927ec --- /dev/null +++ b/sum-error/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/sum-error/.gitignore b/sum-error/.gitignore new file mode 100644 index 0000000..46ca9bd --- /dev/null +++ b/sum-error/.gitignore @@ -0,0 +1,4 @@ +/dist/ +/dist-newstyle/ +/.stack-work/ + diff --git a/sum-error/LICENSE b/sum-error/LICENSE new file mode 100644 index 0000000..302f74f --- /dev/null +++ b/sum-error/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni 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. + diff --git a/sum-error/Setup.hs b/sum-error/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/sum-error/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sum-error/package.yaml b/sum-error/package.yaml new file mode 100644 index 0000000..c06c347 --- /dev/null +++ b/sum-error/package.yaml @@ -0,0 +1,60 @@ +name: sum-error +version: 0.1.0.0 +synopsis: +description: Please see README.md +homepage: http://github.com/jkarni/sum-error#readme +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +github: jkarni/sum-error +tested-with: GHC == 7.8.3, GHC == 7.10.2, GHC == 8.0.1 + +ghc-options: -Wall + +dependencies: + - base >= 4.9 && < 4.10 + - bookkeeper > 0.3 && < 0.4 + +default-extensions: + - AutoDeriveTypeable + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - KindSignatures + - MultiParamTypeClasses + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables + - TypeFamilies + - TypeOperators + +library: + source-dirs: src + other-modules: [] + +tests: + spec: + main: Spec.hs + source-dirs: test + dependencies: + - sum-error + - hspec > 2 && < 3 + - QuickCheck >= 2.8 && < 2.9 + doctest: + main: Doctest.hs + source-dirs: test + dependencies: + - doctest >= 0.9 && < 0.12 + - Glob >= 0.7 && < 0.8 + - yaml == 0.8.* + diff --git a/sum-error/src/SumError/Internal.hs b/sum-error/src/SumError/Internal.hs new file mode 100644 index 0000000..c942425 --- /dev/null +++ b/sum-error/src/SumError/Internal.hs @@ -0,0 +1,20 @@ +module SumError.Internal where + +-- | A type for extensible errors. +-- The type is kept opaque to ensure the error types are sorted and nubbed. +newtype SumErrorT ledger m a = SumErrorT ( ExceptT (Ledger' Identity ledger) m a ) + deriving (Functor, Applicative, Monad, MonadIO, Foldable, Traversable) + +runSumErrorT :: SumErrorT ledger m a -> m (Either (Ledger' Identity ledger) a) +runSumErrorT (SumErrorT e) = runExceptT e + +throwSumError :: (Monad m, Optionable errorName errorValue ledger) + => Key errorName -> errorValue -> SumErrorT ledger m a +throwSumError key errorValue = SumErrorT (throwError $ option key $ Identity errorValue) + +catchSumError :: (Monad m) + => Key errorName + -> (errorValue -> SumErrorT ledgerWithoutError m a) + -> SumErrorT ledgerWithError + -> SumErrorT ledgerWithoutError m a +catchSumError key handler original = case original diff --git a/sum-error/stack.yaml b/sum-error/stack.yaml new file mode 100644 index 0000000..2adae87 --- /dev/null +++ b/sum-error/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-7.9 +packages: +- '.' +- '../bookkeeper' + extra-dep: true +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/sum-error/sum-error.cabal b/sum-error/sum-error.cabal new file mode 100644 index 0000000..e7624e4 --- /dev/null +++ b/sum-error/sum-error.cabal @@ -0,0 +1,65 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: sum-error +version: 0.1.0.0 +description: Please see README.md +homepage: http://github.com/jkarni/sum-error#readme +bug-reports: https://github.com/jkarni/sum-error/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.8.3, GHC == 7.10.2, GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jkarni/sum-error + +library + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + , doctest >= 0.9 && < 0.12 + , Glob >= 0.7 && < 0.8 + , yaml == 0.8.* + other-modules: + Spec + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + , sum-error + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + other-modules: + Doctest + default-language: Haskell2010 diff --git a/sum-error/test/Doctest.hs b/sum-error/test/Doctest.hs new file mode 100644 index 0000000..849dbbd --- /dev/null +++ b/sum-error/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/sum-error/test/Spec.hs b/sum-error/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/sum-error/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From c821e61a3be56315a696c5d3b857e557d9308a80 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 18:00:40 +0100 Subject: [PATCH 09/27] Move benchmarks --- {bench => bookkeeper/bench}/Main.hs | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {bench => bookkeeper/bench}/Main.hs (100%) diff --git a/bench/Main.hs b/bookkeeper/bench/Main.hs similarity index 100% rename from bench/Main.hs rename to bookkeeper/bench/Main.hs From bf9a8cb18604826aebe0f15f998ad2975dd16437 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 18:44:28 +0100 Subject: [PATCH 10/27] Sum error classes and tests --- bookkeeper/bookkeeper.cabal | 6 +--- bookkeeper/package.yaml | 2 +- bookkeeper/src/Bookkeeper.hs | 1 + sum-error/package.yaml | 6 ++-- sum-error/src/SumError.hs | 9 ++++++ sum-error/src/SumError/Internal.hs | 49 ++++++++++++++++++++++++------ sum-error/sum-error.cabal | 30 +++++++++++------- sum-error/test/SumErrorSpec.hs | 30 ++++++++++++++++++ 8 files changed, 104 insertions(+), 29 deletions(-) create mode 100644 sum-error/src/SumError.hs create mode 100644 sum-error/test/SumErrorSpec.hs diff --git a/bookkeeper/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal index 8c2bacd..7da7f3d 100644 --- a/bookkeeper/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: bookkeeper -version: 0.2.3 +version: 0.3 synopsis: Anonymous records and overloaded labels description: Please see README.md category: Data Structures, Records @@ -18,10 +18,6 @@ tested-with: GHC == 8.0.1 build-type: Simple cabal-version: >= 1.10 -extra-source-files: - CHANGELOG.md - README.md - source-repository head type: git location: https://github.com/turingjump/bookkeeper diff --git a/bookkeeper/package.yaml b/bookkeeper/package.yaml index abce9cc..5166251 100644 --- a/bookkeeper/package.yaml +++ b/bookkeeper/package.yaml @@ -1,5 +1,5 @@ name: bookkeeper -version: 0.2.3 +version: "0.3" synopsis: Anonymous records and overloaded labels description: Please see README.md homepage: http://github.com/turingjump/bookkeeper#readme diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index f00f602..5669295 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -36,6 +36,7 @@ module Bookkeeper -- * Deleting , delete + , Delete -- * Ledger , Ledger diff --git a/sum-error/package.yaml b/sum-error/package.yaml index c06c347..09bb0d0 100644 --- a/sum-error/package.yaml +++ b/sum-error/package.yaml @@ -1,5 +1,5 @@ name: sum-error -version: 0.1.0.0 +version: "0.3" synopsis: description: Please see README.md homepage: http://github.com/jkarni/sum-error#readme @@ -15,7 +15,8 @@ ghc-options: -Wall dependencies: - base >= 4.9 && < 4.10 - - bookkeeper > 0.3 && < 0.4 + - bookkeeper >= 0.3 && < 0.4 + - mtl == 2.* default-extensions: - AutoDeriveTypeable @@ -35,6 +36,7 @@ default-extensions: - OverloadedStrings - RankNTypes - ScopedTypeVariables + - OverloadedLabels - TypeFamilies - TypeOperators diff --git a/sum-error/src/SumError.hs b/sum-error/src/SumError.hs new file mode 100644 index 0000000..dc9aac8 --- /dev/null +++ b/sum-error/src/SumError.hs @@ -0,0 +1,9 @@ +module SumError + ( SumErrorT + , runSumErrorT + , resolve + , MonadSumError(..) + , MonadCatchSumError(..) + ) where + +import SumError.Internal diff --git a/sum-error/src/SumError/Internal.hs b/sum-error/src/SumError/Internal.hs index c942425..26e9b78 100644 --- a/sum-error/src/SumError/Internal.hs +++ b/sum-error/src/SumError/Internal.hs @@ -1,20 +1,49 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module SumError.Internal where +import Bookkeeper +import Bookkeeper.Internal.Types (Ledger') + +import Data.Functor.Identity +import Control.Monad.Except + -- | A type for extensible errors. -- The type is kept opaque to ensure the error types are sorted and nubbed. newtype SumErrorT ledger m a = SumErrorT ( ExceptT (Ledger' Identity ledger) m a ) - deriving (Functor, Applicative, Monad, MonadIO, Foldable, Traversable) + deriving (Functor, Applicative, Monad, MonadIO, Foldable, Traversable + , MonadError (Ledger' Identity ledger)) runSumErrorT :: SumErrorT ledger m a -> m (Either (Ledger' Identity ledger) a) runSumErrorT (SumErrorT e) = runExceptT e -throwSumError :: (Monad m, Optionable errorName errorValue ledger) - => Key errorName -> errorValue -> SumErrorT ledger m a -throwSumError key errorValue = SumErrorT (throwError $ option key $ Identity errorValue) -catchSumError :: (Monad m) - => Key errorName - -> (errorValue -> SumErrorT ledgerWithoutError m a) - -> SumErrorT ledgerWithError - -> SumErrorT ledgerWithoutError m a -catchSumError key handler original = case original +resolve :: Monad m => SumErrorT '[] m a -> m a +resolve e = do + Right val <- runSumErrorT e + return val + +class (Monad m ) => MonadSumError m error value | m error -> value where + throwSumError :: Key error -> value -> m a + +instance (Optionable error value ledger, Monad m) + => MonadSumError (SumErrorT ledger m) error value where + throwSumError key errorValue = SumErrorT (throwError $ option key $ errorValue) + +class MonadSumError m error value + => MonadCatchSumError m m' error value | m error -> m', m' error value -> m where + catchSumError :: Key error -> (value -> m' a) -> m a -> m' a + +instance (ledger' ~ Delete key ledger, Monad m, Optionable key value ledger + , Split key ledger value) + => MonadCatchSumError (SumErrorT ledger m) (SumErrorT ledger' m) key value where + catchSumError key handler original = SumErrorT . ExceptT $ do + mval <- runSumErrorT original + case mval of + Right e -> return $ Right e + Left err -> case split key err of + -- this could be prettier + Right err1 -> runSumErrorT $ handler err1 + Left err2 -> runSumErrorT $ throwError err2 + + diff --git a/sum-error/sum-error.cabal b/sum-error/sum-error.cabal index e7624e4..189a0dc 100644 --- a/sum-error/sum-error.cabal +++ b/sum-error/sum-error.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.14.0. +-- This file has been generated from package.yaml by hpack version 0.14.1. -- -- see: https://github.com/sol/hpack name: sum-error -version: 0.1.0.0 +version: 0.3 description: Please see README.md homepage: http://github.com/jkarni/sum-error#readme bug-reports: https://github.com/jkarni/sum-error/issues @@ -23,11 +23,15 @@ source-repository head library hs-source-dirs: src - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables OverloadedLabels TypeFamilies TypeOperators ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 - , text + base >= 4.9 && < 4.10 + , bookkeeper >= 0.3 && < 0.4 + , mtl == 2.* + exposed-modules: + SumError + SumError.Internal default-language: Haskell2010 test-suite doctest @@ -35,16 +39,18 @@ test-suite doctest main-is: Doctest.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables OverloadedLabels TypeFamilies TypeOperators ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 - , text + base >= 4.9 && < 4.10 + , bookkeeper >= 0.3 && < 0.4 + , mtl == 2.* , doctest >= 0.9 && < 0.12 , Glob >= 0.7 && < 0.8 , yaml == 0.8.* other-modules: Spec + SumErrorSpec default-language: Haskell2010 test-suite spec @@ -52,14 +58,16 @@ test-suite spec main-is: Spec.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables OverloadedLabels TypeFamilies TypeOperators ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 - , text + base >= 4.9 && < 4.10 + , bookkeeper >= 0.3 && < 0.4 + , mtl == 2.* , sum-error , hspec > 2 && < 3 , QuickCheck >= 2.8 && < 2.9 other-modules: Doctest + SumErrorSpec default-language: Haskell2010 diff --git a/sum-error/test/SumErrorSpec.hs b/sum-error/test/SumErrorSpec.hs new file mode 100644 index 0000000..8d56cd5 --- /dev/null +++ b/sum-error/test/SumErrorSpec.hs @@ -0,0 +1,30 @@ +module SumErrorSpec (spec) where + +import Data.Functor.Identity +import SumError +import Test.Hspec + +spec :: Spec +spec = describe "SumErrorT" $ do + + it "allows throwing and catching in order errors" $ do + let fn n = resolve + $ catchSumError #notLarge (\_ -> return 200) + $ catchSumError #notPositive (\_ -> return 202) + $ catchSumError #notEven (\_ -> return 204) + $ eg n + fn 1 `shouldBe` Identity 204 + fn (-2) `shouldBe` Identity 202 + fn 10 `shouldBe` Identity 200 + +eg :: ( MonadSumError m "notPositive" () + , MonadSumError m "notEven" () + , MonadSumError m "notLarge" String + ) => Int -> m Int +eg n + | n <= 0 = throwSumError #notPositive () + | n < 100 = throwSumError #notLarge + $ "Number " ++ show n ++ " ought to be larger than 100" + | n `mod` 2 == 1 = throwSumError #notEven () + | otherwise = return $ n `div` 2 + From 212747a49b13a2b636372e62ed78168173569194 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 19:32:45 +0100 Subject: [PATCH 11/27] instances galore --- bookkeeper/src/Bookkeeper/Internal/Types.hs | 19 +++++++++++++++---- sum-error/src/SumError/Internal.hs | 19 ++++++++++++++++++- 2 files changed, 33 insertions(+), 5 deletions(-) diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 99c5e53..f54d0be 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -163,8 +163,8 @@ instance (Eq (f val), Eq (Ledger' f xs)) => Eq (Ledger' f ((field :=> val) ': xs (_ , _ ) -> False instance - (KnownSymbol key, Show value) - => Show (Ledger' Identity '[key :=> value]) where + (KnownSymbol key, Show (f value)) + => Show (Ledger' f '[key :=> value]) where show (Here x) = "option' " ++ show key ++ " (" ++ show x ++ ")" where key :: Key key @@ -172,14 +172,25 @@ instance show (There _) = error "impossible" instance - (KnownSymbol key, Show value, Show (Ledger' Identity (next ': restOfMap))) - => Show (Ledger' Identity (key :=> value ': next ': restOfMap)) where + (KnownSymbol key, Show (f value), Show (Ledger' f (next ': restOfMap))) + => Show (Ledger' f (key :=> value ': next ': restOfMap)) where show (Here x) = "option' " ++ show key ++ " (" ++ show x ++ ")" where key :: Key key key = Key show (There x) = show x +instance Ord (f value) => Ord (Ledger' f '[ key :=> value]) where + Here x <= Here y = x <= y + _ <= _ = error "impossible" + +instance (Ord (f value), Ord (Ledger' f rest)) + => Ord (Ledger' f (key :=> value ': rest)) where + Here x <= Here y = x <= y + Here _ <= There _ = True + There _ <= Here _ = False + There x <= There y = x <= y + ------------------------------------------------------------------------------ -- Internal stuff ------------------------------------------------------------------------------ diff --git a/sum-error/src/SumError/Internal.hs b/sum-error/src/SumError/Internal.hs index 26e9b78..4c61e26 100644 --- a/sum-error/src/SumError/Internal.hs +++ b/sum-error/src/SumError/Internal.hs @@ -1,9 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module SumError.Internal where import Bookkeeper import Bookkeeper.Internal.Types (Ledger') +import Data.Functor.Classes +import Control.Monad.Cont +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Reader +import Control.Monad.RWS import Data.Functor.Identity import Control.Monad.Except @@ -12,7 +19,17 @@ import Control.Monad.Except -- The type is kept opaque to ensure the error types are sorted and nubbed. newtype SumErrorT ledger m a = SumErrorT ( ExceptT (Ledger' Identity ledger) m a ) deriving (Functor, Applicative, Monad, MonadIO, Foldable, Traversable - , MonadError (Ledger' Identity ledger)) + , MonadError (Ledger' Identity ledger), MonadState s, MonadWriter r + , MonadReader r, MonadCont, MonadFix, MonadRWS r w s) + +deriving instance (Ord a, Ord1 m, Ord (Ledger' Identity ledger)) + => Ord (SumErrorT ledger m a) +deriving instance (Ord1 m, Ord (Ledger' Identity ledger)) + => Ord1 (SumErrorT ledger m) +deriving instance (Eq a, Eq1 m, Eq (Ledger' Identity ledger)) + => Eq (SumErrorT ledger m a) +deriving instance (Eq1 m, Eq (Ledger' Identity ledger)) + => Eq1 (SumErrorT ledger m) runSumErrorT :: SumErrorT ledger m a -> m (Either (Ledger' Identity ledger) a) runSumErrorT (SumErrorT e) = runExceptT e From eaa354c627d7c551f7bed9e766b036127fae16ee Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 19:38:13 +0100 Subject: [PATCH 12/27] SumError type synonym --- bookkeeper/src/Bookkeeper/Internal/Types.hs | 2 ++ sum-error/src/SumError/Internal.hs | 7 +++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index f54d0be..ba6d54e 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -169,6 +169,8 @@ instance where key :: Key key key = Key + -- This isn't really impossible, since sum-errors catches errors down to + -- this. show (There _) = error "impossible" instance diff --git a/sum-error/src/SumError/Internal.hs b/sum-error/src/SumError/Internal.hs index 4c61e26..0248ac0 100644 --- a/sum-error/src/SumError/Internal.hs +++ b/sum-error/src/SumError/Internal.hs @@ -22,6 +22,8 @@ newtype SumErrorT ledger m a = SumErrorT ( ExceptT (Ledger' Identity ledger) m a , MonadError (Ledger' Identity ledger), MonadState s, MonadWriter r , MonadReader r, MonadCont, MonadFix, MonadRWS r w s) +type SumError ledger a = SumErrorT ledger Identity a + deriving instance (Ord a, Ord1 m, Ord (Ledger' Identity ledger)) => Ord (SumErrorT ledger m a) deriving instance (Ord1 m, Ord (Ledger' Identity ledger)) @@ -34,7 +36,10 @@ deriving instance (Eq1 m, Eq (Ledger' Identity ledger)) runSumErrorT :: SumErrorT ledger m a -> m (Either (Ledger' Identity ledger) a) runSumErrorT (SumErrorT e) = runExceptT e +runSumError :: SumError ledger a -> Either (Ledger' Identity ledger) a +runSumError (SumErrorT e) = runIdentity $ runExceptT e +-- | If all errors have been caught, this can be safely converted to a value. resolve :: Monad m => SumErrorT '[] m a -> m a resolve e = do Right val <- runSumErrorT e @@ -62,5 +67,3 @@ instance (ledger' ~ Delete key ledger, Monad m, Optionable key value ledger -- this could be prettier Right err1 -> runSumErrorT $ handler err1 Left err2 -> runSumErrorT $ throwError err2 - - From 8fad99fb9d92cfa10237636ab4b4c483792a9688 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Nov 2016 19:52:20 +0100 Subject: [PATCH 13/27] Documentation --- sum-error/src/SumError.hs | 9 ++++++--- sum-error/src/SumError/Internal.hs | 16 +++++++++++++--- sum-error/test/SumErrorSpec.hs | 6 +++--- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/sum-error/src/SumError.hs b/sum-error/src/SumError.hs index dc9aac8..4952c9a 100644 --- a/sum-error/src/SumError.hs +++ b/sum-error/src/SumError.hs @@ -1,9 +1,12 @@ module SumError - ( SumErrorT + ( SumError + , SumErrorT + , runSumError , runSumErrorT , resolve - , MonadSumError(..) - , MonadCatchSumError(..) + , resolveT + , MonadSumError(throwSumError) + , MonadCatchSumError(catchSumError) ) where import SumError.Internal diff --git a/sum-error/src/SumError/Internal.hs b/sum-error/src/SumError/Internal.hs index 0248ac0..20f5243 100644 --- a/sum-error/src/SumError/Internal.hs +++ b/sum-error/src/SumError/Internal.hs @@ -40,11 +40,17 @@ runSumError :: SumError ledger a -> Either (Ledger' Identity ledger) a runSumError (SumErrorT e) = runIdentity $ runExceptT e -- | If all errors have been caught, this can be safely converted to a value. -resolve :: Monad m => SumErrorT '[] m a -> m a -resolve e = do +resolveT :: Monad m => SumErrorT '[] m a -> m a +resolveT e = do Right val <- runSumErrorT e return val +-- | Like 'resolveT', but for 'SumEror' +resolve :: SumError '[] a -> a +resolve = runIdentity . resolveT + +-- | @MonadSumError m error value@ indicates that monad @m@ allows throwing +-- a labelled error value of type @value@ and label @error@. class (Monad m ) => MonadSumError m error value | m error -> value where throwSumError :: Key error -> value -> m a @@ -52,7 +58,11 @@ instance (Optionable error value ledger, Monad m) => MonadSumError (SumErrorT ledger m) error value where throwSumError key errorValue = SumErrorT (throwError $ option key $ errorValue) -class MonadSumError m error value +-- | @MonadCatchError m m' error value@ indicates that monad @m@ allows +-- catching errores of type @value labelled by @error@. The resulting monad may +-- differ from the original monad by e.g. having the corresponding exception +-- removed. +class (Monad m', MonadSumError m error value) => MonadCatchSumError m m' error value | m error -> m', m' error value -> m where catchSumError :: Key error -> (value -> m' a) -> m a -> m' a diff --git a/sum-error/test/SumErrorSpec.hs b/sum-error/test/SumErrorSpec.hs index 8d56cd5..4f45e01 100644 --- a/sum-error/test/SumErrorSpec.hs +++ b/sum-error/test/SumErrorSpec.hs @@ -13,9 +13,9 @@ spec = describe "SumErrorT" $ do $ catchSumError #notPositive (\_ -> return 202) $ catchSumError #notEven (\_ -> return 204) $ eg n - fn 1 `shouldBe` Identity 204 - fn (-2) `shouldBe` Identity 202 - fn 10 `shouldBe` Identity 200 + fn 1 `shouldBe` 204 + fn (-2) `shouldBe` 202 + fn 10 `shouldBe` 200 eg :: ( MonadSumError m "notPositive" () , MonadSumError m "notEven" () From 6d73593ab0bb69d8c06e809c9198af0077940f94 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 22 Nov 2016 14:00:10 +0100 Subject: [PATCH 14/27] Start forum --- bookkeeper/src/Bookkeeper/Internal/Types.hs | 4 + forum/.ghci | 1 + forum/.gitignore | 4 + forum/LICENSE | 31 +++++++ forum/Setup.hs | 2 + forum/forum.cabal | 90 +++++++++++++++++++++ forum/package.yaml | 67 +++++++++++++++ forum/src/Forum/Internal.hs | 4 + forum/src/Forum/Internal/SQL.hs | 49 +++++++++++ forum/src/Forum/Internal/ToTable.hs | 67 +++++++++++++++ forum/src/Forum/Internal/Types.hs | 13 +++ forum/test/Doctest.hs | 26 ++++++ forum/test/ForumSpec.hs | 69 ++++++++++++++++ forum/test/Spec.hs | 1 + 14 files changed, 428 insertions(+) create mode 100644 forum/.ghci create mode 100644 forum/.gitignore create mode 100644 forum/LICENSE create mode 100644 forum/Setup.hs create mode 100644 forum/forum.cabal create mode 100644 forum/package.yaml create mode 100644 forum/src/Forum/Internal.hs create mode 100644 forum/src/Forum/Internal/SQL.hs create mode 100644 forum/src/Forum/Internal/ToTable.hs create mode 100644 forum/src/Forum/Internal/Types.hs create mode 100644 forum/test/Doctest.hs create mode 100644 forum/test/ForumSpec.hs create mode 100644 forum/test/Spec.hs diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index ba6d54e..d3c6789 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -193,6 +193,10 @@ instance (Ord (f value), Ord (Ledger' f rest)) There _ <= Here _ = False There x <= There y = x <= y +{-instance Generic (Ledger' Identity '[key :=> value]) where-} + {-type Rep (Ledger' Identity '[key :=> value]) =-} + {-from (Here x) = L1 _-} + ------------------------------------------------------------------------------ -- Internal stuff ------------------------------------------------------------------------------ diff --git a/forum/.ghci b/forum/.ghci new file mode 100644 index 0000000..ae927ec --- /dev/null +++ b/forum/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/forum/.gitignore b/forum/.gitignore new file mode 100644 index 0000000..46ca9bd --- /dev/null +++ b/forum/.gitignore @@ -0,0 +1,4 @@ +/dist/ +/dist-newstyle/ +/.stack-work/ + diff --git a/forum/LICENSE b/forum/LICENSE new file mode 100644 index 0000000..302f74f --- /dev/null +++ b/forum/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni 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. + diff --git a/forum/Setup.hs b/forum/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/forum/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/forum/forum.cabal b/forum/forum.cabal new file mode 100644 index 0000000..51aca7c --- /dev/null +++ b/forum/forum.cabal @@ -0,0 +1,90 @@ +-- This file has been generated from package.yaml by hpack version 0.14.1. +-- +-- see: https://github.com/sol/hpack + +name: forum +version: 0.1.0.0 +description: Please see README.md +homepage: http://github.com/jkarni/forum#readme +bug-reports: https://github.com/jkarni/forum/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jkarni/forum + +library + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , bookkeeper + , hssqlppp >= 0.6 && < 0.7 + , text >= 1 && < 2 + , hasql-class >= 0.0.1 && < 0.0.2 + , hasql >= 0.19 && < 0.20 + , template-haskell >= 2.11 && < 2.12 + , bytestring >= 0.10 && < 0.11 + exposed-modules: + Forum.Internal + Forum.Internal.SQL + Forum.Internal.ToTable + Forum.Internal.Types + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , bookkeeper + , hssqlppp >= 0.6 && < 0.7 + , text >= 1 && < 2 + , hasql-class >= 0.0.1 && < 0.0.2 + , hasql >= 0.19 && < 0.20 + , template-haskell >= 2.11 && < 2.12 + , bytestring >= 0.10 && < 0.11 + , doctest >= 0.9 && < 0.12 + , Glob >= 0.7 && < 0.8 + , yaml == 0.8.* + other-modules: + ForumSpec + Spec + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , bookkeeper + , hssqlppp >= 0.6 && < 0.7 + , text >= 1 && < 2 + , hasql-class >= 0.0.1 && < 0.0.2 + , hasql >= 0.19 && < 0.20 + , template-haskell >= 2.11 && < 2.12 + , bytestring >= 0.10 && < 0.11 + , forum + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + other-modules: + Doctest + ForumSpec + default-language: Haskell2010 diff --git a/forum/package.yaml b/forum/package.yaml new file mode 100644 index 0000000..6100037 --- /dev/null +++ b/forum/package.yaml @@ -0,0 +1,67 @@ +name: forum +version: 0.1.0.0 +synopsis: +description: Please see README.md +homepage: http://github.com/jkarni/forum#readme +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +github: jkarni/forum +tested-with: GHC == 8.0.1 + +ghc-options: -Wall + +dependencies: + - base >= 4.7 && < 4.10 + - bookkeeper + - hssqlppp >= 0.6 && < 0.7 + - text >= 1 && < 2 + - hasql-class >= 0.0.1 && < 0.0.2 + - hasql >= 0.19 && < 0.20 + - template-haskell >= 2.11 && < 2.12 + - bytestring >= 0.10 && < 0.11 + +default-extensions: + - AutoDeriveTypeable + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - KindSignatures + - MultiParamTypeClasses + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeFamilies + - TypeOperators + +library: + source-dirs: src + other-modules: [] + +tests: + spec: + main: Spec.hs + source-dirs: test + dependencies: + - forum + - hspec > 2 && < 3 + - QuickCheck >= 2.8 && < 2.9 + doctest: + main: Doctest.hs + source-dirs: test + dependencies: + - doctest >= 0.9 && < 0.12 + - Glob >= 0.7 && < 0.8 + - yaml == 0.8.* + diff --git a/forum/src/Forum/Internal.hs b/forum/src/Forum/Internal.hs new file mode 100644 index 0000000..bb41b94 --- /dev/null +++ b/forum/src/Forum/Internal.hs @@ -0,0 +1,4 @@ +module Forum.Internal (module X) where + +import qualified Forum.Internal.SQL as X +import qualified Forum.Internal.ToTable as X diff --git a/forum/src/Forum/Internal/SQL.hs b/forum/src/Forum/Internal/SQL.hs new file mode 100644 index 0000000..0ee8e0e --- /dev/null +++ b/forum/src/Forum/Internal/SQL.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +module Forum.Internal.SQL where + +import qualified Data.ByteString.Char8 as BS +import qualified Hasql.Query as Hasql +import qualified Hasql.Class as Hasql +import qualified Database.HsSqlPpp.Catalog as Sql +import qualified Database.HsSqlPpp.Syntax as Sql +import qualified Database.HsSqlPpp.Parse as Sql +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH +import qualified Language.Haskell.TH.Syntax as TH +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +parseSQL :: String -> Either Sql.ParseErrorExtra ([Sql.Statement], [String]) +parseSQL s = (, reverse params) <$> parsed + where + -- 'count' is used rather than 'length' for efficiency + go ('$':word) (stmt, params, count) + = (('$':show count) : stmt, word : params, count + 1) + go word (stmt, params, count) + = (word : stmt, params, count) + (stmt, params, _) = foldr go ([], [], 0) (words s) + parsed = Sql.parseStatements Sql.defaultParseFlags + "" Nothing (LT.pack . unwords $ reverse stmt) + +-- | Runs type-checking on the statement, and returns the inferred type +{-typeCheckSQL :: Sql.Statement -> Sql.Catalog -> TH.Q TH.Type-} +{-typeCheckSQL s cat = case Sql.typeCheckStatements Sql.defaultTypeCheckFlags cat [s] of-} + {-(_, [typechecked]) -> case typechecked of-} + {-QueryStatement annot _ | Sql.anType annot -> Just typ -> do-} + {-qtyp <- newName "queryType"-} + {-[t| forall x. (HasSqlType typ qtyp) => qtyp |]-} + +makeStatement :: String -> [String] -> TH.Q TH.Exp +makeStatement stmt' params = [e| Hasql.stmtList (BS.pack $stmt) True |] + where + stmt = TH.liftString stmt' + +sql :: Sql.Catalog -> TH.QuasiQuoter +sql catalog = TH.QuasiQuoter + { TH.quoteExp = \s -> case parseSQL s of + Left err -> error $ show err + Right (_, params) -> makeStatement s params + , TH.quotePat = undefined + , TH.quoteDec = undefined + , TH.quoteType = undefined + } diff --git a/forum/src/Forum/Internal/ToTable.hs b/forum/src/Forum/Internal/ToTable.hs new file mode 100644 index 0000000..e36eaca --- /dev/null +++ b/forum/src/Forum/Internal/ToTable.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE PolyKinds #-} +module Forum.Internal.ToTable where + +import Bookkeeper +import Data.Bifunctor (second) +import Hasql.Class (Encodable, Decodable) +import GHC.Generics (Generic) +import Data.Proxy (Proxy(..)) +import GHC.TypeLits +import qualified Data.Text as T +import qualified Database.HsSqlPpp.Syntax as Sql +import qualified Database.HsSqlPpp.Types as Sql +import qualified Database.HsSqlPpp.Catalog as Sql + +import Forum.Internal.Types + +-- * SqlValue + +class (Encodable a, Decodable a) => SqlValue (a :: *) where + sqlType :: Proxy a -> Sql.Type + +instance SqlValue a => SqlValue (PrimaryKey tbl a) where + sqlType _ = sqlType (Proxy :: Proxy a) +instance SqlValue a => SqlValue (ForeignKey tbl a) where + sqlType _ = sqlType (Proxy :: Proxy a) + +instance SqlValue Bool where sqlType _ = Sql.ScalarType "bool" +instance SqlValue T.Text where sqlType _ = Sql.ScalarType "varchar" +{-instance SqlValue String where sqlType _ = Sql.ScalarType "varchar"-} + + +-- * ToTable + +class ToTable (a :: [*]) where + toTable :: Proxy a -> [(T.Text, Sql.Type)] + +instance (SqlValue fieldVal, KnownSymbol fieldName) + => ToTable '[ fieldName :=> (fieldVal :: *) ] where + toTable _ = [(T.pack $ symbolVal (Proxy :: Proxy fieldName) + , sqlType (Proxy :: Proxy fieldVal))] + +instance (SqlValue fieldVal, ToTable restOfTable, KnownSymbol fieldName) + => ToTable (fieldName :=> (fieldVal :: *) ': restOfTable) where + toTable _ + = ( T.pack $ symbolVal (Proxy :: Proxy fieldName) + , sqlType (Proxy :: Proxy fieldVal)) + : toTable (Proxy :: Proxy restOfTable) + +-- * ToCatalogUpdate + +class ToCatalogUpdate (a :: [*]) where + toCatalogUpdate :: Proxy a -> [Sql.CatalogUpdate] + +instance ToCatalogUpdate '[] where + toCatalogUpdate _ = [] + +instance (KnownSymbol tableName, ToTable table, ToCatalogUpdate rest) + => ToCatalogUpdate ( tableName :=> table ': rest) where + toCatalogUpdate _ = Sql.CatCreateTable tableName columns + : toCatalogUpdate (Proxy :: Proxy rest) + where + tableName = ("public", T.pack $ symbolVal (Proxy :: Proxy tableName)) + + columns = second typeToCatNameExtra <$> toTable (Proxy :: Proxy table) + + typeToCatNameExtra :: Sql.Type -> Sql.CatNameExtra + typeToCatNameExtra (Sql.ScalarType t) = Sql.mkCatNameExtra t diff --git a/forum/src/Forum/Internal/Types.hs b/forum/src/Forum/Internal/Types.hs new file mode 100644 index 0000000..65c40a3 --- /dev/null +++ b/forum/src/Forum/Internal/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} +module Forum.Internal.Types where + +import GHC.TypeLits +import GHC.Generics (Generic) +import Hasql.Class (Encodable, Decodable) + +newtype PrimaryKey (tbl :: Symbol) val = PrimaryKey val + deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) + + +newtype ForeignKey (tbl :: Symbol) val = ForeignKey val + deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) diff --git a/forum/test/Doctest.hs b/forum/test/Doctest.hs new file mode 100644 index 0000000..849dbbd --- /dev/null +++ b/forum/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/forum/test/ForumSpec.hs b/forum/test/ForumSpec.hs new file mode 100644 index 0000000..28e2755 --- /dev/null +++ b/forum/test/ForumSpec.hs @@ -0,0 +1,69 @@ +module ForumSpec (spec) where + +spec :: Spec +spec = describe "forum" $ do + let discoverer = emptyBook & #discovererId =: 1 + & #firstName =: "Carl" + & #lastName =: "Linnaeus" + + it "allows inserting and querying" $ do + runSql [sql| INSERT $discoverer INTO discoverer |] + result <- runSql [sql| SELECT (firstName) FROM discoverer |] + result `shouldBe` [subSet discoverer] + + it "allows WHERE clauses" $ do + runSql [sql| INSERT $discoverer INTO discoverer |] + result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |] + result `shouldBe` [] + + it "types WHERE on primary keys as Maybe" $ do + runSql [sql| INSERT $discoverer INTO discoverer |] + result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |] + result `shouldBe` Nothing + +------------------------------------------------------------------------------ +-- Setup + +withEmptyDb :: (DB -> IO a) -> IO a +withEmptyDb action = do + db <- getOrCreateDB "forum-test" (Proxy :: Proxy Schema) + result <- action db + deleteDB db + return result + + +------------------------------------------------------------------------------ +-- Schema and Types + +type Species = + '[ "speciesId" :=> PrimaryKey "species" Int + , "name" :=> T.Text + , "genus" :=> ForeignKey "genus" Int + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Genus = + '[ "genusId" :=> PrimaryKey "genus" Int + , "name" :=> T.Text + , "genus" :=> ForeignKey "family" Int + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Family = + '[ "familyId" :=> PrimaryKey "family" Int + , "name" :=> T.Text + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Discoverer = + '[ "discovererId" :=> PrimaryKey "family" Int + , "firstName" :=> T.Text + , "lastName" :=> T.Text + ] + +type Schema = + '[ "species" :=> Species + , "genus" :=> Genus + , "family" :=> Family + , "discoverer" :=> Discoverer + ] diff --git a/forum/test/Spec.hs b/forum/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/forum/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From b0cbc0e3ef408f15d181459697ae44b9754b641f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 22 Nov 2016 14:20:52 +0100 Subject: [PATCH 15/27] Force things to compile --- forum/forum.cabal | 12 ++++-- forum/package.yaml | 3 ++ forum/src/Forum.hs | 20 +++++++++ forum/src/Forum/Internal.hs | 5 ++- forum/src/Forum/Internal/SQL.hs | 16 ++++++- forum/src/Forum/Internal/ToTable.hs | 2 - forum/src/Forum/Internal/Types.hs | 9 +++- forum/test/ForumSpec.hs | 67 ++++++----------------------- forum/test/Schema.hs | 53 +++++++++++++++++++++++ 9 files changed, 123 insertions(+), 64 deletions(-) create mode 100644 forum/src/Forum.hs create mode 100644 forum/test/Schema.hs diff --git a/forum/forum.cabal b/forum/forum.cabal index 51aca7c..09e3dbe 100644 --- a/forum/forum.cabal +++ b/forum/forum.cabal @@ -23,7 +23,7 @@ source-repository head library hs-source-dirs: src - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash ghc-options: -Wall build-depends: base >= 4.7 && < 4.10 @@ -32,9 +32,11 @@ library , text >= 1 && < 2 , hasql-class >= 0.0.1 && < 0.0.2 , hasql >= 0.19 && < 0.20 + , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 exposed-modules: + Forum Forum.Internal Forum.Internal.SQL Forum.Internal.ToTable @@ -46,7 +48,7 @@ test-suite doctest main-is: Doctest.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash ghc-options: -Wall build-depends: base >= 4.7 && < 4.10 @@ -55,6 +57,7 @@ test-suite doctest , text >= 1 && < 2 , hasql-class >= 0.0.1 && < 0.0.2 , hasql >= 0.19 && < 0.20 + , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 , doctest >= 0.9 && < 0.12 @@ -62,6 +65,7 @@ test-suite doctest , yaml == 0.8.* other-modules: ForumSpec + Schema Spec default-language: Haskell2010 @@ -70,7 +74,7 @@ test-suite spec main-is: Spec.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash ghc-options: -Wall build-depends: base >= 4.7 && < 4.10 @@ -79,6 +83,7 @@ test-suite spec , text >= 1 && < 2 , hasql-class >= 0.0.1 && < 0.0.2 , hasql >= 0.19 && < 0.20 + , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 , forum @@ -87,4 +92,5 @@ test-suite spec other-modules: Doctest ForumSpec + Schema default-language: Haskell2010 diff --git a/forum/package.yaml b/forum/package.yaml index 6100037..bf19cd7 100644 --- a/forum/package.yaml +++ b/forum/package.yaml @@ -20,6 +20,7 @@ dependencies: - text >= 1 && < 2 - hasql-class >= 0.0.1 && < 0.0.2 - hasql >= 0.19 && < 0.20 + - hasql-pool >= 0.4 && < 0.5 - template-haskell >= 2.11 && < 2.12 - bytestring >= 0.10 && < 0.11 @@ -44,6 +45,8 @@ default-extensions: - TupleSections - TypeFamilies - TypeOperators + - OverloadedLabels + - MagicHash library: source-dirs: src diff --git a/forum/src/Forum.hs b/forum/src/Forum.hs new file mode 100644 index 0000000..9ed4adb --- /dev/null +++ b/forum/src/Forum.hs @@ -0,0 +1,20 @@ +module Forum + ( module X + , sqlQQFor + , getOrCreateDB + , deleteDB + , PrimaryKey(..) + , ForeignKey(..) + , DB + , dbName + , dbConnectionPool + , dbCatalog + , QuasiQuoter + , Proxy(..) + ) where + +import Bookkeeper as X +import Data.Proxy (Proxy (Proxy)) +import Forum.Internal (DB (..), ForeignKey (..), PrimaryKey (..), + deleteDB, getOrCreateDB, sqlQQFor) +import Language.Haskell.TH.Quote (QuasiQuoter) diff --git a/forum/src/Forum/Internal.hs b/forum/src/Forum/Internal.hs index bb41b94..265e318 100644 --- a/forum/src/Forum/Internal.hs +++ b/forum/src/Forum/Internal.hs @@ -1,4 +1,5 @@ module Forum.Internal (module X) where -import qualified Forum.Internal.SQL as X -import qualified Forum.Internal.ToTable as X +import Forum.Internal.SQL as X +import Forum.Internal.ToTable as X +import Forum.Internal.Types as X diff --git a/forum/src/Forum/Internal/SQL.hs b/forum/src/Forum/Internal/SQL.hs index 0ee8e0e..899bd4a 100644 --- a/forum/src/Forum/Internal/SQL.hs +++ b/forum/src/Forum/Internal/SQL.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Forum.Internal.SQL where +import Data.Proxy (Proxy) import qualified Data.ByteString.Char8 as BS import qualified Hasql.Query as Hasql import qualified Hasql.Class as Hasql @@ -13,6 +14,8 @@ import qualified Language.Haskell.TH.Syntax as TH import qualified Data.Text as T import qualified Data.Text.Lazy as LT +import Forum.Internal.Types + parseSQL :: String -> Either Sql.ParseErrorExtra ([Sql.Statement], [String]) parseSQL s = (, reverse params) <$> parsed where @@ -38,8 +41,11 @@ makeStatement stmt' params = [e| Hasql.stmtList (BS.pack $stmt) True |] where stmt = TH.liftString stmt' -sql :: Sql.Catalog -> TH.QuasiQuoter -sql catalog = TH.QuasiQuoter +sqlQQFor :: Proxy a -> TH.QuasiQuoter +sqlQQFor _ = undefined + +sqlQQForSchema :: Sql.Catalog -> TH.QuasiQuoter +sqlQQForSchema catalog = TH.QuasiQuoter { TH.quoteExp = \s -> case parseSQL s of Left err -> error $ show err Right (_, params) -> makeStatement s params @@ -47,3 +53,9 @@ sql catalog = TH.QuasiQuoter , TH.quoteDec = undefined , TH.quoteType = undefined } + +getOrCreateDB :: String -> Proxy (a :: *) -> IO DB +getOrCreateDB = undefined + +deleteDB :: DB -> IO () +deleteDB = undefined diff --git a/forum/src/Forum/Internal/ToTable.hs b/forum/src/Forum/Internal/ToTable.hs index e36eaca..e03730b 100644 --- a/forum/src/Forum/Internal/ToTable.hs +++ b/forum/src/Forum/Internal/ToTable.hs @@ -4,11 +4,9 @@ module Forum.Internal.ToTable where import Bookkeeper import Data.Bifunctor (second) import Hasql.Class (Encodable, Decodable) -import GHC.Generics (Generic) import Data.Proxy (Proxy(..)) import GHC.TypeLits import qualified Data.Text as T -import qualified Database.HsSqlPpp.Syntax as Sql import qualified Database.HsSqlPpp.Types as Sql import qualified Database.HsSqlPpp.Catalog as Sql diff --git a/forum/src/Forum/Internal/Types.hs b/forum/src/Forum/Internal/Types.hs index 65c40a3..9310706 100644 --- a/forum/src/Forum/Internal/Types.hs +++ b/forum/src/Forum/Internal/Types.hs @@ -4,10 +4,17 @@ module Forum.Internal.Types where import GHC.TypeLits import GHC.Generics (Generic) import Hasql.Class (Encodable, Decodable) +import Hasql.Pool (Pool) +import qualified Database.HsSqlPpp.Catalog as Sql newtype PrimaryKey (tbl :: Symbol) val = PrimaryKey val deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) - newtype ForeignKey (tbl :: Symbol) val = ForeignKey val deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) + +data DB = DB + { dbCatalog :: Sql.Catalog + , dbName :: String + , dbConnectionPool :: Pool + } diff --git a/forum/test/ForumSpec.hs b/forum/test/ForumSpec.hs index 28e2755..24a6998 100644 --- a/forum/test/ForumSpec.hs +++ b/forum/test/ForumSpec.hs @@ -1,69 +1,28 @@ +{-# LANGUAGE QuasiQuotes #-} module ForumSpec (spec) where +import Forum +import Schema +import qualified Data.Text as T +import Test.Hspec + spec :: Spec -spec = describe "forum" $ do - let discoverer = emptyBook & #discovererId =: 1 - & #firstName =: "Carl" - & #lastName =: "Linnaeus" +spec = describe "forum" $ around withEmptyDb $ do + let discoverer = emptyBook & #discovererId =: 1 + & #firstName =: "Carl" + & #lastName =: "Linnaeus" - it "allows inserting and querying" $ do + it "allows inserting and querying" $ \db -> do runSql [sql| INSERT $discoverer INTO discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer |] result `shouldBe` [subSet discoverer] - it "allows WHERE clauses" $ do + it "allows WHERE clauses" $ \db -> do runSql [sql| INSERT $discoverer INTO discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |] result `shouldBe` [] - it "types WHERE on primary keys as Maybe" $ do + it "types WHERE on primary keys as Maybe" $ \db -> do runSql [sql| INSERT $discoverer INTO discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |] result `shouldBe` Nothing - ------------------------------------------------------------------------------- --- Setup - -withEmptyDb :: (DB -> IO a) -> IO a -withEmptyDb action = do - db <- getOrCreateDB "forum-test" (Proxy :: Proxy Schema) - result <- action db - deleteDB db - return result - - ------------------------------------------------------------------------------- --- Schema and Types - -type Species = - '[ "speciesId" :=> PrimaryKey "species" Int - , "name" :=> T.Text - , "genus" :=> ForeignKey "genus" Int - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Genus = - '[ "genusId" :=> PrimaryKey "genus" Int - , "name" :=> T.Text - , "genus" :=> ForeignKey "family" Int - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Family = - '[ "familyId" :=> PrimaryKey "family" Int - , "name" :=> T.Text - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Discoverer = - '[ "discovererId" :=> PrimaryKey "family" Int - , "firstName" :=> T.Text - , "lastName" :=> T.Text - ] - -type Schema = - '[ "species" :=> Species - , "genus" :=> Genus - , "family" :=> Family - , "discoverer" :=> Discoverer - ] diff --git a/forum/test/Schema.hs b/forum/test/Schema.hs new file mode 100644 index 0000000..ebf9c7e --- /dev/null +++ b/forum/test/Schema.hs @@ -0,0 +1,53 @@ +module Schema where + +import Forum +import qualified Data.Text as T + +------------------------------------------------------------------------------ +-- Setup + +withEmptyDb :: (DB -> IO a) -> IO a +withEmptyDb action = do + db <- getOrCreateDB "forum-test" (Proxy :: Proxy Schema) + result <- action db + deleteDB db + return result + +sql :: QuasiQuoter +sql = sqlQQFor (Proxy :: Proxy Schema) + +------------------------------------------------------------------------------ +-- Schema and Types + +type Species = Book + '[ "speciesId" :=> PrimaryKey "species" Int + , "name" :=> T.Text + , "genus" :=> ForeignKey "genus" Int + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Genus = Book + '[ "genusId" :=> PrimaryKey "genus" Int + , "name" :=> T.Text + , "genus" :=> ForeignKey "family" Int + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Family = Book + '[ "familyId" :=> PrimaryKey "family" Int + , "name" :=> T.Text + , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) + ] + +type Discoverer = Book + '[ "discovererId" :=> PrimaryKey "family" Int + , "firstName" :=> T.Text + , "lastName" :=> T.Text + ] + +type Schema = Book + '[ "species" :=> Species + , "genus" :=> Genus + , "family" :=> Family + , "discoverer" :=> Discoverer + ] From 83aacc87bc1807971d379eeeec47f645064aad41 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 22 Nov 2016 14:31:46 +0100 Subject: [PATCH 16/27] Fix insert into --- forum/test/ForumSpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/forum/test/ForumSpec.hs b/forum/test/ForumSpec.hs index 24a6998..867f957 100644 --- a/forum/test/ForumSpec.hs +++ b/forum/test/ForumSpec.hs @@ -13,16 +13,16 @@ spec = describe "forum" $ around withEmptyDb $ do & #lastName =: "Linnaeus" it "allows inserting and querying" $ \db -> do - runSql [sql| INSERT $discoverer INTO discoverer |] + runSql [sql| INSERT INTO discoverer VALUES $discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer |] result `shouldBe` [subSet discoverer] it "allows WHERE clauses" $ \db -> do - runSql [sql| INSERT $discoverer INTO discoverer |] + runSql [sql| INSERT INTO discoverer VALUES $discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |] result `shouldBe` [] it "types WHERE on primary keys as Maybe" $ \db -> do - runSql [sql| INSERT $discoverer INTO discoverer |] + runSql [sql| INSERT INTO discoverer VALUES $discoverer |] result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |] result `shouldBe` Nothing From 33ec0f44c4def288e329d2e2cee33aed286d0b6b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 26 Nov 2016 11:36:43 +0100 Subject: [PATCH 17/27] Move Sql types to type level --- forum/forum.cabal | 5 ++ forum/package.yaml | 1 + forum/src/Forum/Internal/SQL.hs | 36 +++++++++------ forum/src/Forum/Internal/ToTable.hs | 69 ++++++++++++++++++++++------ forum/test/Forum/Internal/SQLSpec.hs | 18 ++++++++ forum/test/ForumSpec.hs | 26 ++++++----- forum/test/Schema.hs | 6 +-- 7 files changed, 119 insertions(+), 42 deletions(-) create mode 100644 forum/test/Forum/Internal/SQLSpec.hs diff --git a/forum/forum.cabal b/forum/forum.cabal index 09e3dbe..a3a0545 100644 --- a/forum/forum.cabal +++ b/forum/forum.cabal @@ -35,6 +35,7 @@ library , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 + , reflection >= 2 && < 3 exposed-modules: Forum Forum.Internal @@ -60,10 +61,12 @@ test-suite doctest , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 + , reflection >= 2 && < 3 , doctest >= 0.9 && < 0.12 , Glob >= 0.7 && < 0.8 , yaml == 0.8.* other-modules: + Forum.Internal.SQLSpec ForumSpec Schema Spec @@ -86,11 +89,13 @@ test-suite spec , hasql-pool >= 0.4 && < 0.5 , template-haskell >= 2.11 && < 2.12 , bytestring >= 0.10 && < 0.11 + , reflection >= 2 && < 3 , forum , hspec > 2 && < 3 , QuickCheck >= 2.8 && < 2.9 other-modules: Doctest + Forum.Internal.SQLSpec ForumSpec Schema default-language: Haskell2010 diff --git a/forum/package.yaml b/forum/package.yaml index bf19cd7..6d480f9 100644 --- a/forum/package.yaml +++ b/forum/package.yaml @@ -23,6 +23,7 @@ dependencies: - hasql-pool >= 0.4 && < 0.5 - template-haskell >= 2.11 && < 2.12 - bytestring >= 0.10 && < 0.11 + - reflection >= 2 && < 3 default-extensions: - AutoDeriveTypeable diff --git a/forum/src/Forum/Internal/SQL.hs b/forum/src/Forum/Internal/SQL.hs index 899bd4a..3379ab1 100644 --- a/forum/src/Forum/Internal/SQL.hs +++ b/forum/src/Forum/Internal/SQL.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module Forum.Internal.SQL where -import Data.Proxy (Proxy) +import Data.Proxy (Proxy(Proxy)) +import Data.Char (isAlphaNum) import qualified Data.ByteString.Char8 as BS import qualified Hasql.Query as Hasql import qualified Hasql.Class as Hasql @@ -13,36 +14,43 @@ import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH import qualified Data.Text as T import qualified Data.Text.Lazy as LT +import Bookkeeper.Internal.Types (Book') import Forum.Internal.Types +import Forum.Internal.ToTable parseSQL :: String -> Either Sql.ParseErrorExtra ([Sql.Statement], [String]) -parseSQL s = (, reverse params) <$> parsed +parseSQL s = (, params) <$> parsed where + parsed = Sql.parseStatements Sql.defaultParseFlags + "" Nothing (LT.pack . unwords $ stmt) + (stmt, params, _) = foldr go ([], [], 0) (words s) -- 'count' is used rather than 'length' for efficiency go ('$':word) (stmt, params, count) - = (('$':show count) : stmt, word : params, count + 1) + = (('?' : extra) : stmt , param : params, count + 1) + where + (param, extra) = span isAlphaNum word go word (stmt, params, count) = (word : stmt, params, count) - (stmt, params, _) = foldr go ([], [], 0) (words s) - parsed = Sql.parseStatements Sql.defaultParseFlags - "" Nothing (LT.pack . unwords $ reverse stmt) -- | Runs type-checking on the statement, and returns the inferred type -{-typeCheckSQL :: Sql.Statement -> Sql.Catalog -> TH.Q TH.Type-} -{-typeCheckSQL s cat = case Sql.typeCheckStatements Sql.defaultTypeCheckFlags cat [s] of-} - {-(_, [typechecked]) -> case typechecked of-} - {-QueryStatement annot _ | Sql.anType annot -> Just typ -> do-} - {-qtyp <- newName "queryType"-} - {-[t| forall x. (HasSqlType typ qtyp) => qtyp |]-} +typeCheckSQL :: Sql.Statement -> Sql.Catalog -> TH.Q TH.Type +typeCheckSQL s cat = case Sql.typeCheckStatements Sql.defaultTypeCheckFlags cat [s] of + (_, [typechecked]) -> case typechecked of + QueryStatement annot _ -> case Sql.anType annot of + Just typ -> do + qtyp <- newName "queryType" + [t| forall x. (HasSqlType typ qtyp) => qtyp |] makeStatement :: String -> [String] -> TH.Q TH.Exp makeStatement stmt' params = [e| Hasql.stmtList (BS.pack $stmt) True |] where stmt = TH.liftString stmt' -sqlQQFor :: Proxy a -> TH.QuasiQuoter -sqlQQFor _ = undefined +sqlQQFor :: forall a f. ToCatalogUpdate a => Proxy (Book' f (a :: [*])) -> TH.QuasiQuoter +sqlQQFor _ = case sqlQQForSchema <$> toCatalog (Proxy :: Proxy a) of + Left e -> error $ "Error constructing catalog: " ++ show e + Right v -> v sqlQQForSchema :: Sql.Catalog -> TH.QuasiQuoter sqlQQForSchema catalog = TH.QuasiQuoter diff --git a/forum/src/Forum/Internal/ToTable.hs b/forum/src/Forum/Internal/ToTable.hs index e03730b..96a60bf 100644 --- a/forum/src/Forum/Internal/ToTable.hs +++ b/forum/src/Forum/Internal/ToTable.hs @@ -3,7 +3,8 @@ module Forum.Internal.ToTable where import Bookkeeper import Data.Bifunctor (second) -import Hasql.Class (Encodable, Decodable) +import Data.Reflection (Reifies(..)) +import Data.Int import Data.Proxy (Proxy(..)) import GHC.TypeLits import qualified Data.Text as T @@ -14,46 +15,88 @@ import Forum.Internal.Types -- * SqlValue -class (Encodable a, Decodable a) => SqlValue (a :: *) where - sqlType :: Proxy a -> Sql.Type + + +class SqlValue (haskellType :: *) where + sqlType :: Proxy haskellType -> Sql.Type + isNullable :: Proxy haskellType -> Bool + isNullable _ = False instance SqlValue a => SqlValue (PrimaryKey tbl a) where sqlType _ = sqlType (Proxy :: Proxy a) + instance SqlValue a => SqlValue (ForeignKey tbl a) where sqlType _ = sqlType (Proxy :: Proxy a) + isNullable _ = isNullable (Proxy :: Proxy a) + +instance SqlValue a => SqlValue (Maybe a) where + sqlType _ = sqlType (Proxy :: Proxy a) + isNullable _ = True instance SqlValue Bool where sqlType _ = Sql.ScalarType "bool" instance SqlValue T.Text where sqlType _ = Sql.ScalarType "varchar" +instance SqlValue Int where sqlType _ = Sql.ScalarType "bigint" {-instance SqlValue String where sqlType _ = Sql.ScalarType "varchar"-} +-- * HasSqlValue + +class (Reifies (SqlType haskellType) Sql.Type) => HasSqlValue (haskellType :: *) where + type SqlType haskellType + type IsNullable haskellType :: Bool + type IsNullable haskellType = 'False + +instance HasSqlValue T.Text where type SqlType T.Text = Scalar "varchar" +instance HasSqlValue String where type SqlType String = Scalar "varchar" +instance HasSqlValue Bool where type SqlType Bool = Scalar "bool" +instance HasSqlValue Int16 where type SqlType Int16 = Scalar "smallint" +instance HasSqlValue Int32 where type SqlType Int32 = Scalar "integer" +instance HasSqlValue Int64 where type SqlType Int64 = Scalar "bigint" +instance HasSqlValue Float where type SqlType Float = Scalar "real" +instance HasSqlValue Double where type SqlType Double = Scalar "double" +instance (HasSqlValue a, IsNullable a ~ 'False) => HasSqlValue (Maybe a) where + type SqlType (Maybe a) = SqlType a + type IsNullable (Maybe a) = 'True + +data Scalar (s :: Symbol) + +instance KnownSymbol s => Reifies (Scalar s) Sql.Type where + reflect _ = Sql.ScalarType (T.pack $ symbolVal (Proxy :: Proxy s)) + + +toSqlType :: forall a. HasSqlValue a => Proxy a -> Sql.Type +toSqlType _ = reflect (Proxy :: Proxy (SqlType a)) -- * ToTable class ToTable (a :: [*]) where toTable :: Proxy a -> [(T.Text, Sql.Type)] -instance (SqlValue fieldVal, KnownSymbol fieldName) - => ToTable '[ fieldName :=> (fieldVal :: *) ] where +instance (HasSqlValue fieldVal, KnownSymbol fieldName) + => ToTable '[ fieldName :=> fieldVal ] where toTable _ = [(T.pack $ symbolVal (Proxy :: Proxy fieldName) - , sqlType (Proxy :: Proxy fieldVal))] + , toSqlType (Proxy :: Proxy fieldVal))] -instance (SqlValue fieldVal, ToTable restOfTable, KnownSymbol fieldName) - => ToTable (fieldName :=> (fieldVal :: *) ': restOfTable) where +instance (HasSqlValue fieldVal, ToTable (snd ': restOfTable), KnownSymbol fieldName) + => ToTable (fieldName :=> fieldVal ': snd ': restOfTable) where toTable _ = ( T.pack $ symbolVal (Proxy :: Proxy fieldName) - , sqlType (Proxy :: Proxy fieldVal)) - : toTable (Proxy :: Proxy restOfTable) + , toSqlType (Proxy :: Proxy fieldVal)) + : toTable (Proxy :: Proxy (snd ': restOfTable)) -- * ToCatalogUpdate +toCatalog :: ToCatalogUpdate a => Proxy a -> Either [Sql.TypeError] Sql.Catalog +toCatalog p = Sql.updateCatalog (toCatalogUpdate p) undefined + class ToCatalogUpdate (a :: [*]) where toCatalogUpdate :: Proxy a -> [Sql.CatalogUpdate] -instance ToCatalogUpdate '[] where +instance {-# OVERLAPPING #-} ToCatalogUpdate '[] where toCatalogUpdate _ = [] -instance (KnownSymbol tableName, ToTable table, ToCatalogUpdate rest) - => ToCatalogUpdate ( tableName :=> table ': rest) where +instance {-# OVERLAPPABLE #-} + (KnownSymbol tableName, ToTable table, ToCatalogUpdate rest) + => ToCatalogUpdate ( tableName :=> Book' f table ': rest) where toCatalogUpdate _ = Sql.CatCreateTable tableName columns : toCatalogUpdate (Proxy :: Proxy rest) where diff --git a/forum/test/Forum/Internal/SQLSpec.hs b/forum/test/Forum/Internal/SQLSpec.hs new file mode 100644 index 0000000..d196457 --- /dev/null +++ b/forum/test/Forum/Internal/SQLSpec.hs @@ -0,0 +1,18 @@ +module Forum.Internal.SQLSpec (spec) where + +import Forum.Internal.SQL +import Test.Hspec + +spec :: Spec +spec = do + parseSQLSpec + +parseSQLSpec :: Spec +parseSQLSpec = describe "parseSQL" $ do + + it "returns all params" $ do + let p = case parseSQL "SELECT * FROM tbl WHERE a = $p1 AND b = $p2;" of + Left e -> error $ show e + Right (_, v) -> v + p `shouldBe` ["p1", "p2"] + diff --git a/forum/test/ForumSpec.hs b/forum/test/ForumSpec.hs index 867f957..60461c4 100644 --- a/forum/test/ForumSpec.hs +++ b/forum/test/ForumSpec.hs @@ -12,17 +12,19 @@ spec = describe "forum" $ around withEmptyDb $ do & #firstName =: "Carl" & #lastName =: "Linnaeus" - it "allows inserting and querying" $ \db -> do - runSql [sql| INSERT INTO discoverer VALUES $discoverer |] - result <- runSql [sql| SELECT (firstName) FROM discoverer |] - result `shouldBe` [subSet discoverer] + it "is pending" $ \db -> pending - it "allows WHERE clauses" $ \db -> do - runSql [sql| INSERT INTO discoverer VALUES $discoverer |] - result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |] - result `shouldBe` [] + {-it "allows inserting and querying" $ \db -> do-} + {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} + {-result <- runSql [sql| SELECT (firstName) FROM discoverer |]-} + {-result `shouldBe` [subSet discoverer]-} - it "types WHERE on primary keys as Maybe" $ \db -> do - runSql [sql| INSERT INTO discoverer VALUES $discoverer |] - result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |] - result `shouldBe` Nothing + {-it "allows WHERE clauses" $ \db -> do-} + {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} + {-result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |]-} + {-result `shouldBe` []-} + + {-it "types WHERE on primary keys as Maybe" $ \db -> do-} + {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} + {-result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |]-} + {-result `shouldBe` Nothing-} diff --git a/forum/test/Schema.hs b/forum/test/Schema.hs index ebf9c7e..d7e0bc8 100644 --- a/forum/test/Schema.hs +++ b/forum/test/Schema.hs @@ -47,7 +47,7 @@ type Discoverer = Book type Schema = Book '[ "species" :=> Species - , "genus" :=> Genus - , "family" :=> Family - , "discoverer" :=> Discoverer + {-, "genus" :=> Genus-} + {-, "family" :=> Family-} + {-, "discoverer" :=> Discoverer-} ] From 2961ebea7c9d5ec516910e84203a9f15a8c3342f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 26 Nov 2016 11:37:02 +0100 Subject: [PATCH 18/27] Export book --- bookkeeper/src/Bookkeeper.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index 5669295..acfba80 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -53,6 +53,7 @@ module Bookkeeper -- * Types , Book + , Book' , (:=>) , Key From 94914f042a21b373a1bd054459f46900dbabe73a Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 26 Nov 2016 11:38:22 +0100 Subject: [PATCH 19/27] Move forum out --- forum/.ghci | 1 - forum/.gitignore | 4 - forum/LICENSE | 31 -------- forum/Setup.hs | 2 - forum/forum.cabal | 101 ------------------------- forum/package.yaml | 71 ------------------ forum/src/Forum.hs | 20 ----- forum/src/Forum/Internal.hs | 5 -- forum/src/Forum/Internal/SQL.hs | 69 ----------------- forum/src/Forum/Internal/ToTable.hs | 108 --------------------------- forum/src/Forum/Internal/Types.hs | 20 ----- forum/test/Doctest.hs | 26 ------- forum/test/Forum/Internal/SQLSpec.hs | 18 ----- forum/test/ForumSpec.hs | 30 -------- forum/test/Schema.hs | 53 ------------- forum/test/Spec.hs | 1 - 16 files changed, 560 deletions(-) delete mode 100644 forum/.ghci delete mode 100644 forum/.gitignore delete mode 100644 forum/LICENSE delete mode 100644 forum/Setup.hs delete mode 100644 forum/forum.cabal delete mode 100644 forum/package.yaml delete mode 100644 forum/src/Forum.hs delete mode 100644 forum/src/Forum/Internal.hs delete mode 100644 forum/src/Forum/Internal/SQL.hs delete mode 100644 forum/src/Forum/Internal/ToTable.hs delete mode 100644 forum/src/Forum/Internal/Types.hs delete mode 100644 forum/test/Doctest.hs delete mode 100644 forum/test/Forum/Internal/SQLSpec.hs delete mode 100644 forum/test/ForumSpec.hs delete mode 100644 forum/test/Schema.hs delete mode 100644 forum/test/Spec.hs diff --git a/forum/.ghci b/forum/.ghci deleted file mode 100644 index ae927ec..0000000 --- a/forum/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/forum/.gitignore b/forum/.gitignore deleted file mode 100644 index 46ca9bd..0000000 --- a/forum/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -/dist/ -/dist-newstyle/ -/.stack-work/ - diff --git a/forum/LICENSE b/forum/LICENSE deleted file mode 100644 index 302f74f..0000000 --- a/forum/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright Julian K. Arni (c) 2015 - -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 Julian K. Arni 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. - diff --git a/forum/Setup.hs b/forum/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/forum/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/forum/forum.cabal b/forum/forum.cabal deleted file mode 100644 index a3a0545..0000000 --- a/forum/forum.cabal +++ /dev/null @@ -1,101 +0,0 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. --- --- see: https://github.com/sol/hpack - -name: forum -version: 0.1.0.0 -description: Please see README.md -homepage: http://github.com/jkarni/forum#readme -bug-reports: https://github.com/jkarni/forum/issues -author: Julian K. Arni -maintainer: jkarni@gmail.com -copyright: (c) Julian K. Arni -license: BSD3 -license-file: LICENSE -tested-with: GHC == 8.0.1 -build-type: Simple -cabal-version: >= 1.10 - -source-repository head - type: git - location: https://github.com/jkarni/forum - -library - hs-source-dirs: - src - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash - ghc-options: -Wall - build-depends: - base >= 4.7 && < 4.10 - , bookkeeper - , hssqlppp >= 0.6 && < 0.7 - , text >= 1 && < 2 - , hasql-class >= 0.0.1 && < 0.0.2 - , hasql >= 0.19 && < 0.20 - , hasql-pool >= 0.4 && < 0.5 - , template-haskell >= 2.11 && < 2.12 - , bytestring >= 0.10 && < 0.11 - , reflection >= 2 && < 3 - exposed-modules: - Forum - Forum.Internal - Forum.Internal.SQL - Forum.Internal.ToTable - Forum.Internal.Types - default-language: Haskell2010 - -test-suite doctest - type: exitcode-stdio-1.0 - main-is: Doctest.hs - hs-source-dirs: - test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash - ghc-options: -Wall - build-depends: - base >= 4.7 && < 4.10 - , bookkeeper - , hssqlppp >= 0.6 && < 0.7 - , text >= 1 && < 2 - , hasql-class >= 0.0.1 && < 0.0.2 - , hasql >= 0.19 && < 0.20 - , hasql-pool >= 0.4 && < 0.5 - , template-haskell >= 2.11 && < 2.12 - , bytestring >= 0.10 && < 0.11 - , reflection >= 2 && < 3 - , doctest >= 0.9 && < 0.12 - , Glob >= 0.7 && < 0.8 - , yaml == 0.8.* - other-modules: - Forum.Internal.SQLSpec - ForumSpec - Schema - Spec - default-language: Haskell2010 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: - test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeFamilies TypeOperators OverloadedLabels MagicHash - ghc-options: -Wall - build-depends: - base >= 4.7 && < 4.10 - , bookkeeper - , hssqlppp >= 0.6 && < 0.7 - , text >= 1 && < 2 - , hasql-class >= 0.0.1 && < 0.0.2 - , hasql >= 0.19 && < 0.20 - , hasql-pool >= 0.4 && < 0.5 - , template-haskell >= 2.11 && < 2.12 - , bytestring >= 0.10 && < 0.11 - , reflection >= 2 && < 3 - , forum - , hspec > 2 && < 3 - , QuickCheck >= 2.8 && < 2.9 - other-modules: - Doctest - Forum.Internal.SQLSpec - ForumSpec - Schema - default-language: Haskell2010 diff --git a/forum/package.yaml b/forum/package.yaml deleted file mode 100644 index 6d480f9..0000000 --- a/forum/package.yaml +++ /dev/null @@ -1,71 +0,0 @@ -name: forum -version: 0.1.0.0 -synopsis: -description: Please see README.md -homepage: http://github.com/jkarni/forum#readme -license: BSD3 -license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com -copyright: (c) Julian K. Arni -github: jkarni/forum -tested-with: GHC == 8.0.1 - -ghc-options: -Wall - -dependencies: - - base >= 4.7 && < 4.10 - - bookkeeper - - hssqlppp >= 0.6 && < 0.7 - - text >= 1 && < 2 - - hasql-class >= 0.0.1 && < 0.0.2 - - hasql >= 0.19 && < 0.20 - - hasql-pool >= 0.4 && < 0.5 - - template-haskell >= 2.11 && < 2.12 - - bytestring >= 0.10 && < 0.11 - - reflection >= 2 && < 3 - -default-extensions: - - AutoDeriveTypeable - - ConstraintKinds - - DataKinds - - DefaultSignatures - - DeriveFoldable - - DeriveFunctor - - DeriveGeneric - - DeriveTraversable - - FlexibleContexts - - FlexibleInstances - - FunctionalDependencies - - GADTs - - KindSignatures - - MultiParamTypeClasses - - OverloadedStrings - - RankNTypes - - ScopedTypeVariables - - TupleSections - - TypeFamilies - - TypeOperators - - OverloadedLabels - - MagicHash - -library: - source-dirs: src - other-modules: [] - -tests: - spec: - main: Spec.hs - source-dirs: test - dependencies: - - forum - - hspec > 2 && < 3 - - QuickCheck >= 2.8 && < 2.9 - doctest: - main: Doctest.hs - source-dirs: test - dependencies: - - doctest >= 0.9 && < 0.12 - - Glob >= 0.7 && < 0.8 - - yaml == 0.8.* - diff --git a/forum/src/Forum.hs b/forum/src/Forum.hs deleted file mode 100644 index 9ed4adb..0000000 --- a/forum/src/Forum.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Forum - ( module X - , sqlQQFor - , getOrCreateDB - , deleteDB - , PrimaryKey(..) - , ForeignKey(..) - , DB - , dbName - , dbConnectionPool - , dbCatalog - , QuasiQuoter - , Proxy(..) - ) where - -import Bookkeeper as X -import Data.Proxy (Proxy (Proxy)) -import Forum.Internal (DB (..), ForeignKey (..), PrimaryKey (..), - deleteDB, getOrCreateDB, sqlQQFor) -import Language.Haskell.TH.Quote (QuasiQuoter) diff --git a/forum/src/Forum/Internal.hs b/forum/src/Forum/Internal.hs deleted file mode 100644 index 265e318..0000000 --- a/forum/src/Forum/Internal.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Forum.Internal (module X) where - -import Forum.Internal.SQL as X -import Forum.Internal.ToTable as X -import Forum.Internal.Types as X diff --git a/forum/src/Forum/Internal/SQL.hs b/forum/src/Forum/Internal/SQL.hs deleted file mode 100644 index 3379ab1..0000000 --- a/forum/src/Forum/Internal/SQL.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Forum.Internal.SQL where - -import Data.Proxy (Proxy(Proxy)) -import Data.Char (isAlphaNum) -import qualified Data.ByteString.Char8 as BS -import qualified Hasql.Query as Hasql -import qualified Hasql.Class as Hasql -import qualified Database.HsSqlPpp.Catalog as Sql -import qualified Database.HsSqlPpp.Syntax as Sql -import qualified Database.HsSqlPpp.Parse as Sql -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Quote as TH -import qualified Language.Haskell.TH.Syntax as TH -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Bookkeeper.Internal.Types (Book') - -import Forum.Internal.Types -import Forum.Internal.ToTable - -parseSQL :: String -> Either Sql.ParseErrorExtra ([Sql.Statement], [String]) -parseSQL s = (, params) <$> parsed - where - parsed = Sql.parseStatements Sql.defaultParseFlags - "" Nothing (LT.pack . unwords $ stmt) - (stmt, params, _) = foldr go ([], [], 0) (words s) - -- 'count' is used rather than 'length' for efficiency - go ('$':word) (stmt, params, count) - = (('?' : extra) : stmt , param : params, count + 1) - where - (param, extra) = span isAlphaNum word - go word (stmt, params, count) - = (word : stmt, params, count) - --- | Runs type-checking on the statement, and returns the inferred type -typeCheckSQL :: Sql.Statement -> Sql.Catalog -> TH.Q TH.Type -typeCheckSQL s cat = case Sql.typeCheckStatements Sql.defaultTypeCheckFlags cat [s] of - (_, [typechecked]) -> case typechecked of - QueryStatement annot _ -> case Sql.anType annot of - Just typ -> do - qtyp <- newName "queryType" - [t| forall x. (HasSqlType typ qtyp) => qtyp |] - -makeStatement :: String -> [String] -> TH.Q TH.Exp -makeStatement stmt' params = [e| Hasql.stmtList (BS.pack $stmt) True |] - where - stmt = TH.liftString stmt' - -sqlQQFor :: forall a f. ToCatalogUpdate a => Proxy (Book' f (a :: [*])) -> TH.QuasiQuoter -sqlQQFor _ = case sqlQQForSchema <$> toCatalog (Proxy :: Proxy a) of - Left e -> error $ "Error constructing catalog: " ++ show e - Right v -> v - -sqlQQForSchema :: Sql.Catalog -> TH.QuasiQuoter -sqlQQForSchema catalog = TH.QuasiQuoter - { TH.quoteExp = \s -> case parseSQL s of - Left err -> error $ show err - Right (_, params) -> makeStatement s params - , TH.quotePat = undefined - , TH.quoteDec = undefined - , TH.quoteType = undefined - } - -getOrCreateDB :: String -> Proxy (a :: *) -> IO DB -getOrCreateDB = undefined - -deleteDB :: DB -> IO () -deleteDB = undefined diff --git a/forum/src/Forum/Internal/ToTable.hs b/forum/src/Forum/Internal/ToTable.hs deleted file mode 100644 index 96a60bf..0000000 --- a/forum/src/Forum/Internal/ToTable.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module Forum.Internal.ToTable where - -import Bookkeeper -import Data.Bifunctor (second) -import Data.Reflection (Reifies(..)) -import Data.Int -import Data.Proxy (Proxy(..)) -import GHC.TypeLits -import qualified Data.Text as T -import qualified Database.HsSqlPpp.Types as Sql -import qualified Database.HsSqlPpp.Catalog as Sql - -import Forum.Internal.Types - --- * SqlValue - - - -class SqlValue (haskellType :: *) where - sqlType :: Proxy haskellType -> Sql.Type - isNullable :: Proxy haskellType -> Bool - isNullable _ = False - -instance SqlValue a => SqlValue (PrimaryKey tbl a) where - sqlType _ = sqlType (Proxy :: Proxy a) - -instance SqlValue a => SqlValue (ForeignKey tbl a) where - sqlType _ = sqlType (Proxy :: Proxy a) - isNullable _ = isNullable (Proxy :: Proxy a) - -instance SqlValue a => SqlValue (Maybe a) where - sqlType _ = sqlType (Proxy :: Proxy a) - isNullable _ = True - -instance SqlValue Bool where sqlType _ = Sql.ScalarType "bool" -instance SqlValue T.Text where sqlType _ = Sql.ScalarType "varchar" -instance SqlValue Int where sqlType _ = Sql.ScalarType "bigint" -{-instance SqlValue String where sqlType _ = Sql.ScalarType "varchar"-} - --- * HasSqlValue - -class (Reifies (SqlType haskellType) Sql.Type) => HasSqlValue (haskellType :: *) where - type SqlType haskellType - type IsNullable haskellType :: Bool - type IsNullable haskellType = 'False - -instance HasSqlValue T.Text where type SqlType T.Text = Scalar "varchar" -instance HasSqlValue String where type SqlType String = Scalar "varchar" -instance HasSqlValue Bool where type SqlType Bool = Scalar "bool" -instance HasSqlValue Int16 where type SqlType Int16 = Scalar "smallint" -instance HasSqlValue Int32 where type SqlType Int32 = Scalar "integer" -instance HasSqlValue Int64 where type SqlType Int64 = Scalar "bigint" -instance HasSqlValue Float where type SqlType Float = Scalar "real" -instance HasSqlValue Double where type SqlType Double = Scalar "double" -instance (HasSqlValue a, IsNullable a ~ 'False) => HasSqlValue (Maybe a) where - type SqlType (Maybe a) = SqlType a - type IsNullable (Maybe a) = 'True - -data Scalar (s :: Symbol) - -instance KnownSymbol s => Reifies (Scalar s) Sql.Type where - reflect _ = Sql.ScalarType (T.pack $ symbolVal (Proxy :: Proxy s)) - - -toSqlType :: forall a. HasSqlValue a => Proxy a -> Sql.Type -toSqlType _ = reflect (Proxy :: Proxy (SqlType a)) - --- * ToTable - -class ToTable (a :: [*]) where - toTable :: Proxy a -> [(T.Text, Sql.Type)] - -instance (HasSqlValue fieldVal, KnownSymbol fieldName) - => ToTable '[ fieldName :=> fieldVal ] where - toTable _ = [(T.pack $ symbolVal (Proxy :: Proxy fieldName) - , toSqlType (Proxy :: Proxy fieldVal))] - -instance (HasSqlValue fieldVal, ToTable (snd ': restOfTable), KnownSymbol fieldName) - => ToTable (fieldName :=> fieldVal ': snd ': restOfTable) where - toTable _ - = ( T.pack $ symbolVal (Proxy :: Proxy fieldName) - , toSqlType (Proxy :: Proxy fieldVal)) - : toTable (Proxy :: Proxy (snd ': restOfTable)) - --- * ToCatalogUpdate - -toCatalog :: ToCatalogUpdate a => Proxy a -> Either [Sql.TypeError] Sql.Catalog -toCatalog p = Sql.updateCatalog (toCatalogUpdate p) undefined - -class ToCatalogUpdate (a :: [*]) where - toCatalogUpdate :: Proxy a -> [Sql.CatalogUpdate] - -instance {-# OVERLAPPING #-} ToCatalogUpdate '[] where - toCatalogUpdate _ = [] - -instance {-# OVERLAPPABLE #-} - (KnownSymbol tableName, ToTable table, ToCatalogUpdate rest) - => ToCatalogUpdate ( tableName :=> Book' f table ': rest) where - toCatalogUpdate _ = Sql.CatCreateTable tableName columns - : toCatalogUpdate (Proxy :: Proxy rest) - where - tableName = ("public", T.pack $ symbolVal (Proxy :: Proxy tableName)) - - columns = second typeToCatNameExtra <$> toTable (Proxy :: Proxy table) - - typeToCatNameExtra :: Sql.Type -> Sql.CatNameExtra - typeToCatNameExtra (Sql.ScalarType t) = Sql.mkCatNameExtra t diff --git a/forum/src/Forum/Internal/Types.hs b/forum/src/Forum/Internal/Types.hs deleted file mode 100644 index 9310706..0000000 --- a/forum/src/Forum/Internal/Types.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -module Forum.Internal.Types where - -import GHC.TypeLits -import GHC.Generics (Generic) -import Hasql.Class (Encodable, Decodable) -import Hasql.Pool (Pool) -import qualified Database.HsSqlPpp.Catalog as Sql - -newtype PrimaryKey (tbl :: Symbol) val = PrimaryKey val - deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) - -newtype ForeignKey (tbl :: Symbol) val = ForeignKey val - deriving (Eq, Show, Read, Generic, Ord, Encodable, Decodable) - -data DB = DB - { dbCatalog :: Sql.Catalog - , dbName :: String - , dbConnectionPool :: Pool - } diff --git a/forum/test/Doctest.hs b/forum/test/Doctest.hs deleted file mode 100644 index 849dbbd..0000000 --- a/forum/test/Doctest.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Main (main) where - --- Runs doctest on all files in "src" dir. Assumes: --- (a) You are using hpack --- (b) The top-level "default-extensions" are the only extensions besides the --- ones in the files. - -import System.FilePath.Glob (glob) -import Test.DocTest (doctest) -import Data.Yaml - -newtype Exts = Exts { getExts :: [String] } - deriving (Eq, Show, Read) - -instance FromJSON Exts where - parseJSON (Object v) = Exts <$> v .: "default-extensions" - parseJSON _ = fail "expecting object" - -main :: IO () -main = do - hpack' <- decodeFile "package.yaml" - hpack <- case hpack' of - Nothing -> return $ Exts [] - Just v -> return v - files <- glob "src/**/*.hs" - doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/forum/test/Forum/Internal/SQLSpec.hs b/forum/test/Forum/Internal/SQLSpec.hs deleted file mode 100644 index d196457..0000000 --- a/forum/test/Forum/Internal/SQLSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Forum.Internal.SQLSpec (spec) where - -import Forum.Internal.SQL -import Test.Hspec - -spec :: Spec -spec = do - parseSQLSpec - -parseSQLSpec :: Spec -parseSQLSpec = describe "parseSQL" $ do - - it "returns all params" $ do - let p = case parseSQL "SELECT * FROM tbl WHERE a = $p1 AND b = $p2;" of - Left e -> error $ show e - Right (_, v) -> v - p `shouldBe` ["p1", "p2"] - diff --git a/forum/test/ForumSpec.hs b/forum/test/ForumSpec.hs deleted file mode 100644 index 60461c4..0000000 --- a/forum/test/ForumSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module ForumSpec (spec) where - -import Forum -import Schema -import qualified Data.Text as T -import Test.Hspec - -spec :: Spec -spec = describe "forum" $ around withEmptyDb $ do - let discoverer = emptyBook & #discovererId =: 1 - & #firstName =: "Carl" - & #lastName =: "Linnaeus" - - it "is pending" $ \db -> pending - - {-it "allows inserting and querying" $ \db -> do-} - {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} - {-result <- runSql [sql| SELECT (firstName) FROM discoverer |]-} - {-result `shouldBe` [subSet discoverer]-} - - {-it "allows WHERE clauses" $ \db -> do-} - {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} - {-result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE lastName = 0 |]-} - {-result `shouldBe` []-} - - {-it "types WHERE on primary keys as Maybe" $ \db -> do-} - {-runSql [sql| INSERT INTO discoverer VALUES $discoverer |]-} - {-result <- runSql [sql| SELECT (firstName) FROM discoverer WHERE discovererId = 0 |]-} - {-result `shouldBe` Nothing-} diff --git a/forum/test/Schema.hs b/forum/test/Schema.hs deleted file mode 100644 index d7e0bc8..0000000 --- a/forum/test/Schema.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Schema where - -import Forum -import qualified Data.Text as T - ------------------------------------------------------------------------------- --- Setup - -withEmptyDb :: (DB -> IO a) -> IO a -withEmptyDb action = do - db <- getOrCreateDB "forum-test" (Proxy :: Proxy Schema) - result <- action db - deleteDB db - return result - -sql :: QuasiQuoter -sql = sqlQQFor (Proxy :: Proxy Schema) - ------------------------------------------------------------------------------- --- Schema and Types - -type Species = Book - '[ "speciesId" :=> PrimaryKey "species" Int - , "name" :=> T.Text - , "genus" :=> ForeignKey "genus" Int - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Genus = Book - '[ "genusId" :=> PrimaryKey "genus" Int - , "name" :=> T.Text - , "genus" :=> ForeignKey "family" Int - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Family = Book - '[ "familyId" :=> PrimaryKey "family" Int - , "name" :=> T.Text - , "discoverer" :=> Maybe (ForeignKey "discoverer" Int) - ] - -type Discoverer = Book - '[ "discovererId" :=> PrimaryKey "family" Int - , "firstName" :=> T.Text - , "lastName" :=> T.Text - ] - -type Schema = Book - '[ "species" :=> Species - {-, "genus" :=> Genus-} - {-, "family" :=> Family-} - {-, "discoverer" :=> Discoverer-} - ] diff --git a/forum/test/Spec.hs b/forum/test/Spec.hs deleted file mode 100644 index a824f8c..0000000 --- a/forum/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From 72f331415306f93045b9da3482a34fb6544df664 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 5 Dec 2016 13:01:23 +0100 Subject: [PATCH 20/27] wip --- bookkeeper/bench/Main.hs | 3 +- bookkeeper/bookkeeper.cabal | 13 +- bookkeeper/package.yaml | 4 +- bookkeeper/src/Bookkeeper.hs | 21 +++ bookkeeper/src/Bookkeeper/Internal.hs | 1 + .../src/Bookkeeper/Internal/Operations.hs | 32 ++++ bookkeeper/src/Bookkeeper/Internal/Types.hs | 141 +++++++++++++----- 7 files changed, 171 insertions(+), 44 deletions(-) diff --git a/bookkeeper/bench/Main.hs b/bookkeeper/bench/Main.hs index 2f4b774..f9d4c4e 100644 --- a/bookkeeper/bench/Main.hs +++ b/bookkeeper/bench/Main.hs @@ -2,9 +2,10 @@ module Main where import Bookkeeper import Criterion.Main +import GHC.Prim type PersonB = Book '[ "name" :=> String, "age" :=> Int ] -data PersonR = PersonR { name :: !String, age :: !Int } deriving (Eq, Show) +data PersonR = PersonR { name :: !String, age :: {-# NOUNPACK #-} !Int } deriving (Eq, Show) pb :: PersonB pb = emptyBook diff --git a/bookkeeper/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal index 7da7f3d..b4be812 100644 --- a/bookkeeper/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.cabal @@ -25,7 +25,7 @@ source-repository head library hs-source-dirs: src - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels StandaloneDeriving MagicHash ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 @@ -44,7 +44,7 @@ executable compileTime main-is: CompileTime.hs hs-source-dirs: exec - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels StandaloneDeriving MagicHash ghc-options: -Wall -Wall build-depends: base >= 4.9 && < 4.10 @@ -70,7 +70,7 @@ test-suite doctest main-is: Doctest.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels StandaloneDeriving MagicHash ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 @@ -89,7 +89,7 @@ test-suite spec main-is: Spec.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels StandaloneDeriving MagicHash ghc-options: -Wall build-depends: base >= 4.9 && < 4.10 @@ -108,12 +108,13 @@ benchmark bench main-is: Main.hs hs-source-dirs: bench - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels MagicHash - ghc-options: -Wall -O2 + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFunctor DeriveGeneric DeriveFoldable DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs MultiParamTypeClasses KindSignatures TypeInType OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators OverloadedLabels StandaloneDeriving MagicHash + ghc-options: -Wall -O3 build-depends: base >= 4.9 && < 4.10 , mtl == 2.2.* , data-default-class , bookkeeper , criterion + , ghc-prim default-language: Haskell2010 diff --git a/bookkeeper/package.yaml b/bookkeeper/package.yaml index 5166251..58ee3c1 100644 --- a/bookkeeper/package.yaml +++ b/bookkeeper/package.yaml @@ -49,6 +49,7 @@ library: - TypeFamilies - TypeOperators - OverloadedLabels + - StandaloneDeriving - MagicHash tests: @@ -77,7 +78,8 @@ benchmarks: dependencies: - bookkeeper - criterion - ghc-options: -O2 + - ghc-prim + ghc-options: -O3 executables: diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index acfba80..43493ea 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -46,6 +46,9 @@ module Bookkeeper , split , getIf + -- ** Split + , getSubset + , Subset -- ** Option , Optionable @@ -57,14 +60,32 @@ module Bookkeeper , (:=>) , Key + -- * Operations + , bmap + , bmapConstraint + , bcollapse + , bcollapseWithKeys + , BKeys(bkeys) + , bsequence + , bproxies + , All + , All2 + , And + , IsEqTo + -- * From Haskell record , fromRecord -- * Re-exports , (&) + , Const(..) + , Identity(..) ) where import Bookkeeper.Internal import Bookkeeper.Internal.Types +import Bookkeeper.Internal.Operations import Data.Function +import Data.Functor.Const +import Data.Functor.Identity diff --git a/bookkeeper/src/Bookkeeper/Internal.hs b/bookkeeper/src/Bookkeeper/Internal.hs index 88297ca..0f88775 100644 --- a/bookkeeper/src/Bookkeeper/Internal.hs +++ b/bookkeeper/src/Bookkeeper/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -ddump-simpl #-} module Bookkeeper.Internal where import Control.Monad.Identity diff --git a/bookkeeper/src/Bookkeeper/Internal/Operations.hs b/bookkeeper/src/Bookkeeper/Internal/Operations.hs index 981021e..4c23b6d 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Operations.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Operations.hs @@ -1,13 +1,40 @@ +{-# LANGUAGE PolyKinds #-} module Bookkeeper.Internal.Operations where import Bookkeeper.Internal.Types +import Data.Proxy (Proxy(Proxy)) +import GHC.TypeLits (symbolVal, KnownSymbol) import Data.Functor.Identity +import Data.Functor.Const -- | Maps a natural transformation over every record. bmap :: (forall x. f x -> g x) -> Book' f entries -> Book' g entries bmap _ BNil = BNil bmap nat (BCons value rest) = BCons (nat value) (bmap nat rest) +-- | Map a class method over every record. +bmapConstraint :: All c entries => Proxy c -> (forall x . c x => f x -> g x) -> Book' f entries -> Book' g entries +bmapConstraint _ _ BNil = BNil +bmapConstraint p nat (BCons value rest) = BCons (nat value) (bmapConstraint p nat rest) + +-- | Collapse a map into a list. +bcollapse :: Book' (Const a) entries -> [a] +bcollapse BNil = [] +bcollapse (BCons (Const h) rest) = h : bcollapse rest + +-- | Collapse a map, including the keys. +bcollapseWithKeys :: forall a entries. BKeys entries => Book' (Const a) entries -> [(String, a)] +bcollapseWithKeys b = zip (bkeys (Proxy :: Proxy entries)) (bcollapse b) + +class BKeys entries where + bkeys :: Proxy entries -> [String] + +instance BKeys '[] where + bkeys _ = [] + +instance (KnownSymbol key, BKeys rest) => BKeys (key :=> val ': rest) where + bkeys _ = symbolVal (Proxy :: Proxy key) : bkeys (Proxy :: Proxy rest) + -- | Analogous to 'Data.Traversable.sequence'. bsequence :: Monad m => Book' m entries -> m (Book' Identity entries) bsequence BNil = return BNil @@ -15,3 +42,8 @@ bsequence (BCons mvalue mrest) = do value <- mvalue rest <- bsequence mrest return $ BCons (return value) rest + +-- Make a book filled with @Proxy@s. +bproxies :: Book' Proxy entries +bproxies = bmap (const Proxy) undefined + diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index d3c6789..6ae99bf 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -1,22 +1,27 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Bookkeeper.Internal.Types where import Control.Monad.Identity -import Data.Bifunctor (first) -import Data.Default.Class (Default(..)) -import Data.Kind (Type) -import Data.Monoid ((<>)) -import Data.List (intercalate) +import Data.Bifunctor (first) +import Data.Default.Class (Default (..)) +import Data.Functor.Const +import Data.Functor.Identity +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Monoid ((<>)) import Data.Proxy -import Data.Type.Equality (type (==)) +import Data.Type.Equality (type (==)) +import GHC.Exts (Constraint) import GHC.Generics import GHC.OverloadedLabels -import GHC.TypeLits (Symbol, TypeError, ErrorMessage(Text), CmpSymbol, KnownSymbol, symbolVal) +import GHC.TypeLits (CmpSymbol, ErrorMessage (Text), KnownSymbol, + Symbol, TypeError, symbolVal) ------------------------------------------------------------------------------ -- :=> @@ -52,18 +57,15 @@ data Book' :: (k -> Type) -> [Type] -> Type where -- ** Eq -instance Eq (Book' f '[]) where - _ == _ = True - -instance (Eq (f val), Eq (Book' f xs)) => Eq (Book' f ((field :=> val) ': xs)) where - BCons value1 rest1 == BCons value2 rest2 - = value1 == value2 && rest1 == rest2 +deriving instance All (Eq `Compose` f) as => Eq (Book' f as) -- ** Monoid -instance Monoid (Book' Identity '[]) where - mempty = emptyBook - _ `mappend` _ = emptyBook +instance All (Monoid `Compose` f) as => Monoid (Book' f as) where + mempty = bmapConstraint (Proxy :: Proxy (Monoid `Compose` f)) go bproxies + where + go :: forall f a. Monoid (f a) => Proxy a -> f a + go _ = mempty -- ** Default @@ -82,25 +84,25 @@ emptyBook = BNil -- ** Show -instance ShowHelper (Book' Identity a) => Show (Book' Identity a) where - show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}" - where - go (k, v) = k <> " = " <> v +{-instance ShowHelper (Book' Identity a) => Show (Book' Identity a) where-} + {-show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}"-} + {-where-} + {-go (k, v) = k <> " = " <> v-} -class ShowHelper a where - showHelper :: a -> [(String, String)] +{-class ShowHelper a where-} + {-showHelper :: a -> [(String, String)]-} -instance ShowHelper (Book' Identity '[]) where - showHelper _ = [] +{-instance ShowHelper (Book' Identity '[]) where-} + {-showHelper _ = []-} -instance ( ShowHelper (Book' Identity xs) - , Show v - , KnownSymbol k - ) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where - showHelper (BCons v rest) = (show k, show v):showHelper rest - where - k :: Key k - k = Key +{-instance ( ShowHelper (Book' Identity xs)-} + {-, Show v-} + {-, KnownSymbol k-} + {-) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where-} + {-showHelper (BCons v rest) = (show k, show v):showHelper rest-} + {-where-} + {-k :: Key k-} + {-k = Key-} -- ** MFunctor @@ -112,6 +114,8 @@ instance MFunctor Book' where -} -- ** Generics +{-instance Generic (Book' f '[ field :=> val ]) where-} + {-type Rep (Book' f '[ field :=> val ]) = S1 -} class FromGeneric a book | a -> book where fromGeneric :: a x -> Book' Identity book @@ -353,3 +357,68 @@ type family Union leftBook rightBook where class Unionable leftBook rightBook where union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) + +------------------------------------------------------------------------------ +-- Constraints +------------------------------------------------------------------------------ + +type family All (ctx :: k -> Constraint) (v :: [k]) :: Constraint where + All ctx '[] = () + All ctx (key :=> value ': rest) = (ctx value, All ctx rest) + +class All2 ctx a +instance All2 ctx '[] +instance (All ctx field, All2 ctx rest) => All2 ctx (key :=> field ': rest) + +class (c1 x, c2 x) => And c1 c2 x + +class (a ~ b) => IsEqTo a b +instance (a ~ b) => IsEqTo a b + +class (f (g x)) => (f `Compose` g) x +instance (f (g x)) => (f `Compose` g) x +infixr 9 `Compose` + +------------------------------------------------------------------------------ +-- Operations +------------------------------------------------------------------------------ + +-- | Maps a natural transformation over every record. +bmap :: (forall x. f x -> g x) -> Book' f entries -> Book' g entries +bmap _ BNil = BNil +bmap nat (BCons value rest) = BCons (nat value) (bmap nat rest) + +-- | Map a class method over every record. +bmapConstraint :: All c entries => Proxy c -> (forall x . c x => f x -> g x) -> Book' f entries -> Book' g entries +bmapConstraint _ _ BNil = BNil +bmapConstraint p nat (BCons value rest) = BCons (nat value) (bmapConstraint p nat rest) + +-- | Collapse a map into a list. +bcollapse :: Book' (Const a) entries -> [a] +bcollapse BNil = [] +bcollapse (BCons (Const h) rest) = h : bcollapse rest + +-- | Collapse a map, including the keys. +bcollapseWithKeys :: forall a entries. BKeys entries => Book' (Const a) entries -> [(String, a)] +bcollapseWithKeys b = zip (bkeys (Proxy :: Proxy entries)) (bcollapse b) + +class BKeys entries where + bkeys :: Proxy entries -> [String] + +instance BKeys '[] where + bkeys _ = [] + +instance (KnownSymbol key, BKeys rest) => BKeys (key :=> val ': rest) where + bkeys _ = symbolVal (Proxy :: Proxy key) : bkeys (Proxy :: Proxy rest) + +-- | Analogous to 'Data.Traversable.sequence'. +bsequence :: Monad m => Book' m entries -> m (Book' Identity entries) +bsequence BNil = return BNil +bsequence (BCons mvalue mrest) = do + value <- mvalue + rest <- bsequence mrest + return $ BCons (return value) rest + +-- Make a book filled with @Proxy@s. +bproxies :: Book' Proxy entries +bproxies = bmap (const Proxy) undefined From 229e5383ed5dc82c43ab25e25ac1d7a064024a41 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 6 Dec 2016 13:14:39 +0100 Subject: [PATCH 21/27] Better instances --- bookkeeper/bookkeeper.cabal | 1 - bookkeeper/src/Bookkeeper.hs | 1 - .../src/Bookkeeper/Internal/Operations.hs | 49 --------------- bookkeeper/src/Bookkeeper/Internal/Types.hs | 60 +++++++++++-------- 4 files changed, 36 insertions(+), 75 deletions(-) delete mode 100644 bookkeeper/src/Bookkeeper/Internal/Operations.hs diff --git a/bookkeeper/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal index b4be812..c9d9e89 100644 --- a/bookkeeper/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.cabal @@ -35,7 +35,6 @@ library Bookkeeper Bookkeeper.Internal Bookkeeper.Internal.Errors - Bookkeeper.Internal.Operations Bookkeeper.Internal.Sort Bookkeeper.Internal.Types default-language: Haskell2010 diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index 43493ea..7392bfd 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -85,7 +85,6 @@ module Bookkeeper import Bookkeeper.Internal import Bookkeeper.Internal.Types -import Bookkeeper.Internal.Operations import Data.Function import Data.Functor.Const import Data.Functor.Identity diff --git a/bookkeeper/src/Bookkeeper/Internal/Operations.hs b/bookkeeper/src/Bookkeeper/Internal/Operations.hs deleted file mode 100644 index 4c23b6d..0000000 --- a/bookkeeper/src/Bookkeeper/Internal/Operations.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module Bookkeeper.Internal.Operations where - -import Bookkeeper.Internal.Types -import Data.Proxy (Proxy(Proxy)) -import GHC.TypeLits (symbolVal, KnownSymbol) -import Data.Functor.Identity -import Data.Functor.Const - --- | Maps a natural transformation over every record. -bmap :: (forall x. f x -> g x) -> Book' f entries -> Book' g entries -bmap _ BNil = BNil -bmap nat (BCons value rest) = BCons (nat value) (bmap nat rest) - --- | Map a class method over every record. -bmapConstraint :: All c entries => Proxy c -> (forall x . c x => f x -> g x) -> Book' f entries -> Book' g entries -bmapConstraint _ _ BNil = BNil -bmapConstraint p nat (BCons value rest) = BCons (nat value) (bmapConstraint p nat rest) - --- | Collapse a map into a list. -bcollapse :: Book' (Const a) entries -> [a] -bcollapse BNil = [] -bcollapse (BCons (Const h) rest) = h : bcollapse rest - --- | Collapse a map, including the keys. -bcollapseWithKeys :: forall a entries. BKeys entries => Book' (Const a) entries -> [(String, a)] -bcollapseWithKeys b = zip (bkeys (Proxy :: Proxy entries)) (bcollapse b) - -class BKeys entries where - bkeys :: Proxy entries -> [String] - -instance BKeys '[] where - bkeys _ = [] - -instance (KnownSymbol key, BKeys rest) => BKeys (key :=> val ': rest) where - bkeys _ = symbolVal (Proxy :: Proxy key) : bkeys (Proxy :: Proxy rest) - --- | Analogous to 'Data.Traversable.sequence'. -bsequence :: Monad m => Book' m entries -> m (Book' Identity entries) -bsequence BNil = return BNil -bsequence (BCons mvalue mrest) = do - value <- mvalue - rest <- bsequence mrest - return $ BCons (return value) rest - --- Make a book filled with @Proxy@s. -bproxies :: Book' Proxy entries -bproxies = bmap (const Proxy) undefined - diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 6ae99bf..95b25cb 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -11,10 +11,9 @@ import Control.Monad.Identity import Data.Bifunctor (first) import Data.Default.Class (Default (..)) import Data.Functor.Const -import Data.Functor.Identity -import Data.Kind (Type) -import Data.List (intercalate) import Data.Monoid ((<>)) +import Data.List (intercalate) +import Data.Kind (Type) import Data.Proxy import Data.Type.Equality (type (==)) import GHC.Exts (Constraint) @@ -61,11 +60,13 @@ deriving instance All (Eq `Compose` f) as => Eq (Book' f as) -- ** Monoid -instance All (Monoid `Compose` f) as => Monoid (Book' f as) where - mempty = bmapConstraint (Proxy :: Proxy (Monoid `Compose` f)) go bproxies - where - go :: forall f a. Monoid (f a) => Proxy a -> f a - go _ = mempty +instance Monoid (Book' f '[]) where + mempty = BNil + _ `mappend` _ = BNil + +instance (Monoid (f a), Monoid (Book' f as)) => Monoid (Book' f (key :=> a ': as)) where + mempty = BCons mempty mempty + BCons a as `mappend` BCons b bs = BCons (a <> b) (as <> bs) -- ** Default @@ -84,25 +85,25 @@ emptyBook = BNil -- ** Show -{-instance ShowHelper (Book' Identity a) => Show (Book' Identity a) where-} - {-show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}"-} - {-where-} - {-go (k, v) = k <> " = " <> v-} +instance ShowHelper (Book' Identity a) => Show (Book' Identity a) where + show x = "Book {" <> intercalate ", " (go <$> showHelper x) <> "}" + where + go (k, v) = k <> " = " <> v -{-class ShowHelper a where-} - {-showHelper :: a -> [(String, String)]-} +class ShowHelper a where + showHelper :: a -> [(String, String)] -{-instance ShowHelper (Book' Identity '[]) where-} - {-showHelper _ = []-} +instance ShowHelper (Book' Identity '[]) where + showHelper _ = [] -{-instance ( ShowHelper (Book' Identity xs)-} - {-, Show v-} - {-, KnownSymbol k-} - {-) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where-} - {-showHelper (BCons v rest) = (show k, show v):showHelper rest-} - {-where-} - {-k :: Key k-} - {-k = Key-} +instance ( ShowHelper (Book' Identity xs) + , Show v + , KnownSymbol k + ) => ShowHelper (Book' Identity ((k :=> v) ': xs)) where + showHelper (BCons v rest) = (show k, show v):showHelper rest + where + k :: Key k + k = Key -- ** MFunctor @@ -422,3 +423,14 @@ bsequence (BCons mvalue mrest) = do -- Make a book filled with @Proxy@s. bproxies :: Book' Proxy entries bproxies = bmap (const Proxy) undefined + +class BZipWith fn f g h xs ys zs where + bzipWith :: fn -> Book' f xs -> Book' g ys -> Book' h zs + +instance BZipWith fn f g h '[] '[] '[] where + bzipWith _ BNil BNil = BNil + +instance (BZipWith (f a -> g b -> h c) f g h rest1 rest2 rest3) => + BZipWith (f a -> g b -> h c) f g h + (field :=> a ': rest1) (field :=> b ': rest2) (field :=> c ': rest3) where + bzipWith f (BCons x r1) (BCons y r2) = BCons (f x y) (bzipWith f r1 r2) From e09db451dd8b3418311f86faf5229301ff056a47 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Dec 2016 13:27:11 +0100 Subject: [PATCH 22/27] wip --- bookkeeper/src/Bookkeeper.hs | 4 +++ bookkeeper/src/Bookkeeper/Internal.hs | 4 +-- bookkeeper/src/Bookkeeper/Internal/Types.hs | 28 +++++++++++++++++---- 3 files changed, 29 insertions(+), 7 deletions(-) diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index 7392bfd..0832ace 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -34,6 +34,10 @@ module Bookkeeper , Unionable , union + -- * Sorting + , Sorted + , sorted + -- * Deleting , delete , Delete diff --git a/bookkeeper/src/Bookkeeper/Internal.hs b/bookkeeper/src/Bookkeeper/Internal.hs index 0f88775..b56195d 100644 --- a/bookkeeper/src/Bookkeeper/Internal.hs +++ b/bookkeeper/src/Bookkeeper/Internal.hs @@ -11,9 +11,9 @@ import Bookkeeper.Internal.Types -- Using a type synonym allows the user to write the fields in any order, and -- yet have the underlying value always have sorted fields. -type Book xs = Book' Identity (Sort xs '[]) +type Book xs = Book' Identity (Sort xs) -type Ledger ledger = Ledger' Identity (Sort ledger '[]) +type Ledger ledger = Ledger' Identity (Sort ledger) ------------------------------------------------------------------------------ -- Setters and getters diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 95b25cb..6c06563 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -115,8 +115,6 @@ instance MFunctor Book' where -} -- ** Generics -{-instance Generic (Book' f '[ field :=> val ]) where-} - {-type Rep (Book' f '[ field :=> val ]) = S1 -} class FromGeneric a book | a -> book where fromGeneric :: a x -> Book' Identity book @@ -206,10 +204,12 @@ instance (Ord (f value), Ord (Ledger' f rest)) -- Internal stuff ------------------------------------------------------------------------------ +type Sort xs = Sort' xs '[] + -- Insertion sort for simplicity. -type family Sort unsorted sorted where - Sort '[] sorted = sorted - Sort (key :=> value ': xs) sorted = Sort xs (Insert key value sorted) +type family Sort' unsorted sorted where + Sort' '[] sorted = sorted + Sort' (key :=> value ': xs) sorted = Sort' xs (Insert key value sorted) type family Insert key value oldMap where Insert key value '[] = '[ key :=> value ] @@ -359,6 +359,24 @@ type family Union leftBook rightBook where class Unionable leftBook rightBook where union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) +------------------------------------------------------------------------------ +-- Sorted +------------------------------------------------------------------------------ + +class Sorted xs where + sorted :: Book' f xs -> Book' f (Sort xs) + +instance Sorted '[] where + sorted _ = BNil + +instance (Sort (field :=> x ': xs) ~ Insert field x (Sort xs), Sorted xs + , Insertable field x (Sort xs) + , head ~ (field :=> x) + ) + => Sorted (head ': xs) where + sorted (BCons x xs) = insert (Key :: Key field) x (sorted xs) + + ------------------------------------------------------------------------------ -- Constraints ------------------------------------------------------------------------------ From 3ccaaf7efabf27bf1d919e63d68de9dccf870fae Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Dec 2016 14:33:15 +0100 Subject: [PATCH 23/27] Union fixes and more tests --- bookkeeper/src/Bookkeeper/Internal/Types.hs | 8 ++++++++ bookkeeper/test/BookkeeperSpec.hs | 15 +++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 6c06563..1f7a872 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -359,6 +359,14 @@ type family Union leftBook rightBook where class Unionable leftBook rightBook where union :: Book' f leftBook -> Book' f rightBook -> Book' f (Union leftBook rightBook) +instance Unionable leftBook '[] where + union leftBook _ = leftBook + +instance ( Insertable key value leftBook + , Unionable (Insert key value leftBook) rest + ) => Unionable leftBook (key :=> value ': rest) where + union leftBook (BCons x xs) = union (insert (Key :: Key key) x leftBook) xs + ------------------------------------------------------------------------------ -- Sorted ------------------------------------------------------------------------------ diff --git a/bookkeeper/test/BookkeeperSpec.hs b/bookkeeper/test/BookkeeperSpec.hs index ba070e2..b175ced 100644 --- a/bookkeeper/test/BookkeeperSpec.hs +++ b/bookkeeper/test/BookkeeperSpec.hs @@ -4,6 +4,7 @@ import Data.Char (toUpper) import Data.Either (isLeft) import Test.Hspec import Test.QuickCheck +import GHC.Generics (Generic) import Bookkeeper @@ -64,8 +65,22 @@ bookSpec = describe "books" $ do it "obeys the 'put . put' law" $ property $ \(x :: Int) (y :: Int) -> do set #label y (set #label x emptyBook) `shouldBe` set #label y emptyBook + context "fromRecord" $ do + + it "converts similarly-shaped types to books" $ do + let pr :: PersonR + pr = PersonR "a" 1 + p :: Person + p = fromRecord pr + + get #name p `shouldBe` "a" + get #age p `shouldBe` 1 + + type Person = Book '[ "name" :=> String , "age" :=> Int] +data PersonR = PersonR { name :: String, age :: Int } + deriving (Eq, Show, Read, Generic) ledgerSpec :: Spec ledgerSpec = describe "ledger" $ do From 15177a609c0193ab281398fc8b0c6fd866ec93cf Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Dec 2016 20:40:52 +0100 Subject: [PATCH 24/27] bookkeeper-aeson --- bookkeeper-aeson/.ghci | 1 + bookkeeper-aeson/.gitignore | 4 ++ bookkeeper-aeson/LICENSE | 30 +++++++++ bookkeeper-aeson/Setup.hs | 2 + bookkeeper-aeson/bookkeeper-aeson.cabal | 74 +++++++++++++++++++++ bookkeeper-aeson/package.yaml | 65 ++++++++++++++++++ bookkeeper-aeson/src/Bookkeeper/Aeson.hs | 48 +++++++++++++ bookkeeper-aeson/test/Doctest.hs | 26 ++++++++ bookkeeper-aeson/test/Spec.hs | 1 + bookkeeper/LICENSE | 30 +++++++++ bookkeeper/bookkeeper.cabal | 2 + bookkeeper/src/Bookkeeper.hs | 3 +- bookkeeper/src/Bookkeeper/Internal/Types.hs | 4 +- 13 files changed, 287 insertions(+), 3 deletions(-) create mode 100644 bookkeeper-aeson/.ghci create mode 100644 bookkeeper-aeson/.gitignore create mode 100644 bookkeeper-aeson/LICENSE create mode 100644 bookkeeper-aeson/Setup.hs create mode 100644 bookkeeper-aeson/bookkeeper-aeson.cabal create mode 100644 bookkeeper-aeson/package.yaml create mode 100644 bookkeeper-aeson/src/Bookkeeper/Aeson.hs create mode 100644 bookkeeper-aeson/test/Doctest.hs create mode 100644 bookkeeper-aeson/test/Spec.hs create mode 100644 bookkeeper/LICENSE diff --git a/bookkeeper-aeson/.ghci b/bookkeeper-aeson/.ghci new file mode 100644 index 0000000..ae927ec --- /dev/null +++ b/bookkeeper-aeson/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/bookkeeper-aeson/.gitignore b/bookkeeper-aeson/.gitignore new file mode 100644 index 0000000..46ca9bd --- /dev/null +++ b/bookkeeper-aeson/.gitignore @@ -0,0 +1,4 @@ +/dist/ +/dist-newstyle/ +/.stack-work/ + diff --git a/bookkeeper-aeson/LICENSE b/bookkeeper-aeson/LICENSE new file mode 100644 index 0000000..ab0c022 --- /dev/null +++ b/bookkeeper-aeson/LICENSE @@ -0,0 +1,30 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni 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. \ No newline at end of file diff --git a/bookkeeper-aeson/Setup.hs b/bookkeeper-aeson/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/bookkeeper-aeson/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bookkeeper-aeson/bookkeeper-aeson.cabal b/bookkeeper-aeson/bookkeeper-aeson.cabal new file mode 100644 index 0000000..2b15d20 --- /dev/null +++ b/bookkeeper-aeson/bookkeeper-aeson.cabal @@ -0,0 +1,74 @@ +-- This file has been generated from package.yaml by hpack version 0.14.1. +-- +-- see: https://github.com/sol/hpack + +name: bookkeeper-aeson +version: 0.1.0.0 +synopsis: Aeson instances for bookkeeper +description: This package provides ToJSON and FromJSON instances for bookkeeper's @Book@ type. +homepage: http://github.com/turingjump/bookkeeper#readme +bug-reports: https://github.com/jkarni/bookkeeper-aeson/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.8.3, GHC == 7.10.2, GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jkarni/bookkeeper-aeson + +library + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , aeson + , bookkeeper + , text + exposed-modules: + Bookkeeper.Aeson + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , aeson + , bookkeeper + , text + , doctest >= 0.9 && < 0.12 + , Glob >= 0.7 && < 0.8 + , yaml == 0.8.* + other-modules: + Spec + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , aeson + , bookkeeper + , text + , bookkeeper-aeson + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + other-modules: + Doctest + default-language: Haskell2010 diff --git a/bookkeeper-aeson/package.yaml b/bookkeeper-aeson/package.yaml new file mode 100644 index 0000000..88e3d02 --- /dev/null +++ b/bookkeeper-aeson/package.yaml @@ -0,0 +1,65 @@ +name: bookkeeper-aeson +version: 0.1.0.0 +synopsis: Aeson instances for bookkeeper +description: > + This package provides ToJSON and FromJSON instances for bookkeeper's + @Book@ type. +homepage: http://github.com/turingjump/bookkeeper#readme +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +github: jkarni/bookkeeper-aeson +tested-with: GHC == 8.0.2 + +ghc-options: -Wall + +dependencies: + - base >= 4.9 && < 4.10 + - aeson + - bookkeeper + - text + +default-extensions: + - AutoDeriveTypeable + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - KindSignatures + - MultiParamTypeClasses + - OverloadedStrings + - OverloadedLabels + - RankNTypes + - ScopedTypeVariables + - TypeFamilies + - TypeOperators + - MagicHash + +library: + source-dirs: src + other-modules: [] + +tests: + spec: + main: Spec.hs + source-dirs: test + dependencies: + - bookkeeper-aeson + - hspec > 2 && < 3 + - QuickCheck >= 2.8 && < 2.9 + doctest: + main: Doctest.hs + source-dirs: test + dependencies: + - doctest >= 0.9 && < 0.12 + - Glob >= 0.7 && < 0.8 + - yaml == 0.8.* diff --git a/bookkeeper-aeson/src/Bookkeeper/Aeson.hs b/bookkeeper-aeson/src/Bookkeeper/Aeson.hs new file mode 100644 index 0000000..e13552a --- /dev/null +++ b/bookkeeper-aeson/src/Bookkeeper/Aeson.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Bookkeeper.Aeson where + +import Bookkeeper +import Bookkeeper.Internal.Types +import Data.Aeson +import Data.Bifunctor +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits + +-- | @ToJSON@ instance for @Book@s. Does the obvious thing: +-- +-- >>> encode julian +-- "{\"age\":28,\"name\":\"Julian K. Arni\"}" +instance (All (ToJSON `Compose` f) a, BKeys a) => ToJSON (Book' f a) where + toJSON b = object $ first T.pack <$> list + where + list = bcollapseWithKeys + $ bmapConstraint (Proxy :: Proxy (ToJSON `Compose` f)) (Const . toJSON) b + +-- | @FromJSON@ instance for @Book@s. Does the obvious thing: +-- +-- >>> decode "{\"age\":28,\"name\":\"Julian K. Arni\"}" :: Maybe Person +-- Just Book {#age = Identity 28, #name = Identity "Julian K. Arni"} +instance {-# OVERLAPPING #-} + (KnownSymbol key, FromJSON (f value)) + => FromJSON (Book' f '[key :=> value]) where + parseJSON (Object v) = go <$> v .: key + where + key = T.pack $ symbolVal (Proxy :: Proxy key) + go x = BCons x BNil + parseJSON _ = fail "expecting object" + +instance {-# OVERLAPPABLE #-} + (KnownSymbol key, FromJSON (f value), FromJSON (Book' f rest)) + => FromJSON (Book' f (key :=> value ': rest)) where + parseJSON o@(Object v) = go $ v .: key + where + key = T.pack $ symbolVal (Proxy :: Proxy key) + go x = BCons <$> x <*> parseJSON o + parseJSON _ = fail "expecting object" + +-- $setup +-- >>> import Data.Function ((&)) +-- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ] +-- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni" diff --git a/bookkeeper-aeson/test/Doctest.hs b/bookkeeper-aeson/test/Doctest.hs new file mode 100644 index 0000000..849dbbd --- /dev/null +++ b/bookkeeper-aeson/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/bookkeeper-aeson/test/Spec.hs b/bookkeeper-aeson/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/bookkeeper-aeson/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/bookkeeper/LICENSE b/bookkeeper/LICENSE new file mode 100644 index 0000000..ab0c022 --- /dev/null +++ b/bookkeeper/LICENSE @@ -0,0 +1,30 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni 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. \ No newline at end of file diff --git a/bookkeeper/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal index c9d9e89..94ec419 100644 --- a/bookkeeper/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.cabal @@ -50,6 +50,7 @@ executable compileTime , mtl == 2.2.* , data-default-class , base >=4.9 && < 4.10 , bookkeeper + buildable: False default-language: Haskell2010 executable readme @@ -62,6 +63,7 @@ executable readme , mtl == 2.2.* , data-default-class , base >=4.9 && < 4.10 , bookkeeper , markdown-unlit + buildable: False default-language: Haskell2010 test-suite doctest diff --git a/bookkeeper/src/Bookkeeper.hs b/bookkeeper/src/Bookkeeper.hs index 0832ace..138d987 100644 --- a/bookkeeper/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -62,7 +62,7 @@ module Bookkeeper , Book , Book' , (:=>) - , Key + , Key(Key) -- * Operations , bmap @@ -76,6 +76,7 @@ module Bookkeeper , All2 , And , IsEqTo + , Compose -- * From Haskell record , fromRecord diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 1f7a872..6bf4f94 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -185,11 +185,11 @@ instance key = Key show (There x) = show x -instance Ord (f value) => Ord (Ledger' f '[ key :=> value]) where +instance {-# OVERLAPPING #-} Ord (f value) => Ord (Ledger' f '[ key :=> value]) where Here x <= Here y = x <= y _ <= _ = error "impossible" -instance (Ord (f value), Ord (Ledger' f rest)) +instance {-# OVERLAPPABLE #-} (Ord (f value), Ord (Ledger' f rest)) => Ord (Ledger' f (key :=> value ': rest)) where Here x <= Here y = x <= y Here _ <= There _ = True From 083af9f35b8034373fd29879e76cfcaec3d352f8 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Dec 2016 20:41:03 +0100 Subject: [PATCH 25/27] Stack file with ghc 8.0.2 --- stack.yaml | 97 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 92 insertions(+), 5 deletions(-) diff --git a/stack.yaml b/stack.yaml index 0cb52b6..99c9a12 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,93 @@ -resolver: nightly-2016-05-27 +flags: + time-locale-compat: + old-locale: false packages: -- '.' -- '../Haskell-MMorph-Library' -extra-deps: [] -flags: {} +- ./bookkeeper +- ./bookkeeper-aeson +setup-info: + ghc: + windows64: + 8.0.1.20161117: + url: https://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-unknown-mingw32.tar.xz + content-length: 155652048 + linux64: + 8.0.1.20161117: + url: http://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-deb8-linux.tar.xz + sha1: 6a6e4c9c53c71cc84b6966a9f61948542fd2f15a + content-length: 112047972 + macosx: + 8.0.1.20161117: + url: https://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-apple-darwin.tar.xz + sha1: 53ed03d986a49ea680c291540ce44ce469514d7c + content-length: 113379688 +extra-deps: +- Glob-0.7.13 +- HUnit-1.5.0.0 +- QuickCheck-2.8.2 +- abstract-deque-0.3 +- abstract-par-0.3.3 +- aeson-1.0.2.1 +- ansi-terminal-0.6.2.3 +- ansi-wl-pprint-0.6.7.3 +- async-2.1.1 +- attoparsec-0.13.1.0 +- base-compat-0.9.1 +- blaze-builder-0.4.0.2 +- call-stack-0.1.0 +- cassava-0.4.5.1 +- cereal-0.5.4.0 +- code-page-0.1.1 +- conduit-1.2.8 +- criterion-1.1.4.0 +- data-default-class-0.1.2.0 +- dlist-0.8.0.2 +- doctest-0.11.0 +- enclosed-exceptions-1.0.2 +- erf-2.0.0.0 +- exceptions-0.8.3 +- ghc-paths-0.1.0.9 +- hashable-1.2.4.0 +- hastache-0.6.1 +- hspec-2.3.2 +- hspec-core-2.3.2 +- hspec-discover-2.3.2 +- hspec-expectations-0.8.2 +- ieee754-0.7.9 +- js-flot-0.8.3 +- js-jquery-3.1.1 +- lifted-base-0.2.3.8 +- markdown-unlit-0.4.0 +- math-functions-0.2.1.0 +- mmorph-1.0.9 +- monad-control-1.0.1.0 +- monad-par-0.3.4.8 +- monad-par-extras-0.3.3 +- mtl-2.2.1 +- mwc-random-0.13.5.0 +- optparse-applicative-0.13.0.0 +- parallel-3.2.1.0 +- parsec-3.1.11 +- primitive-0.6.1.0 +- quickcheck-io-0.1.4 +- random-1.1 +- resourcet-1.1.8.1 +- scientific-0.3.4.9 +- semigroups-0.18.2 +- setenv-0.1.1.3 +- statistics-0.13.3.0 +- stm-2.4.4.1 +- syb-0.6 +- tagged-0.8.5 +- text-1.2.2.1 +- tf-random-0.5 +- time-locale-compat-0.1.1.3 +- transformers-base-0.4.4 +- transformers-compat-0.5.1.4 +- unordered-containers-0.2.7.1 +- vector-0.11.0.0 +- vector-algorithms-0.7.0.1 +- vector-binary-instances-0.2.3.3 +- vector-th-unbox-0.2.1.6 +- yaml-0.8.21.1 +compiler-check: match-exact +resolver: ghc-8.0.1.20161117 From a761c53bd5103b968041b0815002542c6e36e0cd Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 2 Mar 2017 13:14:00 -0600 Subject: [PATCH 26/27] doctest fixes --- bookkeeper-aeson/bookkeeper-aeson.cabal | 18 ++--- bookkeeper-aeson/package.yaml | 2 +- bookkeeper/bookkeeper.cabal | 7 +- bookkeeper/package.yaml | 2 +- bookkeeper/src/Bookkeeper/Internal.hs | 16 ++-- bookkeeper/src/Bookkeeper/Internal/Sort.hs | 2 - bookkeeper/src/Bookkeeper/Internal/Types.hs | 8 +- stack.yaml | 90 +-------------------- 8 files changed, 25 insertions(+), 120 deletions(-) delete mode 100644 bookkeeper/src/Bookkeeper/Internal/Sort.hs diff --git a/bookkeeper-aeson/bookkeeper-aeson.cabal b/bookkeeper-aeson/bookkeeper-aeson.cabal index 2b15d20..ed407b8 100644 --- a/bookkeeper-aeson/bookkeeper-aeson.cabal +++ b/bookkeeper-aeson/bookkeeper-aeson.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. +-- This file has been generated from package.yaml by hpack version 0.15.0. -- -- see: https://github.com/sol/hpack @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com copyright: (c) Julian K. Arni license: BSD3 license-file: LICENSE -tested-with: GHC == 7.8.3, GHC == 7.10.2, GHC == 8.0.1 +tested-with: GHC == 8.0.2 build-type: Simple cabal-version: >= 1.10 @@ -24,10 +24,10 @@ source-repository head library hs-source-dirs: src - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 + base >= 4.9 && < 4.10 , aeson , bookkeeper , text @@ -40,10 +40,10 @@ test-suite doctest main-is: Doctest.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 + base >= 4.9 && < 4.10 , aeson , bookkeeper , text @@ -59,16 +59,16 @@ test-suite spec main-is: Spec.hs hs-source-dirs: test - default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash ghc-options: -Wall build-depends: - base >= 4.7 && < 4.10 + base >= 4.9 && < 4.10 , aeson , bookkeeper , text , bookkeeper-aeson , hspec > 2 && < 3 - , QuickCheck >= 2.8 && < 2.9 + , QuickCheck >= 2.8 && < 2.10 other-modules: Doctest default-language: Haskell2010 diff --git a/bookkeeper-aeson/package.yaml b/bookkeeper-aeson/package.yaml index 88e3d02..03c9277 100644 --- a/bookkeeper-aeson/package.yaml +++ b/bookkeeper-aeson/package.yaml @@ -55,7 +55,7 @@ tests: dependencies: - bookkeeper-aeson - hspec > 2 && < 3 - - QuickCheck >= 2.8 && < 2.9 + - QuickCheck >= 2.8 && < 2.10 doctest: main: Doctest.hs source-dirs: test diff --git a/bookkeeper/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal index 94ec419..abb26bc 100644 --- a/bookkeeper/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. +-- This file has been generated from package.yaml by hpack version 0.15.0. -- -- see: https://github.com/sol/hpack @@ -35,7 +35,6 @@ library Bookkeeper Bookkeeper.Internal Bookkeeper.Internal.Errors - Bookkeeper.Internal.Sort Bookkeeper.Internal.Types default-language: Haskell2010 @@ -50,7 +49,6 @@ executable compileTime , mtl == 2.2.* , data-default-class , base >=4.9 && < 4.10 , bookkeeper - buildable: False default-language: Haskell2010 executable readme @@ -63,7 +61,6 @@ executable readme , mtl == 2.2.* , data-default-class , base >=4.9 && < 4.10 , bookkeeper , markdown-unlit - buildable: False default-language: Haskell2010 test-suite doctest @@ -98,7 +95,7 @@ test-suite spec , data-default-class , bookkeeper , hspec > 2 && < 3 - , QuickCheck >= 2.8 && < 2.9 + , QuickCheck >= 2.8 && < 2.10 other-modules: BookkeeperSpec Doctest diff --git a/bookkeeper/package.yaml b/bookkeeper/package.yaml index 58ee3c1..39b6e5d 100644 --- a/bookkeeper/package.yaml +++ b/bookkeeper/package.yaml @@ -60,7 +60,7 @@ tests: dependencies: - bookkeeper - hspec > 2 && < 3 - - QuickCheck >= 2.8 && < 2.9 + - QuickCheck >= 2.8 && < 2.10 doctest: main: Doctest.hs source-dirs: test diff --git a/bookkeeper/src/Bookkeeper/Internal.hs b/bookkeeper/src/Bookkeeper/Internal.hs index b56195d..3ce2ae6 100644 --- a/bookkeeper/src/Bookkeeper/Internal.hs +++ b/bookkeeper/src/Bookkeeper/Internal.hs @@ -34,8 +34,6 @@ type Gettable field book val = (Subset book '[ field :=> val ]) -- >>> get #moneyFrom julian -- ... -- ... • The provided Book does not contain the field "moneyFrom" --- ... Book type: --- ... '["age" ':-> Int, "name" ':-> String] -- ... • In the expression: get #moneyFrom julian -- ... get :: forall field book val. (Gettable field book val) @@ -63,7 +61,7 @@ type Settable field value oldBook = Insertable field value oldBook -- | Sets or updates a field to a value. -- -- >>> set #likesDoctest True julian --- Book {age = 28, likesDoctest = True, name = "Julian K. Arni"} +-- Book {#age = Identity 28, #likesDoctest = Identity True, #name = Identity "Julian K. Arni"} set :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) set key value = insert key (Identity value) {-# INLINE set #-} @@ -71,7 +69,7 @@ set key value = insert key (Identity value) -- | Infix version of 'set' -- -- >>> julian & #age =: 29 --- Book {age = 29, name = "Julian K. Arni"} +-- Book {#age = Identity 29, #name = Identity "Julian K. Arni"} (=:) :: ( Insertable key value old ) => Key key -> value -> Book' Identity old -> Book' Identity (Insert key value old) (=:) = set infix 3 =: @@ -90,14 +88,12 @@ type Modifiable field originalValue newValue originalBook = -- | Apply a function to a field. -- -- >>> julian & modify #name (fmap toUpper) --- Book {age = 28, name = "JULIAN K. ARNI"} +-- Book {#age = Identity 28, #name = Identity "JULIAN K. ARNI"} -- -- If the key does not exist, throws a type error -- >>> modify #height (\_ -> 132) julian -- ... -- ... • The provided Book does not contain the field "height" --- ... Book type: --- ... '["age" ':-> Int, "name" ':-> String] -- ... • In the expression: modify #height (\ _ -> 132) julian -- ... modify :: (Modifiable key originalValue newValue originalBook) @@ -110,7 +106,7 @@ modify p f b = set p v b -- | Infix version of 'modify'. -- -- >>> julian & #name %: fmap toUpper --- Book {age = 28, name = "JULIAN K. ARNI"} +-- Book {#age = Identity 28, #name = Identity "JULIAN K. ARNI"} (%:) :: (Modifiable key originalValue newValue originalBook) => Key key -> (originalValue -> newValue) -> Book' Identity originalBook -> Book' Identity (Insert key newValue originalBook) @@ -126,8 +122,6 @@ type Deletable key oldBook = Subset oldBook (Delete key oldBook) -- >>> get #name $ delete #name julian -- ... -- ... • The provided Book does not contain the field "name" --- ... Book type: --- ... '["age" ':-> Int] -- ... • In the expression: get #name -- ... delete :: forall key oldBook f . @@ -141,7 +135,7 @@ delete _ bk = getSubset bk -- -- >>> data Test = Test { field1 :: String, field2 :: Int, field3 :: Char } deriving Generic -- >>> fromRecord (Test "hello" 0 'c') --- Book {field1 = "hello", field2 = 0, field3 = 'c'} +-- Book {#field1 = Identity "hello", #field2 = Identity 0, #field3 = Identity 'c'} -- -- Trying to convert a datatype which is not a record will result in a type -- error: diff --git a/bookkeeper/src/Bookkeeper/Internal/Sort.hs b/bookkeeper/src/Bookkeeper/Internal/Sort.hs deleted file mode 100644 index 22a2400..0000000 --- a/bookkeeper/src/Bookkeeper/Internal/Sort.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Bookkeeper.Internal.Sort where - diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index 6bf4f94..ba29b35 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -19,8 +19,9 @@ import Data.Type.Equality (type (==)) import GHC.Exts (Constraint) import GHC.Generics import GHC.OverloadedLabels -import GHC.TypeLits (CmpSymbol, ErrorMessage (Text), KnownSymbol, - Symbol, TypeError, symbolVal) +import GHC.TypeLits (CmpSymbol, ErrorMessage (Text, (:<>:), + ShowType), KnownSymbol, Symbol, TypeError, + symbolVal) ------------------------------------------------------------------------------ -- :=> @@ -240,6 +241,9 @@ instance {-# OVERLAPPING #-} (Subset tail1 tail2, value ~ value') instance {-# OVERLAPPABLE #-} (Subset tail subset) => Subset (head ': tail) subset where getSubset (BCons _value oldBook) = getSubset oldBook {-# INLINE getSubset #-} +instance TypeError (Text "The provided Book does not contain the field " :<>: ShowType key) + => Subset '[] (key :=> val ': xs) where + getSubset = error "unreachable" ------------------------------------------------------------------------------ diff --git a/stack.yaml b/stack.yaml index 99c9a12..3ae8844 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,93 +1,5 @@ -flags: - time-locale-compat: - old-locale: false packages: - ./bookkeeper - ./bookkeeper-aeson -setup-info: - ghc: - windows64: - 8.0.1.20161117: - url: https://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-unknown-mingw32.tar.xz - content-length: 155652048 - linux64: - 8.0.1.20161117: - url: http://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-deb8-linux.tar.xz - sha1: 6a6e4c9c53c71cc84b6966a9f61948542fd2f15a - content-length: 112047972 - macosx: - 8.0.1.20161117: - url: https://downloads.haskell.org/~ghc/8.0.2-rc1/ghc-8.0.1.20161117-x86_64-apple-darwin.tar.xz - sha1: 53ed03d986a49ea680c291540ce44ce469514d7c - content-length: 113379688 extra-deps: -- Glob-0.7.13 -- HUnit-1.5.0.0 -- QuickCheck-2.8.2 -- abstract-deque-0.3 -- abstract-par-0.3.3 -- aeson-1.0.2.1 -- ansi-terminal-0.6.2.3 -- ansi-wl-pprint-0.6.7.3 -- async-2.1.1 -- attoparsec-0.13.1.0 -- base-compat-0.9.1 -- blaze-builder-0.4.0.2 -- call-stack-0.1.0 -- cassava-0.4.5.1 -- cereal-0.5.4.0 -- code-page-0.1.1 -- conduit-1.2.8 -- criterion-1.1.4.0 -- data-default-class-0.1.2.0 -- dlist-0.8.0.2 -- doctest-0.11.0 -- enclosed-exceptions-1.0.2 -- erf-2.0.0.0 -- exceptions-0.8.3 -- ghc-paths-0.1.0.9 -- hashable-1.2.4.0 -- hastache-0.6.1 -- hspec-2.3.2 -- hspec-core-2.3.2 -- hspec-discover-2.3.2 -- hspec-expectations-0.8.2 -- ieee754-0.7.9 -- js-flot-0.8.3 -- js-jquery-3.1.1 -- lifted-base-0.2.3.8 -- markdown-unlit-0.4.0 -- math-functions-0.2.1.0 -- mmorph-1.0.9 -- monad-control-1.0.1.0 -- monad-par-0.3.4.8 -- monad-par-extras-0.3.3 -- mtl-2.2.1 -- mwc-random-0.13.5.0 -- optparse-applicative-0.13.0.0 -- parallel-3.2.1.0 -- parsec-3.1.11 -- primitive-0.6.1.0 -- quickcheck-io-0.1.4 -- random-1.1 -- resourcet-1.1.8.1 -- scientific-0.3.4.9 -- semigroups-0.18.2 -- setenv-0.1.1.3 -- statistics-0.13.3.0 -- stm-2.4.4.1 -- syb-0.6 -- tagged-0.8.5 -- text-1.2.2.1 -- tf-random-0.5 -- time-locale-compat-0.1.1.3 -- transformers-base-0.4.4 -- transformers-compat-0.5.1.4 -- unordered-containers-0.2.7.1 -- vector-0.11.0.0 -- vector-algorithms-0.7.0.1 -- vector-binary-instances-0.2.3.3 -- vector-th-unbox-0.2.1.6 -- yaml-0.8.21.1 -compiler-check: match-exact -resolver: ghc-8.0.1.20161117 +resolver: lts-8.3 From 86d8b5e7b866bfde949b24dbe6ae756188babdc8 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 2 Mar 2017 13:23:03 -0600 Subject: [PATCH 27/27] update travis.yml --- .travis.yml | 85 +++++---------------- bookkeeper/src/Bookkeeper/Internal/Types.hs | 2 +- 2 files changed, 18 insertions(+), 69 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8759c31..8b1e185 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,76 +1,25 @@ -# This file has been generated -- see https://github.com/hvr/multi-ghc-travis -language: c sudo: false -cache: - directories: - - $HOME/.cabsnap - - $HOME/.cabal/packages - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar +env: + - STACK_YAML=stack.yaml -matrix: - include: - - env: CABALVER=1.24 GHCVER=8.0.1 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} - -before_install: - - unset CC - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH +addons: + apt: + packages: libgmp-dev install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > - $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - -# check whether current requested install-plan matches cached package-db snapshot - - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install --only-dependencies --enable-tests --enable-benchmarks; - fi + # stack + - mkdir -p ~/.local/bin + - export PATH=~/.local/bin:$PATH + - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + - stack --version -# snapshot package-db on cache miss - - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. script: - - if [ -f configure.ac ]; then autoreconf -i; fi - - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test - - cabal check - - cabal sdist # tests that a source-distribution can be generated - -# Check that the resulting source distribution can be built & installed. -# If there are no other `.tar.gz` files in `dist`, this can be even simpler: -# `cabal install --force-reinstalls dist/*-*.tar.gz` - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + - stack setup --no-terminal + - stack build --ghc-options=-Werror --no-terminal + - stack test --ghc-options=-Werror --no-terminal --coverage + - stack haddock --no-terminal -# EOF +cache: + directories: + - $HOME/.stack diff --git a/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs index ba29b35..6f67773 100644 --- a/bookkeeper/src/Bookkeeper/Internal/Types.hs +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -241,7 +241,7 @@ instance {-# OVERLAPPING #-} (Subset tail1 tail2, value ~ value') instance {-# OVERLAPPABLE #-} (Subset tail subset) => Subset (head ': tail) subset where getSubset (BCons _value oldBook) = getSubset oldBook {-# INLINE getSubset #-} -instance TypeError (Text "The provided Book does not contain the field " :<>: ShowType key) +instance TypeError ('Text "The provided Book does not contain the field " ':<>: 'ShowType key) => Subset '[] (key :=> val ': xs) where getSubset = error "unreachable"