diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for safe-wild-cards + +## 1.0.0 + +First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Monadfix + +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 Monadfix 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# safe-wild-cards + +`-XRecordWildCards` is convenient, but sometimes you want to assert that +you have handled all fields of a record. `safe-wild-cards` lets you do this. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/safe-wild-cards.cabal b/safe-wild-cards.cabal new file mode 100644 --- /dev/null +++ b/safe-wild-cards.cabal @@ -0,0 +1,61 @@ +cabal-version: >=1.10 + +name: safe-wild-cards +version: 1.0.0 +synopsis: Use RecordWildCards safely +description: + @-XRecordWildCards@ is convenient, but sometimes you want to assert that + you have handled all fields of a record, and there is no easy way to do that. + +license: BSD3 +license-file: LICENSE +author: Artyom Kazak +maintainer: Monadfix +homepage: https://github.com/monadfix/safe-wild-cards +category: Control +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md +tested-with: + GHC ==8.0.2 + GHC ==8.2.2 + GHC ==8.4.4 + GHC ==8.6.5 + GHC ==8.8.4 + GHC ==8.10.4 + GHC ==9.0.1 + +source-repository head + type: git + location: git@github.com:monadfix/safe-wild-cards.git + +library + exposed-modules: + SafeWildCards + build-depends: + base <5, + template-haskell <2.18, + th-abstraction >=0.3 && <0.5 + hs-source-dirs: + src + default-language: + Haskell2010 + ghc-options: + -Wall + +test-suite test + type: exitcode-stdio-1.0 + main-is: + Test.hs + other-modules: + TestTypes + build-depends: + base, + safe-wild-cards + hs-source-dirs: + test + default-language: + Haskell2010 + ghc-options: + -Wall diff --git a/src/SafeWildCards.hs b/src/SafeWildCards.hs new file mode 100644 --- /dev/null +++ b/src/SafeWildCards.hs @@ -0,0 +1,73 @@ +-- | Use @-XRecordWildCards@ safely. +module SafeWildCards (fields, fieldsPrefixed, fieldsNamed) where + +import Language.Haskell.TH (Name, PatQ, mkName, conP, varP, nameBase, recover) +import Language.Haskell.TH.Datatype + +-- | Put all fields of a record constructor into scope. +-- +-- @f $(fields 'Rec) = ...@ is equivalent to @f Rec{..}@, but the compiler +-- will warn you about all unused fields. Thus 'fields' brings compile-time +-- safety whenever you want to guarantee that a certain function uses all +-- fields of @Rec@. +-- +-- To explicitly ignore a field, match it against @_@: +-- +-- @ +-- f $(fields 'Rec) = ... +-- where +-- -- Ignored fields +-- _ = (recUselessField1, recUselessField2) +-- @ +-- +-- Usage examples include @ToJSON@ instances and various encoders in +-- general: +-- +-- @ +-- instance ToJSON Rec where +-- toJSON $(fields 'Rec) = ... +-- @ +-- +-- __Note:__ if you want to define the data type and use 'fields' in the +-- same module, you will need to add @\$(pure [])@ after the type +-- declaration. See the post about +-- for more details. Your code will look like this: +-- +-- @ +-- data Rec = ... +-- \$(pure []) +-- +-- f $(fields 'Rec) = ... +-- @ +fields :: Name -> PatQ +fields = fieldsNamed id + +-- | Like 'fields', but prefixes all fields with the given prefix. +-- +-- Useful if you need to put fields from more than one record into scope: +-- +-- @ +-- diff :: Rec -> Rec -> Text +-- diff $(fieldsPrefixed "a_" 'Rec) $(fieldsPrefixed "b_" 'Rec) = ... +-- @ +fieldsPrefixed :: String -> Name -> PatQ +fieldsPrefixed prefix = fieldsNamed (prefix ++) + +-- | General form of 'fields' and 'fieldsPrefixed'. +fieldsNamed :: (String -> String) -> Name -> PatQ +fieldsNamed f recordConstructor = do + cons <- + recover + (fail $ + "Could not find " ++ nameBase recordConstructor ++ ". If it is defined in the same module where you are using\n" ++ + " 'safe-wild-cards', you need to break the declaration group like this:\n" ++ + " data ... = " ++ nameBase recordConstructor ++ " ...\n" ++ + " $(pure [])\n" ++ + " Read the 'SafeWildCards' module documentation for more details.\n" + ) + (reifyConstructor recordConstructor) + case constructorVariant cons of + RecordConstructor recordFields -> + conP recordConstructor (map (varP . mkName . f . nameBase) recordFields) + _ -> fail $ + "Expected " ++ show recordConstructor ++ " to be a record constructor" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import SafeWildCards +import TestTypes (Rec (Rec1, Rec2), RecFamily (RecFamily1)) + +main :: IO () +main = do + fieldsSpec + fieldsPrefixedSpec + +---------------------------------------------------------------------------- +-- fields +---------------------------------------------------------------------------- + +f :: Rec -> [Int] +f $(fields 'Rec1) = [a, b] +f $(fields 'Rec2) = [a, b, c] + +fFamily :: RecFamily -> [Int] +fFamily $(fields 'RecFamily1) = [af, bf] + +fieldsSpec :: IO () +fieldsSpec = do + f (Rec1 1 2) `mustBe` [1, 2] + f (Rec2 1 2 3) `mustBe` [1, 2, 3] + fFamily (RecFamily1 1 2) `mustBe` [1, 2] + +---------------------------------------------------------------------------- +-- fieldsPrefixed +---------------------------------------------------------------------------- + +p :: Rec -> Rec -> [Int] +p $(fieldsPrefixed "r1_" 'Rec1) $(fieldsPrefixed "r2_" 'Rec2) = + [r1_a, r1_b, r2_a, r2_b, r2_c] +p _ _ = undefined + +pFamily :: RecFamily -> RecFamily -> [Int] +pFamily $(fieldsPrefixed "r1_" 'RecFamily1) $(fieldsPrefixed "r2_" 'RecFamily1) = + [r1_af, r1_bf, r2_af, r2_bf] + +fieldsPrefixedSpec :: IO () +fieldsPrefixedSpec = do + p (Rec1 1 2) (Rec2 3 4 5) `mustBe` [1, 2, 3, 4, 5] + pFamily (RecFamily1 1 2) (RecFamily1 3 4) `mustBe` [1, 2, 3, 4] + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +mustBe :: (Eq a, Show a) => a -> a -> IO () +mustBe x y + | x == y = return () + | otherwise = error $ show x ++ " must be " ++ show y diff --git a/test/TestTypes.hs b/test/TestTypes.hs new file mode 100644 --- /dev/null +++ b/test/TestTypes.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +module TestTypes (Rec(..), RecFamily(..)) where + +data Rec + = Rec1 { a :: Int, b :: Int } + | Rec2 { a :: Int, b :: Int, c :: Int } + +data family RecFamily + +data instance RecFamily = RecFamily1 { af :: Int, bf :: Int }