Skip to content

Commit

Permalink
Merge pull request ElvishJerricco#6 from ElvishJerricco/drop-vinyl-plus
Browse files Browse the repository at this point in the history 
Drop vinyl plus
  • Loading branch information
@ElvishJerricco
ElvishJerricco authored Jul 19, 2018
2 parents fcc4628 + ce00bd0 commit 9d45666
Show file tree
Hide file tree
Showing 3 changed files with 64 additions and 39 deletions.
2 changes: 1 addition & 1 deletion fraxl.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28,7 +28,7 @@ library
, mtl
, dependent-sum
, dependent-map
, vinyl-plus
, vinyl >= 0.6
, type-aligned
ghc-options: -Wall
default-language: Haskell2010
Expand Down
9 changes: 3 additions & 6 deletions src/Control/Monad/Fraxl/Class.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ import Control.Monad.Trans.Cont
import Control.Monad.Trans.Except
import Control.Monad.Trans.Fraxl
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
Expand All @@ -30,9 +29,8 @@ import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import Data.Vinyl.Optic.Plain.Class
import qualified Data.Vinyl.Prelude.CoRec as CR
import Data.Vinyl.Types
import Data.Vinyl
import Data.Vinyl.CoRec

-- | Class for Fraxl-capable monads.
class Monad m => MonadFraxl f m where
Expand All @@ -42,15 +40,14 @@ class Monad m => MonadFraxl f m where
dataFetch = lift . dataFetch

instance (Monad m, f ∈ r) => MonadFraxl f (Fraxl r m) where
dataFetch = liftF . liftAp . Union . FunctorCoRec . CR.lift . Flap
dataFetch = liftF . liftAp . Union . CoRec . Flap

instance Monad m => MonadFraxl f (FreerT f m) where
dataFetch = liftF . liftAp

instance MonadFraxl f m => MonadFraxl f (ContT r m) where
instance MonadFraxl f m => MonadFraxl f (ExceptT e m) where
instance MonadFraxl f m => MonadFraxl f (IdentityT m) where
instance MonadFraxl f m => MonadFraxl f (ListT m) where
instance MonadFraxl f m => MonadFraxl f (MaybeT m) where
instance MonadFraxl f m => MonadFraxl f (ReaderT e m) where
instance (MonadFraxl f m, Monoid w) => MonadFraxl f (Lazy.RWST r w s m) where
Expand Down
92 changes: 60 additions & 32 deletions src/Control/Monad/Trans/Fraxl.hs
View file
Original file line number Diff line number Diff line change
@@ -1,11 +1,14 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Monad.Trans.Fraxl
(
Expand Down Expand Up @@ -33,8 +36,8 @@ module Control.Monad.Trans.Fraxl
, module Data.GADT.Compare
-- * Union
, Union(..)
, getCoRec
, mkUnion
, unconsCoRec
, Flap(..)
) where

import Control.Applicative.Fraxl.Free
Expand All @@ -45,11 +48,14 @@ import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Trans.Fraxl.Free
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.GADT.Compare
import qualified Data.Vinyl.Prelude.CoRec as CR
import Data.Vinyl.Types
import Data.Maybe (fromJust)
import Data.Vinyl
import Data.Vinyl.CoRec
import Data.Vinyl.Functor (Compose(..), (:.))
import Data.Vinyl.TypeLevel

-- | Fraxl is based on a particular Freer monad.
-- This Freer monad has applicative optimization,
Expand All @@ -72,7 +78,7 @@ fetchNil ANil = pure ANil
fetchNil _ = error "Not possible - empty union"

-- | Like '(:)' for constructing @Fetch (Union (f ': r))@
(|:|) :: forall f r a m. Monad m
(|:|) :: forall f r a m. (Monad m, RecApplicative r, FoldRec r r)
=> (forall a'. Fetch f m a')
-> (forall a'. Fetch (Union r) m a')
-> Fetch (Union (f ': r)) m a
Expand All @@ -82,13 +88,13 @@ fetchNil _ = error "Not possible - empty union"
-> ASeq (Union (f ': r)) z
-> m (ASeq m x, ASeq m y, ASeq m z)
runUnion flist ulist ANil = (, , ANil) <$> fetch flist <*> fetchU ulist
runUnion flist ulist (ACons u us) = case CR.uncons (getCoRec u) of
runUnion flist ulist (ACons (Union u) us) = case unconsCoRec u of
Left (Flap fa) -> fmap
(\(ACons ma ms, other, rest) -> (ms, other, ACons ma rest))
(runUnion (ACons fa flist) ulist us)
Right u' -> fmap
(\(other, ACons ma ms, rest) -> (other, ms, ACons ma rest))
(runUnion flist (ACons (mkUnion u') ulist) us)
(runUnion flist (ACons (Union u') ulist) us)

infixr 5 |:|

Expand Down Expand Up @@ -174,33 +180,55 @@ evalCachedFraxl :: forall m f a.
=> (forall a'. Fetch f m a') -> FreerT f m a -> m a
evalCachedFraxl fetch a = fst <$> runCachedFraxl fetch a DMap.empty

-- | 'FunctorCoRec' doesn't implement 'GCompare'.
-- To avoid orphan instances, a newtype is defined.
--
-- @Union@ represents a value of any type constructor in @r@ applied with @a@.
newtype Union r a = Union (FunctorCoRec r a)
class RIndex t ts ~ i => FMatch1 t ts i where
fmatch1' :: Handler r (f t) -> Rec (Maybe :. f) ts -> Either r (Rec (Maybe :. f) (RDelete t ts))

instance FMatch1 t (t ': ts) 'Z where
fmatch1' _ (Compose Nothing :& xs) = Right xs
fmatch1' (H h) (Compose (Just x) :& _) = Left (h x)

instance (FMatch1 t ts i, RIndex t (s ': ts) ~ 'S i,
RDelete t (s ': ts) ~ (s ': RDelete t ts))
=> FMatch1 t (s ': ts) ('S i) where
fmatch1' h (x :& xs) = (x :&) <$> fmatch1' h xs

-- | Handle a single variant of a 'CoRec': either the function is
-- applied to the variant or the type of the 'CoRec' is refined to
-- reflect the fact that the variant is /not/ compatible with the type
-- of the would-be handler
fmatch1 :: (FMatch1 t ts (RIndex t ts),
RecApplicative ts,
FoldRec (RDelete t ts) (RDelete t ts))
=> Handler r (f t)
-> CoRec f ts
-> Either r (CoRec f (RDelete t ts))
fmatch1 h = fmap (fromJust . firstField)
. fmatch1' h
. coRecToRec

unconsCoRec :: (RecApplicative ts, FoldRec ts ts) => CoRec f (t ': ts) -> Either (f t) (CoRec f ts)
unconsCoRec = fmatch1 (H id)

getCoRec :: Union r a -> CoRec (Flap a) r
getCoRec (Union (FunctorCoRec u)) = u
newtype Flap a f = Flap (f a)

mkUnion :: CoRec (Flap a) r -> Union r a
mkUnion u = Union $ FunctorCoRec u
-- | @Union@ represents a value of any type constructor in @r@ applied with @a@.
newtype Union r a = Union (CoRec (Flap a) r)

instance GEq (Union '[]) where
_ `geq` _ = error "Not possible - empty union"

instance (GEq f, GEq (Union r)) => GEq (Union (f ': r)) where
a `geq` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of
instance (RecApplicative r, FoldRec r r, GEq f, GEq (Union r)) => GEq (Union (f ': r)) where
Union a `geq` Union b = case (unconsCoRec a, unconsCoRec b) of
(Left (Flap fa), Left (Flap fb)) -> fa `geq` fb
(Right a', Right b') -> mkUnion a' `geq` mkUnion b'
(Right a', Right b') -> Union a' `geq` Union b'
_ -> Nothing

instance GCompare (Union '[]) where
_ `gcompare` _ = error "Not possible - empty union"

instance (GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where
a `gcompare` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of
instance (RecApplicative r, FoldRec r r, GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where
Union a `gcompare` Union b = case (unconsCoRec a, unconsCoRec b) of
(Left (Flap fa), Left (Flap fb)) -> fa `gcompare` fb
(Right a', Right b') -> mkUnion a' `gcompare` mkUnion b'
(Right a', Right b') -> Union a' `gcompare` Union b'
(Left _, Right _) -> GLT
(Right _, Left _) -> GGT

0 comments on commit 9d45666

Please sign in to comment.