diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..78c8aeb --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,15 @@ +# Changelog for `isomorphic-derive` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +### Generic instances for GenericCoerce + +- Derive Monoid and Semigroup instances via GenericCoerceTo + +## 0.1.0.0 - YYYY-MM-DD diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generic-derive.cabal b/generic-derive.cabal new file mode 100644 index 0000000..02917c5 --- /dev/null +++ b/generic-derive.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.38.0. +-- +-- see: https://github.com/sol/hpack + +name: generic-derive +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/isomorphic-derive#readme +bug-reports: https://github.com/githubuser/isomorphic-derive/issues +author: VegOwOtenks +maintainer: vegowotenks@jossco.de +copyright: AGPL3 +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/githubuser/isomorphic-derive + +library + exposed-modules: + GHC.Generics.Coerce + GHC.Generics.Coerce.Example + GHC.Generics.CoerceTo + GHC.Generics.CoerceTo.Example + other-modules: + Paths_generic_derive + autogen-modules: + Paths_generic_derive + hs-source-dirs: + src + ghc-options: -Weverything + build-depends: + base >=4.7 && <5 + default-language: Haskell2010 + +test-suite isomorphic-derive-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_generic_derive + autogen-modules: + Paths_generic_derive + hs-source-dirs: + test + ghc-options: -Weverything -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , isomorphic-derive + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..ede9226 --- /dev/null +++ b/package.yaml @@ -0,0 +1,40 @@ +name: generic-derive +version: 0.1.0.0 +github: "githubuser/isomorphic-derive" +license: BSD-3-Clause +author: "VegOwOtenks" +maintainer: "vegowotenks@jossco.de" +copyright: "AGPL3" + +extra-source-files: +- README.md +- CHANGELOG.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 + +ghc-options: +- -Weverything + +library: + source-dirs: src + +tests: + isomorphic-derive-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - isomorphic-derive diff --git a/src/GHC/Generics/Coerce.hs b/src/GHC/Generics/Coerce.hs new file mode 100644 index 0000000..a4ee14a --- /dev/null +++ b/src/GHC/Generics/Coerce.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-unsafe #-} + +module GHC.Generics.Coerce +(GenericCoerce(..), genericCoerce) +where + +import Prelude (id, ($), (.)) + +import GHC.Generics (U1, (:*:) ((:*:)), (:+:) (L1, R1), M1 (M1), K1 (K1), Generic) +import GHC.Generics qualified as Generics + +import Data.Coerce (coerce, Coercible) +import Data.Kind (Type, Constraint) + +type GenericCoerce :: (Type -> Type) -> (Type -> Type) -> Constraint + +class GenericCoerce a b where + gfrom :: a i -> b i + gto :: b i -> a i + +-- unit type data +instance GenericCoerce U1 U1 where + gfrom :: U1 i -> U1 i + gfrom = id + gto :: U1 i -> U1 i + gto = id + +-- product type combinations +instance (GenericCoerce a c, GenericCoerce b d) => GenericCoerce (a :*: b) (c :*: d) where + gfrom :: (:*:) a b i -> (:*:) c d i + gfrom (a :*: b) = gfrom a :*: gfrom b + gto :: (:*:) c d i -> (:*:) a b i + gto (a :*: b) = gto a :*: gto b + +-- sum type options +instance (GenericCoerce a c, GenericCoerce b d) => GenericCoerce (a :+: b) (c :+: d) where + gfrom :: (:+:) a b i -> (:+:) c d i + gfrom (L1 a) = L1 $ gfrom a + gfrom (R1 b) = R1 $ gfrom b + gto :: (:+:) c d i -> (:+:) a b i + gto (L1 a) = L1 $ gto a + gto (R1 b) = R1 $ gto b + +-- types and constructors +instance GenericCoerce a a' => GenericCoerce (M1 i_ c a) (M1 i_' c' a') where + gfrom :: M1 i_ c a i -> M1 i_' c' a' i + gfrom (M1 x) = M1 $ gfrom x + gto :: M1 i_' c' a' i -> M1 i_ c a i + gto (M1 x) = M1 $ gto x + +-- constants and parameters +instance Coercible a a' => GenericCoerce (K1 i_ a) (K1 i_' a') where + gfrom :: K1 i_ a i -> K1 i_' a' i + gfrom (K1 x) = K1 $ coerce x + gto :: K1 i_' a' i -> K1 i_ a i + gto (K1 x) = K1 $ coerce x + + +-- convenience functions + +genericCoerce :: (Generic a, Generic b, GenericCoerce (Generics.Rep a) (Generics.Rep b)) => a -> b +genericCoerce = Generics.to . gfrom . Generics.from diff --git a/src/GHC/Generics/Coerce/Example.hs b/src/GHC/Generics/Coerce/Example.hs new file mode 100644 index 0000000..5dcce32 --- /dev/null +++ b/src/GHC/Generics/Coerce/Example.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +{-# OPTIONS_GHC -Wno-unsafe #-} +{-# OPTIONS_GHC -Wno-missing-safe-haskell-mode #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module GHC.Generics.Coerce.Example +() +where + +import Prelude (Show) + +import GHC.Generics (Generic) +import GHC.Generics.Coerce (genericCoerce) + +import Data.Int (Int) +import Data.Kind (Type) + + +type Pair :: Type -> Type -> Type +type role Pair representational representational + +data Pair a b = Pair a b + deriving stock (Generic, Show) + +tupleCoerce :: Pair a b -> (a, b) +tupleCoerce = genericCoerce + +-- >>> tupleCoerce (Pair 1 1) +-- (1,1) + + +type IntPair :: Type +data IntPair = IntPair Int Int + deriving stock (Generic, Show) + +intTupleCoerce :: IntPair -> Pair Int Int +intTupleCoerce = genericCoerce + +-- >>> intTupleCoerce (IntPair 1 2) +-- Pair 1 2 + diff --git a/src/GHC/Generics/CoerceTo.hs b/src/GHC/Generics/CoerceTo.hs new file mode 100644 index 0000000..2dec28f --- /dev/null +++ b/src/GHC/Generics/CoerceTo.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -Wno-unsafe #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module GHC.Generics.CoerceTo +(GenericCoerceTo(..)) +where + +import Prelude ((.), ($)) + +import GHC.Generics (Generic(Rep)) +import GHC.Generics.Coerce (GenericCoerce()) + +import GHC.Generics qualified as Generics +import GHC.Generics.Coerce qualified as GenericCoerce + +import Data.Kind (Type) + +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty + +import Data.Semigroup (Semigroup ((<>), sconcat)) +import Data.Monoid (Monoid (mempty, mconcat)) + +type role GenericCoerceTo representational phantom + +type GenericCoerceTo :: Type -> Type -> Type + +newtype GenericCoerceTo self other = GenericCoerceTo { get :: self } + + +toOther :: (Generic b, Generic a, GenericCoerce (Rep a) (Rep b)) => GenericCoerceTo a b -> b +toOther = Generics.to . GenericCoerce.gfrom . Generics.from . get + +fromOther :: (Generic a, Generic b, GenericCoerce (Rep a) (Rep b)) => b -> GenericCoerceTo a b +fromOther = GenericCoerceTo . Generics.to . GenericCoerce.gto . Generics.from + + +instance + (Generic this + , Generic other + , GenericCoerce (Rep this) (Rep other) + , Semigroup other) + => Semigroup (GenericCoerceTo this other) where + + (<>) :: GenericCoerceTo this other -> GenericCoerceTo this other -> GenericCoerceTo this other + lhs <> rhs = fromOther $ toOther lhs <> toOther rhs + + sconcat :: NonEmpty (GenericCoerceTo this other) -> GenericCoerceTo this other + sconcat = fromOther . sconcat . NonEmpty.map toOther + +instance + (Generic this + , Generic other + , GenericCoerce (Rep this) (Rep other) + , Monoid other) + => Monoid (GenericCoerceTo this other) where + + mempty :: GenericCoerceTo this other + mempty = fromOther mempty + + mconcat :: [GenericCoerceTo this other] -> GenericCoerceTo this other + mconcat = fromOther . mconcat . List.map toOther + diff --git a/src/GHC/Generics/CoerceTo/Example.hs b/src/GHC/Generics/CoerceTo/Example.hs new file mode 100644 index 0000000..c745047 --- /dev/null +++ b/src/GHC/Generics/CoerceTo/Example.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-unsafe #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module GHC.Generics.CoerceTo.Example () where + +import Prelude () + +import GHC.Generics (Generic) +import GHC.Generics.CoerceTo ( GenericCoerceTo(GenericCoerceTo) ) + +import Data.Kind (Type) + +import Data.Semigroup (Semigroup) +import Data.Monoid (Sum(Sum)) +import Data.Int (Int) +import Text.Show (Show) + +type IntPair :: Type + +data IntPair = IntPair Int Int + deriving stock (Generic, Show) + deriving (Semigroup) via (IntPair `GenericCoerceTo` (Sum Int, Sum Int)) + +-- >>> IntPair 1 1 <> IntPair 1 1 +-- IntPair 2 2 + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..4a18d1c --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/configure/yaml/ + +# A 'specific' Stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# snapshot: lts-23.14 +# snapshot: nightly-2025-02-15 +# snapshot: ghc-9.8.4 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# snapshot: ./custom-snapshot.yaml +# snapshot: https://example.com/snapshots/2024-01-01.yaml +snapshot: lts-23.19 +compiler: ghc-9.10.1 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the snapshot. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for project packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=3.5" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..fc7aea1 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: [] +snapshots: +- completed: + sha256: 296a7960c37efa382432ab497161a092684191815eb92a608c5d6ea5f894ace3 + size: 683835 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/19.yaml + original: lts-23.19 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"