packages feed

quiet (empty) → 0.1

raw patch · 8 files changed

+428/−0 lines, 8 filesdep +basedep +quietsetup-changed

Dependencies added: base, quiet

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for quiet++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Jacob Stanley (c) 2016-2020+Copyright Universiteit Utrecht (c) 2010++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 Jacob Stanley 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.
+ README.md view
@@ -0,0 +1,49 @@+# quiet++Generic deriving of `Read` / `Show` with no record labels.++[![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis]++Often one wants to create a `newtype` which has a convenient field+accessor like `unUserId` below, but that makes the derived `Show`+instance overly verbose.++For example:++```hs+newtype UserId = UserId { unUserId :: String } deriving (Show)+```++Renders as:++```+ghci> show (UserId "simon")+UserId {unUserId = "simon"}+```++With 'qshowsPrec' you can have a `Show` instance which doesn't print+the field labels. It will render as if the `unUserId` accessor wasn't+present at all.++```hs+newtype UserId = UserId { unUserId :: String } deriving (Generic)++instance Show UserId where showsPrec = qshowsPrec+```++```+ghci> show (UserId "simon")+UserId "simon"+```++A compatible `Read` instance can also be derived using `qreadPrec` if+necessary.++```hs+instance Read UserId where showsPrec = qreadPrec+```+ [hackage]: http://hackage.haskell.org/package/quiet+ [hackage-shield]: https://img.shields.io/hackage/v/quiet.svg?style=flat++ [travis]: https://travis-ci.org/jacobstanley/quiet+ [travis-shield]: https://travis-ci.org/jacobstanley/quiet.svg?branch=master
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ quiet.cabal view
@@ -0,0 +1,54 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8115fa43cb04ccd92fe9192fc1547bf268155685bac59dcfe87c1933e9c7f7b0++name:           quiet+version:        0.1+synopsis:       Generic deriving of Read/Show with no record labels.+description:    Please see the README on GitHub at <https://github.com/jacobstanley/quiet#readme>+category:       Generics+homepage:       https://github.com/jacobstanley/quiet#readme+bug-reports:    https://github.com/jacobstanley/quiet/issues+author:         Jacob Stanley+maintainer:     jacob@stanley.io+copyright:      Copyright (c) 2016-2020+license:        BSD3+license-file:   LICENSE+tested-with:    GHC==8.0.2,GHC==8.2.2,GHC==8.4.4,GHC==8.6.5,GHC==8.8.1+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/jacobstanley/quiet++library+  exposed-modules:+      Quiet+      Quiet.Internal+  other-modules:+      Paths_quiet+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+  default-language: Haskell2010++test-suite quiet-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_quiet+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , quiet+  default-language: Haskell2010
+ src/Quiet.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Generic deriving of 'Read' / 'Show' with no record labels.+--+-- Often one wants to create a @newtype@ which has a convieniant field+-- accessor like @unUserId@ below, but that makes the derived 'Show'+-- instance overly verbose.+--+-- For example:+--+-- @+-- newtype UserId = UserId { unUserId :: String } deriving (Show)+-- @+--+-- Renders as:+--+-- >>> show (UserId "simon")+-- UserId {unUserId = "simon"}+--+-- With 'qshowsPrec' you can have a @Show@ instance which doesn't print+-- the field labels. It will render as if the @unUserId@ accessor wasn't+-- present at all.+--+-- @+-- newtype UserId = UserId { unUserId :: String } deriving (Generic)+--+-- instance Show UserId where showsPrec = qshowsPrec+-- @+--+-- >>> show (UserId "simon")+-- UserId "simon"+--+-- A compatible 'Read' instance can also be derived using 'qreadPrec' if+-- necessary.+--+-- @+-- instance Read UserId where showsPrec = qreadPrec+-- @+--+module Quiet (+    qshowsPrec+  , qreadPrec+  ) where++import GHC.Generics (Generic(..), Rep)++import Text.ParserCombinators.ReadPrec (ReadPrec)++import Quiet.Internal (ConType(..), QShow(..), QRead(..))+++-- | This implements a quiet version of 'Text.Show.showsPrec' which omits+--   labels for record fields when rendering constructors.+qshowsPrec :: (Generic a, QShow (Rep a)) => Int -> a -> ShowS+qshowsPrec n =+  qshowsPrec_ ConPrefix n . from++-- | This implements a quiet version of 'Text.Read.readPrec' which expects+--   labels for record fields to be omitted when parsing constructors.+qreadPrec :: (Generic a, QRead (Rep a)) => ReadPrec a+qreadPrec =+  fmap to (qreadPrec_ ConPrefix)
+ src/Quiet/Internal.hs view
@@ -0,0 +1,211 @@+-- Some Parts: Copyright 2010, Universiteit Utrecht, All Rights Reserved.+-- License: BSD3++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}++module Quiet.Internal (+    ConType(..)+  , QShow(..)+  , QRead(..)+  , expectInfix+  ) where++import           Data.Proxy (Proxy(..))++import           GHC.Generics ((:*:)(..), (:+:)(..))+import           GHC.Generics (Constructor(..))+import           GHC.Generics (Fixity(..))+import           GHC.Generics (U1(..), K1(..), M1(..), D, C, S)+import qualified GHC.Read as Read+import           GHC.Show (appPrec, appPrec1, showChar, showParen)++import           Text.ParserCombinators.ReadPrec (ReadPrec)+import qualified Text.ParserCombinators.ReadPrec as ReadPrec+import qualified Text.Read.Lex as Lex++--------------------------------------------------------------+-- ConType++data ConType =+    ConPrefix+  | ConInfix String++--------------------------------------------------------------+-- QShow++class QShow f where+  qshowsPrec_ :: ConType -> Int -> f a -> ShowS++  qshowsNullary :: f a -> Bool+  qshowsNullary _ =+    False++instance QShow U1 where+  qshowsPrec_ _ _ U1 =+    id++  qshowsNullary _ =+    True++instance Show c => QShow (K1 i c) where+  qshowsPrec_ _ n (K1 a) =+    showsPrec n a++instance (QShow a, Constructor c) => QShow (M1 C c a) where+  qshowsPrec_ _ n c@(M1 x) =+    let+      fixity =+        conFixity c++      t =+        case fixity of+          Prefix ->+            ConPrefix+          Infix _ _ ->+            ConInfix $ conName c+    in+      case fixity of+        Prefix ->+          showParen (n > appPrec && not (qshowsNullary x)) $+            showString (conName c) .+            if qshowsNullary x then id else showChar ' ' .+            qshowsPrec_ t appPrec1 x+        Infix _ m ->+          showParen (n > m) $ qshowsPrec_ t (m+1) x++instance QShow a => QShow (M1 S s a) where+  qshowsPrec_ t n (M1 x) =+    qshowsPrec_ t n x++  qshowsNullary (M1 x) =+    qshowsNullary x++instance QShow a => QShow (M1 D d a) where+  qshowsPrec_ t n (M1 x) =+    qshowsPrec_ t n x++instance (QShow a, QShow b) => QShow (a :+: b) where+  qshowsPrec_ t n = \case+    L1 x ->+      qshowsPrec_ t n x+    R1 x ->+      qshowsPrec_ t n x++instance (QShow a, QShow b) => QShow (a :*: b) where+  qshowsPrec_ t n (a :*: b) =+    case t of+      ConPrefix ->+        qshowsPrec_ t n a .+        showChar ' ' .+        qshowsPrec_ t n b+      ConInfix s ->+        let+          isInfixTypeCon = \case+            ':':_ ->+              True+            _ ->+              False++          showBacktick =+            if isInfixTypeCon s then+              id+            else+              showChar '`'+        in+          qshowsPrec_ t n a .+          showChar ' ' .+          showBacktick .+          showString s .+          showBacktick .+          showChar ' ' .+          qshowsPrec_ t n b++------------------------------------------------------------------------+-- QRead++class QRead f where+  qreadPrec_ :: ConType -> ReadPrec (f a)++  qreadNullary :: Proxy f -> Bool+  qreadNullary _ =+    False++instance QRead U1 where+  qreadPrec_ _ =+    pure U1++  qreadNullary _ =+    True++instance Read c => QRead (K1 i c) where+  qreadPrec_ _ =+    K1 <$> Read.readPrec++instance (QRead a, Constructor c) => QRead (M1 C c a) where+  qreadPrec_ _ =+    let+      proxy =+        Proxy @(M1 C c a)++      con =+        undefined :: M1 C c a p+    in+      Read.parens $+      case conFixity con of+        Prefix ->+          if qreadNullary proxy then do+            Read.expectP (Lex.Ident (conName con))+            M1 <$> ReadPrec.step (qreadPrec_ ConPrefix)++          else+            ReadPrec.prec appPrec $ do+              Read.expectP (Lex.Ident (conName con))+              M1 <$> ReadPrec.step (qreadPrec_ ConPrefix)++        Infix _ m ->+          ReadPrec.prec m $+            M1 <$> ReadPrec.step (qreadPrec_ (ConInfix (conName con)))++instance QRead a => QRead (M1 S s a) where+  qreadPrec_ t =+    M1 <$> qreadPrec_ t++  qreadNullary x =+    qreadNullary x++instance QRead a => QRead (M1 D d a) where+  qreadPrec_ t =+    M1 <$> qreadPrec_ t++instance (QRead a, QRead b) => QRead (a :+: b) where+  qreadPrec_ t =+    (L1 <$> qreadPrec_ t)+    ReadPrec.++++    (R1 <$> qreadPrec_ t)++instance (QRead a, QRead b) => QRead (a :*: b) where+  qreadPrec_ t =+    Read.parens $+      case t of+        ConPrefix ->+          (:*:)+            <$> qreadPrec_ t+            <*> qreadPrec_ t++        ConInfix s ->+          (:*:)+            <$> qreadPrec_ t <* expectInfix s+            <*> qreadPrec_ t++expectInfix :: String -> ReadPrec ()+expectInfix = \case+  xs@(':':_) ->+    Read.expectP (Lex.Symbol xs)+  xs -> do+    Read.expectP (Lex.Punc "`")+    Read.expectP (Lex.Ident xs)+    Read.expectP (Lex.Punc "`")
+ test/Spec.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveGeneric #-}++import GHC.Generics (Generic)+import Quiet (qshowsPrec)+import System.Exit (exitFailure)++newtype UserId = UserId { unUserId :: String } deriving (Generic)++instance Show UserId where showsPrec = qshowsPrec++main :: IO ()+main =+  if show (UserId "simon") == "UserId \"simon\"" then+    pure ()+  else+    exitFailure