diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal --- a/haskus-utils-variant.cabal +++ b/haskus-utils-variant.cabal @@ -1,5 +1,5 @@ name: haskus-utils-variant -version: 3.0 +version: 3.1 synopsis: Variant and EADT license: BSD3 license-file: LICENSE diff --git a/src/bench/Main.hs b/src/bench/Main.hs --- a/src/bench/Main.hs +++ b/src/bench/Main.hs @@ -16,8 +16,6 @@ import Haskus.Utils.Variant -import Haskus.Utils.EADT -import Haskus.Utils.EADT.TH import Haskus.Utils.ContFlow import Criterion @@ -80,56 +78,18 @@ nodeToVariantNode !(NPlus a b) = VariantNode (toVariantAt @1 (Plus (nodeToVariantNode a) (nodeToVariantNode b))) nodeToVariantNode !(NMinus a b) = VariantNode (toVariantAt @2 (Minus (nodeToVariantNode a) (nodeToVariantNode b))) ------------------------------------------- --- EADT ------------------------------------------- - -data PlusF e = PlusF e e deriving (Generic,NFData) -data MinusF e = MinusF e e deriving (Generic,NFData) -newtype ValueF a e = ValueF a deriving newtype (NFData) - -eadtPattern 'PlusF "EPlus" -eadtPattern 'MinusF "EMinus" -eadtPattern 'ValueF "EValue" - -type EADTNode a = EADT '[ValueF a, PlusF, MinusF] - -nodeToEADTNode :: Node a -> EADTNode a -nodeToEADTNode !(NValue a) = EValue a -nodeToEADTNode !(NPlus a b) = EPlus (nodeToEADTNode a) (nodeToEADTNode b) -nodeToEADTNode !(NMinus a b) = EMinus (nodeToEADTNode a) (nodeToEADTNode b) - -evalEADTNode :: Num a => EADTNode a -> a -evalEADTNode (EValue v) = v -evalEADTNode (EPlus a b) = evalEADTNode a + evalEADTNode b -evalEADTNode (EMinus a b) = evalEADTNode a - evalEADTNode b -evalEADTNode _ = undefined - -evalEADTNodeSafe :: forall a. Num a => EADTNode a -> a -evalEADTNodeSafe v = eadtToCont v >::> - ( \(ValueF x) -> x - , \(PlusF a b) -> evalEADTNodeSafe a + evalEADTNodeSafe b - , \(MinusF a b) -> evalEADTNodeSafe a - evalEADTNodeSafe b - ) - - - - main :: IO () main = do let evalEnv n = do !tree1 <- generate (resize n (arbitrary :: Gen (Node Int))) let !tree2 = nodeToVariantNode tree1 - let !tree3 = nodeToEADTNode tree1 - return (n,tree1,tree2,tree3) + return (n,tree1,tree2) - evalTest ~(n,tree1,tree2,tree3) = bgroup ("Tree Eval at size=" ++ show n) + evalTest (n,tree1,tree2) = bgroup ("Tree Eval at size=" ++ show n) [ bench "ADT" $ whnf evalNode tree1 , bench "Variant ADT - V" $ whnf evalVariantNode tree2 , bench "Variant ADT - Safe match" $ whnf evalVariantNodeSafe tree2 - , bench "EADT - Patterns" $ whnf evalEADTNode tree3 - , bench "EADT - Safe match" $ whnf evalEADTNodeSafe tree3 ] diff --git a/src/lib/Haskus/Utils/ContFlow.hs b/src/lib/Haskus/Utils/ContFlow.hs --- a/src/lib/Haskus/Utils/ContFlow.hs +++ b/src/lib/Haskus/Utils/ContFlow.hs @@ -24,13 +24,14 @@ where import Haskus.Utils.Tuple +import Haskus.Utils.Types -- | A continuation based control-flow -newtype ContFlow (xs :: [*]) r = ContFlow (ContTuple xs r -> r) +newtype ContFlow (xs :: [Type]) r = ContFlow (ContTuple xs r -> r) -- | Convert a list of types into the actual data type representing the -- continuations. -type family ContTuple (xs :: [*]) r where +type family ContTuple (xs :: [Type]) r where ContTuple xs r = Tuple (ToMultiCont xs r) type family ToMultiCont xs r where @@ -39,7 +40,7 @@ -- | A multi-continuable type class MultiCont a where - type MultiContTypes a :: [*] + type MultiContTypes a :: [Type] -- | Convert a data into a multi-continuation toCont :: a -> ContFlow (MultiContTypes a) r @@ -84,7 +85,7 @@ -- | Bind a flow to a 1-tuple of continuations (>:-:>) :: ContFlow '[a] r -> (a -> r) -> r {-# INLINABLE (>:-:>) #-} -(>:-:>) (ContFlow f) c = f (Unit c) +(>:-:>) (ContFlow f) c = f (Solo c) infixl 0 >:-:> diff --git a/src/lib/Haskus/Utils/EADT.hs b/src/lib/Haskus/Utils/EADT.hs --- a/src/lib/Haskus/Utils/EADT.hs +++ b/src/lib/Haskus/Utils/EADT.hs @@ -26,6 +26,8 @@ , popEADT , contToEADT , contToEADTM + , EADTShow (..) + , eadtShow -- * Reexport , module Haskus.Utils.Functor , module Haskus.Utils.VariantF @@ -175,3 +177,11 @@ (f (V (ApplyAll (EADT xs) xs))) -> f (EADT xs) contToEADTM f = EADT <$> contToVariantFM f + + +class EADTShow f where + eadtShow' :: f String -> String + +-- | Show an EADT +eadtShow :: forall xs. BottomUpF EADTShow xs => EADT xs -> String +eadtShow = bottomUp (toBottomUp @EADTShow eadtShow') diff --git a/src/lib/Haskus/Utils/EADT/TH.hs b/src/lib/Haskus/Utils/EADT/TH.hs --- a/src/lib/Haskus/Utils/EADT/TH.hs +++ b/src/lib/Haskus/Utils/EADT/TH.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} -- | Template-Haskell helpers for EADTs module Haskus.Utils.EADT.TH @@ -112,8 +113,11 @@ ForallT tvs _ tys -> do -- make pattern let getConArity = \case - _ :->: b -> 1 + getConArity b - _ -> 0 + AppT (AppT ArrowT _a) b -> 1 + getConArity b +#if MIN_VERSION_base(4,15,0) + AppT (AppT (AppT MulArrowT _m) _a) b -> 1 + getConArity b +#endif + _ -> 0 conArity = getConArity tys conArgs <- replicateM conArity (newName "c") @@ -132,7 +136,10 @@ let -- retrieve constructor type without the functor var -- e.g. ConsF a for ConsF a e - getConTyp (_ :->: b) = getConTyp b + getConTyp (AppT (AppT ArrowT _a) b) = getConTyp b +#if MIN_VERSION_base(4,15,0) + getConTyp (AppT (AppT (AppT MulArrowT _m) _a) b) = getConTyp b +#endif getConTyp (AppT a _) = a -- remove last AppT (functor var) getConTyp _ = error "Invalid constructor type" @@ -141,8 +148,12 @@ -- [* -> *] tyToTyList = AppT ListT (AppT (AppT ArrowT StarT) StarT) - -- retreive functor var in "e" + -- retrieve functor var in "e" +#if MIN_VERSION_base(4,15,0) + KindedTV e _ StarT = last tvs +#else KindedTV e StarT = last tvs +#endif -- make pattern type @@ -150,7 +161,11 @@ xsName <- newName "xs" let xs = VarT xsName +#if MIN_VERSION_base(4,15,0) + xsTy = KindedTV xsName SpecifiedSpec tyToTyList +#else xsTy = KindedTV xsName tyToTyList +#endif eadtXs <- [t| EADT $(return xs) |] prd <- [t| $(return conTyp) :<: $(return xs) |] @@ -172,9 +187,16 @@ tvs' = tvs ++ newTvs -- replace functor variable with EADT type - go (VarT x :->: b) - | x == e = eadtTy :->: go b - go (a :->: b) = a :->: go b + go (AppT (AppT ArrowT a) b) + | VarT v <- a + , v == e = AppT (AppT ArrowT eadtTy) (go b) + | otherwise = AppT (AppT ArrowT a) (go b) +#if MIN_VERSION_base(4,15,0) + go (AppT (AppT (AppT MulArrowT m) a) b) + | VarT v <- a + , v == e = AppT (AppT (AppT MulArrowT m) eadtTy) (go b) + | otherwise = AppT (AppT (AppT MulArrowT m) a) (go b) +#endif go _ = eadtTy t' = go tys @@ -184,7 +206,3 @@ return [sig,pat] _ -> fail $ show consName ++ "'s type doesn't have a free variable, it can't be a functor" - - -pattern (:->:) :: Type -> Type -> Type -pattern a :->: b = AppT (AppT ArrowT a) b diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs --- a/src/lib/Haskus/Utils/Variant.hs +++ b/src/lib/Haskus/Utils/Variant.hs @@ -103,6 +103,7 @@ , toVariant' , LiftVariant' , PopVariant + , ToVariantMaybe(..) , showsVariant ) where @@ -127,7 +128,7 @@ -- | A variant contains a value whose type is at the given position in the type -- list -data V (l :: [*]) = Variant {-# UNPACK #-} !Word Any +data V (l :: [Type]) = Variant {-# UNPACK #-} !Word Any -- Make GHC consider `l` as a representational parameter to make coercions -- between Variant values unsafe @@ -302,7 +303,7 @@ -- >>> toVariantAt @1 10 :: V '[Word,Int,Double] -- 10 -- -toVariantAt :: forall (n :: Nat) (l :: [*]). +toVariantAt :: forall (n :: Nat) (l :: [Type]). ( KnownNat n ) => Index n l -> V l {-# INLINABLE toVariantAt #-} @@ -338,7 +339,7 @@ -- >>> fromVariantAt @2 x -- Nothing -- -fromVariantAt :: forall (n :: Nat) (l :: [*]). +fromVariantAt :: forall (n :: Nat) (l :: [Type]). ( KnownNat n ) => V l -> Maybe (Index n l) {-# INLINABLE fromVariantAt #-} @@ -526,6 +527,35 @@ {-# INLINABLE toVariant' #-} toVariant' = toVariantAt @(IndexOf a l) + +-- | Put a value into a variant if possible +-- +-- >>> toVariantMaybe "Test" :: Maybe (V '[Int,Float]) +-- Nothing +-- +-- >>> toVariantMaybe "Test" :: Maybe (V '[Int,Float,String]) +-- Just "Test" +-- +class ToVariantMaybe a xs where + -- | Put a value into a Variant, when the Variant's row contains that type. + toVariantMaybe :: a -> Maybe (V xs) + +instance ToVariantMaybe a '[] where + {-# INLINABLE toVariantMaybe #-} + toVariantMaybe _ = Nothing + +instance forall a xs n y ys. + ( n ~ MaybeIndexOf a xs + , KnownNat n + , xs ~ (y ': ys) + ) => ToVariantMaybe a (y ': ys) + where + {-# INLINABLE toVariantMaybe #-} + toVariantMaybe a + = case natValue' @n of + 0 -> Nothing + n -> Just (Variant (n-1) (unsafeCoerce a)) + class PopVariant a xs where -- | Remove a type from a variant popVariant' :: V xs -> Either (V (Remove a xs)) a @@ -598,6 +628,7 @@ -- We don't check that "x" is in "xs". type (: Constraint" function returning an empty constraint +-- | Useful to specify a "Type -> Constraint" function returning an empty constraint class NoConstraint a instance NoConstraint a -class AlterVariant c (b :: [*]) where +class AlterVariant c (b :: [Type]) where alterVariant' :: (forall a. c a => a -> a) -> Word -> Any -> Any instance AlterVariant c '[] where @@ -924,7 +955,7 @@ -- instance (Ord a, Num a) => OrdNum a -- alterVariant @OrdNum foo v -- -alterVariant :: forall c (a :: [*]). +alterVariant :: forall c (a :: [Type]). ( AlterVariant c a ) => (forall x. c x => x -> x) -> V a -> V a {-# INLINABLE alterVariant #-} @@ -934,7 +965,7 @@ -class TraverseVariant c (b :: [*]) m where +class TraverseVariant c (b :: [Type]) m where traverseVariant' :: (forall a . (Monad m, c a) => a -> m a) -> Word -> Any -> m Any instance TraverseVariant c '[] m where @@ -956,7 +987,7 @@ -- | Traverse a variant. You need to specify the constraints required by the -- modifying function. -traverseVariant :: forall c (a :: [*]) m. +traverseVariant :: forall c (a :: [Type]) m. ( TraverseVariant c a m , Monad m ) => (forall x. c x => x -> m x) -> V a -> m (V a) @@ -966,7 +997,7 @@ -- | Traverse a variant. You need to specify the constraints required by the -- modifying function. -traverseVariant_ :: forall c (a :: [*]) m. +traverseVariant_ :: forall c (a :: [Type]) m. ( TraverseVariant c a m , Monad m ) => (forall x. c x => x -> m ()) -> V a -> m () @@ -978,7 +1009,7 @@ -class ReduceVariant c (b :: [*]) where +class ReduceVariant c (b :: [Type]) where reduceVariant' :: (forall a. c a => a -> r) -> Word -> Any -> r instance ReduceVariant c '[] where @@ -1006,7 +1037,7 @@ -- >>> let n = V (10 :: Int) :: V '[Int,Word,Integer] -- >>> reduceVariant @Integral fromIntegral n :: Int -- 10 -reduceVariant :: forall c (a :: [*]) r. +reduceVariant :: forall c (a :: [Type]) r. ( ReduceVariant c a ) => (forall x. c x => x -> r) -> V a -> r {-# INLINABLE reduceVariant #-} @@ -1019,12 +1050,12 @@ ----------------------------------------------------------- -- | Extend a variant by appending other possible values -appendVariant :: forall (ys :: [*]) (xs :: [*]). V xs -> V (Concat xs ys) +appendVariant :: forall (ys :: [Type]) (xs :: [Type]). V xs -> V (Concat xs ys) {-# INLINABLE appendVariant #-} appendVariant (Variant t a) = Variant t a -- | Extend a variant by prepending other possible values -prependVariant :: forall (ys :: [*]) (xs :: [*]). +prependVariant :: forall (ys :: [Type]) (xs :: [Type]). ( KnownNat (Length ys) ) => V xs -> V (Concat ys xs) {-# INLINABLE prependVariant #-} @@ -1079,7 +1110,7 @@ productVariant (Variant n1 a1) (Variant n2 a2) = Variant (n1 * natValue @(Length ys) + n2) (unsafeCoerce (a1,a2)) -type family FlattenVariant (xs :: [*]) :: [*] where +type family FlattenVariant (xs :: [Type]) :: [Type] where FlattenVariant '[] = '[] FlattenVariant (V xs:ys) = Concat xs (FlattenVariant ys) FlattenVariant (y:ys) = y ': FlattenVariant ys @@ -1232,21 +1263,21 @@ instance ContVariant '[a] where {-# INLINABLE variantToCont #-} - variantToCont (Variant _ a) = ContFlow $ \(Unit f) -> + variantToCont (Variant _ a) = ContFlow $ \(Solo f) -> f (unsafeCoerce a) {-# INLINABLE variantToContM #-} - variantToContM act = ContFlow $ \(Unit f) -> do + variantToContM act = ContFlow $ \(Solo f) -> do Variant _ a <- act f (unsafeCoerce a) {-# INLINABLE contToVariant #-} contToVariant c = c >::> - Unit (toVariantAt @0) + Solo (toVariantAt @0) {-# INLINABLE contToVariantM #-} contToVariantM c = c >::> - Unit (return . toVariantAt @0) + Solo (return . toVariantAt @0) instance ContVariant '[a,b] where {-# INLINABLE variantToCont #-} diff --git a/src/lib/Haskus/Utils/VariantF.hs b/src/lib/Haskus/Utils/VariantF.hs --- a/src/lib/Haskus/Utils/VariantF.hs +++ b/src/lib/Haskus/Utils/VariantF.hs @@ -96,7 +96,7 @@ -- False -- | Recursive Functor-like Variant -newtype VariantF (xs :: [t -> *]) (e :: t) +newtype VariantF (xs :: [t -> Type]) (e :: t) = VariantF (V (ApplyAll e xs)) -- | Apply its first argument to every element of the 2nd arg list @@ -233,12 +233,12 @@ variantFToValue :: VariantF '[f] e -> f e variantFToValue (VariantF v) = variantToValue v -appendVariantF :: forall (ys :: [* -> *]) (xs :: [* -> *]) e. +appendVariantF :: forall (ys :: [Type -> Type]) (xs :: [Type -> Type]) e. ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys) ) => VariantF xs e -> VariantF (Concat xs ys) e appendVariantF (VariantF v) = VariantF (appendVariant @(ApplyAll e ys) v) -prependVariantF :: forall (xs :: [* -> *]) (ys :: [* -> *]) e. +prependVariantF :: forall (xs :: [Type -> Type]) (ys :: [Type -> Type]) e. ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys) , KnownNat (Length (ApplyAll e xs)) ) => VariantF ys e -> VariantF (Concat xs ys) e