diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,3 @@ +let extensions= (const . return $ let version = Data.Version.versionBranch System.Info.compilerVersion in if version < [6, 6] then ":set -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances" else if version >= [6, 8] then ":set -XTypeOperators -XKindSignatures" else "") :: String -> IO String +:def extensions extensions +:extensions diff --git a/Data/Flex/Applicative.hs b/Data/Flex/Applicative.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Applicative.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolymorphicComponents #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Applicative.hs,v 1.1 2010/03/10 01:56:44 dosuser Exp dosuser $ +module Data.Flex.Applicative where + +class FWApplicative (f :: * -> *) r | f -> r + +data FWDefaultApplicative = FWDefaultApplicative + +data FWPure t (f :: * -> *) = FWPure + +newtype WrapPure f = WrapPure {unwrapPure :: forall a. a -> f a} + +data FWCombine t (f :: * -> *) = FWCombine + +newtype WrapCombine f = + WrapCombine {unwrapCombine :: forall a b. f (a -> b) -> (f a -> f b)} + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Compose.hs b/Data/Flex/Compose.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Compose.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverlappingInstances #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Compose.hs,v 1.14 2010/12/04 01:40:54 dosuser Exp dosuser $ +module Data.Flex.Compose where + +import Control.Monad (liftM, liftM2, join, MonadPlus(..)) +import Control.Monad.Error (Error) +import Control.Monad.Writer (Writer, tell, runWriter) + +import Data.Monoid (Monoid) + +import Data.Type.Apply +import Data.Type.TList + +import Data.Flex.FlipT (FlipT(..)) +import Data.Flex.Monad ( + FWMonad, FWReturn, FWBind, + WrapReturn(..), WrapBind(..), wrapReturn, wrapBind + ) +import Data.Flex.MonadPlus (FWMonadPlus, + FWMZero, WrapMZero(..), + FWMPlus, WrapMPlus(..) + ) +import Data.Flex.MonadTrans (FWMonadTrans, FWLift, WrapLift(..)) +import Data.Flex.Utils (inCompose) +import Data.Flex.Wrap (FlexiWrap(..), FW) +import Data.Flex.WrapCTC (FlexiWrapCTC(..), FWCTC, inFlexiWrapCTC2) + +newtype (f :. g) a = O {unO :: f (g a)} + +type O = (:.) + +inO :: (f (g a) -> f' (g' b)) -> ((f :. g) a -> (f' :. g') b) +inO = inCompose unO O + +inO2 :: (f (g a) -> f' (g' b) -> f'' (g'' c)) -> + ((f :. g) a -> (f' :. g') b -> (f'' :. g'') c) +inO2 = inCompose unO $ inCompose unO O + +flexiCompose :: s -> (forall b. b -> f b) -> g a -> FWCTC s O f g a +flexiCompose _ f ga = FlexiWrapCTC . O $ f ga + +-- Jones/Duponcheel's composition utilities + +returnC :: (Monad m, Monad n) => a -> m (n a) +returnC = return . return + +liftMC :: (Monad f, Monad g) => (a -> b) -> (f (g a) -> f (g b)) +liftMC = liftM . liftM + +open :: FWCTC t O m n a -> m (n a) +open = unO . unFlexiWrapCTC + +close :: m (n a) -> FWCTC t O m n a +close = FlexiWrapCTC . O + +fmapC :: (Monad f, Monad g) => + (a -> b) -> (FWCTC t O f g a -> FWCTC t O f g b) +fmapC f = close . liftMC f . open + +wrapM :: (Monad m, Monad n) => + (m (n (m (n a))) -> m (n a)) -> + (FWCTC t O m n (FWCTC t O m n a) -> FWCTC t O m n a) +wrapM j = close . j . liftMC open . open + +-- and our own utility + +wrapFW :: (Monad m, Monad n) => + (forall a. (m (n (m (n a))) -> m (n a))) -> + WrapBind (FWCTC t O m n) +wrapFW j = wrapBind ((wrapM j .) . flip fmapC) + +-- Jones/Duponcheel's prod construction + +class (Monad m, Monad n) => PComposable m n where + prod :: n (m (n a)) -> m (n a) + +joinP :: PComposable m n => m (n (m (n a))) -> m (n a) +joinP = join . liftM prod + +instance Monad m => PComposable m Maybe where + prod (Just m) = m + prod Nothing = return Nothing + +data FWCompP = FWCompP + +instance FWMonad (FWCTC (FWCompP :*: s) O m n) FWCompP + +instance PComposable m n => + Apply (FWReturn t (O m n)) FWCompP (WrapReturn (FWCTC t O m n)) + where + apply _ _ = wrapReturn (close . returnC) + +instance PComposable m n => + Apply (FWBind t (O m n)) FWCompP (WrapBind (FWCTC t O m n)) + where + apply _ _ = wrapFW joinP + -- apply _ _ = wrapBind ((wrapM joinP .) . flip fmapC) + +-- Jones/Duponcheel's dorp construction + +class (Monad m, Monad n) => DComposable m n where + dorp :: m (n (m a)) -> m (n a) + +joinD :: DComposable m n => m (n (m (n a))) -> m (n a) +joinD = liftM join . dorp + +data FWCompD = FWCompD + +instance FWMonad (FWCTC (FWCompD :*: s) O m n) FWCompD + +instance DComposable m n => + Apply (FWReturn t (O m n)) FWCompD (WrapReturn (FWCTC t O m n)) + where + apply _ _ = wrapReturn (close . returnC) + +instance DComposable m n => + Apply (FWBind t (O m n)) FWCompD (WrapBind (FWCTC t O m n)) + where + apply _ _ = wrapFW joinD + -- apply _ _ = wrapBind ((wrapM joinD .) . flip fmapC) + +instance Monad n => DComposable ((->)r) n where + dorp f r = f r >>= \g -> return (g r) + -- = [ g r | g <- f r ] + +-- Jones/Duponcheel's swap construction + +-- TODO: Left- and right-biased variants (FWCompS{L,R}, SComposable{L,R}) +-- to help reduce boiler-plate instances + +class (Monad m, Monad n) => SComposable m n where + swap :: n (m a) -> m (n a) + +joinS :: SComposable m n => m (n (m (n a))) -> m (n a) +joinS = liftM join . join . liftM swap + +data FWCompS = FWCompS + +instance FWMonad (FWCTC (FWCompS :*: s) O m n) FWCompS + +instance SComposable m n => + Apply (FWReturn t (O m n)) FWCompS (WrapReturn (FWCTC t O m n)) + where + apply _ _ = wrapReturn (close . returnC) + +instance SComposable m n => + Apply (FWBind t (O m n)) FWCompS (WrapBind (FWCTC t O m n)) + where + apply _ _ = wrapFW joinS + -- apply _ _ = wrapBind ((wrapM joinS .) . flip fmapC) + +instance Monad m => SComposable m [] where + swap [] = return [] + swap (x:xs) = x >>= \y -> + swap xs >>= \ys -> + return (y:ys) + -- = [ y:ys | y<-x, ys<-swap xs ] + +instance (Monad m, Monoid s) => SComposable m (Writer s) where + swap wm = do + a <- ma + return $ do + tell s + return a + where + (ma, s) = runWriter wm + {- + swap (Writer (ma, s)) = ma >>= \a -> return (Writer (a, s)) + -- = [ Result s a | a <- ma ] + -} + +-- TODO: Generalise to ... what? +-- MonadError e m => m +-- (doesn't have a sufficiently powerful interface) +instance (Monad m, Error e) => SComposable m (Either e) where + swap (Right m) = liftM Right m + swap (Left msg) = return (Left msg) + +{- +instance (Monad m, MonadError e n) => SComposable m n where + swap m = catchError n ... +-} + +instance Monad m => SComposable m (FW t) where + swap = liftM FlexiWrap . unFlexiWrap + +instance Monad m => SComposable (FW t) m where + swap = FlexiWrap . liftM unFlexiWrap + +-- Resolve overlap +instance SComposable (FW s) (FW t) where + swap = FlexiWrap . liftM unFlexiWrap + +instance Monoid s => SComposable (FW t) (Writer s) where + swap = FlexiWrap . liftM unFlexiWrap + +instance SComposable (FW s) [] where + swap = FlexiWrap . liftM unFlexiWrap + +instance Error e => SComposable (FW s) (Either e) where + swap = FlexiWrap . liftM unFlexiWrap + +data FWCompDefaults = FWCompDefaults + +-- MonadTrans + +data FWCompTrans = FWCompTrans + +instance FWMonadTrans (FWCTC (FWCompTrans :*: s) o f) FWCompTrans +instance FWMonadTrans (FWCTC (FWCompDefaults :*: s) o f) FWCompTrans + +-- TODO: Applicative version? +-- (but *Monad*Trans requires Monad) +instance Monad m => + Apply (FWLift (FWCTC t O m)) FWCompTrans (WrapLift (FWCTC t O m)) + where + apply _ _ = WrapLift (FlexiWrapCTC . O . return) + +instance Monad m => + Apply (FWLift (FWCTC t (FlipT O) m)) FWCompTrans + (WrapLift (FWCTC t (FlipT O) m)) + where + apply _ _ = WrapLift (FlexiWrapCTC . FlipT . O . liftM return) + +-- --- MonadPlus + +data FWCompMonadPlus = FWCompMonadPlus +data FWCompMonadPlusL = FWCompMonadPlusL +data FWCompMonadPlusR = FWCompMonadPlusR + +instance FWMonadPlus (FWCTC (FWCompMonadPlusR :*: s) O m n) FWCompMonadPlusR +instance FWMonadPlus (FWCTC (FWCompMonadPlus :*: s) O m n) FWCompMonadPlusR +instance FWMonadPlus (FWCTC (FWCompDefaults :*: s) O m n) FWCompMonadPlusR + +instance (Monad m, MonadPlus n) => + Apply (FWMZero t (O m n)) FWCompMonadPlusR (WrapMZero (FWCTC t O m n)) + where + apply _ _ = WrapMZero (FlexiWrapCTC . O $ return mzero) + +instance (Monad m, MonadPlus n) => + Apply (FWMPlus t (O m n)) FWCompMonadPlusR (WrapMPlus (FWCTC t O m n)) + where + apply _ _ = WrapMPlus (inFlexiWrapCTC2 . inO2 $ liftM2 mplus) + +instance FWMonadPlus (FWCTC (FWCompMonadPlusL :*: s) O m n) FWCompMonadPlusL + +instance MonadPlus m => + Apply (FWMZero t (O m n)) FWCompMonadPlusL (WrapMZero (FWCTC t O m n)) + where + apply _ _ = WrapMZero (FlexiWrapCTC $ O mzero) + +instance MonadPlus m => + Apply (FWMPlus t (O m n)) FWCompMonadPlusL (WrapMPlus (FWCTC t O m n)) + where + apply _ _ = WrapMPlus (inFlexiWrapCTC2 $ inO2 mplus) + +-- TODO: Remove this - subsumed by FWCompMonadPlus +-- TODO: Maybe :. m +data FWCompMaybeMonadPlus = FWCompMaybeMonadPlus + +instance FWMonadPlus (FWCTC (FWCompMaybeMonadPlus :*: s) O m n) + FWCompMaybeMonadPlus + +instance Monad m => + Apply (FWMZero t (O m Maybe)) FWCompMaybeMonadPlus + (WrapMZero (FWCTC t O m Maybe)) + where + apply _ _ = WrapMZero (FlexiWrapCTC . O $ return Nothing) + +instance Monad m => + Apply (FWMPlus t (O m Maybe)) FWCompMaybeMonadPlus + (WrapMPlus (FWCTC t O m Maybe)) + where + apply _ _ = WrapMPlus (inFlexiWrapCTC2 . inO2 $ liftM2 mplus) + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Examples/Lex/Simple.hs b/Data/Flex/Examples/Lex/Simple.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Examples/Lex/Simple.hs @@ -0,0 +1,43 @@ +module Data.Flex.Examples.Lex.Simple where + +data Basic c = BSimple c + -- | range | set | ... + deriving Show + +data BSingle b = SSimple b | b `SOr` BSingle b + deriving Show + +infixr 9 `SOr` + +type Single c = BSingle (Basic c) + +data Simple f c = TSimple { + simpleSingle :: (Single c) + ,simpleNext :: f + } + deriving Show + +newtype Once f c = SOnce {unSOnce :: Simple f c} + deriving Show +newtype Repeat f c = SRepeat {unSRepeat :: Simple f c} + deriving Show + +data Lex c a + = LNil + | LDone a + | LRepeat (Repeat (Lex c a) c) + | Once (Lex c a) c `LOr` Lex c a + deriving Show + +infixr 9 `LOr` + +type DiffList c = [c] -> [c] + +singleMatch :: Eq c => Single c -> c -> Bool +singleMatch (SSimple c1) c2 = basicMatch c1 c2 +singleMatch (s1 `SOr` s2) c = basicMatch s1 c || singleMatch s2 c + +basicMatch :: Eq c => Basic c -> c -> Bool +basicMatch (BSimple c1) c2 = c1 == c2 + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Examples/Lex/Strict.hs b/Data/Flex/Examples/Lex/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Examples/Lex/Strict.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fcontext-stack=25 #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/Examples/Lex/RCS/Strict.hs,v 1.8 2011/02/16 00:58:48 dosuser Exp dosuser $ +module Data.Flex.Examples.Lex.Strict where + +import Control.Applicative (Applicative(..), (<$>), Alternative(..), + liftA2 + ) +import Control.Monad (join, ap, liftM, MonadPlus(..)) +import Control.Monad.State ( + StateT(..), MonadState(..), modify, gets, evalStateT + ) +import Control.Monad.Trans (MonadTrans(..)) + +import Data.Char (ord) +import Data.Foldable as F (Foldable(..)) +import Data.Maybe (fromJust) +-- isJust, catMaybes, +import Data.List (delete) + +import Data.Flex.Compose ((:.)(..), O, + FWCompP, FWCompS, FWCompDefaults, FWCompMonadPlusL + ) +import Data.Flex.FlipT (FlipT(..), FWFlipDefaults, FWFlipMonad) +import Data.Flex.Wrap (FW, FlexiWrap(..)) +import Data.Flex.WrapCTC (FlexiWrapCTC(..), FWCTC) +import Data.Flex.WrappedMonad (FWMonadApplicative, FWWrapMonad) +import Data.Flex.WrapT (FlexiWrapT(..), FWT, inFlexiWrapT2, FWTDefaultMonadAll) + +import Data.Flex.Examples.Lex.Simple + +import Data.Type.TList + +import Test.QuickCheck + +data FWStrict = FWStrict + +type Strict = FW (FWStrict :*: TNil) + +strict :: a -> Strict a +strict = FlexiWrap + +type StrictT = FWCTC + (FWFlipDefaults :*: + FWCompMonadPlusL :*: FWCompDefaults :*: FWCompS :*: TNil + ) + (FlipT O) Strict + +strictT :: f (Strict a) -> StrictT f a +strictT = FlexiWrapCTC . FlipT . O + +unStrictT :: StrictT f a -> f (Strict a) +unStrictT = unO . unFlipT . unFlexiWrapCTC + +type MaybeT = FWCTC + (FWFlipDefaults :*: FWCompDefaults :*: FWCompP :*: TNil) + (FlipT O) Maybe + +-- maybeT :: Monad f => f (Maybe a) -> MaybeT f a +maybeT :: f (Maybe a) -> MaybeT f a +maybeT = FlexiWrapCTC . FlipT . O + +unMaybeT :: MaybeT f a -> f (Maybe a) +unMaybeT = unO . unFlipT . unFlexiWrapCTC + +type StrictMaybeT f = StrictT (MaybeT f) + +{- + StrictMaybeT f x == + StrictT (MaybeT f) x == + FWCTC tag (FlipT O) Strict (MaybeT f) x ~ + O (MaybeT f) Strict x ~ + MaybeT f (Strict x) == + FWCTC tag (FlipT O) Maybe f (Strict x) ~ + O f Maybe (Strict x) ~ + f (Maybe (Strict x)) +-} + +type WStateT s m = + FWT (FWWrapMonad :*: FWTDefaultMonadAll :*: TNil) (StateT s m) + +type StrictMaybeStateGen s = WStateT s (StrictMaybeT Gen) + +{- +instance Monad m => Applicative (WStateT s m) where + pure = FlexiWrapT . return + (<*>) = inFlexiWrapT2 ap +-} + +-- instance (MonadPlus m, Applicative (WStateT s m)) => +instance MonadPlus m => + Alternative (WStateT s m) where + empty = FlexiWrapT . StateT $ \s -> flip (,) s `liftM` mzero + -- a <|> b = (<|>) <$> a <*> b + a <|> b = FlexiWrapT . StateT $ \s -> + runStateT (unFlexiWrapT a) s `mplus` runStateT (unFlexiWrapT b) s + +{- +-- instance (Monad m, Monad (WStateT s m)) => MonadState s (WStateT s m) where +instance Monad m => MonadState s (WStateT s m) where + -- and/or Monad (WStateT s m), Monad m + get = lift get + put = lift . put +-} + +-- class Monad m => MonadGen m where +class MonadGen m where + liftGen :: Gen a -> m a + +instance MonadGen Gen where + liftGen = id + +-- instance (MonadTrans t, MonadGen m, Monad (t m)) => MonadGen (t m) where +instance (MonadTrans t, Monad m, MonadGen m) => MonadGen (t m) where + liftGen = lift . liftGen + +{- +-- instance (MonadGen m, Monad (WStateT s m)) => MonadGen (WStateT s m) where +instance (Monad m, MonadGen m) => MonadGen (WStateT s m) where + liftGen = lift . lift . liftGen +-} + +class MonadMaybe m where + liftMaybe :: Maybe a -> m a + +instance MonadMaybe Maybe where + liftMaybe = id + +instance Monad m => MonadMaybe (MaybeT m) where + liftMaybe = maybeT . return + +instance (Monad m, MonadMaybe m) => MonadMaybe (StrictT m) where + liftMaybe = lift . liftMaybe + +instance (Monad m, MonadMaybe m) => MonadMaybe (WStateT s m) where + liftMaybe = lift . lift . liftMaybe + +lexAlphabet = "abcde" +lexIndex :: Char -> Int +lexIndex c + | 'a' <= c && c <= 'e' = ord c - ord 'a' + | otherwise = error "lexAlphabet character out of range" + +-- strictMaybeBasic :: (Eq c, MonadState [c] (StrictMaybeStateGen [c])) => +strictMaybeBasic :: Eq c => + StrictMaybeStateGen [c] (Basic c) +strictMaybeBasic = do + c <- join $ gets select + modify $ delete c + return $ BSimple c + where + -- select :: (Eq c, Monad (StrictMaybeStateGen [c])) => + -- select :: Eq c => + select :: + [c] -> StrictMaybeStateGen [c] c + select [] = liftMaybe Nothing + select l = liftGen $ elements l + +{- +-- This clashes with any generic Arbitrary (Maybe a) instance +instance Arbitrary (Maybe (Strict (Basic Char))) where + arbitrary = unMaybeT . unStrictT $ evalStateT strictMaybeBasic lexAlphabet + coarbitrary Nothing = variant 0 + coarbitrary (Just (FlexiWrap (BSimple c))) = variant $ 1 + lexIndex c +-} + +instance Arbitrary ((Maybe :. Strict) (Basic Char)) where + arbitrary = fmap O . unMaybeT . unStrictT $ + evalStateT (unFlexiWrapT strictMaybeBasic) lexAlphabet + coarbitrary (O Nothing) = variant 0 + coarbitrary (O (Just (FlexiWrap (BSimple c)))) = variant $ 1 + lexIndex c + +{- +sizedStrictMaybeBSingle :: ( + Eq c, Applicative (StrictMaybeStateGen [c]), + Monad (StrictMaybeStateGen [c]) + ) => +-} +sizedStrictMaybeBSingle :: Eq c => Int -> StrictMaybeStateGen [c] (Single c) +sizedStrictMaybeBSingle 0 = SSimple <$> strictMaybeBasic +sizedStrictMaybeBSingle n | n > 0 = + (SOr <$> strictMaybeBasic <*> sizedStrictMaybeBSingle (n - 1)) + <|> + sizedStrictMaybeBSingle 0 + +{- +-- This clashes with any generic Arbitrary (Maybe a) instance +instance Arbitrary (Maybe (Strict (Single Char))) where + arbitrary = sized $ unMaybeT . unStrictT . + flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeBSingle + coarbitrary Nothing = variant 0 + coarbitrary (Just (FlexiWrap (SSimple b))) = + variant 1 . coarbitrary (O . Just $ strict b) + coarbitrary (Just (FlexiWrap (b `SOr` c))) = variant 2 . + coarbitrary (O . Just $ strict b) . coarbitrary (O . Just $ strict c) +-} + +instance Arbitrary ((Maybe :. Strict) (Single Char)) where + arbitrary = fmap O . sized $ unMaybeT . unStrictT . + flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeBSingle + coarbitrary (O Nothing) = variant 0 + coarbitrary (O (Just (FlexiWrap (SSimple b)))) = + variant 1 . coarbitrary (O . Just $ strict b) + coarbitrary (O (Just (FlexiWrap (b `SOr` c)))) = variant 2 . + coarbitrary (O . Just $ strict b) . coarbitrary (O . Just $ strict c) + +liftStrictMaybe :: ( + MonadTrans t, MonadTrans u, Monad f, Monad (u (StrictT (MaybeT f))) + ) => + f (Maybe (Strict a)) -> t (u (StrictT (MaybeT f))) a +liftStrictMaybe = lift . lift . strictT . maybeT + +{- +sizedStrictMaybeSimple :: (Eq c, + -- Arbitrary (Maybe (Strict s)) + Arbitrary (Strict s), + Applicative (StrictMaybeStateGen [c]), + Monad (StrictMaybeStateGen [c]) + ) => +-} +sizedStrictMaybeSimple :: (Eq c, + -- Arbitrary (Maybe (Strict s)) + Arbitrary (Strict s) + ) => + Int -> StrictMaybeStateGen [c] (Simple s c) +sizedStrictMaybeSimple n = TSimple <$> sizedStrictMaybeBSingle n2 <*> + liftStrictMaybe (fmap Just $ resize n2 arbitrary) + where n2 = n `div` 2 + +{- +-- This clashes with any generic Arbitrary (Maybe a) instance +instance + -- Arbitrary (Maybe (Strict s)) + Arbitrary (Strict s) + => + Arbitrary (Maybe (Strict (Simple s Char))) + where + arbitrary = sized $ unMaybeT . unStrictT . + flip evalStateT lexAlphabet . sizedStrictMaybeSimple + coarbitrary Nothing = variant 0 + coarbitrary (Just (FlexiWrap (TSimple b l))) = variant 1 . + coarbitrary (O . Just $ strict b) . coarbitrary (strict l) +-} + +instance + Arbitrary (Strict s) + => + Arbitrary ((Maybe :. Strict) (Simple s Char)) + where + arbitrary = fmap O . sized $ unMaybeT . unStrictT . + flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeSimple + coarbitrary (O Nothing) = variant 0 + coarbitrary (O (Just (FlexiWrap (TSimple b l)))) = variant 1 . + coarbitrary (O . Just $ strict b) . coarbitrary (strict l) + +{- +sizedStrictMaybeLex :: ( + Eq c, Arbitrary a, + -- Arbitrary (Maybe (Strict (Lex c a))) + Arbitrary (Strict (Lex c a)), + Applicative (StrictMaybeStateGen [c]), + Monad (StrictMaybeStateGen [c]) + ) => +-} +sizedStrictMaybeLex :: ( + Eq c, Arbitrary a, + -- Arbitrary (Maybe (Strict (Lex c a))) + Arbitrary (Strict (Lex c a)) + ) => + Int -> StrictMaybeStateGen [c] (Lex c a) +sizedStrictMaybeLex 0 = sequence [ + return LNil + , LDone <$> liftGen arbitrary + ] >>= liftGen . elements +sizedStrictMaybeLex n | n > 0 = catAlternatives [ + LRepeat . SRepeat <$> sizedStrictMaybeSimple (n - 1) + , LOr . SOnce <$> sizedStrictMaybeSimple n2 <*> + sizedStrictMaybeLex n2 + ] >>= select + where + n2 = n `div` 2 + select [] = sizedStrictMaybeLex 0 + select l = liftGen $ elements l + +catAlternatives :: (Foldable f, Alternative g) => f (g b) -> g [b] +catAlternatives = F.foldr merge (pure []) where + merge b bs = liftA2 (:) b bs <|> bs + +instance Arbitrary a => Arbitrary (Strict (Lex Char a)) where + arbitrary = alphabetSizedStrictLex lexAlphabet + coarbitrary (FlexiWrap LNil) = variant 0 + coarbitrary (FlexiWrap (LDone a)) = variant 1 . coarbitrary a + coarbitrary (FlexiWrap (LRepeat (SRepeat s))) = variant 2 . + coarbitrary (O . Just $ strict s) + coarbitrary (FlexiWrap (SOnce s `LOr` l)) = variant 3 . + coarbitrary (O . Just $ strict s) . coarbitrary (strict l) + +{- +alphabetSizedStrictLex :: ( + Eq c, Arbitrary a, + -- Arbitrary (Maybe (Strict (Lex c a))) + Arbitrary (Strict (Lex c a)), + Applicative (StrictMaybeStateGen [c]), + Monad (StrictMaybeStateGen [c]) + ) => +-} +alphabetSizedStrictLex :: ( + Eq c, Arbitrary a, + -- Arbitrary (Maybe (Strict (Lex c a))) + Arbitrary (Strict (Lex c a)) + ) => + [c] -> Gen (Strict (Lex c a)) +alphabetSizedStrictLex alphabet = sized $ fmap fromJust . + unMaybeT . unStrictT . flip evalStateT alphabet . + unFlexiWrapT . sizedStrictMaybeLex + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/FlipT.hs b/Data/Flex/FlipT.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/FlipT.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/FlipT.hs,v 1.8 2010/11/27 00:41:20 dosuser Exp dosuser $ +module Data.Flex.FlipT where + +import Control.Monad (MonadPlus(..)) + +import Data.Type.Apply (Apply(..)) +import Data.Type.TList ((:*:)) + +import Data.Flex.Monad ( + FWMonad, FWReturn, WrapReturn, wrapReturn, FWBind, WrapBind, wrapBind + ) +import Data.Flex.MonadPlus (FWMonadPlus, + FWMZero, WrapMZero(..), FWMPlus, WrapMPlus(..) + ) +import Data.Flex.WrapCTC (FWCTC, inFlexiWrapCTC) + +import Data.Flex.Utils (bindWrapper, inCompose) + +newtype FlipT (*.) (f :: * -> *) (g :: * -> *) a = + FlipT {unFlipT :: (g *. f) a} + +inFlipT :: ((g *. f) a -> (g' ?. f') a') -> + (FlipT (*.) f g a -> FlipT (?.) f' g' a') +inFlipT = inCompose unFlipT FlipT + +inFlipT2 :: ((g *. f) a -> (g' ?. f') a' -> (g'' @. f'') a'') -> + (FlipT (*.) f g a -> FlipT (?.) f' g' a' -> FlipT (@.) f'' g'' a'') +inFlipT2 = inCompose unFlipT inFlipT +-- inFlipT2 = inCompose unFlipT $ inCompose unFlipT FlipT + +data FWFlipDefaults = FWFlipDefaults + +data FWFlipMonad = FWFlipMonad + +instance FWMonad (FWCTC (FWFlipMonad :*: s) (FlipT o) f g) FWFlipMonad +instance FWMonad (FWCTC (FWFlipDefaults :*: s) (FlipT o) f g) FWFlipMonad + +instance Monad (FWCTC t o g f) => + Apply (FWReturn t (FlipT o f g)) FWFlipMonad + (WrapReturn (FWCTC t (FlipT o) f g)) + where + apply _ _ = wrapReturn (inFlexiWrapCTC FlipT . return) + +instance Monad (FWCTC t o g f) => + Apply (FWBind t (FlipT o f g)) FWFlipMonad + (WrapBind (FWCTC t (FlipT o) f g)) + where + apply _ _ = wrapBind ( + bindWrapper (inFlexiWrapCTC unFlipT) (inFlexiWrapCTC FlipT) (>>=) + ) + +data FWFlipMonadPlus = FWFlipMonadPlus + +instance FWMonadPlus (FWCTC (FWFlipMonadPlus :*: s) (FlipT o) f g) + FWFlipMonadPlus +instance FWMonadPlus (FWCTC (FWFlipDefaults :*: s) (FlipT o) f g) + FWFlipMonadPlus + +instance MonadPlus (FWCTC t o g f) => + Apply (FWMZero t (FlipT o f g)) FWFlipMonadPlus + (WrapMZero (FWCTC t (FlipT o) f g)) + where + apply _ _ = WrapMZero (inFlexiWrapCTC FlipT mzero) + +instance MonadPlus (FWCTC t o g f) => + Apply (FWMPlus t (FlipT o f g)) FWFlipMonadPlus + (WrapMPlus (FWCTC t (FlipT o) f g)) + where + apply _ _ = WrapMPlus + (inCompose2R (inFlexiWrapCTC unFlipT) (inFlexiWrapCTC FlipT) mplus) + where + inCompose2R :: (forall a. p a -> q a) -> (q d -> e) -> + (q b -> q c -> q d) -> + (p b -> p c -> e) + inCompose2R down up = inCompose down $ inCompose down up + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Functor.hs b/Data/Flex/Functor.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Functor.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables, PolymorphicComponents #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Functor.hs,v 1.2 2010/03/12 23:46:00 dosuser Exp dosuser $ +module Data.Flex.Functor where + +class FWFunctor (f :: * -> *) r | f -> r + +data FWDefaultFunctor = FWDefaultFunctor + +data FWFmap t (f :: * -> *) = FWFmap + +newtype WrapFmap f = + WrapFmap {unwrapFmap :: forall a b. (a -> b) -> (f a -> f b)} + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Monad.hs b/Data/Flex/Monad.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Monad.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Monad.hs,v 1.1 2010/03/10 01:57:35 dosuser Exp dosuser $ +module Data.Flex.Monad where + +-- import Data.Flex.Applicative (WrapPure(..)) + +class FWMonad (m :: * -> *) r | m -> r + +data FWDefaultMonad = FWDefaultMonad + +data FWReturn t (m :: * -> *) = FWReturn + +newtype WrapReturn m = WrapReturn {unwrapReturn :: forall a. a -> m a} +wrapReturn :: (forall a. a -> m a) -> WrapReturn m +wrapReturn = WrapReturn +{- GHC 6.6.1 can't cope with this version of unwrapReturn +type WrapReturn = WrapPure +wrapReturn :: (forall a. a -> m a) -> WrapReturn m +wrapReturn = WrapPure +unwrapReturn :: WrapReturn m -> (forall a. a -> m a) +unwrapReturn = unwrapPure +-} + +data FWBind t (m :: * -> *) = FWBind + +newtype WrapBind m = + WrapBind {unwrapBind :: forall a b. m a -> (a -> m b) -> m b} + +wrapBind :: (forall a b. m a -> (a -> m b) -> m b) -> WrapBind m +wrapBind = WrapBind + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/MonadPlus.hs b/Data/Flex/MonadPlus.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/MonadPlus.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables, PolymorphicComponents #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +-- .$Header$ +module Data.Flex.MonadPlus where + +class FWMonadPlus (m :: * -> *) r | m -> r + +data FWDefaultMonadPlus = FWDefaultMonadPlus + +data FWMZero t (m :: * -> *) = FWMZero + +newtype WrapMZero m = WrapMZero {unwrapMZero :: forall a. m a} + +data FWMPlus t (m :: * -> *) = FWMPlus + +newtype WrapMPlus m = WrapMPlus {unwrapMPlus :: forall a. m a -> m a -> m a} + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/MonadState.hs b/Data/Flex/MonadState.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/MonadState.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables, PolymorphicComponents #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +-- .$Header$ +module Data.Flex.MonadState where + +class FWMonadState (m :: * -> *) r | m -> r + +data FWDefaultMonadState = FWDefaultMonadState + +data FWGet t s (m :: * -> *) = FWGet + +{- +newtype WrapGet s m = WrapGet {unwrapGet :: m s} +-} + +data FWPut t s (m :: * -> *) = FWPut + +{- +newtype WrapPut s m = WrapPut {unwrapPut :: s -> m ()} +-} + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/MonadTrans.hs b/Data/Flex/MonadTrans.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/MonadTrans.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ScopedTypeVariables, PolymorphicComponents #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/MonadTrans.hs,v 1.2 2010/03/12 23:46:34 dosuser Exp dosuser $ +module Data.Flex.MonadTrans where + +class FWMonadTrans (f :: (* -> *) -> (* -> *)) a | f -> a + +data FWDefaultMonadTrans = FWDefaultMonadTrans + +data FWLift (t :: (* -> *) -> (* -> *)) + +newtype WrapLift t = + WrapLift {unwrapLift :: forall m a. Monad m => m a -> t m a} + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/SmallCheck/Wrap.hs b/Data/Flex/SmallCheck/Wrap.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/SmallCheck/Wrap.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +-- $Header: c:/Source/Haskell/Wrapper/Data/Flex/SmallCheck/RCS/Wrap.hs,v 1.2 2010/03/13 00:11:09 dosuser Exp dosuser $ +module Data.Flex.SmallCheck.Wrap where + +import Test.SmallCheck + +{- +import Control.Applicative ((<$>)) + +import Data.Wrap (result, argument) +-} + +import Data.Type.Apply (Apply(..)) +import Data.Type.Eq (TypeCast) +import Data.Type.TList ((:*:), TNil) + +import Data.Flex.Wrap + +{- +import Data.Flex.SmallCheck.Instances +-} + +data X = X + +prop_default_Eq_is_Eq x y = (x == y) == (w x == w y) where + w = fWrap X :: Bool -> FW (X :*: TNil) Bool + types = x :: Bool + +data FWEqFirst = FWEqFirst + +instance TypeCast r FWEqFirst => FWEq (FW (FWEqFirst :*: s) a) r + +instance Eq a => + Apply (FWEquals t (a, b)) FWEqFirst (FW t (a, b) -> FW t (a, b) -> Bool) + where + apply _ _ = (==) `on` fst . unFlexiWrap + +instance Eq a => + Apply (FWNotEquals t (a, b)) FWEqFirst (FW t (a, b) -> FW t (a, b) -> Bool) + where + apply _ _ = (/=) `on` fst `on` unFlexiWrap + +prop_EqFirst_is_Eq_fst x y = (x `eqFst` y) == (w x == w y) where + eqFst = (==) `on` fst + w = FlexiWrap :: (Bool, Bool) -> FW (FWEqFirst :*: TNil) (Bool, Bool) + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Test/Compose.hs b/Data/Flex/Test/Compose.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Test/Compose.hs @@ -0,0 +1,267 @@ +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/Test/RCS/Compose.hs,v 1.5 2010/04/24 00:59:15 dosuser Exp dosuser $ +module Data.Flex.Test.Compose where + +import Control.Monad (MonadPlus(..)) +import Control.Monad.Trans (lift) +import Control.Monad.Writer (Writer) + +import Data.Char (chr) + +import Data.Type.TList ((:*:), TNil) + +import Data.Flex.Compose +import Data.Flex.FlipT (FlipT(..), FWFlipMonad, FWFlipMonadPlus) +import Data.Flex.Wrap (FW, FlexiWrap(..), fWrap) +import Data.Flex.WrapCTC (FWCTC) + +chrM :: Monad m => Int -> m Char +chrM = return . chr + +data Tag1 = Tag1 +type Tag1W = FW (Tag1 :*: TNil) + +type Tag1T = FWCTC (FWCompMonadPlus :*: FWCompTrans :*: FWCompS :*: TNil) + O Tag1W + +type M1 = Tag1T Maybe +-- Monad +t0 :: M1 Int +t0 = return 65 +t1 :: M1 Int -> (Int -> M1 Char) -> M1 Char +t1 = (>>=) +t2 :: M1 Char +t2 = t1 t0 $ return . chr + +-- MonadTrans +t3 :: M1 Int +t3 = lift $ Just 0 + +-- MonadPlus +t3a :: M1 Int +t3a = mzero +t3b :: M1 Int +t3b = t3a `mplus` t0 + +type ReaderT1 r = FWCTC (FWCompDefaults :*: FWCompD :*: TNil) O ((->) r) +type ReaderT2 = ReaderT1 Int + +type M2 = ReaderT2 Maybe +-- Monad +t4 :: M2 Int +t4 = return 65 +t5 :: M2 Int -> (Int -> M2 Char) -> M2 Char +t5 = (>>=) +t6 :: M2 Char +t6 = t5 t4 $ return . chr + +-- MonadTrans +t7 :: M2 Int +t7 = lift $ Just 0 + +-- MonadPlus +t7a :: M2 Int +t7a = mzero +t7b :: M2 Int +t7b = t7a `mplus` t4 + +data Tag2 = Tag2 +type Tag2W = FW (Tag2 :*: TNil) + +type M3 = Tag1T Tag2W +-- Monad +t8 :: M3 Int +t8 = return 65 +t9 :: M3 Int -> (Int -> M3 Char) -> M3 Char +t9 = (>>=) +t10 :: M3 Char +t10 = t9 t8 $ return . chr + +-- MonadTrans +t11 :: Tag2W Int +t11 = FlexiWrap 0 +t12 :: M3 Int +t12 = lift t11 + +-- PComposable m Maybe +type M4 = FWCTC (FWCompMaybeMonadPlus :*: FWCompP :*: TNil) O Tag1W Maybe +-- Monad +t13 :: M4 Int +t13 = return 65 +t14 :: M4 Int -> (Int -> M4 Char) -> M4 Char +t14 = (>>=) +t15 :: M4 Char +t15 = t14 t13 $ return . chr + +-- MonadPlus +t15a :: M4 Int +t15a = mzero +t15b :: M4 Int +t15b = t15a `mplus` t13 + +type M5 = Tag1T [] +-- Monad +t16 :: M5 Int +t16 = return 65 +t17 :: M5 Int -> (Int -> M5 Char) -> M5 Char +t17 = (>>=) +t18 :: M5 Char +t18 = t17 t16 $ return . chr + +-- MonadTrans +t18a :: M5 Int +t18a = lift [] + +-- MonadPlus +t18b :: M5 Int +t18b = mzero +t18c :: M5 Int +t18c = t18b `mplus` t16 + +type M6 = Tag1T (Either String) +-- Monad +t19 :: M6 Int +t19 = return 65 +t20 :: M6 Int -> (Int -> M6 Char) -> M6 Char +t20 = (>>=) +t21 :: M6 Char +t21 = t20 t19 $ return . chr + +-- MonadTrans +t21a :: M6 Int +t21a = lift $ Right 0 + +-- MonadPlus +t21b :: M6 Int +t21b = mzero +t21c :: M6 Int +t21c = t21b `mplus` t19 + +type M7 = Tag1T (Writer [String]) +-- Monad +t22 :: M7 Int +t22 = return 65 +t23 :: M7 Int -> (Int -> M7 Char) -> M7 Char +t23 = (>>=) +t24 :: M7 Char +t24 = t23 t22 $ return . chr + +-- MonadTrans +t25 :: M7 Int +t25 = lift $ return 0 + +-- Flip(ped) instances +type MaybeT = FWCTC + (FWFlipMonadPlus :*: FWFlipMonad :*: + FWCompMonadPlus :*: FWCompTrans :*: FWCompP :*: TNil + ) + (FlipT O) Maybe + +type M8 = MaybeT Tag1W +-- Monad +t26 :: M8 Int +t26 = return 65 +t27 :: M8 Int -> (Int -> M8 Char) -> M8 Char +t27 = (>>=) +t28 :: M8 Char +t28 = t27 t26 $ return . chr + +-- MonadTrans +t29 :: Tag1W Int +t29 = FlexiWrap 0 +t30 :: M8 Int +t30 = lift t29 + +-- MonadPlus +t30a :: M8 Int +t30a = mzero +t31a :: M8 Int +t31a = t30a `mplus` t26 + +type ListT = + FWCTC (FWFlipMonad :*: FWCompTrans :*: FWCompS :*: TNil) (FlipT O) [] + +type M9 = ListT Tag1W +-- Monad +t31 :: M9 Int +t31 = return 65 +t32 :: M9 Int -> (Int -> M9 Char) -> M9 Char +t32 = (>>=) +t33 :: M9 Char +t33 = t32 t31 $ return . chr + +-- MonadTrans +t34 :: Tag1W Int +t34 = return 0 +t35 :: M9 Int +t35 = lift t34 + +type WriterT = FWCTC (FWFlipMonad :*: FWCompTrans :*: FWCompS :*: TNil) + (FlipT O) (Writer [String]) + +type M10 = WriterT Tag1W +-- Monad +t36 :: M10 Int +t36 = return 65 +t37 :: M10 Int -> (Int -> M10 Char) -> M10 Char +t37 = (>>=) +t38 :: M10 Char +t38 = t37 t36 chrM + +-- MonadTrans +t39 :: Tag1W Int +t39 = t34 +t40 :: M10 Int +t40 = lift t39 + +type EitherT = FWCTC (FWFlipMonad :*: FWCompTrans :*: FWCompS :*: TNil) + (FlipT O) (Either String) + +type M11 = EitherT Tag1W +-- Monad +t41 :: M11 Int +t41 = return 65 +t42 :: M11 Int -> (Int -> M11 Char) -> M11 Char +t42 = (>>=) +t43 :: M11 Char +t43 = t42 t41 chrM + +-- MonadTrans +t44 :: Tag1W Int +t44 = t34 +t45 :: M11 Int +t45 = lift t44 + +type Tag1FT = FWCTC (FWFlipMonad :*: FWCompTrans :*: FWCompS :*: TNil) + (FlipT O) Tag1W + +type M12 = Tag1FT Tag2W +-- Monad +t46 :: M12 Int +t46 = return 65 +t47 :: M12 Int -> (Int -> M12 Char) -> M12 Char +t47 = (>>=) +t48 :: M12 Char +t48 = t47 t46 chrM + +-- MonadTrans +t49 :: Tag2W Int +t49 = return 0 +t50 :: M12 Int +t50 = lift t49 + +type M13 = Tag1FT Maybe +-- Monad +t51 :: M13 Int +t51 = return 65 +t52 :: M13 Int -> (Int -> M13 Char) -> M13 Char +t52 = (>>=) +t53 :: M13 Char +t53 = t52 t51 chrM + +-- MonadTrans +t54 :: Maybe Int +t54 = return 0 +t55 :: M13 Int +t55 = lift t54 + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Test/Wrap.hs b/Data/Flex/Test/Wrap.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Test/Wrap.hs @@ -0,0 +1,43 @@ +-- $Header: c:/Source/Haskell/Wrapper/Data/Flex/Test/RCS/Wrap.hs,v 1.4 2010/02/05 00:39:46 dosuser Exp dosuser $ +module Data.Flex.Test.Wrap where + +import Data.Flex.Wrap +import Data.Flex.WrapT + +import Data.Type.TList + +data X = X + +t8 :: FW TNil () +t8 = fWrap TNil () +t9 :: FW (X :*: TNil) () +t9 = fWrap X () +t10 :: FW (X :*: TNil) () +t10 = fWrap (X :*: TNil) () + +t11 :: FW TNil () +t11 = fWrap TNil t8 +t12 :: FW (X :*: TNil) () +t12 = fWrap TNil t9 +t13 :: FW (X :*: TNil) () +t13 = fWrap X t8 +t14 :: FW (X :*: TNil) () +t14 = fWrap (X :*: TNil) t8 + +t15 :: FWT TNil Maybe () +t15 = fWrapT TNil $ Just () +t16 :: FWT (X :*: TNil) Maybe () +t16 = fWrapT X $ Just () +t17 :: FWT (X :*: TNil) Maybe () +t17 = fWrapT (X :*: TNil) $ Just () + +t18 :: FWT TNil Maybe () +t18 = fWrapT TNil t15 +t19 :: FWT (X :*: TNil) Maybe () +t19 = fWrapT TNil t16 +t20 :: FWT (X :*: TNil) Maybe () +t20 = fWrapT X t15 +t21 :: FWT (X :*: TNil) Maybe () +t21 = fWrapT (X :*: TNil) t15 + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Test/WrappedMonad.hs b/Data/Flex/Test/WrappedMonad.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Test/WrappedMonad.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +-- .$Header$ +module Data.Flex.Test.WrappedMonad where + +import Control.Applicative (Applicative(..)) + +import Test.QuickCheck (Gen, Arbitrary(..)) + +import Data.Type.TList + +import Data.Flex.Utils (bindWrapper) +import Data.Flex.WrapT (FWT, fWrapT) +import Data.Flex.WrappedMonad + +t0 :: FWT (FWMonadApplicative :*: TNil) Gen Int +t0 = fWrapT FWMonadApplicative arbitrary +t1 :: FWT (FWMonadApplicative :*: TNil) Gen Int +t1 = pure 0 +t2 :: FWT (FWMonadApplicative :*: TNil) Gen Int +t2 = pure succ <*> t0 + +newtype TestMonad m a = TM {unTM :: m a} + +app_prec = 10 + +instance Show (m a) => Show (TestMonad m a) where + showsPrec d (TM w) = showParen (d > app_prec) $ + showString "TM " . showsPrec (app_prec+1) w + +instance Monad m => Monad (TestMonad m) where + return = TM . return + (>>=) = bindWrapper unTM TM (>>=) + +t3 :: FWT (FWMonadFunctor :*: TNil) (TestMonad []) Int +t3 = fWrapT FWMonadFunctor $ TM [0] +t4 :: FWT (FWMonadFunctor :*: TNil) (TestMonad []) Int +t4 = fmap succ t3 +t5 :: FWT (FWMonadFunctor :*: TNil) (TestMonad Maybe) Int +t5 = fWrapT FWMonadFunctor . TM $ Just 0 +t6 :: FWT (FWMonadFunctor :*: TNil) (TestMonad Maybe) Int +t6 = fmap succ t5 + +t7 :: FWT (FWWrapMonad :*: TNil) (TestMonad []) Int +t7 = fWrapT FWWrapMonad $ TM [0] +t8 :: FWT (FWWrapMonad :*: TNil) (TestMonad []) Int +t8 = fmap succ t7 +t9 :: FWT (FWWrapMonad :*: TNil) (TestMonad Maybe) Int +t9 = pure 0 +t10 :: FWT (FWWrapMonad :*: TNil) (TestMonad Maybe) Int +t10 = pure succ <*> t9 + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Utils.hs b/Data/Flex/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Utils.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Utils.hs,v 1.1 2010/11/26 23:54:58 dosuser Exp dosuser $ +module Data.Flex.Utils (inCompose, inCompose2, bindWrapper) where + +circumpose :: (c -> d) -> (a -> b) -> (b -> c) -> (a -> d) +circumpose left right = (left .) . (. right) + +inCompose :: (a -> b) -> (c -> d) -> (b -> c) -> (a -> d) +inCompose = flip circumpose + +inCompose2 :: (forall a. f a -> a) -> (d -> e) -> + (b -> c -> d) -> (f b -> f c -> e) +inCompose2 unwrap wrap = inCompose unwrap $ inCompose unwrap wrap + +result :: (b -> c) -> (a -> b) -> (a -> c) +result = (.) + +-- Utility function to construct (>>=) for a target monad from the (>>=) +-- for an implementation monad +-- Parameters: +-- wrap: function from target monad to implementation monad (t a -> i a) +-- unwrap: vice versa (i a -> t a) +bindWrapper :: (forall q. f q -> g q) -> (d -> e) -> (g a -> (c -> g b) -> d) -> + f a -> (c -> f b) -> e +bindWrapper wrap unwrap = inCompose wrap $ inCompose (result wrap) unwrap + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/Wrap.hs b/Data/Flex/Wrap.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/Wrap.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Wrap.hs,v 1.13 2010/04/24 00:47:40 dosuser Exp dosuser $ +module Data.Flex.Wrap where + +import Control.Applicative (Applicative(..)) + -- , (<$>), liftA2, Alternative(..)) + +import Data.Foldable as F (Foldable(..)) +import qualified Data.Traversable as T (Traversable(..)) + +import Data.Type.Apply (Apply(..)) +import Data.Type.Eq (TypeCast) +import Data.Type.TList ((:*:), TNil) + +import Data.Flex.Utils (inCompose, inCompose2) + +-- begin FlexiWrap + +newtype FlexiWrap s a = FlexiWrap {unFlexiWrap :: a} + +type FW = FlexiWrap + +flexiWrap :: s -> a -> FW s a +flexiWrap _ = FlexiWrap + +inFlexiWrap :: (a -> b) -> (FW s a -> FW s b) +inFlexiWrap = inCompose unFlexiWrap FlexiWrap + +inFlexiWrap2 :: (a -> b -> c) -> (FW s a -> FW s b -> FW s c) +-- inFlexiWrap2 = inCompose unFlexiWrap $ inCompose unFlexiWrap FlexiWrap +inFlexiWrap2 = inCompose2 unFlexiWrap FlexiWrap + +-- TODO: Use flexible instance machinery + +instance Functor (FW t) where + fmap = inFlexiWrap + +instance Applicative (FW t) where + pure = FlexiWrap + (<*>) = inFlexiWrap . unFlexiWrap + +instance F.Foldable (FW t) where + foldr f z (FlexiWrap a) = f a z + +instance T.Traversable (FW t) where + traverse = (fmap FlexiWrap .) . (. unFlexiWrap) + sequenceA = fmap FlexiWrap . unFlexiWrap + +instance Monad (FW t) where + return = FlexiWrap + (>>=) = flip (. unFlexiWrap) + +-- append and to produce +-- may or may not be terminated by TNil +-- if so, it does not appear in the result +class FWNormAppend s t u | s t -> u + +instance FWNormAppend TNil t t + +instance FWNormAppend s t u => FWNormAppend (x :*: s) t (x :*: u) + +instance TypeCast u (x :*: t) => FWNormAppend x t u + +-- class FWrap w a b where +class FWrap w a b | w a -> b where + fWrap :: w -> a -> b + +class FWIsWrapped a r | a -> r + +data FWAlreadyWrapped = FWAlreadyWrapped +data FWNewWrapper = FWNewWrapper + +data FWFWrap s a = FWFWrap + +instance FWIsWrapped (FW s a) FWAlreadyWrapped +instance TypeCast r FWNewWrapper => FWIsWrapped a r + +instance Apply (FWFWrap u a) FWNewWrapper (a -> FW u a) where + apply _ _ = FlexiWrap +instance Apply (FWFWrap u (FW s a)) FWAlreadyWrapped (FW s a -> FW u a) where + apply _ _ = FlexiWrap . unFlexiWrap + +data FWTag + +instance Apply FWTag (FW t a) t +instance TypeCast r TNil => Apply FWTag a r + +instance forall a b s t u w. ( + Apply FWTag a t, + FWNormAppend s t u, + FWIsWrapped a w, + Apply (FWFWrap u a) w (a -> FW u b) + ) => + FWrap s a (FW u b) + where + fWrap _ = apply (undefined :: FWFWrap u a) (undefined :: w) + +{- +instance FWNormAppend s t u => FWrap s (FW t a) (FW u a) where + fWrap _ (FlexiWrap a) = FlexiWrap a + +instance FWNormAppend s TNil u => FWrap s a (FW u a) where + fWrap _ = FlexiWrap +-} + +{- +instance FWrap TNil (FW s a) (FW s a) where + fWrap _ = id + +instance FWrap s (FW t a) (FW u a) => + FWrap (w :*: s) (FW t a) (FW (w :*: u) a) where + fWrap _ (FlexiWrap a) = FlexiWrap a + +instance TypeCast t (w :*: s) => FWrap w (FW s a) (FW t a) where + fWrap _ (FlexiWrap a) = FlexiWrap a + +{- +instance FWrap w (FW s a) (FW (w :*: s) a) where + fWrap _ (FlexiWrap a) = FlexiWrap a +-} + +{- +instance TypeCast r (FW TNil a) => FWrap TNil a r where + fWrap _ = FlexiWrap +-} + +instance FWrap TNil a (FW TNil a) where + fWrap _ = FlexiWrap + +instance FWrap s a (FW t a) => FWrap (x :*: s) a (FW (x :*: t) a) where + fWrap _ = FlexiWrap + +instance FWrap w a (FW (w :*: TNil) a) where + fWrap _ = FlexiWrap +-} + +infixl 8 `on` +on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c) +(op `on` f) x y = f x `op` f y + +class FWEq a r | a -> r + +data FWDefaultEq = FWDefaultEq + +data FWEquals t a = FWEquals + +data FWNotEquals t a = FWNotEquals + +-- default instance +instance TypeCast r FWDefaultEq => FWEq (FW t a) r + +instance FWEq (FW s a) r => FWEq (FW (x :*: s) a) r + +instance Eq a => Apply (FWEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool) + where + apply _ _ = (==) `on` unFlexiWrap + +instance Eq a => Apply (FWNotEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool) + where + apply _ _ = (/=) `on` unFlexiWrap + +instance forall t a r. (Apply (FWEquals t a) r (FW t a -> FW t a -> Bool), + Apply (FWNotEquals t a) r (FW t a -> FW t a -> Bool), + FWEq (FW t a) r + ) => + Eq (FW t a) where + (==) = apply (undefined :: FWEquals t a) (undefined :: r) + (/=) = apply (undefined :: FWNotEquals t a) (undefined :: r) + +-- end FlexiWrap + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/WrapCTC.hs b/Data/Flex/WrapCTC.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/WrapCTC.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/WrapCTC.hs,v 1.4 2010/12/01 00:24:20 dosuser Exp dosuser $ +module Data.Flex.WrapCTC where + +import Control.Monad (MonadPlus(..)) +import Control.Monad.Trans (MonadTrans(..)) + +import Data.Type.Apply (Apply(..)) +import Data.Type.Eq (TypeCast) +import Data.Type.TList ((:*:)) + +import Data.Flex.Functor (FWFunctor, FWFmap, WrapFmap(..)) +import Data.Flex.Monad (FWMonad, + FWReturn, WrapReturn, wrapReturn, unwrapReturn, + FWBind, WrapBind(..), wrapBind + ) +import Data.Flex.MonadPlus (FWMonadPlus, + FWMZero, WrapMZero(..), + FWMPlus, WrapMPlus(..) + ) +import Data.Flex.MonadTrans ( + FWMonadTrans, + -- FWDefaultMonadTrans, + FWLift, WrapLift(..) + ) + +import Data.Flex.Utils (inCompose, bindWrapper) + +newtype FlexiWrapCTC s o (f :: * -> *) (g :: * -> *) a = + FlexiWrapCTC {unFlexiWrapCTC :: o f g a} + +type FWCTC = FlexiWrapCTC + +flexiWrapCTC :: s -> o f g a -> FWCTC s o f g a +flexiWrapCTC _ = FlexiWrapCTC + +inFlexiWrapCTC :: (o f g a -> o' f' g' a') -> + (FWCTC s o f g a -> FWCTC s o' f' g' a') +inFlexiWrapCTC = inCompose unFlexiWrapCTC FlexiWrapCTC + +inFlexiWrapCTC2 :: (o f g a -> o' f' g' a' -> o'' f'' g'' a'') -> + (FWCTC s o f g a -> FWCTC s o' f' g' a' -> FWCTC s o'' f'' g'' a'') +inFlexiWrapCTC2 = inCompose unFlexiWrapCTC $ + inCompose unFlexiWrapCTC FlexiWrapCTC + +-- Functor definitions + +data FWCTCDefaultFunctor = FWCTCDefaultFunctor + +-- default instance +instance TypeCast r FWCTCDefaultFunctor => FWFunctor (FWCTC t o f g) r + +-- deferred instance +instance FWFunctor (FWCTC s o f g) r => FWFunctor (FWCTC (x :*: s) o f g) r + +instance Functor (o f g) => + Apply (FWFmap t (o f g)) FWCTCDefaultFunctor (WrapFmap (FWCTC t o f g)) + where + apply _ _ = WrapFmap (inFlexiWrapCTC . fmap) + +instance forall t o f g r. (FWFunctor (FWCTC t o f g) r, + Apply (FWFmap t (o f g)) r (WrapFmap (FWCTC t o f g)) + ) => + Functor (FWCTC t o f g) + where + fmap = unwrapFmap $ apply (undefined :: FWFmap t (o f g)) (undefined :: r) + +-- Monad definitions + +data FWCTCDefaultMonad = FWCTCDefaultMonad + +-- default instance +instance TypeCast r FWCTCDefaultMonad => FWMonad (FWCTC t o m n) r + +-- deferred instance +instance FWMonad (FWCTC s o m n) r => FWMonad (FWCTC (x :*: s) o m n) r + +instance Monad (o m n) => + Apply (FWReturn t (o m n)) FWCTCDefaultMonad (WrapReturn (FWCTC t o m n)) + where + apply _ _ = wrapReturn (FlexiWrapCTC . return) + +instance Monad (o m n) => + Apply (FWBind t (o m n)) FWCTCDefaultMonad (WrapBind (FWCTC t o m n)) + where + apply _ _ = wrapBind (bindWrapper unFlexiWrapCTC FlexiWrapCTC (>>=)) + +instance forall t o m n r. ( + Apply (FWReturn t (o m n)) r (WrapReturn (FWCTC t o m n)), + Apply (FWBind t (o m n)) r (WrapBind (FWCTC t o m n)), + FWMonad (FWCTC t o m n) r + ) => + Monad (FWCTC t o m n) where + return = unwrapReturn $ + apply (undefined :: FWReturn t (o m n)) (undefined :: r) + (>>=) = unwrapBind $ apply (undefined :: FWBind t (o m n)) (undefined :: r) + +-- --- MonadPlus definitions + +instance FWMonadPlus (FWCTC s o m n) r => FWMonadPlus (FWCTC (t :*: s) o m n) r + +instance forall t o m n r. ( + Monad (FWCTC t o m n), + FWMonadPlus (FWCTC t o m n) r, + Apply (FWMZero t (o m n)) r (WrapMZero (FWCTC t o m n)), + Apply (FWMPlus t (o m n)) r (WrapMPlus (FWCTC t o m n)) + ) => + MonadPlus (FWCTC t o m n) + where + mzero = unwrapMZero $ + apply (undefined :: (FWMZero t (o m n))) (undefined :: r) + mplus = unwrapMPlus $ + apply (undefined :: (FWMPlus t (o m n))) (undefined :: r) + +-- MonadTrans definitions + +{- +-- No default instances -- the kinds below don't work out +-- default instance +instance TypeCast r FWDefaultMonadTrans => FWMonadTrans (FWCTC t o) r + +instance Apply (FWLift (FWCTC s o)) FWDefaultMonadTrans (WrapLift (FWCTC s o)) + where + apply _ _ = WrapLift FlexiWrapCTC +-} + +-- deferred instance +instance FWMonadTrans (FWCTC s o f) r => FWMonadTrans (FWCTC (x :*: s) o f) r + +instance forall s o f r. ( + Apply (FWLift (FWCTC s o f)) r (WrapLift (FWCTC s o f)), + FWMonadTrans (FWCTC s o f) r + ) => MonadTrans (FWCTC s o f) where + lift = unwrapLift $ + apply (undefined :: FWLift (FWCTC s o f)) (undefined :: r) + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/WrapT.hs b/Data/Flex/WrapT.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/WrapT.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/WrapT.hs,v 1.9 2010/12/01 00:37:45 dosuser Exp dosuser $ +module Data.Flex.WrapT where + +import Control.Applicative (Applicative(..)) +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (MonadState(..)) + +import Data.Type.Apply (Apply(..)) +import Data.Type.Eq (TypeCast) +import Data.Type.TList ((:*:), TNil) + +import Data.Flex.Utils (inCompose, bindWrapper) + +import Data.Flex.Applicative (FWApplicative, + FWPure, WrapPure(..), + FWCombine, WrapCombine(..) + ) +import Data.Flex.Functor (FWFunctor, FWFmap, WrapFmap(..)) +import Data.Flex.MonadTrans ( + FWMonadTrans, FWDefaultMonadTrans, FWLift, WrapLift(..) + ) +import Data.Flex.Monad (FWMonad, + FWReturn, WrapReturn, wrapReturn, unwrapReturn, + FWBind, WrapBind(..), wrapBind + ) + +import Data.Flex.MonadState (FWMonadState, FWGet, FWPut) +import Data.Flex.Wrap (FWAlreadyWrapped, FWNewWrapper, FWNormAppend) + +-- begin FlexiWrapT + +newtype FlexiWrapT s f a = FlexiWrapT {unFlexiWrapT :: f a} + +type FWT = FlexiWrapT + +flexiWrapT :: s -> f a -> FWT s f a +flexiWrapT _ = FlexiWrapT + +inFlexiWrapT :: (f a -> g b) -> (FWT s f a -> FWT s g b) +inFlexiWrapT = inCompose unFlexiWrapT FlexiWrapT + +inFlexiWrapT2 :: (f a -> g b -> h c) -> + (FWT s f a -> FWT s g b -> FWT s h c) +inFlexiWrapT2 = inCompose unFlexiWrapT $ inCompose unFlexiWrapT FlexiWrapT + +asFlexiWrapT :: (FWT s f a -> FWT s g b) -> (f a -> g b) +asFlexiWrapT = inCompose FlexiWrapT unFlexiWrapT + +-- --- Functor definitions + +data FWTDefaultFunctor = FWTDefaultFunctor + +-- default instance +instance TypeCast r FWTDefaultFunctor => FWFunctor (FWT t f) r + +-- deferred instance +instance FWFunctor (FWT s f) r => FWFunctor (FWT (x :*: s) f) r + +instance Functor f => + Apply (FWFmap t f) FWTDefaultFunctor (WrapFmap (FWT t f)) + where + apply _ _ = WrapFmap (inFlexiWrapT . fmap) + +instance forall t f r. (FWFunctor (FWT t f) r, + Apply (FWFmap t f) r (WrapFmap (FWT t f)) + ) => + Functor (FWT t f) + where + fmap = unwrapFmap $ apply (undefined :: FWFmap t f) (undefined :: r) + +{- +instance Functor f => Functor (FWT s f) where + fmap = inFlexiWrapT . fmap +-} + +-- --- Applicative definitions + +data FWTDefaultApplicative = FWTDefaultApplicative + +-- default instance +instance TypeCast r FWTDefaultApplicative => FWApplicative (FWT t f) r + +-- deferred instance +instance FWApplicative (FWT s f) r => + FWApplicative (FWT (x :*: s) f) r + +instance Applicative f => + Apply (FWPure t f) FWTDefaultApplicative (WrapPure (FWT t f)) + where + apply _ _ = WrapPure (FlexiWrapT . pure) + +instance Applicative f => + Apply (FWCombine t f) FWTDefaultApplicative (WrapCombine (FWT t f)) + where + apply _ _ = WrapCombine (inFlexiWrapT2 (<*>)) + +instance forall t f r. (Apply (FWPure t f) r (WrapPure (FWT t f)), + Apply (FWCombine t f) r (WrapCombine (FWT t f)), + FWApplicative (FWT t f) r, + Functor (FWT t f) + ) => + Applicative (FWT t f) where + pure = unwrapPure $ apply (undefined :: FWPure t f) (undefined :: r) + (<*>) = unwrapCombine $ apply (undefined :: FWCombine t f) (undefined :: r) + +{- +instance Applicative f => Apply FWPure t (WrapPure (FWT t f)) where + apply _ _ = WrapPure $ FlexiWrapT . pure + +instance Applicative f => Apply FWCombine t (WrapCombine (FWT t f)) where + apply _ _ = WrapCombine $ inFlexiWrapT2 (<*>) + +instance (Apply FWPure t (WrapPure f), Apply FWCombine t (WrapCombine f)) => + Applicative (FWT t f) where + pure = unwrapPure $ apply FWPure (undefined :: t) + (<*>) = unwrapCombine $ apply FWCombine (undefined :: t) +-} + + +{- +instance FWrap TNil (FWT s f a) (FWT s f a) where + fWrap _ = id + +instance FWrap s (FWT t f a) (FWT u f a) => + FWrap (w :*: s) (FWT t f a) (FWT (w :*: u) f a) where + fWrap _ (FlexiWrapT a) = FlexiWrapT a + +instance FWrap w (FWT s f a) (FWT (w :*: s) f a) where + fWrap _ (FlexiWrapT a) = FlexiWrapT a + +instance FWrap TNil (f a) (FWT TNil f a) where + fWrap _ = FlexiWrapT + +instance FWrap s (f a) (FWT t f a) => FWrap (x :*: s) (f a) (FWT (x :*: t) f a) where + fWrap _ = FlexiWrapT + +instance FWrap w (f a) (FWT (w :*: TNil) f a) where + fWrap _ = FlexiWrapT +-} + +-- --- Monad definitions + +data FWTDefaultMonad = FWTDefaultMonad + +data FWTDefaultMonadAll = FWTDefaultMonadAll + +-- default instance +instance TypeCast r FWTDefaultMonad => FWMonad (FWT t m) r + +-- explicit instances +instance FWMonad (FWT (FWTDefaultMonad :*: s) m) FWTDefaultMonad +instance FWMonad (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonad + +-- deferred instance +instance FWMonad (FWT s m) r => FWMonad (FWT (x :*: s) m) r + +instance Monad m => + Apply (FWReturn t m) FWTDefaultMonad (WrapReturn (FWT t m)) + where + apply _ _ = wrapReturn (FlexiWrapT . return) + +instance Monad m => + Apply (FWBind t m) FWTDefaultMonad (WrapBind (FWT t m)) + where + apply _ _ = wrapBind (bindWrapper unFlexiWrapT FlexiWrapT (>>=)) + +instance forall t m r. (Apply (FWReturn t m) r (WrapReturn (FWT t m)), + Apply (FWBind t m) r (WrapBind (FWT t m)), + FWMonad (FWT t m) r + ) => + Monad (FWT t m) where + return = unwrapReturn $ + apply (undefined :: FWReturn t m) (undefined :: r) + (>>=) = unwrapBind $ apply (undefined :: FWBind t m) (undefined :: r) + +-- MonadState + +data FWTDefaultMonadState = FWTDefaultMonadState + +-- default instance +instance TypeCast r FWTDefaultMonadState => FWMonadState (FWT t m) r + +-- explicit instances +instance FWMonadState (FWT (FWTDefaultMonadState :*: s) m) FWTDefaultMonadState +instance FWMonadState (FWT (FWTDefaultMonadAll :*: s) m) FWTDefaultMonadState + +-- deferred instance +instance FWMonadState (FWT s m) r => FWMonadState (FWT (x :*: s) m) r + +instance MonadState s m => + Apply (FWGet t s m) FWTDefaultMonadState (FWT t m s) + where + apply _ _ = FlexiWrapT get + +instance MonadState s m => + Apply (FWPut t s m) FWTDefaultMonadState (s -> FWT t m ()) + where + apply _ _ = FlexiWrapT . put + +class FwtMonadState s m | m -> s where + fwtGet :: m s + fwtPut :: s -> m () + +instance forall t s m r. ( + -- Monad (FWT t m), + MonadState s m, + Apply (FWGet t s m) r (FWT t m s), + Apply (FWPut t s m) r (s -> FWT t m ()), + FWMonadState (FWT t m) r + ) => + FwtMonadState s (FWT t m) where + fwtGet = apply (undefined :: FWGet t s m) (undefined :: r) + fwtPut = apply (undefined :: FWPut t s m) (undefined :: r) + +instance (Monad (FWT t m), FwtMonadState s (FWT t m)) => + MonadState s (FWT t m) + where + get = fwtGet + put = fwtPut + +-- MonadTrans + +-- default instance +instance TypeCast r FWDefaultMonadTrans => FWMonadTrans (FWT t) r + +-- deferred instance +instance FWMonadTrans (FWT s) r => FWMonadTrans (FWT (x :*: s)) r + +instance Apply (FWLift (FWT s)) FWDefaultMonadTrans (WrapLift (FWT s)) where + apply _ _ = WrapLift FlexiWrapT + +instance forall s r. ( + Apply (FWLift (FWT s)) r (WrapLift (FWT s)), + FWMonadTrans (FWT s) r + ) => MonadTrans (FWT s) where + lift = unwrapLift $ apply (undefined :: FWLift (FWT s)) (undefined :: r) + +-- --- FWrapT + +class FWrapT w a b | w a -> b where + fWrapT :: w -> a -> b + +data FWTagT + +instance Apply FWTagT (FWT t f a) t +instance TypeCast r TNil => Apply FWTagT a r + +class FWCon a (f :: * -> *) | a -> f + +instance FWCon (FWT t f a) f +instance TypeCast (r a) (f a) => FWCon (f a) r + +class FWIsWrappedT a r | a -> r + +instance FWIsWrappedT (FWT s f a) FWAlreadyWrapped +instance TypeCast r FWNewWrapper => FWIsWrappedT a r + +data FWFWrapT s (f :: * -> *) a = FWFWrapT + +instance Apply (FWFWrapT u f (f a)) FWNewWrapper (f a -> FWT u f a) where + apply _ _ = FlexiWrapT +instance Apply (FWFWrapT u f (FWT s f a)) FWAlreadyWrapped + (FWT s f a -> FWT u f a) + where + apply _ _ = FlexiWrapT . unFlexiWrapT + +instance forall a b f s t u w. ( + Apply FWTagT a t, + FWCon a f, + FWNormAppend s t u, + FWIsWrappedT a w, + Apply (FWFWrapT u f a) w (a -> FWT u f b) + ) => + FWrapT s a (FWT u f b) + where + fWrapT _ = apply (undefined :: FWFWrapT u f a) (undefined :: w) + +-- end FlexiWrapT + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Flex/WrappedMonad.hs b/Data/Flex/WrappedMonad.hs new file mode 100644 --- /dev/null +++ b/Data/Flex/WrappedMonad.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/WrappedMonad.hs,v 1.2 2010/02/10 00:26:03 dosuser Exp dosuser $ +module Data.Flex.WrappedMonad where + +import Control.Monad (liftM, ap) + +import Data.Type.Apply +import Data.Type.TList + +import Data.Flex.Applicative (FWApplicative, + FWPure, WrapPure(..), + FWCombine, WrapCombine(..) + ) +import Data.Flex.Functor (FWFunctor, FWFmap, WrapFmap(..)) +import Data.Flex.WrapT (inFlexiWrapT, + FlexiWrapT(..), FWT, inFlexiWrapT2, + ) + +data FWWrapMonad = FWWrapMonad + +data FWMonadFunctor = FWMonadFunctor +data FWMonadApplicative = FWMonadApplicative + +instance FWFunctor (FWT (FWWrapMonad :*: s) f) FWMonadFunctor + +instance FWFunctor (FWT (FWMonadFunctor :*: s) f) FWMonadFunctor + +instance Monad m => Apply (FWFmap t m) FWMonadFunctor (WrapFmap (FWT t m)) where + apply _ _ = WrapFmap (inFlexiWrapT . liftM) + +instance FWApplicative (FWT (FWWrapMonad :*: s) f) FWMonadApplicative + +instance FWApplicative (FWT (FWMonadApplicative :*: s) f) FWMonadApplicative + +-- instance (Functor m, Monad m) => +instance Monad m => + Apply (FWPure t m) FWMonadApplicative (WrapPure (FWT t m)) + where + apply _ _ = WrapPure (FlexiWrapT . return) + +-- instance (Functor m, Monad m) => +instance Monad m => + Apply (FWCombine t m) FWMonadApplicative (WrapCombine (FWT t m)) + where + apply _ _ = WrapCombine (inFlexiWrapT2 ap) + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/Data/Wrap.hs b/Data/Wrap.hs new file mode 100644 --- /dev/null +++ b/Data/Wrap.hs @@ -0,0 +1,626 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- .$Header: c:/Source/Haskell/Wrapper/Data/RCS/Wrap.hs,v 1.1 2010/03/12 23:41:16 dosuser Exp dosuser $ +module Data.Wrap ( + Wrapper(..), + circumpose, + inCompose, inCompose2, + inWrapping, inWrapping2, + traverseWrapping, foldWrapping, foldWrapper, + inWrapper, inWrapper2, + asWrapped, asWrapped2, + Wrap(..), + InnerWrapT(..), OuterWrapT(..), + inInnerWrapT, inInnerWrapT2, + inOuterWrapT, inOuterWrapT2, + fromInnerWrapT, mFromInnerWrapT, fromOuterWrapT, + toInnerWrapT, mToInnerWrapT, toOuterWrapT, + asInnerWrapT, mAsInnerWrapT, asOuterWrapT, + asInnerWrapT2, mAsInnerWrapT2, asOuterWrapT2, + -- traverseInnerWrapT, traverseOuterWrapT + -- traverseWrapT + traverseWrapper, sequenceWrapper, + bindWrapper, contWrapper, catchWrapper, fixWrapper, + readerWrapper, writerWrapper, + result, argument +) where + +import Control.Applicative (Applicative(..), Alternative(..), (<$>)) +-- (<$>), liftA2, Alternative(..)) +import Control.Compose (Cofunctor(..)) +import Control.Monad (MonadPlus(..), liftM) +import Control.Monad.Cont (MonadCont(..)) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State(MonadState(..)) +import Control.Monad.Trans (MonadTrans(..), MonadIO(..)) +import Control.Monad.Writer (MonadWriter(..)) +-- lift, + +import Data.Foldable as F (Foldable(..)) +-- import Data.Generics (Data, Typeable2(..), mkTyCon, mkTyConApp) +import Data.Monoid (Monoid(..)) +import qualified Data.Traversable as T (Traversable(..)) + +import Test.QuickCheck (Arbitrary(..)) + +class Wrapper f where + wrap :: a -> f a + unwrap :: f a -> a + +circumpose :: (c -> d) -> (a -> b) -> (b -> c) -> (a -> d) +circumpose left right = (left .) . (. right) + +-- inCompose :: (f b -> b) -> (c -> d) -> (b -> c) -> (f b -> d) +inCompose :: (a -> b) -> (c -> d) -> (b -> c) -> (a -> d) +-- inCompose unwrap wrap = (wrap .) . (. unwrap) +inCompose = flip circumpose + +-- inCompose2 :: (a -> b) -> (c -> d) -> (b -> b -> c) -> (a -> a -> d) +inCompose2 :: (forall a. f a -> a) -> (d -> e) -> + (b -> c -> d) -> (f b -> f c -> e) +inCompose2 unwrap wrap = inCompose unwrap $ inCompose unwrap wrap +-- inCompose2 unwrap wrap = (inCompose unwrap wrap .) . (. unwrap) + +inWrapping :: (f a -> a) -> (b -> c) -> (a -> b) -> f a -> c +-- inWrapping unwrap wrap = circumpose wrap unwrap +-- inWrapping = flip circumpose +inWrapping = inCompose + +inWrapping2 :: (forall a. f a -> a) -> (d -> e) -> + (b -> c -> d) -> (f b -> f c -> e) +inWrapping2 unwrap wrap = inWrapping unwrap $ inWrapping unwrap wrap + +{- +traverseWrapping :: Functor g => (f a -> a) -> (b -> c) -> (a -> g b) -> + (f a -> g c) +-} +traverseWrapping :: Functor f => (a -> b) -> (c -> d) -> + (b -> f c) -> (a -> f d) +traverseWrapping unwrap wrap = inCompose unwrap $ fmap wrap + +inWrapper :: Wrapper f => (a -> b) -> f a -> f b +inWrapper = inWrapping unwrap wrap +-- inWrapper = (wrap .) . (. unwrap) + +inWrapper2 :: Wrapper f => (a -> b -> c) -> f a -> f b -> f c +inWrapper2 = inWrapping2 unwrap wrap + +asWrapped :: (Wrap f a -> Wrap f b) -> (f a -> f b) +asWrapped = inCompose Wrapped unWrapped + +asWrapped2 :: (Wrap f a -> Wrap f b -> Wrap f c) -> (f a -> f b -> f c) +asWrapped2 = inCompose Wrapped asWrapped + +{- +asWrapped :: Wrapper f => (f a -> f b) -> (a -> b) +asWrapped = inCompose wrap unwrap + +asWrapped2 :: Wrapper f => (f a -> f b -> f c) -> (a -> b -> c) +asWrapped2 = inCompose wrap asWrapped +-} + +newtype Wrap f a = Wrapped {unWrapped :: f a} + deriving (Eq, Ord, Monoid) + -- , Show, Read) + -- Functor, Applicative, Monad + -- Foldable, Traversable + -- Monoid + -- Arbitrary + -- Data, Typeable + -- CoMonad + -- but NOT + -- Cofunctor + -- Alternative, MonadPlus + -- MonadTrans, MonadState, MonadIO, ... + +app_prec = 10 + +instance Show (f a) => Show (Wrap f a) where + showsPrec d (Wrapped w) = showParen (d > app_prec) $ + showString "Wrapped " . showsPrec (app_prec+1) w + +instance Read (f a) => Read (Wrap f a) where + readsPrec d r = readParen + (d > app_prec) + (\r -> [(Wrapped m, t) | + ("Wrapped", s) <- lex r, + (m, t) <- readsPrec (app_prec+1) s + ]) + r + +instance Wrapper f => Wrapper (Wrap f) where + wrap = Wrapped . wrap + unwrap = unwrap . unWrapped + +instance Wrapper f => Functor (Wrap f) where + fmap = inWrapper + +instance Wrapper f => Applicative (Wrap f) where + pure = wrap + (<*>) = inWrapper . unwrap + +instance Wrapper f => F.Foldable (Wrap f) where + foldr f z = flip f z . unwrap + +instance Wrapper f => T.Traversable (Wrap f) where + traverse = traverseWrapping unwrap wrap + -- traverse = inWrapping unwrap $ fmap wrap + -- traverse = (fmap wrap .) . (. unwrap) + sequenceA = fmap wrap . unwrap + +instance Wrapper f => Monad (Wrap f) where + return = wrap + (>>=) = flip (. unwrap) + +instance (Wrapper f, Arbitrary a) => Arbitrary (Wrap f a) where + arbitrary = wrap <$> arbitrary + coarbitrary = coarbitrary . unwrap + +-- Utility function to construct (>>=) for a target monad from the (>>=) +-- for an implementation monad +-- Parameters: +-- wrap: function from target monad to implementation monad (t a -> i a) +-- unwrap: vice versa (i a -> t a) +bindWrapper :: (forall a. f a -> g a) -> (d -> e) -> (g a -> (c -> g b) -> d) -> + f a -> (c -> f b) -> e +bindWrapper wrap unwrap = inCompose wrap $ inCompose (result wrap) unwrap + +newtype InnerWrapT f g a = InnerWrapT {runInnerWrapT :: g (Wrap f a)} + deriving (Eq, Ord, Monoid) + -- , Show, Read) + -- deriving (Functor, Applicative, Monad, MonadTrans) + -- Alternative, MonadPlus + -- MonadState, MonadIO, ... + -- Foldable, Traversable + -- Cofunctor + -- Monoid + -- Arbitrary + -- Data, Typeable + -- CoMonad + +newtype OuterWrapT f g a = OuterWrapT {runOuterWrapT :: Wrap f (g a)} + deriving (Eq, Ord, Monoid) + -- , Show, Read) + -- deriving (Functor, Applicative, Foldable, T.Traversable, Monad, + -- MonadTrans) + -- Alternative, MonadPlus + -- MonadState, MonadIO, ... + -- Cofunctor, CoMonad + -- Monoid + -- Arbitrary + -- Data, Typeable + +inInnerWrapT :: (g (Wrap f a) -> g (Wrap f b)) -> + InnerWrapT f g a -> InnerWrapT f g b +inInnerWrapT = circumpose InnerWrapT runInnerWrapT + +inInnerWrapT2 :: (g (Wrap f a) -> g (Wrap f b) -> g (Wrap f c)) -> + InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c +inInnerWrapT2 = circumpose inInnerWrapT runInnerWrapT + +inOuterWrapT :: (Wrap f (g a) -> Wrap f (g b)) -> + OuterWrapT f g a -> OuterWrapT f g b +inOuterWrapT = circumpose OuterWrapT runOuterWrapT + +inOuterWrapT2 :: (Wrap f (g a) -> Wrap f (g b) -> Wrap f (g c)) -> + OuterWrapT f g a -> OuterWrapT f g b -> OuterWrapT f g c +inOuterWrapT2 = circumpose inOuterWrapT runOuterWrapT + +fromInnerWrapT :: Functor g => InnerWrapT f g a -> g (f a) +fromInnerWrapT = fmap unWrapped . runInnerWrapT + +fromOuterWrapT :: OuterWrapT f g a -> f (g a) +fromOuterWrapT = unWrapped . runOuterWrapT + +mFromInnerWrapT :: Monad g => InnerWrapT f g a -> g (f a) +mFromInnerWrapT = liftM unWrapped . runInnerWrapT + +toInnerWrapT :: Functor g => g (f a) -> InnerWrapT f g a +toInnerWrapT = InnerWrapT . fmap Wrapped + +toOuterWrapT :: f (g a) -> OuterWrapT f g a +toOuterWrapT = OuterWrapT . Wrapped + +mToInnerWrapT :: Monad g => g (f a) -> InnerWrapT f g a +mToInnerWrapT = InnerWrapT . liftM Wrapped + +asInnerWrapT :: Functor g => (InnerWrapT f g a -> InnerWrapT f g b) -> + g (f a) -> g (f b) +asInnerWrapT = circumpose fromInnerWrapT toInnerWrapT +-- asInnerWrapT = inCompose (InnerWrapT . fmap Wrapped) fromInnerWrapT + +asOuterWrapT :: (OuterWrapT f g a -> OuterWrapT f g b) -> + f (g a) -> f (g b) +asOuterWrapT = circumpose fromOuterWrapT toOuterWrapT + +mAsInnerWrapT :: Monad g => (InnerWrapT f g a -> InnerWrapT f g b) -> + g (f a) -> g (f b) +mAsInnerWrapT = circumpose mFromInnerWrapT mToInnerWrapT +-- mAsInnerWrapT = inCompose (InnerWrapT . liftM Wrapped) mFromInnerWrapT + +asInnerWrapT2 :: Functor g => + (InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c) -> + g (f a) -> g (f b) -> g (f c) +asInnerWrapT2 = circumpose asInnerWrapT toInnerWrapT + +asOuterWrapT2 :: (OuterWrapT f g a -> OuterWrapT f g b -> OuterWrapT f g c) -> + f (g a) -> f (g b) -> f (g c) +asOuterWrapT2 = circumpose asOuterWrapT toOuterWrapT + +mAsInnerWrapT2 :: Monad g => + (InnerWrapT f g a -> InnerWrapT f g b -> InnerWrapT f g c) -> + g (f a) -> g (f b) -> g (f c) +mAsInnerWrapT2 = circumpose mAsInnerWrapT mToInnerWrapT + +instance Show (g (Wrap f a)) => Show (InnerWrapT f g a) where + showsPrec d (InnerWrapT w) = showParen (d > app_prec) $ + showString "InnerWrapT " . showsPrec (app_prec+1) w + +instance Read (g (Wrap f a)) => Read (InnerWrapT f g a) where + readsPrec d r = readParen + (d > app_prec) + (\r -> [(InnerWrapT m, t) | + ("InnerWrapT", s) <- lex r, + (m, t) <- readsPrec (app_prec+1) s + ]) + r + +instance Show (f (g a)) => Show (OuterWrapT f g a) where + showsPrec d (OuterWrapT w) = showParen (d > app_prec) $ + showString "OuterWrapT " . showsPrec (app_prec+1) w + +instance Read (f (g a)) => Read (OuterWrapT f g a) where + readsPrec d r = readParen + (d > app_prec) + (\r -> [(OuterWrapT m, t) | + ("OuterWrapT", s) <- lex r, + (m, t) <- readsPrec (app_prec+1) s + ]) + r + +instance (Wrapper f, Functor g) => Functor (InnerWrapT f g) where + fmap = inInnerWrapT . fmap . inWrapper + +instance (Wrapper f, Functor g) => Functor (OuterWrapT f g) where + fmap = inOuterWrapT . inWrapper . fmap + +instance (Wrapper f, Cofunctor g) => Cofunctor (InnerWrapT f g) where + -- cofmap h = InnerWrapT . cofmap (fmap h) . runInnerWrapT + -- cofmap h = inInnerWrapT $ cofmap $ fmap h + cofmap = inInnerWrapT . cofmap . fmap + +-- cofmapCF h (O gf) = O (cofmap (fmap h) gf) + +instance (Wrapper f, Cofunctor g) => Cofunctor (OuterWrapT f g) where + cofmap = inOuterWrapT . fmap . cofmap + +-- cofmapFC = inO.fmap.cofmap + +instance (Wrapper f, Applicative g) => Applicative (InnerWrapT f g) where + pure = InnerWrapT . pure . wrap + (<*>) = inInnerWrapT2 $ (<*>) . fmap (<*>) + -- (<*>) = inInnerWrapT2 $ inCompose2 (fmap unwrap) (fmap wrap) (<*>) + {- + (<*>) :: Wrap f (a -> b) -> Wrap f a -> Wrap f b + fmap (<*>) :: g (Wrap f (a -> b)) -> g (Wrap f a -> Wrap f b) + (<*>) . fmap (<*>) :: g (Wrap f (a -> b)) -> g (Wrap f a) -> g (Wrap f b) + -} + +instance (Wrapper f, Applicative g) => Applicative (OuterWrapT f g) where + pure = OuterWrapT . wrap . pure + (<*>) = inOuterWrapT2 $ (<*>) . fmap (<*>) + {- + (<*>) :: g (a -> b) -> g a -> g b + fmap (<*>) :: Wrap f (g (a -> b)) -> Wrap f (g a -> g b) + (<*>) . fmap (<*>) :: Wrap f (g (a -> b)) -> Wrap f (g a) -> Wrap f (g b) + -} + +instance (Wrapper f, Alternative g) => Alternative (InnerWrapT f g) where + empty = InnerWrapT empty + (<|>) = inInnerWrapT2 (<|>) + +instance (Wrapper f, Alternative g) => Alternative (OuterWrapT f g) where + empty = OuterWrapT $ wrap empty + (<|>) = inOuterWrapT2 $ inWrapper2 (<|>) + +result = (.) +argument = flip (.) + +foldWrapping :: (Foldable f, Foldable g) => (a -> b -> b) -> b -> f (g a) -> b +foldWrapping f z = flip F.foldr z . flip $ F.foldr f + +foldWrapper :: (Foldable f, Foldable g) => (c -> f (g a)) -> + (a -> b -> b) -> b -> c -> b +-- foldWrapper = flip flip foldWrapping $ result . result . argument +foldWrapper = flip (result . result . argument) foldWrapping +-- foldWrapper = result . result . argument `flip` foldWrapping + +instance (Wrapper f, Foldable g) => Foldable (InnerWrapT f g) where + foldr = foldWrapper runInnerWrapT + -- foldr = (result . result . argument) runInnerWrapT foldWrapping + -- foldr f z = foldWrapping f z . runInnerWrapT + -- foldr f z = F.foldr (flip $ F.foldr f) z . runInnerWrapT + +instance (Wrapper f, Foldable g) => Foldable (OuterWrapT f g) where + foldr = foldWrapper runOuterWrapT + -- foldr = (result . result . argument) runOuterWrapT foldWrapping + -- foldr f z = foldWrapping f z . runOuterWrapT + -- foldr f z = F.foldr (flip $ F.foldr f) z . runOuterWrapT + +traverseInnerWrapT :: Functor h => (g (Wrap f a) -> h (g' (Wrap f' b))) -> + InnerWrapT f g a -> h (InnerWrapT f' g' b) +traverseInnerWrapT = traverseWrapping runInnerWrapT InnerWrapT +-- traverseInnerWrapT = (fmap InnerWrapT .) . (. runInnerWrapT) + +traverseWrapT :: (T.Traversable t, Applicative f) => + ((t a -> f (t b)) -> c) -> (a -> f b) -> c +traverseWrapT wrapper mapper = wrapper $ T.sequenceA . fmap mapper + +traverseWrapper :: (T.Traversable t, T.Traversable u, Applicative f) => + ((t (u a) -> f (t (u b))) -> c) -> (a -> f b) -> c +traverseWrapper wrapper = traverseWrapT wrapper . T.traverse + +sequenceWrapper :: (T.Traversable t, T.Traversable u, Applicative f) => + ((t (u (f a)) -> f (t (u a))) -> c) -> c +sequenceWrapper wrapper = traverseWrapT wrapper T.sequenceA + +instance (Wrapper f, T.Traversable g) => T.Traversable (InnerWrapT f g) where + traverse = traverseWrapper traverseInnerWrapT + -- traverse = traverseWrapT traverseInnerWrapT . T.traverse + -- traverse f = traverseWrapT traverseInnerWrapT $ T.traverse f + -- traverse f = traverseInnerWrapT $ T.sequenceA . fmap (T.traverse f) + {- + traverse f = fmap InnerWrapT . T.sequenceA . + fmap (T.traverse f) . runInnerWrapT + -} + {- + InnerWrapT f g a + -> runInnerWrapT -> + g (Wrap f a) + -> fmap (traverse f) -> + g (h (Wrap f b)) + -> sequenceA -> + h (g (Wrap f b)) + -> fmap InnerWrapT -> + h (InnerWrapT f g b) + -} + sequenceA = sequenceWrapper traverseInnerWrapT + -- sequenceA = traverseWrapT traverseInnerWrapT T.sequenceA + -- sequenceA = traverseInnerWrapT $ T.sequenceA . fmap T.sequenceA + {- + sequenceA = fmap InnerWrapT . T.sequenceA . + fmap T.sequenceA . runInnerWrapT + -} + {- + InnerWrapT f g (h a) + -> runInnerWrapT -> + g (Wrap f (h a)) + -> fmap sequenceA -> + g (h (Wrap f a)) + -> sequenceA -> + h (g (Wrap f a)) + -> fmap InnerWrapT -> + h (InnerWrapT f g a) + -} + +traverseOuterWrapT :: Functor h => (Wrap f (g a) -> h (Wrap f' (g' b))) -> + OuterWrapT f g a -> h (OuterWrapT f' g' b) +traverseOuterWrapT = traverseWrapping runOuterWrapT OuterWrapT +-- traverseOuterWrapT = (fmap OuterWrapT .) . (. runOuterWrapT) + +instance (Wrapper f, T.Traversable g) => T.Traversable (OuterWrapT f g) where + traverse = traverseWrapper traverseOuterWrapT + {- + traverse f = fmap OuterWrapT . T.sequenceA . + fmap (T.traverse f) . runOuterWrapT + -} + {- + OuterWrapT f g a + -> runOuterWrapT -> + Wrap f (g a) + -> fmap (traverse f) -> + Wrap f (h (g b)) + -> sequenceA -> + h (Wrap f (g b)) + -> fmap OuterWrapT -> + h (OuterWrapT f g b) + -} + sequenceA = sequenceWrapper traverseOuterWrapT + {- + sequenceA = fmap OuterWrapT . T.sequenceA . + fmap T.sequenceA . runOuterWrapT + -} + {- + OuterWrapT f g (h a) + -> runOuterWrapT -> + Wrap f (g (h a)) + -> fmap sequenceA -> + Wrap f (h (g a)) + -> sequenceA -> + h (Wrap f (g a)) + -> fmap OuterWrapT -> + h (OuterWrapT f g a) + -} + +instance (Wrapper f, Monad g) => Monad (InnerWrapT f g) where + return = InnerWrapT . return . wrap + a >>= f = InnerWrapT $ runInnerWrapT a >>= runInnerWrapT . f . unwrap + +instance (Wrapper f, Monad g) => Monad (OuterWrapT f g) where + return = OuterWrapT . wrap . return + a >>= f = OuterWrapT . wrap $ + unwrap (runOuterWrapT a) >>= unwrap . runOuterWrapT . f + +instance (Wrapper f, MonadPlus g) => MonadPlus (InnerWrapT f g) where + mzero = InnerWrapT mzero + mplus = inInnerWrapT2 mplus + +instance (Wrapper f, MonadPlus g) => MonadPlus (OuterWrapT f g) where + mzero = OuterWrapT $ wrap mzero + mplus = inOuterWrapT2 $ inWrapper2 mplus + +instance Wrapper f => MonadTrans (InnerWrapT f) where + lift = InnerWrapT . liftM wrap + +instance Wrapper f => MonadTrans (OuterWrapT f) where + lift = OuterWrapT . wrap + +instance (Wrapper f, MonadState s g) => MonadState s (InnerWrapT f g) where + get = lift get + put = lift . put + +instance (Wrapper f, MonadState s g) => MonadState s (OuterWrapT f g) where + get = lift get + put = lift . put + +instance (Wrapper f, MonadIO g) => MonadIO (InnerWrapT f g) where + liftIO = lift . liftIO + +instance (Wrapper f, MonadIO g) => MonadIO (OuterWrapT f g) where + liftIO = lift . liftIO + +{- +contWrapper :: (b -> d) -> (e -> c) -> + (((a -> b) -> c) -> b) -> (((a -> d) -> e) -> d) +-} +contWrapper :: (forall b. m b -> n b) -> (n c -> m c) -> + (((a -> m b) -> m c) -> m d) -> (((a -> n b) -> n c) -> n d) +contWrapper lift unlift = circumpose lift . circumpose unlift $ result lift +{- +contWrapper lift unlift = ((argument $ circumpose unlift (result lift)) . + result lift + ) +contWrapper lift unlift = ((argument $ inCompose (result lift) unlift) . + result lift + ) +contWrapper lift unlift = ((argument $ + argument (result lift) . result unlift) . + result lift + ) +contWrapper lift unlift = ((argument $ + (argument . result) lift . result unlift) . + result lift + ) +contWrapper lift unlift = ((argument . argument . result) lift . + (argument . result) unlift . + result lift + ) +-} + +unliftInner :: (Wrapper f, Monad g) => InnerWrapT f g a -> g a +unliftInner = liftM unwrap . runInnerWrapT + +innerWrapper :: (Wrapper f, Monad g) => ( + (forall a. g a -> InnerWrapT f g a) -> + (InnerWrapT f g a -> g a) -> + b + ) -> b +innerWrapper w = w lift unliftInner + +instance (Wrapper f, MonadCont g) => MonadCont (InnerWrapT f g) where + callCC = innerWrapper contWrapper callCC + -- callCC = contWrapper lift unliftInner callCC + -- callCC = contWrapper lift (liftM unwrap . runInnerWrapT) callCC + {- + callCC = ((argument . argument . result) lift . + (argument . result) (liftM unwrap . runInnerWrapT) . + result lift + ) callCC + -} + +unliftOuter :: Wrapper f => OuterWrapT f g a -> g a +unliftOuter = unwrap . runOuterWrapT + +outerWrapper :: (Wrapper f, Monad g) => ( + (forall a. g a -> OuterWrapT f g a) -> + (OuterWrapT f g a -> g a) -> + b + ) -> b +outerWrapper w = w lift unliftOuter + +instance (Wrapper f, MonadCont g) => MonadCont (OuterWrapT f g) where + callCC = outerWrapper contWrapper callCC + -- callCC = contWrapper lift unliftOuter callCC + -- callCC = contWrapper lift (unwrap . runOuterWrapT) callCC + {- + callCC = ((argument . argument . result) lift . + (argument . result) (unwrap . runOuterWrapT) . + result lift + ) callCC + -} + +{- +catchWrapper :: (m a -> n a) -> (n a -> m a) -> + (m a -> (e -> m a) -> m a) -> (n a -> (e -> n a) -> n a) +-} +catchWrapper :: (a -> b) -> (b -> a) -> + (a -> (e -> a) -> a) -> (b -> (e -> b) -> b) +catchWrapper lift unlift = inCompose unlift . circumpose lift $ result unlift + +instance (Wrapper f, MonadError e g) => MonadError e (InnerWrapT f g) where + throwError = lift . throwError + catchError = innerWrapper catchWrapper catchError + -- catchError = catchWrapper lift unliftInner catchError + {- + catchError = (inCompose unliftInner . circumpose lift $ result unliftInner) + catchError + -} + +instance (Wrapper f, MonadError e g) => MonadError e (OuterWrapT f g) where + throwError = lift . throwError + catchError = outerWrapper catchWrapper catchError + -- catchError = catchWrapper lift unliftOuter catchError + {- + catchError = (inCompose unliftOuter . circumpose lift $ result unliftOuter) + catchError + -} + +fixWrapper :: (m a -> n a) -> (n a -> m a) -> + ((a -> m a) -> m a) -> ((a -> n a) -> n a) +fixWrapper lift unlift = circumpose lift $ result unlift + +instance (Wrapper f, MonadFix g) => MonadFix (InnerWrapT f g) where + mfix = innerWrapper fixWrapper mfix + -- mfix = fixWrapper lift unliftInner mfix + +instance (Wrapper f, MonadFix g) => MonadFix (OuterWrapT f g) where + mfix = outerWrapper fixWrapper mfix + -- mfix = fixWrapper lift unliftOuter mfix + +readerWrapper :: (m a -> n a) -> (n a -> m a) -> + ((r -> r) -> m a -> m a) -> ((r -> r) -> n a -> n a) +readerWrapper lift unlift = result $ inCompose unlift lift + +instance (Wrapper f, MonadReader r g) => MonadReader r (InnerWrapT f g) where + ask = lift ask + local = innerWrapper readerWrapper local + +instance (Wrapper f, MonadReader r g) => MonadReader r (OuterWrapT f g) where + ask = lift ask + local = outerWrapper readerWrapper local + +writerWrapper :: (m b -> n b) -> (n a -> m a) -> + (m a -> m b) -> (n a -> n b) +writerWrapper = circumpose + +instance (Wrapper f, MonadWriter w g) => MonadWriter w (InnerWrapT f g) where + tell = lift . tell + listen = innerWrapper writerWrapper listen + pass = innerWrapper writerWrapper pass + +instance (Wrapper f, MonadWriter w g) => MonadWriter w (OuterWrapT f g) where + tell = lift . tell + listen = outerWrapper writerWrapper listen + pass = outerWrapper writerWrapper pass + +instance (Wrapper f, Functor g, Arbitrary (g a)) => + Arbitrary (InnerWrapT f g a) where + arbitrary = InnerWrapT . fmap wrap <$> arbitrary + coarbitrary = coarbitrary . fmap unwrap . runInnerWrapT + +instance (Wrapper f, Arbitrary (g a)) => Arbitrary (OuterWrapT f g a) where + arbitrary = OuterWrapT . wrap <$> arbitrary + coarbitrary = coarbitrary . unwrap . runOuterWrapT + +-- vim: expandtab:tabstop=4:shiftwidth=4 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Iain Alexander 2010. +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 Iain Alexander 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/flexiwrap.cabal b/flexiwrap.cabal new file mode 100644 --- /dev/null +++ b/flexiwrap.cabal @@ -0,0 +1,46 @@ +Name: flexiwrap +Version: 0.0.1 +Cabal-version: >= 1.2.3 +Build-Type: Simple +Synopsis: Flexible wrappers +Description: MPTC/FD framework using multi-purpose wrappers + to direct instance selection +Category: Data +License: BSD3 +License-File: LICENSE +Author: Iain Alexander +Maintainer: Iain Alexander +Build-Type: Simple +Extra-source-files: Data/Flex/SmallCheck/Wrap.hs + , Data/Flex/Test/Compose.hs + , Data/Flex/Test/Wrap.hs + , Data/Flex/Test/WrappedMonad.hs + , Data/Flex/Examples/Lex/Simple.hs + , Data/Flex/Examples/Lex/Strict.hs + , Data/Wrap.hs + , .ghci +Tested-with: GHC==6.4.1, GHC==6.6.1, GHC==6.8.3, GHC==6.10.4, GHC==6.12.3 + , GHC==7.0.1 +Library + Exposed-Modules: Data.Flex.Applicative + , Data.Flex.Compose + , Data.Flex.FlipT + , Data.Flex.Functor + , Data.Flex.Monad + , Data.Flex.MonadPlus + , Data.Flex.MonadState + , Data.Flex.MonadTrans + , Data.Flex.Utils + , Data.Flex.Wrap + , Data.Flex.WrapCTC + , Data.Flex.WrappedMonad + , Data.Flex.WrapT + if impl(ghc < 6.6.1) + Extensions: UndecidableInstances + Build-Depends: special-functors < 2 + if impl(ghc < 6.8.1) + Ghc-options: -fglasgow-exts + if impl(ghc >= 6.8.1) + Extensions: TypeOperators, KindSignatures + Build-Depends: base < 5, data-type < 0.1, mtl < 2.1 +-- vim: expandtab:tabstop=4:shiftwidth=4