haskus-utils-variant 3.0 → 3.1

raw patch · 7 files changed

+99/−79 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• haskus-utils-variant.cabal +1/−1
• src/bench/Main.hs +2/−42
• src/lib/Haskus/Utils/ContFlow.hs +5/−4
• src/lib/Haskus/Utils/EADT.hs +10/−0
• src/lib/Haskus/Utils/EADT/TH.hs +29/−11
• src/lib/Haskus/Utils/Variant.hs +49/−18
• src/lib/Haskus/Utils/VariantF.hs +3/−3

@@ -1,5 +1,5 @@ name:                haskus-utils-variant-version:             3.0+version:             3.1 synopsis:            Variant and EADT license:             BSD3 license-file:        LICENSE

@@ -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          ]  

@@ -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 >:-:> 

@@ -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')

@@ -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

@@ -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 (:<?) x xs =    ( PopVariant x xs+   , ToVariantMaybe x xs    )  -- | Extract a type from a variant. Return either the value of this type or the@@ -889,11 +920,11 @@ -- Generic operations with type classes ----------------------------------------------------------- --- | Useful to specify a "* -> 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 #-}

@@ -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