diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,18 @@ # ChangeLog / ReleaseNotes +## Version 0.3.0.0 + +* Fixed defaultMakeFieldName, which actually behaved correctly only in very few + cases. (**bug fix**) +* Added missing `HAVE_OVERLOADED_LABELS` macro, that actually allows us to use + GHC's `IsLabel` on GHC >8. (**bug fix**) +* Exposing previously hidden `FromArrow` and `IsFieldAccessor`. (**change**) +* Few simple unit tests. (**new**) +* Uploaded to [Hackage][]: + + + ## Version 0.2.0.0 * Function `overloadedRecords` renamed to `overloadedRecord`. There is also new diff --git a/overloaded-records.cabal b/overloaded-records.cabal --- a/overloaded-records.cabal +++ b/overloaded-records.cabal @@ -1,5 +1,5 @@ name: overloaded-records -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Overloaded Records based on current GHC proposal. description: Implementation of /Overloaded Record Fields/ based on current GHC proposal. @@ -46,7 +46,7 @@ , Data.OverloadedRecords.TH -- other-modules: - default-language: Haskell2010 + default-language: Haskell2010 other-extensions: CPP , DataKinds @@ -73,7 +73,9 @@ , template-haskell >=2.9 && <2.12 if impl(ghc >=8.0) - cpp-options: -DHAVE_MONAD_FAIL + cpp-options: + -DHAVE_MONAD_FAIL + -DHAVE_OVERLOADED_LABELS ghc-options: -Wall if flag(pedantic) @@ -82,6 +84,67 @@ -fwarn-implicit-prelude -- -Werror +test-suite unit-tests + hs-source-dirs: src, test + type: exitcode-stdio-1.0 + main-is: unit-tests.hs + other-modules: + Data.OverloadedLabels + , Data.OverloadedLabels.TH + , Data.OverloadedRecords + , Data.OverloadedRecords.TH + , TestCase + , TestCase.Data.OverloadedRecords + + default-language: Haskell2010 + other-extensions: + CPP + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , ExplicitForAll + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , KindSignatures + , LambdaCase + , MagicHash + , MultiParamTypeClasses + , NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , TupleSections + , TypeFamilies + , UndecidableInstances + + build-depends: + base >=4.7 && <5 + , data-default-class ==0.0.* + , template-haskell >=2.9 && <2.12 + + -- {{{ Test-suite dependencies -------------------------------------------- + , HUnit >=1.2 && <2 + -- ^ Same constraints as test-framework-hunit + -- ^ Same constraints as test-framework-quickcheck2==0.3.0.3. + , test-framework >=0.8 && <1 + -- ^ Same constraint as test-framework-skip, other packages that + -- depend on it have less restrictive bounds. + , test-framework-hunit >=0.2.6 && <1 + -- ^ Lower versions have more restrictive bounds on test-framework. + -- }}} Test-suite dependencies -------------------------------------------- + + if impl(ghc >=8.0) + cpp-options: + -DHAVE_MONAD_FAIL + -DHAVE_OVERLOADED_LABELS + + ghc-options: -Wall + if flag(pedantic) + ghc-options: + -fwarn-tabs + -fwarn-implicit-prelude +-- -Werror + source-repository head type: git location: git://github.com/trskop/overloaded-records.git @@ -89,4 +152,4 @@ source-repository this type: git location: git://github.com/trskop/overloaded-records.git - tag: 0.2.0.0 + tag: 0.3.0.0 diff --git a/src/Data/OverloadedRecords.hs b/src/Data/OverloadedRecords.hs --- a/src/Data/OverloadedRecords.hs +++ b/src/Data/OverloadedRecords.hs @@ -31,13 +31,20 @@ module Data.OverloadedLabels -- * Overloaded Record Fields + -- + -- ** Getter , FieldType , HasField(..) + -- ** Setter , UpdateType , SetField(..) , Setter , set + + -- ** IsLabel For Getter and Lens + , FromArrow + , IsFieldAccessor(..) ) where @@ -76,6 +83,7 @@ FromArrow (x -> y) = 'True FromArrow t = 'False +-- | Distinguish between getter and lens. class ( z ~ FromArrow x ) => IsFieldAccessor (l :: Symbol) x y (z :: Bool) | l y -> x @@ -85,7 +93,11 @@ instance IsFieldAccessor l x y (FromArrow x) => IsLabel l (x -> y) where fromLabel = fieldAccessor --- | @'Functor' f => 'Proxy#' l -> (a -> f b) -> s -> f t@ +-- | Overloaded lens: +-- +-- @ +-- 'Functor' f => 'Proxy#' l -> (a -> f b) -> s -> f t +-- @ instance ( Functor f , HasField l s a @@ -96,7 +108,11 @@ where fieldAccessor proxy f s = setField proxy s <$> f (getField proxy s) --- | @'Proxy#' l -> r -> a@ +-- | Overloaded getter: +-- +-- @ +-- 'Proxy#' l -> r -> a +-- @ instance ( HasField l s a , FieldType l s ~ a @@ -105,8 +121,25 @@ where fieldAccessor = getField +-- | Wrapper for a set function, lens naming convention is used for type +-- variables. Its instance for 'IsLabel' forces overloaded label to behave as a +-- setter. newtype Setter s t b = Setter (s -> b -> t) +-- | Extract set function from 'Setter'. Using 'Setter' instance for 'IsLabel' +-- forces overloaded label to behave as a setter. +-- +-- Usage example: +-- +-- @ +-- newtype Bar a = Bar {_bar :: a} +-- deriving Show +-- +-- overloadedRecord ''Bar +-- @ +-- +-- >>> set bar (Bar (Just False)) Nothing +-- Bar {_bar = Nothing} set :: Setter s t b -> s -> b -> t set (Setter f) = f diff --git a/src/Data/OverloadedRecords/TH.hs b/src/Data/OverloadedRecords/TH.hs --- a/src/Data/OverloadedRecords/TH.hs +++ b/src/Data/OverloadedRecords/TH.hs @@ -152,6 +152,8 @@ #ifndef HAVE_OVERLOADED_LABELS -- | Overloaded label that can be used for accessing function of type -- 'FieldDerivation' from 'DeriveOverloadedRecordsParams'. +-- +-- This definition is available only if compiled with GHC <8. fieldDerivation :: IsLabel "fieldDerivation" a => a fieldDerivation = fromLabel (proxy# :: Proxy# "fieldDerivation") #endif @@ -256,22 +258,24 @@ defaultMakeFieldName typeName constructorName _fieldPosition = \case Nothing -> Nothing Just fieldName - | startsWith "_" -> Just $ dropPrefix "_" fieldName - | startsWith typePrefix -> Just $ dropPrefix typePrefix fieldName - | startsWith constructorPrefix -> Just $ dropPrefix typePrefix fieldName - | otherwise -> Nothing + | startsWith "_" -> Just $ dropPrefix "_" fieldName + | startsWith typePrefix -> Just $ dropPrefix typePrefix fieldName + | startsWith conPrefix -> Just $ dropPrefix conPrefix fieldName + | otherwise -> Nothing where startsWith :: String -> Bool startsWith = (`List.isPrefixOf` fieldName) dropPrefix :: String -> String -> String - dropPrefix s = List.drop (List.length s) + dropPrefix s = headToLower . List.drop (List.length s) + headToLower :: String -> String headToLower "" = "" headToLower (x : xs) = Char.toLower x : xs + typePrefix, conPrefix :: String typePrefix = headToLower typeName - constructorPrefix = headToLower constructorName + conPrefix = headToLower constructorName -- | Function used by default value of 'DeriveOverloadedRecordsParams'. defaultFieldDerivation :: FieldDerivation diff --git a/test/TestCase.hs b/test/TestCase.hs new file mode 100644 --- /dev/null +++ b/test/TestCase.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: All test cases aggregated and exported as tests :: [Test]. +-- Copyright: (c) 2016, Peter Trško +-- License: BSD3 +-- +-- Stability: stable +-- Portability: NoImplicitPrelude +-- +-- All test cases aggregated and exported as @tests :: ['Test']@. +module TestCase (tests) + where + +import Test.Framework (Test, testGroup) + +import qualified TestCase.Data.OverloadedRecords as OverloadedRecords (tests) + + +tests :: [Test] +tests = + [ testGroup "TestCase.Data.OverloadedRecords" OverloadedRecords.tests + ] diff --git a/test/TestCase/Data/OverloadedRecords.hs b/test/TestCase/Data/OverloadedRecords.hs new file mode 100644 --- /dev/null +++ b/test/TestCase/Data/OverloadedRecords.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module: $HEADER$ +-- Description: Unit tests for OverloadedRecords and related TH functions. +-- Copyright: (c) 2016, Peter Trško +-- License: BSD3 +-- +-- Stability: experimental +-- Portability: NoImplicitPrelude +module TestCase.Data.OverloadedRecords (tests) + where + +import Data.Bool (Bool(False, True)) +import Data.Eq (Eq) +import Data.Function (($), (&), (.), const) +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import Data.Int (Int) +import Data.List (map) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Monoid ((<>)) +import Text.Show (Show(show)) + +import Data.Default.Class (Default(def)) + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +import Data.OverloadedLabels.TH (label, labels) +import Data.OverloadedRecords.TH (defaultMakeFieldName, overloadedRecord) + + +data Foo a = Foo + { _x :: Int + , _y :: a + } + deriving (Eq, Show) + +overloadedRecord def ''Foo +labels ["x", "y"] + +newtype Bar a = Bar {_bar :: a} + deriving (Eq, Show) + +overloadedRecord def ''Bar +label "bar" + +tests :: [Test] +tests = + [ testGroup "defaultMakeFieldName" $ map test_defaultMakeField + [ (Just "_foo", Just "foo") + , (Just "_Foo", Just "foo") + , (Just "typeNameFieldName", Just "fieldName") + , (Just "constructorNameFieldName", Just "fieldName") + , (Just "somethingElseEntirely", Nothing) + , (Nothing, Nothing) + ] + , testGroup "overloadedRecord" + [ testCase "x (Foo 1 False) = 1" + $ x (Foo 1 False) @?= 1 + , testCase "y (Foo 1 False) = False" + $ y (Foo 1 False) @?= False + , testCase "bar (Bar (Just True)) = Just True" + $ bar (Bar (Just True)) @?= Just True + , testCase "Foo 1 False & x .~ 2 = Foo 2 False" + $ (Foo 1 False & x .~ 2) @?= Foo 2 False + , testCase "Foo 1 False & y .~ True = Foo 1 True" + $ (Foo 1 False & y .~ True) @?= Foo 1 True + , testCase "Bar (Just True) & bar .~ Nothing = Bar Nothing" + $ (Bar (Just True) & bar .~ Nothing) @?= Bar Nothing + ] + ] + where + test_defaultMakeField (input, output) = + testCase (show input <> " -> " <> show output) + $ defaultMakeFieldName tn cn 0 input @?= output + where + tn = "TypeName" + cn = "ConstructorName" + + (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t + (.~) l b = runIdentity . l (const $ Identity b) diff --git a/test/unit-tests.hs b/test/unit-tests.hs new file mode 100644 --- /dev/null +++ b/test/unit-tests.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: Main +-- Description: Tests main +-- Copyright: (c) 2015, Jan Šipr, Matej Kollár, Peter Trško +-- License: BSD3 +-- +-- Stability: stable +-- Portability: NoImplicitPrelude +-- +-- Tests main. +module Main (main) + where + +import System.IO (IO) + +import Test.Framework (defaultMain) + +import TestCase (tests) + + +main :: IO () +main = defaultMain tests