mirror of
https://github.com/srid/ema.git
synced 2024-09-11 15:05:23 +03:00
Merge pull request #132 from lucasvreis/coercible
Change from `GIsomorphic` to `Coercible`
This commit is contained in:
commit
c1855fd8e1
@ -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`
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
@ -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)
|
||||
|
@ -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')
|
||||
|
@ -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 ()]
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user