packages feed

existential (empty) → 0.1.0.0

raw patch · 5 files changed

+520/−0 lines, 5 filesdep +QuickCheckdep +basedep +existentialsetup-changed

Dependencies added: QuickCheck, base, existential, lens, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Simon Hudon++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Eq.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell,TypeSynonymInstances,FlexibleInstances,MultiParamTypeClasses #-}+import Control.Lens+import Data.Existential++newtype MyType = MyType { _myTypeCell :: Cell MyClass }++class (Eq a, Show a) => MyClass a where++makeFields ''MyType+    -- makeFields create an Iso' MyType (Cell Eq) called cell,+    -- i.e. MyType is made into an instance of HasCell.++instance Eq MyType where+    (==) = cellEqual' (==)++instance Show MyType where+    show = ("MyType " ++) . readCell' show++instance MyClass Int where+instance MyClass Char where+instance MyClass a => MyClass [a] where++main :: IO ()+main = do+    let xs = [makeCell (7 :: Int),makeCell "hello",makeCell [1,2,3::Int]]+        xs :: [MyType]+    print $ xs == xs+        -- prints True+    let ys = xs & traverse._Cell' .~ (8 :: Int)+        ys' = replicate 3 $ makeCell (8 :: Int)+        zs  = [makeCell (8 :: Int),makeCell "hello",makeCell [1,2,3::Int]]+        zs :: [MyType]+        zs' = xs & traverse .~ makeCell (8 :: Int)+        zs' :: [MyType]+        zs'' = xs & traverse %~ readCell' (makeCell . show)+        zs'' :: [MyType]+    print $ xs == ys+        -- prints False+    print $ ys == ys'+        -- prints False+    print $ zs == ys+        -- prints True+    print $ zs' == ys'+        -- prints True+    print zs+        -- prints [MyType 8,MyType "hello",MyType [1,2,3]]+    print zs'+        -- prints [MyType 8,MyType 8,MyType 8]+    print zs''+        -- prints [MyType "7",MyType "\"hello\"",MyType "[1,2,3]"]
+ existential.cabal view
@@ -0,0 +1,78 @@+-- Initial existential.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                existential++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            A library for existential types++-- A longer description of the package.+description:         The library defines the type Cell and Cell1 uses Constraint kinds to so that it can stand for any existential type. Combinators and lenses of various types are built on top of 'Cell' and 'Cell1'++-- URL for the project homepage or repository.+homepage:            https://bitbucket.org/cipher2048/existential/wiki/Home++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Simon Hudon++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          simon.hudon@gmail.com++-- A copyright notice.+copyright:           Simon Hudon++category:            Data++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://cipher2048@bitbucket.org/cipher2048/existential.git++library+  -- Modules exported by the library.+  exposed-modules: Data.Existential+  +  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- LANGUAGE extensions used by modules in this package.+  default-extensions:    TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, Rank2Types+  +  -- Other library packages from which modules are imported.+  build-depends:       base >=4.8 && <4.9, QuickCheck, template-haskell, lens+  +  -- Directories containing source files.+  hs-source-dirs:      src+  +  -- Base language which the package is written in.+  default-language:    Haskell2010++executable example-Eq+  main-is: examples/Eq.hs+  -- other-modules:+  build-depends: base >=4.8 && <4.9, lens, existential+  default-language:    Haskell2010
+ src/Data/Existential.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE KindSignatures+    ,ConstraintKinds+    ,ExistentialQuantification+    #-}+-- | Conventions: +--   * fooCell: a function that applies to 'Cell's directly+--   * fooCell': a function, very similar to fooCell but +--     that applies to a type which wraps a 'Cell' using+--     an instance of 'HasCell'+--   * fooCell1: a function that applies to 'Cell1'+--   * fooCell1': a function that a applies to a wrapped Cell1 +--     (depends on 'HasCell')+module Data.Existential where++import Control.Applicative as A+import Control.Lens+import Control.Monad++import Data.Maybe+import Data.Typeable++import GHC.Exts (Constraint)++import Language.Haskell.TH++import Test.QuickCheck++import Text.Printf++-- |+-- = The Cell Type+++-- | A polymorphic cell. Type 'Cell MyClass' can take a value of any+-- type that conforms to 'MyClass' and to 'Typeable'. It is defined+-- in terms of 'Cell1'.+type Cell = Cell1 Identity++data Cell1 f (constr :: * -> Constraint) = forall a. (constr a, Typeable a) => Cell (f a)+-- ^ Generilization of 'Cell'. 'Cell1 MyFunctor MyClass' takes values+-- ^ of type 'MyFunctor a' with '(MyClass a,Typeable a)'.++-- | 'HasCell' permits the overloading of "Iso" 'cell' and makes it easier+-- | to wrap a 'Cell' with a newtype without having to mention 'Cell' all+-- | the time.+class HasCell a b | a -> b where+    cell :: Iso' a b++instance HasCell (Cell1 f constr) (Cell1 f constr) where+    cell = id++-- |+-- = Contructors++makeCell :: (HasCell a (Cell constr), constr b, Typeable b)+         => b -> a+-- ^ We can use 'makeCell "hello" :: MyType' if there is an instance+-- ^ 'HasCell MyType (Cell Show)' (or any other class than show).+makeCell = makeCell1 . Identity++-- ^ Similar to 'makeCell'. Uses 'Cell1' to allow the content+-- ^ of a 'Cell' to be wrapped with a generic type.+makeCell1 :: (HasCell a (Cell1 f constr), constr b, Typeable b)+          => f b -> a+makeCell1 x = Cell x ^. from cell++-- |+-- = Prisms++_Cell :: (constr b,Typeable b,Typeable a) => Prism (Cell constr) (Cell constr) a b+-- ^ Treats a 'Cell' as an unbounded sum type: 'c^?_Cell :: Maybe a' has the+-- ^ value 'Just x' if x is of type 'a' and 'c' contains value 'x'. If cell 'c'+-- ^ has a value of any other type then 'a', 'c^?_Cell == Nothing'.+_Cell = _Cell1._Wrapped++_Cell' :: (constr a,Typeable a,HasCell c (Cell constr)) => Prism c c a a+-- ^ Similar to '_Cell' but operates on types that wrap a cell instead of+-- ^ on the cell itself.+_Cell' = cell.asCell++_Cell1 :: (constr b,Typeable b,Typeable a,Typeable f) +       => Prism (Cell1 f constr) (Cell1 f constr) (f a) (f b)+-- ^ Similar to '_Cell' but values are wrapped in type 'f' inside the cell.+_Cell1 = prism Cell $ \x -> maybe (Left x) Right $ readCell1 cast x++_Cell1' :: (constr a,Typeable a,Typeable f,HasCell c (Cell1 f constr)) => Prism c c (f a) (f a)+-- ^ Analogous to '_Cell'' and '_Cell1'.+_Cell1' = cell.asCell1++asCell :: (constr a,Typeable a) => Prism (Cell constr) (Cell constr) a a+-- ^ Like '_Cell' but disallows changing the type of the content of the cell.+-- ^ facilitates type checking when the prism is not used for modification.+asCell = _Cell++asCell1 :: (constr a,Typeable a,Typeable f) => Prism (Cell1 f constr) (Cell1 f constr) (f a) (f a)+-- ^ Like '_Cell1' and as 'asCell'.+asCell1 = _Cell1++-- |+-- = Traversals++traverseCell :: Functor f => (forall a. (constr a,Typeable a) => a -> f a) +             -> Cell constr -> f (Cell constr)+traverseCell f = traverseCell1 $ _Wrapped f++traverseCell' :: (Functor f,HasCell c (Cell constr))+              => (forall a. (constr a,Typeable a) => a -> f a) -> c -> f c+traverseCell' f = cell (traverseCell f)++traverseCell1 :: Functor f => (forall a. (constr a,Typeable a) => g a -> f (h a))+              -> Cell1 g constr -> f (Cell1 h constr)+traverseCell1 f (Cell x) = Cell <$> f x++traverseCell1' :: (Functor f,HasCell c (Cell1 g constr))+               => (forall a. (constr a,Typeable a) => g a -> f (g a)) -> c -> f c+traverseCell1' f = cell (traverseCell1 f)++mapCell :: (forall a. (constr a,Typeable a) => a -> a) -> Cell constr -> Cell constr+mapCell f = runIdentity . traverseCell (Identity . f)++mapCell' :: HasCell c (Cell constr)+         => (forall a. (constr a,Typeable a) => a -> a) +         -> c -> c+mapCell' f x = mapCell f (x^.cell) ^. from cell++readCell1 :: (forall a. (constr a,Typeable a) => f a -> r) -> Cell1 f constr -> r+readCell1 = readCell1'++readCell1' :: HasCell c (Cell1 f constr)+           => (forall a. (constr a,Typeable a) => f a -> r) +           -> c -> r+readCell1' f = getConst . traverseCell1' (Const . f)++readCell :: (forall a. (constr a,Typeable a) => a -> r) -> Cell constr -> r+readCell f = getConst . traverseCell (Const . f)++readCell' :: HasCell c (Cell constr)+          => (forall a. (constr a,Typeable a) => a -> r) +          -> c -> r+readCell' f x = readCell f $ x^.cell++-- |+-- = Combinators =++apply2Cells :: Functor f+            => (forall a. (constr a,Typeable a) +                    => a -> a -> f a) +            -> f (Cell constr) +            -> Cell constr -> Cell constr +            -> f (Cell constr)+apply2Cells f = apply2Cells1 (\(Identity x) (Identity y) -> Identity <$> f x y)++apply2Cells' :: (Functor f,HasCell c (Cell constr))+             => (forall a. (constr a,Typeable a) +                     => a -> a -> f a) +             -> f c -> c -> c -> f c+apply2Cells' f def x y = view (from cell) <$> apply2Cells f (view cell <$> def) (x^.cell) (y^.cell)++apply2Cells1 :: (Functor f,Typeable g)+             => (forall a. (constr a,Typeable a) +                     => g a -> g a -> f (g a))+             -> f (Cell1 g constr) +             -> Cell1 g constr -> Cell1 g constr +             -> f (Cell1 g constr)+apply2Cells1 f def (Cell x) (Cell y) = fromMaybe def $ fmap Cell . f x <$> cast y++apply2Cells1' :: (Functor f,Typeable g,HasCell c (Cell1 g constr))+              => (forall a. (constr a,Typeable a) +                      => g a -> g a -> f (g a))+              -> f c +              -> c -> c+              -> f c+apply2Cells1' f def x y = view (from cell) <$> apply2Cells1 f (view cell <$> def) (x^.cell) (y^.cell)++map2Cells :: (forall a. (constr a,Typeable a) +                  => a -> a -> a) +          -> Cell constr -> Cell constr -> Cell constr +          -> Cell constr +map2Cells f def x y = runIdentity $ apply2Cells (fmap pure . f) (pure def) x y++map2Cells' :: HasCell c (Cell constr) +           => (forall a. (constr a,Typeable a) +                   => a -> a -> a) +           -> c -> c -> c -> c +map2Cells' f def x y = view (from cell) $ map2Cells f (def^.cell) (x^.cell) (y^.cell)++map2Cells1 :: (forall a. (constr a,Typeable a) +                   => a -> a -> a) +           -> Cell constr -> Cell constr -> Cell constr +           -> Cell constr +map2Cells1 f def x y = runIdentity $ apply2Cells (fmap pure . f) (pure def) x y++map2Cells1' :: HasCell c (Cell constr) +            => (forall a. (constr a,Typeable a) +                    => a -> a -> a) +            -> c -> c -> c -> c +map2Cells1' f def x y = view (from cell) $ map2Cells f (def^.cell) (x^.cell) (y^.cell)+++read2CellsWith :: (forall a. (constr a,Typeable a) => a -> a -> r) -> r -> Cell constr -> Cell constr -> r+read2CellsWith f = read2Cells1With $ onIdentity f++read2CellsWith' :: HasCell c (Cell constr)+                => (forall a. (constr a,Typeable a) => a -> a -> r) +                -> r -> c -> c -> r+read2CellsWith' f def x y = read2CellsWith f def (x^.cell) (y^.cell)++read2Cells1With :: Typeable f+                => (forall a. (constr a,Typeable a) => f a -> f a -> r) +                -> r -> Cell1 f constr -> Cell1 f constr -> r+read2Cells1With f x = fmap getConst . apply2Cells1 (fmap Const . f) (Const x)++read2Cells1With' :: (HasCell c (Cell1 f constr),Typeable f)+                 => (forall a. (constr a,Typeable a) => f a -> f a -> r) +                 -> r -> c -> c -> r+read2Cells1With' f def x y = read2Cells1With f def (x^.cell) (y^.cell)++-- |+-- = Heterogenous Combinators+++read2CellsH :: (forall a b. (constr a,Typeable a,constr b,Typeable b) => a -> b -> r) +            -> Cell constr -> Cell constr -> r+read2CellsH f (Cell x) (Cell y) = f (runIdentity x) (runIdentity y)++read2CellsH' :: HasCell c (Cell constr)+             => (forall a b. (constr a,Typeable a,constr b,Typeable b) => a -> b -> r) +             -> c -> c -> r+read2CellsH' f x y = read2CellsH f (x^.cell) (y^.cell)++read2Cells1H :: (forall a b. (constr a,Typeable a,constr b,Typeable b) => f a -> f b -> r) +             -> Cell1 f constr -> Cell1 f constr -> r+read2Cells1H f (Cell x) (Cell y) = f x y++read2Cells1H' :: (forall a b. (constr a,Typeable a,constr b,Typeable b) => f a -> f b -> r) +              -> Cell1 f constr -> Cell1 f constr -> r+read2Cells1H' f x y = read2Cells1H f (x^.cell) (y^.cell)++-- |+-- = Comparing the content of cells++cell1Equal :: Typeable f+           => (forall a. constr a => f a -> f a -> Bool)+           -> Cell1 f constr +           -> Cell1 f constr +           -> Bool+cell1Equal f = read2Cells1With f False++cell1Equal' :: (HasCell c (Cell1 f constr),Typeable f)+            => (forall a. constr a => f a -> f a -> Bool)+            -> c -> c -> Bool+cell1Equal' f x y = cell1Equal f (x^.cell) (y^.cell)++cellEqual :: (forall a. constr a => a -> a -> Bool)+          -> Cell constr +          -> Cell constr +          -> Bool+cellEqual f = read2CellsWith f False++cellEqual' :: HasCell c (Cell constr) +           => (forall a. constr a => a -> a -> Bool)+           -> c -> c -> Bool+cellEqual' f x y = cellEqual f (x^.cell) (y^.cell)+++cellCompare :: (forall a. constr a => a -> a -> Ordering)+            -> Cell constr +            -> Cell constr +            -> Ordering+cellCompare = cellCompare'++cellCompare' :: HasCell c (Cell constr) +             => (forall a. constr a => a -> a -> Ordering)+             -> c -> c -> Ordering+cellCompare' f = cell1Compare' $ onIdentity f++cell1Compare :: (Typeable f)+             => (forall a. constr a => f a -> f a -> Ordering)+             -> Cell1 f constr +             -> Cell1 f constr +             -> Ordering+cell1Compare f x y = read2Cells1With f (x' `compare` y') x y+    where+        x' = readCell1 typeOf x :: TypeRep+        y' = readCell1 typeOf y :: TypeRep++cell1Compare' :: (HasCell c (Cell1 f constr),Typeable f)+              => (forall a. constr a => f a -> f a -> Ordering)+              -> c -> c -> Ordering+cell1Compare' f x y = cell1Compare f (x^.cell) (y^.cell)++-- |+-- = Creating Lenses++cellLens :: Functor f => (forall a. constr a => LensLike' f a b) -> LensLike' f (Cell constr) b+cellLens = cellLens'++cellLens' :: (HasCell c (Cell constr), Functor f)+          => (forall a. constr a => LensLike' f a b) +          -> LensLike' f c b+cellLens' ln f = traverseCell' (ln f)++cell1Lens :: Functor f => (forall a. constr a => LensLike' f (g a) b) -> LensLike' f (Cell1 g constr) b+cell1Lens = cell1Lens'++cell1Lens' :: (HasCell c (Cell1 g constr), Functor f)+           => (forall a. constr a => LensLike' f (g a) b) +           -> LensLike' f c b+cell1Lens' ln f = traverseCell1' (ln f)++-- |+-- = QuickCheck Helpers++arbitraryCell :: Name -> ExpQ+arbitraryCell cl = arbitraryCell' cl []++arbitraryCell' :: Name -> [TypeQ] -> ExpQ+arbitraryCell' cl ts = [e| $(arbitraryInstanceOf' 'Cell cl ts) :: Gen (Cell $(conT cl)) |]++arbitraryInstanceOf :: Name -> Name -> ExpQ+arbitraryInstanceOf cons cl = arbitraryInstanceOf' cons cl []++arbitraryInstanceOf' :: Name -> Name -> [TypeQ] -> ExpQ+arbitraryInstanceOf' cons cl ts = do+        ClassI _ is <- reify cl+        ts <- sequence ts+        let getArg (InstanceD [] (AppT _ t) []) +                | t `notElem` ts = return (Just t)+                | otherwise      = return Nothing+            getArg t = do+                reportError $ "invalid number of arguments in instance: " ++ pprint t+                return Nothing+            --trigger x = ++        is' <- catMaybes <$> mapM (fmap (fmap return) . getArg) is+        let arbits = [ [e| $(conE cons) <$> $(arb i) |] | i <- is' ]+            arb i  = sigE [e| arbitrary |] [t| Gen $i |]+        when (null is') $ fail $ printf "no instances of '%s' found" (show cl)+        [e| oneof $(listE arbits) |]++-- |+-- = Utilities++-- | Utility function to facilitate the implementation of 'Cell'+-- | functions in terms of 'Cell1' functions.+onIdentity :: (a -> b -> c) +           -> Identity a -> Identity b+           -> c+onIdentity f (Identity x) (Identity y) = f x y++-- |+-- = Properties++-- | Wrapping two values in cells does not change their equality+prop_consistent_equal :: (Eq a,Typeable a) => a -> a -> Property+prop_consistent_equal x y = cellEqual (==) (makeCell' x) (makeCell' y) === (x == y)+    where+      makeCell' = makeCell :: (Eq a,Typeable a) => a -> Cell Eq++-- | Wrapping two values in cells does not change their relative order+prop_consistent_compare :: (Ord a,Typeable a) => a -> a -> Property+prop_consistent_compare x y = cellCompare compare (makeCell' x) (makeCell' y) === (x `compare` y)+    where+      makeCell' = makeCell :: (Ord a,Typeable a) => a -> Cell Ord++return []++-- | Check all the QuickCheck properties.+run_tests :: IO Bool+run_tests = $quickCheckAll