Merge pull request #132 from lucasvreis/coercible

Change from `GIsomorphic` to `Coercible`

docs/guide/route/generic.md

@@ -88,7 +88,7 @@ The `WithSubRoutes` option to `GenericRoute` can be powerful if you want to use
 
 In GHC 9.2+, `WithSubRoutes` is generically determined in this manner. A constructor like `Route_Blog BlogRoute` automatically expands to `FolderRoute "blog" Slug`. 
 
-You can use any arbitrary type as long as their generic representations are isomorphic (per the `GIsomorphic` class). In effect, `WithSubRoutes` enables "deriving [HasSubRoutes] via" the specified isomorphic route constructor representations.
+You can use any arbitrary type as long as they are coercible. In effect, `WithSubRoutes` enables "deriving [HasSubRoutes] via" the specified isomorphic route constructor representations.
 
 ### `HasSubModels`
 

ema.cabal

@@ -156,7 +156,6 @@ library
     Ema.Generate
     Ema.Route.Class
     Ema.Route.Generic
-    Ema.Route.Generic.Iso
     Ema.Route.Generic.RGeneric
     Ema.Route.Generic.SubModel
     Ema.Route.Generic.SubRoute

src/Ema/Route/Generic.hs

@@ -32,7 +32,7 @@ import Ema.Route.Lib.Folder (FolderRoute (FolderRoute))
 import Ema.Route.Lib.Multi (MultiModel, MultiRoute)
 import Ema.Route.Prism.Type (mapRoutePrism)
 import GHC.Generics qualified as GHC
-import Generics.SOP (All, Code, I (..), NP)
+import Generics.SOP (All, I (..), NP)
 import Optics.Core (ReversibleOptic (re), coercedTo, equality, review, (%))
 import Prelude hiding (All, Generic)
 
@@ -48,7 +48,7 @@ data WithModel (r :: Type)
 
 {- | Specify isomorphic types to delegate sub-route behaviour. Usually this is identical to the route product type.
 
-    The isomorphism is specified by @GIsomorphic@ and is thus via generic representation.
+    The isomorphism is specified by @Coercible@.
 
     The default implementation uses @FileRoute@ for terminal routes, and
     @FolderRoute@ (with constructor prefix stripped) for wrapping sub-routes types.
@@ -128,7 +128,7 @@ instance
       (MultiModel (SubRoutes (GenericRoute r opts)))
       (OptSubModels r opts)
       ~ (() :: Constraint)
-  , VerifyRoutes (Code r) (SubRoutes (GenericRoute r opts)) ~ (() :: Constraint)
+  , VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))
   , GSubModels (RouteModel (GenericRoute r opts)) (MultiModel (OptSubRoutes r opts)) (OptSubModels r opts)
   , HasSubRoutes (GenericRoute r opts)
   , GenericRouteOpts r opts
@@ -142,7 +142,7 @@ instance
       m
 
 instance
-  ( VerifyRoutes (Code r) (SubRoutes (GenericRoute r opts)) ~ (() :: Constraint)
+  ( VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))
   , HasSubRoutes r
   , HasSubModels r
   , ValidSubRoutes r (SubRoutes r)

src/Ema/Route/Generic/Iso.hs

@@ -1,65 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
-module Ema.Route.Generic.Iso (
-  GIsomorphic (giso),
-  IsUnwrappedRoute',
-) where
-
-import Data.Type.Bool (type (&&), type (||))
-import Data.Type.Equality (type (==))
-import GHC.Generics qualified as GHC
-import Optics.Core (Iso', iso)
-
-{- | Types `a` and `b` are isomorphic via their generic representation
-
-  Unlike `Coercible` this constraint does not require that the two types have
-  identical *runtime* representation. For example, `data Foo = Foo` is not
-  coercible to `()` (they have different runtime representations), but they are
-  both isomorphic via their generic representation.
--}
-class (Generic a, Generic b, GHC.Rep a () `Coercible` GHC.Rep b ()) => GIsomorphic a b where
-  giso :: Iso' a b
-
-instance (Generic a, Generic b, GHC.Rep a () `Coercible` GHC.Rep b ()) => GIsomorphic a b where
-  giso =
-    iso
-      (GHC.to @b @() . coerce . GHC.from @a @())
-      (GHC.to @a @() . coerce . GHC.from @b @())
-
--- NOTE: The following code was added as part of custom type errors PR
--- https://github.com/EmaApps/ema/pull/120
---
--- It may require further reflection, and even a rewrite. It exists in this
--- module insofar as it checks the `GIsomorphic` constraint at compile-time for
--- deriving clauses.
-
-{- | Attempts to 'unwrap' @r2@ to see if the constructor fields specified by @r1@ match its internal representation 1:1
-
- In the ideal world, we would piggyback on @GIsoMorphic@ to do the
- heavylifting for us, but GHC is not smart enough for that yet.
--}
-type family IsUnwrappedRoute (r1 :: [Type]) (r2 :: Type) :: Bool where
--- For routes that derived /stock/ GHC.Generic;
--- TODO: The implementation is a bit overkill here as it checks for all fields, but this could be useful
--- should semantics expand in the future perhaps?
-  IsUnwrappedRoute ts (GHC.D1 _ (GHC.C1 _ fields) _) =
-    IsUnwrappedRoute ts (fields ())
-  IsUnwrappedRoute (t ': '[]) (GHC.S1 _ (GHC.K1 _ t') _) =
-    t == t'
-  IsUnwrappedRoute (t ': ts) ((GHC.S1 _ (GHC.K1 _ t') GHC.:*: nxt) _) =
-    t == t' && IsUnwrappedRoute ts (nxt ())
--- Special case for routes with no fields internally, since we can think of Unwrapped () ~ ()
-  IsUnwrappedRoute '[] (GHC.U1 ()) =
-    'True
--- Catch-all
-  IsUnwrappedRoute _ _ =
-    'False
-
--- We need to implement the matching logic as 2 type families here due to overlapping patterns
-type family IsUnwrappedRoute' (r1 :: [Type]) (r2 :: Type) :: Bool where
--- For routes that derived /newtype/ GHC.Generic; simply verify the reps are equal
--- Otherwise, pass it on to match with the assumption of /stock/ GHC.Generic deriving
-  IsUnwrappedRoute' (t ': ts) ts' =
-    GHC.Rep t () == ts' || IsUnwrappedRoute (t ': ts) ts'
-  IsUnwrappedRoute' r1 r2 =
-    IsUnwrappedRoute r1 r2

src/Ema/Route/Generic/SubRoute.hs

@@ -25,10 +25,9 @@ import Ema.Route.Lib.Folder (FolderRoute)
 #else 
 import GHC.TypeLits
 #endif
-import Ema.Route.Generic.Iso (GIsomorphic (giso))
 import Generics.SOP (All, I (..), NS, SameShapeAs, Top, unI)
 import Generics.SOP.Type.Metadata qualified as SOPM
-import Optics.Core (Iso', iso, view)
+import Optics.Core (Iso', iso)
 import Prelude hiding (All)
 
 {- | HasSubRoutes is a class of routes with an underlying MultiRoute (and MultiModel) representation.
@@ -58,7 +57,7 @@ gtoSubRoutes ::
   ) =>
   NS I (RCode r) ->
   MultiRoute subRoutes
-gtoSubRoutes = trans_NS (Proxy @GIsomorphic) (I . view giso . unI)
+gtoSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI)
 
 gfromSubRoutes ::
   forall r subRoutes.
@@ -67,7 +66,7 @@ gfromSubRoutes ::
   ) =>
   MultiRoute subRoutes ->
   NS I (RCode r)
-gfromSubRoutes = trans_NS (Proxy @GIsomorphic) (I . view giso . unI)
+gfromSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI)
 
 -- | @subRoutes@ are valid sub-routes of @r@
 type ValidSubRoutes r subRoutes =
@@ -75,8 +74,8 @@ type ValidSubRoutes r subRoutes =
   , SameShapeAs subRoutes (RCode r)
   , All Top (RCode r)
   , All Top subRoutes
-  , AllZipF GIsomorphic (RCode r) subRoutes
-  , AllZipF GIsomorphic subRoutes (RCode r)
+  , AllZipF Coercible (RCode r) subRoutes
+  , AllZipF Coercible subRoutes (RCode r)
   )
 
 #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)

src/Ema/Route/Generic/Verification.hs

@@ -6,9 +6,7 @@ module Ema.Route.Generic.Verification (
 ) where
 
 import Data.Type.Bool (If)
-import Ema.Route.Generic.Iso (IsUnwrappedRoute')
 import Ema.Route.Generic.Verification.Any (HasAnyT)
-import GHC.Generics qualified as GHC
 import Type.Errors.Pretty (TypeError, type (%), type (<>))
 
 {- | @VerifyModels model routeModels lookups@ verifies the given @model@ to ensure that there
@@ -45,7 +43,7 @@ exists a valid @HasSubRoutes@ instance for @route@ given its @rep@ and the @subr
 
 Invariant: code ~ Code route
 -}
-type family VerifyRoutes (code :: [[Type]]) (subRoutes :: [Type]) :: Constraint where
+type family VerifyRoutes (rcode :: [Type]) (subRoutes :: [Type]) :: Constraint where
   VerifyRoutes '[] '[] = ()
 -- Inconsistent lengths
   VerifyRoutes '[] t =
@@ -57,29 +55,11 @@ type family VerifyRoutes (code :: [[Type]]) (subRoutes :: [Type]) :: Constraint
           % ""
           % ("\t" <> t)
       )
--- Subroute rep is unit
-  VerifyRoutes ('[] ': rs) (() : rs') = VerifyRoutes rs rs'
-  VerifyRoutes ('[()] ': rs) (() : rs') = VerifyRoutes rs rs'
+-- Subroute rep is unit (REVIEW: this case not strictly necessary anymore; should it be removed?)
+  VerifyRoutes (() ': rs) (() : rs') = VerifyRoutes rs rs'
   VerifyRoutes (r' ': rs) (() : rs') =
     TypeError
       ( "A 'WithSubRoutes' entry is '()' instead of the expected: "
           % r'
       )
--- Constructor type ~ Subroute spec
-  VerifyRoutes ('[r'] ': rs) (r' : rs') = VerifyRoutes rs rs'
--- Constructor type ~ Unwrapped (Subroute spec) as a last-resort assumption
-  VerifyRoutes (r1 ': rs) (r2 ': rs') =
-    If
-      (r1 `IsUnwrappedRoute'` (GHC.Rep r2 ()))
-      (VerifyRoutes rs rs')
-      ( TypeError
-          ( "A 'WithSubRoutes' type:"
-              % ""
-              % ("\t" <> r2)
-              % ""
-              % "is not isomorphic to the corresponding route constructor type:"
-              % ""
-              % ("\t" <> r1)
-              % ""
-          )
-      )
+  VerifyRoutes (r1 ': rs) (r2 ': rs') = (Coercible r1 r2, VerifyRoutes rs rs')

src/Ema/Route/Lib/File.hs

@@ -7,7 +7,7 @@ import Ema.Route.Prism (
   toPrism_,
  )
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
-import Optics.Core (iso, only, (%))
+import Optics.Core (coercedTo, only, (%))
 
 {- | A type-level singleton route, whose encoding is given by the symbol parameter.
 
@@ -15,7 +15,7 @@ import Optics.Core (iso, only, (%))
 
  TODO: Can this type be simplified? See https://stackoverflow.com/q/72755053/55246
 -}
-data FileRoute (filename :: Symbol) = FileRoute
+newtype FileRoute (filename :: Symbol) = FileRoute ()
   deriving stock (Eq, Ord, Show, Generic)
 
 instance KnownSymbol fn => IsRoute (FileRoute fn) where
@@ -23,6 +23,6 @@ instance KnownSymbol fn => IsRoute (FileRoute fn) where
   routePrism () =
     toPrism_ $
       only (symbolVal (Proxy @fn))
-        % iso (\() -> FileRoute) (\FileRoute -> ())
+        % coercedTo
   routeUniverse () =
-    [FileRoute]
+    [FileRoute ()]

test/type-errors/Deriving.hs

@@ -24,12 +24,13 @@ import Text.RawString.QQ (r)
 #undef ENABLE_SPEC
 #ifdef ENABLE_SPEC
 data BadRoute = BR_1 Int String | BR_2 String
+data M = M { m1 :: (), m2 :: () } deriving stock GHC.Generic
 
 deriveGeneric ''BadRoute
 -- Subroutes should not have constructors with multiple fields
 -- Expect: MultiRoute: too many arguments
 deriveIsRoute ''BadRoute [t|
-    '[ WithModel (NiceNamedM () ())
+    '[ WithModel M
      ]
   |]
 #endif
@@ -46,7 +47,7 @@ deriveGeneric ''R
 {-
 'WithSubRoutes' is missing subroutes for:
 
-  '[ '[()]]
+  '[()]
 -}
 deriveIsRoute ''R [t|
   '[ WithSubRoutes '[ () ] ]
@@ -83,7 +84,7 @@ deriveGeneric ''R
 -- Expect:
 {-
 A 'WithSubRoutes' entry is '()' instead of the expected:
-'[Int]
+Int
 -}
 deriveIsRoute ''R [t|
   '[ WithSubRoutes '[ (), () ] ]
@@ -100,13 +101,8 @@ deriveGeneric ''R
 -- subroute types that are nonisomorphic to what is specified in 'WithSubRoutes' should be illegal
 -- Expect:
 {-
-A 'WithSubRoutes' type:
-
-  Bool
-
-is not isomorphic to the corresponding route constructor type:
-
-  '[()]
+Couldn't match representation of type ‘()’ with that of ‘Bool’
+  arising from a use of ‘routePrism’
 -}
 deriveIsRoute ''R [t|
   ' [ WithSubRoutes '[ (), Bool] ]
@@ -247,20 +243,3 @@ deriveIsRoute ''R
 #define ENABLE_SPEC
 
 -----------------------------------------
-
--- | Low priority
-#undef ENABLE_SPEC
-#ifdef ENABLE_SPEC
-routeSpec "submodel field name selectors on models with multiple constructors should be illegal"
-  (niceRoute ''() ''())
-  [t|
-    '[ WithModel (BadM () ())
-     , WithSubModels '[ Proxy "niceNamed1", () ]
-     , WithSubRoutes '[ (), () ]
-     ]
-  |]
-  [r|
-Type rep field name lookup: multiple constructors
-  |]
-#endif
-#define ENABLE_SPEC