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-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/Setup.hs b/bookkeeper-aeson/Setup.hs similarity index 100% rename from Setup.hs rename to bookkeeper-aeson/Setup.hs diff --git a/bookkeeper-aeson/bookkeeper-aeson.cabal b/bookkeeper-aeson/bookkeeper-aeson.cabal new file mode 100644 index 0000000..ed407b8 --- /dev/null +++ b/bookkeeper-aeson/bookkeeper-aeson.cabal @@ -0,0 +1,74 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- 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 == 8.0.2 +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 OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash + ghc-options: -Wall + build-depends: + base >= 4.9 && < 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 OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash + ghc-options: -Wall + build-depends: + base >= 4.9 && < 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 OverloadedLabels RankNTypes ScopedTypeVariables TypeFamilies TypeOperators MagicHash + ghc-options: -Wall + build-depends: + base >= 4.9 && < 4.10 + , aeson + , bookkeeper + , text + , bookkeeper-aeson + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.10 + other-modules: + Doctest + default-language: Haskell2010 diff --git a/bookkeeper-aeson/package.yaml b/bookkeeper-aeson/package.yaml new file mode 100644 index 0000000..03c9277 --- /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.10 + 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/test/Spec.hs b/bookkeeper-aeson/test/Spec.hs similarity index 100% rename from test/Spec.hs rename to bookkeeper-aeson/test/Spec.hs 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/Setup.hs b/bookkeeper/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/bookkeeper/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bookkeeper/bench/Main.hs similarity index 87% rename from bench/Main.hs rename to bookkeeper/bench/Main.hs index d4e03d7..f9d4c4e 100644 --- a/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 :: {-# NOUNPACK #-} Int } deriving (Eq, Show) +data PersonR = PersonR { name :: !String, age :: {-# NOUNPACK #-} !Int } deriving (Eq, Show) pb :: PersonB pb = emptyBook diff --git a/bookkeeper.cabal b/bookkeeper/bookkeeper.cabal similarity index 73% rename from bookkeeper.cabal rename to bookkeeper/bookkeeper.cabal index b989d32..abb26bc 100644 --- a/bookkeeper.cabal +++ b/bookkeeper/bookkeeper.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.15.0. -- -- 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 @@ -29,16 +25,30 @@ 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 - , type-level-sets + , mtl == 2.2.* , data-default-class exposed-modules: Bookkeeper Bookkeeper.Internal Bookkeeper.Internal.Errors + 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 StandaloneDeriving 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 @@ -48,7 +58,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 @@ -58,11 +68,11 @@ 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 - , type-level-sets + , mtl == 2.2.* , data-default-class , doctest >= 0.9 && < 0.12 , Glob >= 0.7 && < 0.8 @@ -77,15 +87,15 @@ 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 - , type-level-sets + , mtl == 2.2.* , data-default-class , bookkeeper , hspec > 2 && < 3 - , QuickCheck >= 2.8 && < 2.9 + , QuickCheck >= 2.8 && < 2.10 other-modules: BookkeeperSpec Doctest @@ -96,12 +106,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 - , type-level-sets + , mtl == 2.2.* , data-default-class , bookkeeper , criterion + , ghc-prim default-language: Haskell2010 diff --git a/bookkeeper/exec/CompileTime.hs b/bookkeeper/exec/CompileTime.hs new file mode 100644 index 0000000..e227fe0 --- /dev/null +++ b/bookkeeper/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/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 83% rename from package.yaml rename to bookkeeper/package.yaml index 7edbe68..39b6e5d 100644 --- a/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 @@ -19,7 +19,7 @@ ghc-options: -Wall dependencies: - base >= 4.9 && < 4.10 - - type-level-sets + - mtl == 2.2.* - data-default-class @@ -49,6 +49,7 @@ library: - TypeFamilies - TypeOperators - OverloadedLabels + - StandaloneDeriving - MagicHash tests: @@ -59,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 @@ -77,7 +78,8 @@ benchmarks: dependencies: - bookkeeper - criterion - ghc-options: -O2 + - ghc-prim + ghc-options: -O3 executables: @@ -90,3 +92,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/bookkeeper/src/Bookkeeper.hs similarity index 60% rename from src/Bookkeeper.hs rename to bookkeeper/src/Bookkeeper.hs index 7476583..138d987 100644 --- a/src/Bookkeeper.hs +++ b/bookkeeper/src/Bookkeeper.hs @@ -30,21 +30,66 @@ module Bookkeeper , modify , (%:) + -- * Union + , Unionable + , union + + -- * Sorting + , Sorted + , sorted + -- * Deleting , delete + , Delete + + -- * Ledger + , Ledger + + -- ** Split + , Split + , split + , getIf + + -- ** Split + , getSubset + , Subset + + -- ** Option + , Optionable + , option -- * Types , Book + , Book' , (:=>) - , Key + , Key(Key) + + -- * Operations + , bmap + , bmapConstraint + , bcollapse + , bcollapseWithKeys + , BKeys(bkeys) + , bsequence + , bproxies + , All + , All2 + , And + , IsEqTo + , Compose -- * From Haskell record , fromRecord -- * Re-exports , (&) + , Const(..) + , Identity(..) ) where import Bookkeeper.Internal +import Bookkeeper.Internal.Types 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 new file mode 100644 index 0000000..3ce2ae6 --- /dev/null +++ b/bookkeeper/src/Bookkeeper/Internal.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -ddump-simpl #-} +module Bookkeeper.Internal where + +import Control.Monad.Identity +import GHC.Generics +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 Ledger ledger = Ledger' Identity (Sort ledger) + +------------------------------------------------------------------------------ +-- Setters and getters +------------------------------------------------------------------------------ + +-- * Getters + +-- | @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 = (Subset book '[ field :=> val ]) + +-- | Get a value by key, if it exists. +-- +-- >>> get #age julian +-- 28 +-- +-- If the key does not exist, throws a type error +-- >>> get #moneyFrom julian +-- ... +-- ... • The provided Book does not contain the field "moneyFrom" +-- ... • In the expression: get #moneyFrom julian +-- ... +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 +{-# INLINE get #-} + +-- | Flipped and infix version of 'get'. +-- +-- >>> julian ?: #name +-- "Julian K. Arni" +(?:) :: forall field book val. (Gettable field book val) + => Book' Identity book -> Key field -> val +(?:) = flip get +infixl 3 ?: +{-# INLINE (?:) #-} + +-- * Setters + +-- | '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. +-- +-- >>> set #likesDoctest True julian +-- 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 #-} + +-- | Infix version of 'set' +-- +-- >>> julian & #age =: 29 +-- 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 =: +{-# INLINE (=:) #-} + +-- * Modifiers + +-- | @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 originalValue newValue originalBook = + ( Gettable field originalBook originalValue + , Insertable field newValue originalBook + ) + +-- | Apply a function to a field. +-- +-- >>> julian & modify #name (fmap toUpper) +-- 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" +-- ... • In the expression: modify #height (\ _ -> 132) julian +-- ... +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 +{-# INLINE modify #-} + +-- | Infix version of 'modify'. +-- +-- >>> julian & #name %: fmap toUpper +-- 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) +(%:) = modify +infixr 3 %: +{-# INLINE (%:) #-} + + +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. +-- +-- >>> get #name $ delete #name julian +-- ... +-- ... • The provided Book does not contain the field "name" +-- ... • In the expression: get #name +-- ... +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. +-- +-- >>> data Test = Test { field1 :: String, field2 :: Int, field3 :: Char } deriving Generic +-- >>> fromRecord (Test "hello" 0 '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: +-- +-- >>> data SomeSumType = LeftSide | RightSide deriving Generic +-- >>> fromRecord LeftSide +-- ... +-- ... • Cannot convert sum types into Books +-- ... +-- +-- >>> data Unit = Unit deriving Generic +-- >>> fromRecord Unit +-- ... +-- ... • Cannot convert non-record types into Books +-- ... +fromRecord :: (Generic a, FromGeneric (Rep a) bookRep) => a -> Book' Identity bookRep +fromRecord = fromGeneric . from + +-- $setup +-- >>> import Data.Function ((&)) +-- >>> import Data.Char (toUpper) +-- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ] +-- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni" diff --git a/src/Bookkeeper/Internal/Errors.hs b/bookkeeper/src/Bookkeeper/Internal/Errors.hs similarity index 88% rename from src/Bookkeeper/Internal/Errors.hs rename to bookkeeper/src/Bookkeeper/Internal/Errors.hs index e0f2a90..5fc6550 100644 --- a/src/Bookkeeper/Internal/Errors.hs +++ b/bookkeeper/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 @@ -16,5 +15,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/bookkeeper/src/Bookkeeper/Internal/Types.hs b/bookkeeper/src/Bookkeeper/Internal/Types.hs new file mode 100644 index 0000000..6f67773 --- /dev/null +++ b/bookkeeper/src/Bookkeeper/Internal/Types.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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.Functor.Const +import Data.Monoid ((<>)) +import Data.List (intercalate) +import Data.Kind (Type) +import Data.Proxy +import Data.Type.Equality (type (==)) +import GHC.Exts (Constraint) +import GHC.Generics +import GHC.OverloadedLabels +import GHC.TypeLits (CmpSymbol, ErrorMessage (Text, (:<>:), + ShowType), KnownSymbol, Symbol, TypeError, + symbolVal) + +------------------------------------------------------------------------------ +-- :=> +------------------------------------------------------------------------------ + +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, Read, Generic) + +instance KnownSymbol key => Show (Key key) where + show _ = '#':(symbolVal (Proxy :: Proxy key)) + +instance (s ~ s') => IsLabel s (Key s') where + fromLabel _ = Key + {-# INLINE fromLabel #-} + +------------------------------------------------------------------------------ +-- Book +------------------------------------------------------------------------------ + +data Book' :: (k -> Type) -> [Type] -> Type where + BNil :: Book' f '[] + BCons :: !(f a) -> !(Book' f as) -> Book' f (k :=> a ': as) + +-- * Instances + +-- ** Eq + +deriving instance All (Eq `Compose` f) as => Eq (Book' f as) + +-- ** Monoid + +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 + +instance Default (Book' Identity '[]) where + def = emptyBook + +instance ( Default (Book' f xs) + , Default (f v) + ) => Default (Book' f ((k :=> v) ': xs)) where + def = BCons def def + +-- | A book with no records. You'll usually want to use this to construct +-- books. +emptyBook :: Book' Identity '[] +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 + +class ShowHelper a where + showHelper :: a -> [(String, String)] + +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 + +-- ** 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 + +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 ~ '[name :=> t]) + => FromGeneric (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) v where + fromGeneric (M1 (K1 t)) = BCons (Identity t) emptyBook + +instance + ( FromGeneric l leftBook + , FromGeneric r rightBook + , unionBook ~ (Union leftBook rightBook) + , Unionable leftBook rightBook + ) => FromGeneric (l :*: r) unionBook where + fromGeneric (l :*: r) + = union (fromGeneric l) (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" + +------------------------------------------------------------------------------ +-- 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 + +instance + (KnownSymbol key, Show (f value)) + => Show (Ledger' f '[key :=> value]) where + show (Here x) = "option' " ++ show key ++ " (" ++ show x ++ ")" + where + key :: Key key + key = Key + -- This isn't really impossible, since sum-errors catches errors down to + -- this. + show (There _) = error "impossible" + +instance + (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 {-# OVERLAPPING #-} Ord (f value) => Ord (Ledger' f '[ key :=> value]) where + Here x <= Here y = x <= y + _ <= _ = error "impossible" + +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 + 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 +------------------------------------------------------------------------------ + +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 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) + (focusKey :=> someValue ': Insert key value 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 value oldBook) = BCons value $ getSubset oldBook + {-# INLINE getSubset #-} +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" + + +------------------------------------------------------------------------------ +-- 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 value oldBook + {-# INLINE insert #-} + +instance {-# OVERLAPPING #-} + Insertable key value (key :=> someValue ': restOfMap) where + insert _key value (BCons _ oldBook) = BCons value oldBook + {-# INLINE insert #-} + +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 + {-# INLINE insert #-} + +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 value oldBook + {-# INLINE insert' #-} +instance Insertable' 'EQ key value + (key :=> oldValue ': restOfMap) + (key :=> value ': restOfMap) where + 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 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 (Ledger' f (Delete key map)) (f value) + +instance {-# OVERLAPPING #-} Split key (key :=> value ': restOfMap) value where + split' _ ledger = case ledger of + Here x -> Right x + There y -> Left 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 -> 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 + Right e -> Just $ runIdentity e + Left _ -> Nothing + +------------------------------------------------------------------------------ +-- Deletion +------------------------------------------------------------------------------ + +type family Delete keyToDelete oldBook where + Delete keyToDelete (keyToDelete :=> someValue ': xs) = xs + Delete keyToDelete (anotherKey :=> someValue ': xs) + = (anotherKey :=> someValue ': Delete keyToDelete xs) + +------------------------------------------------------------------------------ +-- 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) + +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 +------------------------------------------------------------------------------ + +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 +------------------------------------------------------------------------------ + +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 + +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) 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 60% rename from test/BookkeeperSpec.hs rename to bookkeeper/test/BookkeeperSpec.hs index 3d17f1c..b175ced 100644 --- a/test/BookkeeperSpec.hs +++ b/bookkeeper/test/BookkeeperSpec.hs @@ -1,13 +1,20 @@ module BookkeeperSpec (spec) where import Data.Char (toUpper) +import Data.Either (isLeft) import Test.Hspec import Test.QuickCheck +import GHC.Generics (Generic) 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" @@ -50,7 +57,7 @@ spec = 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 @@ -58,8 +65,44 @@ spec = 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 + + 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 + + it "allows splitting" $ do + split #bool aBool `shouldBe` Right True + split #bool anInt `shouldSatisfy` isLeft + + it "has a decent show instance" $ do + show aBool `shouldBe` "option' #bool (Identity True)" + +type BaseType = Ledger '[ "bool" :=> Bool, "int" :=> Int] typeLevelTest :: Expectation typeLevelTest = True `shouldBe` True 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/bookkeeper/test/Spec.hs b/bookkeeper/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/bookkeeper/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} 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/src/Bookkeeper/Internal.hs b/src/Bookkeeper/Internal.hs deleted file mode 100644 index 55d8467..0000000 --- a/src/Bookkeeper/Internal.hs +++ /dev/null @@ -1,273 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# 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 Bookkeeper.Internal.Errors - ------------------------------------------------------------------------------- --- 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)) - --- | 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 ------------------------------------------------------------------------------- - --- * Getters - --- | @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) - --- | Get a value by key, if it exists. --- --- >>> get #age julian --- 28 --- --- If the key does not exist, throws a type error --- >>> 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) - => Key field -> Book' book -> val -get _ (Book bk) = case (Map.submap bk :: Map '[field :=> val]) of - Map.Ext _ v Map.Empty -> 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 -(?:) = flip get -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'. -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 - --- | 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 -(=:) = set -infix 3 =: - --- * Modifiers - --- | @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 - ) - --- | Apply a function to a field. --- --- >>> julian & modify #name (fmap toUpper) --- Book {age = 28, name = "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 field val val' old new) - => Key field -> (val -> val') -> Book' old -> Book new -modify p f b = set p v b - where v = f $ get p b - --- | Infix version of 'modify'. --- --- >>> 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 -(%:) = modify -infixr 3 %: - - --- | Delete a field from a 'Book', if it exists. If it does not, returns the --- @Book@ unmodified. --- --- >>> 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 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 - -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. --- --- >>> data Test = Test { field1 :: String, field2 :: Int, field3 :: Char } deriving Generic --- >>> fromRecord (Test "hello" 0 'c') --- Book {field1 = "hello", field2 = 0, field3 = 'c'} --- --- Trying to convert a datatype which is not a record will result in a type --- error: --- --- >>> data SomeSumType = LeftSide | RightSide deriving Generic --- >>> fromRecord LeftSide --- ... --- ... • Cannot convert sum types into Books --- ... --- --- >>> data Unit = Unit deriving Generic --- >>> fromRecord Unit --- ... --- ... • Cannot convert non-record types into Books --- ... -fromRecord :: (Generic a, FromGeneric (Rep a) bookRep) => a -> Book' bookRep -fromRecord = fromGeneric . from - --- $setup --- >>> import Data.Function ((&)) --- >>> import Data.Char (toUpper) --- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ] --- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni" diff --git a/stack.yaml b/stack.yaml index a06aa4b..3ae8844 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,5 @@ -resolver: nightly-2016-05-27 packages: -- '.' +- ./bookkeeper +- ./bookkeeper-aeson extra-deps: -- 'type-level-sets-0.7' -flags: {} +resolver: lts-8.3 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..09bb0d0 --- /dev/null +++ b/sum-error/package.yaml @@ -0,0 +1,62 @@ +name: sum-error +version: "0.3" +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 + - mtl == 2.* + +default-extensions: + - AutoDeriveTypeable + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - KindSignatures + - MultiParamTypeClasses + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables + - OverloadedLabels + - 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.hs b/sum-error/src/SumError.hs new file mode 100644 index 0000000..4952c9a --- /dev/null +++ b/sum-error/src/SumError.hs @@ -0,0 +1,12 @@ +module SumError + ( SumError + , SumErrorT + , runSumError + , runSumErrorT + , resolve + , 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 new file mode 100644 index 0000000..20f5243 --- /dev/null +++ b/sum-error/src/SumError/Internal.hs @@ -0,0 +1,79 @@ +{-# 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 + +-- | 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 + , 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)) + => 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 + +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. +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 + +instance (Optionable error value ledger, Monad m) + => MonadSumError (SumErrorT ledger m) error value where + throwSumError key errorValue = SumErrorT (throwError $ option key $ errorValue) + +-- | @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 + +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/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..189a0dc --- /dev/null +++ b/sum-error/sum-error.cabal @@ -0,0 +1,73 @@ +-- 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.3 +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 OverloadedLabels TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.9 && < 4.10 + , bookkeeper >= 0.3 && < 0.4 + , mtl == 2.* + exposed-modules: + SumError + SumError.Internal + 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 OverloadedLabels TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + 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 + 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 OverloadedLabels TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + 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/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 #-} diff --git a/sum-error/test/SumErrorSpec.hs b/sum-error/test/SumErrorSpec.hs new file mode 100644 index 0000000..4f45e01 --- /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` 204 + fn (-2) `shouldBe` 202 + fn 10 `shouldBe` 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 +