overloaded-records 0.2.0.0 → 0.3.0.0

raw patch · 7 files changed

+258/−12 lines, 7 filesdep +HUnitdep +test-frameworkdep +test-framework-hunitdep ~data-default-classPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, test-framework, test-framework-hunit

Dependency ranges changed: data-default-class

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• overloaded-records.cabal +67/−4
• src/Data/OverloadedRecords.hs +35/−2
• src/Data/OverloadedRecords/TH.hs +10/−6
• test/TestCase.hs +23/−0
• test/TestCase/Data/OverloadedRecords.hs +88/−0
• test/unit-tests.hs +23/−0

@@ -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][]:+  <http://hackage.haskell.org/package/overloaded-records-0.3.0.0>++ ## Version 0.2.0.0  * Function `overloadedRecords` renamed to `overloadedRecord`. There is also new

@@ -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

@@ -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 

@@ -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

@@ -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+    ]

@@ -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)

@@ -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