clean-unions 0.0.2 → 0.1

raw patch · 2 files changed

+66/−9 lines, 2 files

Files

• clean-unions.cabal +2/−1
• src/Data/OpenUnion1/Clean.hs +64/−8

@@ -1,5 +1,5 @@ name:                clean-unions
-version:             0.0.2
+version:             0.1
 synopsis:            Open unions without need for Typeable
 -- description:         
 homepage:            https://github.com/fumieval/clean-unions
@@ -19,4 +19,5 @@   other-extensions:    Rank2Types, TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, DataKinds, KindSignatures, PolyKinds, GADTs, ScopedTypeVariables, LambdaCase, OverlappingInstances
   build-depends:       base == 4.*
   hs-source-dirs:      src
+  ghc-options: -Wall
   default-language:    Haskell2010

@@ -13,25 +13,41 @@   , FlexibleContexts
   , FunctionalDependencies
   , UndecidableInstances
-  , OverlappingInstances #-}
-module Data.OpenUnion1.Clean (Union(..), Nil, List(..), (|>)(..), (||>), exhaust, simply, (∈)(), Member, liftU, (⊆)(..), Include) where
+  , OverlappingInstances
+  , EmptyDataDecls #-}
+module Data.OpenUnion1.Clean (
+  -- * Basic types and classes
+  Union(..), 
+  Nil, (|>)(),
+  List(..),
+  (∈)(), Member, 
+  -- * Construction
+  liftU,
+  -- * Transformation
+  (⊆)(..), Include,
+  Pick(..),
+  hoistU,
+  -- * Destruction
+  (||>), 
+  exhaust, 
+  simply,
+  retractU) where
 
+import Control.Applicative
+
 data Proxy a = Proxy
 
 -- | Poly-kinded list
 data List a = Empty | a :> List a
 
-infixr 5 :>
 infixr 5 |>
+infixr 5 :>
 
 -- | Append a new element to a union.
 type family (f :: * -> *) |> (s :: * -> *) :: * -> *
 
 type instance f |> Union s = Union (f :> s)
 
--- | Combine two 'List's.
-type family (s :: List k) ++> (t :: List k) :: List k
-
 -- | An uninhabited union.
 type Nil = Union Empty
 
@@ -73,7 +89,7 @@ infix 4 ⊆
 
 instance f ∈ (f :> s) where query _ _ = Zero
-instance (f ∈ s) => f ∈ (g :> s) where query p q = Succ (query p (Proxy :: Proxy s))
+instance (f ∈ s) => f ∈ (g :> s) where query p _ = Succ (query p (Proxy :: Proxy s))
 
 -- | Lift some value into a union.
 liftU :: forall s f a. (f ∈ s) => f a -> Union s a
@@ -82,6 +98,46 @@   go Zero = Single f
   go (Succ q) = Union (go q)
 
+class Pick f s where
+  -- | Traversal for a specific element
+  picked :: Applicative g => (f a -> g (f a)) -> Union s a -> g (Union s a)
+
+instance Pick f s => Pick f (f :> s) where
+  picked k (Single f) = Single <$> k f
+  picked k (Union u) = Union <$> picked k u
+
+instance Pick f s => Pick f (g :> s) where
+  picked _ u@(Single _) = pure u
+  picked k (Union u) = Union <$> picked k u
+
+instance Pick f Empty where
+  picked _ = pure
+
+newtype Id a = Id { getId :: a }
+
+instance Functor Id where
+  fmap f (Id a) = Id (f a)
+
+instance Applicative Id where
+  pure = Id
+  Id f <*> Id a = Id (f a)
+
+newtype C a b = C { getC :: Maybe a }
+
+instance Functor (C a) where
+  fmap _ (C a) = C a
+
+instance Applicative (C a) where
+  pure _ = C Nothing
+  C (Just a) <*> C _ = C (Just a)
+  C _ <*> C b = C b
+
+retractU :: Pick f s => Union s a -> Maybe (f a)
+retractU u = getC (picked (C . Just) u)
+
+hoistU :: Pick f s => (f a -> f a) -> Union s a -> Union s a
+hoistU f u = getId (picked (Id . f) u)
+
 -- | Type-level inclusion characterized by 'reunion'.
 class s ⊆ t where
   -- | Lift a union into equivalent or larger one, permuting elements if necessary.
@@ -97,4 +153,4 @@ 
 type Member f s = f ∈ s
 
-type Include s t = s ⊆ t
+type Include s t = s ⊆ t