auto-lift-classes (empty) → 1

raw patch · 7 files changed

+445/−0 lines, 7 filesdep +auto-lift-classesdep +basedep +reflectionsetup-changed

Dependencies added: auto-lift-classes, base, reflection

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
auto-lift-classes.cabal +35/−0
example/test.hs +86/−0
src/AutoLift.hs +158/−0
src/AutoLift/Machinery.hs +129/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for autoshow1++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2018 - 2023, Koji Miyazato++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 Koji Miyazato 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ auto-lift-classes.cabal view

@@ -0,0 +1,35 @@+cabal-version:       2.0+name:                auto-lift-classes+version:             1+synopsis:            Deriving (Show|Read)(1|2)+description:         Deriving (Show|Read)(1|2) from the usual, stock deriveable+                     instances like @Show a => Show (f a)@.+license:             BSD3+license-file:        LICENSE+author:              Koji Miyazato+maintainer:          viercc@gmail.com+copyright:           (c) 2018-2023, Koji Miyazato+category:            Data, Reflection+build-type:          Simple+extra-source-files:  CHANGELOG.md+tested-with:         GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.5, GHC ==9.4.4++source-repository head+  type:     git+  location: https://github.com/viercc/auto-lift-classes+  branch:   master++library+  exposed-modules:    AutoLift, AutoLift.Machinery+  build-depends:      base >= 4.12 && < 5.0,+                      reflection >= 1.0+  hs-source-dirs:     src+  default-language:   Haskell2010+  ghc-options:        -Wall -Wcompat++test-suite run-example+  type:                exitcode-stdio-1.0+  hs-source-dirs:      example+  main-is:             test.hs+  build-depends:       base, auto-lift-classes+  default-language:    Haskell2010

+ example/test.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RoleAnnotations #-}+module Main where++import Data.Functor.Classes+import Text.Read++import AutoLift++data Test a = Test Int a [a]+    deriving (Show, Read, Eq)+    deriving (Show1, Read1) via (Reflected1 Test)++{-++-- The following does not compile due to type role annotation++data BadTest a = BadTest a [a]+    deriving (Show, Read, Eq)+    deriving (Show1, Read1) via (Reflected1 BadTest)++type role BadTest nominal++-}++test :: Test Char+test = Test 1 'a' "bcd"++testShow :: String+testShow = show test++testShow1 :: String+testShow1 = showsPrec1 0 test ""++readStr :: String+readStr = "Test 2 'e' \"fg\"   "++testRead :: [(Test Char, String)]+testRead = reads readStr++testRead1 :: [(Test Char, String)]+testRead1 = readsPrec1 0 readStr++data Crest a b = Crest Int [a] [b]+    deriving (Show, Read, Eq)+    deriving (Show1, Read1) via (Reflected1 (Crest a))+    deriving (Show2, Read2) via (Reflected2 Crest)++crest :: Crest Char Bool+crest = Crest 2 "foo" [False, True]++crestShow, crestShow1, crestShow2 :: String+crestShow = show crest+crestShow1 = showsPrec1 0 crest ""+crestShow2 = showsPrec2 0 crest ""++crestReadStr :: String+crestReadStr = "Crest 3 \"foo\" [True] rest of text"++crestRead, crestRead1, crestRead2 :: [(Crest Char Bool, String)]+crestRead = reads crestReadStr+crestRead1 = readsPrec1 0 crestReadStr+crestRead2 = readsPrec2 0 crestReadStr++main :: IO ()+main = putStrLn . unlines $+  [ "testShow:  " ++ show testShow+  , "testShow1: " ++ show testShow1+  , "testShow == testShow1: " ++ show (testShow == testShow1)+  , ""+  , "testRead:  " ++ show testRead+  , "testRead1: " ++ show testRead1+  , "testRead == testRead1: " ++ show (testRead == testRead1)+  , ""+  , "crestShow:  " ++ show crestShow+  , "crestShow1: " ++ show crestShow1+  , "crestShow2: " ++ show crestShow2+  , "crestShow == crestShow1: " ++ show (crestShow == crestShow1)+  , "crestShow == crestShow2: " ++ show (crestShow == crestShow2)+  , ""+  , "crestRead:  " ++ show crestRead+  , "crestRead1: " ++ show crestRead1+  , "crestRead2: " ++ show crestRead2+  , "crestRead == crestRead1: " ++ show (crestRead == crestRead1)+  , "crestRead == crestRead2: " ++ show (crestRead == crestRead2)+  ]

+ src/AutoLift.hs view

@@ -0,0 +1,158 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Derive lifted version of 'Show' or 'Read' classes, like @'Show1' f@ or @'Read1' f@,+--   from derivable instance @forall a. Show a => Show (f a)@.+module AutoLift+  ( Reflected1 (..),+    Reflected2 (..),++    -- * Reexports+    Show1 (..),+    Read (..),+    Read1 (..),+    ReadPrec,+  )+where++import AutoLift.Machinery+import Data.Coerce+import Data.Functor.Classes+import Text.Read++-- | A newtype wrapper to derive @'Show1' f@ and @'Read1' f@ from the following,+--   often derivable instance.+--+--   > instance Show a => Show (f a)+--   > instance Read a => Read (f a)+--+-- ==== Example+--+-- Suppose you define a new type constructor @Foo@, and+-- derived its @Show@ instance.+--+-- >>> data Foo a = Foo [a] Int a deriving Show+--+-- The derived @Show (Foo a)@ instance is defined for all @a@ with @Show a@ instance.+--+-- > instance Show a => Show (Foo a)+--+-- @Reflected1@ allows you to derive @'Show1' Foo@ instance from the above instance.+--+-- >>> :set -XStandaloneDeriving -XDerivingVia+-- >>> deriving via (Reflected1 Foo) instance Show1 Foo+--+-- Let's try the derived @Show1@ instance, by showing @Foo Bool@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec (const yesno) (showListWith yesno) 0 (Foo [True, False] 5 False) ""+-- "Foo [yes,no] 5 no"+newtype Reflected1 f a = Reflected1 (f a)++wrapShowDict1 :: ShowDict (f a) -> ShowDict (Reflected1 f a)+wrapShowDict1 = coerce++wrapReadDict1 :: ReadDict (f a) -> ReadDict (Reflected1 f a)+wrapReadDict1 = coerce++instance+  ( forall a. Show a => Show (f a),+    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)+  ) =>+  Show1 (Reflected1 f)+  where+  liftShowsPrec showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)+     in _showsPrec showFB+  liftShowList showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)+     in _showList showFB++instance+  ( forall a. Read a => Read (f a),+    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)+  ) =>+  Read1 (Reflected1 f)+  where+  liftReadPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)+     in _readPrec readFB++  liftReadListPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)+     in _readListPrec readFB++-- | A newtype wrapper to derive @'Show2' f@ and @'Read2' f@ from the following,+--   often derivable instance.+--+--   > instance (Show a, Show b) => Show (f a b)+--   > instance (Read a, Read b) => Read (f a b)+--+-- ==== Example+--+-- Suppose you define a new type constructor @Bar@, and+-- derived its @Show@ instance.+--+-- >>> data Bar a b = Bar [(Int,a,b)] deriving Show+--+-- The derived @Show (Bar a b)@ instance is defined for all @a@ and @b@ with @Show@ instances.+--+-- > instance (Show a, Show b) => Show (Bar a b)+--+-- @Reflected2@ allows you to derive @'Show2' Bar@ instance from the above instance.+--+-- >>> :set -XStandaloneDeriving -XDerivingVia+-- >>> deriving via (Reflected2 Bar) instance Show2 Bar+--+-- Let's try the derived @Show2@ instance by showing @Bar Bool Char@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec2 (const yesno) (showListWith yesno) showsPrec showList 0 (Bar [(1, True, 'A'), (2, False, 'B')]) ""+-- "Bar [(1,yes,'A'),(2,no,'B')]"+newtype Reflected2 f a b = Reflected2 (f a b)++wrapShowDict2 :: ShowDict (f a b) -> ShowDict (Reflected2 f a b)+wrapShowDict2 = coerce++wrapReadDict2 :: ReadDict (f a b) -> ReadDict (Reflected2 f a b)+wrapReadDict2 = coerce++instance+  ( forall a b. (Show a, Show b) => Show (f a b),+    forall x1 y1 x2 y2.+    (Coercible x1 y1, Coercible x2 y2) =>+    Coercible (f x1 x2) (f y1 y2)+  ) =>+  Show2 (Reflected2 f)+  where+  liftShowsPrec2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showsPrec showFCD+  liftShowList2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showList showFCD++instance+  ( forall a b. (Read a, Read b) => Read (f a b),+    forall x1 y1 x2 y2.+    (Coercible x1 y1, Coercible x2 y2) =>+    Coercible (f x1 x2) (f y1 y2)+  ) =>+  Read2 (Reflected2 f)+  where+  liftReadPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readPrec readFCD++  liftReadListPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readListPrec readFCD

+ src/AutoLift/Machinery.hs view

@@ -0,0 +1,129 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Internal workings of "AutoLift". You usually don't need to import+--   this module.+module AutoLift.Machinery (+    AdHoc(..),+    ShowDict(..), showDict, autoShow1, autoShow2,+    ReadDict(..), readDict, autoRead1, autoRead2+) where++import Data.Reflection+import Data.Proxy+import Data.Coerce+import Text.Read++-- | Apply ad hoc instances on type @a@.+newtype AdHoc s a = AdHoc a++-- * Show++-- | Injected dictionary of Show+data ShowDict a = ShowDict+  { _showsPrec :: Int -> a -> ShowS+  , _showList :: [a] -> ShowS+  }++showDict :: forall a. Show a => ShowDict a+showDict = ShowDict { _showsPrec = showsPrec, _showList = showList }+{-# INLINE showDict #-}++instance (Reifies s (ShowDict a)) => Show (AdHoc s a) where+  showsPrec = coerce $ _showsPrec (reflect (Proxy @s))+  {-# INLINABLE showsPrec #-}++  showList = coerce $ _showList (reflect (Proxy @s))+  {-# INLINABLE showList #-}++{-++u/Iceland_jack taught me the technique to use QuantifiedConstraint on Coercible constraint. Thanks!++https://www.reddit.com/r/haskell_jp/comments/a75z0s/blog_reflection%E3%82%92%E4%BD%BF%E3%81%A3%E3%81%9F%E3%83%86%E3%82%AF%E3%83%8B%E3%83%83%E3%82%AF/ed3efcv/++-}++-- | Automatic Show1+autoShow1 :: forall f b.+     (forall a. Show a => Show (f a))+  => (forall x y. Coercible x y => Coercible (f x) (f y))+  => ShowDict b+  -> ShowDict (f b)+autoShow1 showB = reify showB body+  where+    body :: forall name. Reifies name (ShowDict b) => Proxy name -> ShowDict (f b)+    body _ = coerce $ showDict @(f (AdHoc name b))+{-# INLINABLE autoShow1 #-}++-- | Automatic Show2+autoShow2 :: forall f c d.+     (forall a b. (Show a, Show b) => Show (f a b))+  => (forall x1 x2 y1 y2.+         (Coercible x1 y1, Coercible x2 y2) => Coercible (f x1 x2) (f y1 y2)+       )+  => ShowDict c+  -> ShowDict d+  -> ShowDict (f c d)+autoShow2 showC showD =+  reify showC $ \proxyC ->+    reify showD $ \proxyD ->+      body proxyC proxyD+  where+    body :: forall name1 name2. (Reifies name1 (ShowDict c), Reifies name2 (ShowDict d))+         => Proxy name1 -> Proxy name2 -> ShowDict (f c d)+    body _ _ = coerce $ showDict @(f (AdHoc name1 c) (AdHoc name2 d))+{-# INLINABLE autoShow2 #-}++-- * Read++-- | Injected dictionary of 'Read'+data ReadDict a = ReadDict+  { _readPrec :: ReadPrec a+  , _readListPrec :: ReadPrec [a]+  }++readDict :: forall a. Read a => ReadDict a+readDict = ReadDict{ _readPrec = readPrec, _readListPrec = readListPrec }+{-# INLINE readDict #-}++instance (Reifies s (ReadDict a)) => Read (AdHoc s a) where+  readPrec = coerce $ _readPrec (reflect (Proxy @s))+  {-# INLINABLE readPrec #-}+  readListPrec = coerce $ _readListPrec (reflect (Proxy @s))+  {-# INLINABLE readListPrec #-}++-- | Automatic Read1+autoRead1 :: forall f b.+     (forall a. Read a => Read (f a))+  => (forall x y. Coercible x y => Coercible (f x) (f y))+  => ReadDict b+  -> ReadDict (f b)+autoRead1 readB =+  reify readB body+  where+    body :: forall name. (Reifies name (ReadDict b)) => Proxy name -> ReadDict (f b)+    body _ = coerce (readDict @(f (AdHoc name b)))+{-# INLINABLE autoRead1 #-}++autoRead2 :: forall f c d.+     (forall a b. (Read a, Read b) => Read (f a b))+  => (forall x1 x2 y1 y2.+         (Coercible x1 y1, Coercible x2 y2) => Coercible (f x1 x2) (f y1 y2)+       )+  => ReadDict c+  -> ReadDict d+  -> ReadDict (f c d)+autoRead2 readC readD =+  reify readC $ \proxyC ->+    reify readD $ \proxyD ->+      body proxyC proxyD+  where+    body :: forall name1 name2. (Reifies name1 (ReadDict c), Reifies name2 (ReadDict d))+         => Proxy name1 -> Proxy name2 -> ReadDict (f c d)+    body _ _ = coerce (readDict @(f (AdHoc name1 c) (AdHoc name2 d)))+{-# INLINABLE autoRead2 #-}