reflection-extras (empty) → 0.1.0.0
raw patch · 4 files changed
+488/−0 lines, 4 filesdep +aesondep +basedep +constraintssetup-changed
Dependencies added: aeson, base, constraints, lens, reflection, tagged
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- reflection-extras.cabal +53/−0
- src/Data/Reflection/Extras.hs +403/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jonathan Fischoff++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 Jonathan Fischoff 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reflection-extras.cabal view
@@ -0,0 +1,53 @@+-- Initial reflection-extras.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: reflection-extras+version: 0.1.0.0+synopsis: Utilities for the reflection package+description: + This package is meant to implement the constraint machinary for the + reflection package. It has been primarly ripped from the Constraint example+ of the reflection package with some extension. + .+ The implementation is also influenced by Austin Seipp's + <https://www.fpcomplete.com/user/thoughtpolice/using-reflection article> + on the reflection package ++homepage: http://github.com/jfischoff/reflection-extras+license: BSD3+license-file: LICENSE+author: Jonathan Fischoff, Edward Kmett, Austin Seipp+maintainer: jonathangfischoff@gmail.com+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Data.Reflection.Extras+ -- other-modules: + other-extensions: Rank2Types+ , FlexibleContexts+ , UndecidableInstances+ , TypeFamilies+ , ConstraintKinds+ , KindSignatures+ , PolyKinds+ , TypeOperators+ , FlexibleInstances+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , ExistentialQuantification + , DeriveFunctor + , CPP + + build-depends: base >=4.6 && <4.7+ , tagged >=0.7 && <0.8+ , reflection >=1.3 && <1.4+ , lens >=3.10 && <3.11+ , constraints == 0.3.*+ , aeson == 0.6.2.*+ + hs-source-dirs: src+ default-language: Haskell2010
+ src/Data/Reflection/Extras.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures#-} +{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+module Data.Reflection.Extras + ( using+ , usingT+ , reifyInstance+ , with+ , Lift+ , ReifiableConstraint (..)+ ) where+import Data.Constraint+import Data.Constraint.Unsafe+import Data.Monoid+import Data.Proxy+import Data.Reflection+import Control.Lens+import Data.Aeson+import Data.Aeson.Types+import Control.Applicative++#define REFLECT (reflect (Proxy :: Proxy s))++--------------------------------------------------------------------------------+-- Intro+-- I made this a functor to make the instances easier+newtype Lift (p :: * -> Constraint) (s :: *) (a :: *) = Lift { lower :: a }+ deriving (Functor)+ +instance Applicative (Lift p s) where+ pure = Lift+ Lift f <*> Lift x = Lift $ f x++makeIso ''Lift++newtype ProxyLift (p :: * -> Constraint) (a :: *) (s :: *) = PLift { plower :: a }++makeIso ''ProxyLift ++flipS :: Iso' (Lift p s a) (ProxyLift p a s) +flipS = from lift . pLift++class ReifiableConstraint p where+ data Def (p :: * -> Constraint) (a :: * ) :: *+ reifiedIns :: forall s a. Reifies s (Def p a) :- p (Lift p s a)+-- default reifiedIns :: forall s a. p (Lift p s a)+-- => Reifies s (Def p a) :- p (Lift p s a)+-- reifiedIns = Sub (Dict :: Reifies s (Def p a) +-- => Dict (p (Lift p s a)))++--------------------------------------------------------------------------------+-- Machinery+++with :: forall p a. Def p a -> (forall s. Reifies s (Def p a) => Lift p s a) -> a+with d v = reify d (plower . asProxyOf (view flipS v))++reifyInstance :: Def p a -> (forall (s :: *). Reifies s (Def p a) => Proxy s -> r) -> r+reifyInstance = reify++asProxyOf :: f s -> Proxy s -> f s+asProxyOf a _ = a++-- | Choose a dictionary for a local type class instance.+-- +-- >>> using (Monoid (+) 0) $ mempty <> 10 <> 12+-- > 12+-- +using :: forall p a. ReifiableConstraint p => Def p a -> (p a => a) -> a+using d m = reify d $ \(_ :: Proxy s) ->+ let replaceProof :: Reifies s (Def p a) :- p a+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p (Lift p s a) :- p a+ in m \\ replaceProof++usingT :: forall p f a. ReifiableConstraint p => Def p a -> (p a => f a) -> f a+usingT d m = reify d $ \(_ :: Proxy s) ->+ let replaceProof :: Reifies s (Def p a) :- p a+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p (Lift p s a) :- p a+ in m \\ replaceProof++{-+-- ClassProxy+data ClassProxy (p :: * -> Constraint) = ClassProxy++given :: ClassProxy c -> p s -> a -> Lift c s a+given _ _ = Lift++eq :: ClassProxy Eq+eq = ClassProxy++ord :: ClassProxy Ord+ord = ClassProxy++monoid :: ClassProxy Monoid+monoid = ClassProxy+-}+--------------------------------------------------------------------------------+-- Instances+++instance Reifies s (Def Enum a) => Enum (Lift Enum s a) where+ succ a = Lift $ succ_ REFLECT (lower a)+ pred a = Lift $ pred_ REFLECT (lower a)+ toEnum a = Lift $ toEnum_ REFLECT a+ fromEnum a = fromEnum_ REFLECT $ lower a+ enumFrom a = map Lift $ enumFrom_ REFLECT (lower a)+ enumFromThen a b = map Lift $ enumFromThen_ REFLECT (lower a) (lower b)+ enumFromTo a b = map Lift $ enumFromTo_ REFLECT (lower a) (lower b)+ enumFromThenTo a b c = map Lift $ enumFromThenTo_ REFLECT (lower a) (lower b) (lower c)++instance ReifiableConstraint Enum where+ data Def Enum a = Enum + { succ_ :: a -> a+ , pred_ :: a -> a+ , toEnum_ :: Int -> a+ , fromEnum_ :: a -> Int+ , enumFrom_ :: a -> [a]+ , enumFromThen_ :: a -> a -> [a]+ , enumFromTo_ :: a -> a -> [a]+ , enumFromThenTo_ :: a -> a -> a -> [a]+ }+ reifiedIns = Sub Dict++instance Reifies s (Def Bounded a) => Bounded (Lift Bounded s a) where+ minBound = Lift $ minBound_ REFLECT+ maxBound = Lift $ maxBound_ REFLECT++instance ReifiableConstraint Bounded where+ data Def Bounded a = Bounded + { minBound_ :: a+ , maxBound_ :: a+ }+ reifiedIns = Sub Dict++instance Reifies s (Def Num a) => Num (Lift Num s a) where+ (+) = liftA2 ((+.) REFLECT)+ (*) = liftA2 ((*.) REFLECT)+ (-) = liftA2 ((-.) REFLECT)+ negate = fmap (negate_ REFLECT) + abs = fmap (abs_ REFLECT) + signum = fmap (signum_ REFLECT) + fromInteger = Lift . fromInteger_ REFLECT++instance ReifiableConstraint Num where+ data Def Num a = Num + { (+.) :: a -> a -> a+ , (*.) :: a -> a -> a+ , (-.) :: a -> a -> a+ , negate_ :: a -> a+ , abs_ :: a -> a + , signum_ :: a -> a+ , fromInteger_ :: Integer -> a + }+ reifiedIns = Sub Dict++instance (Reifies s (Def Real a)) => Eq (Lift Real s a) where+ a == b = compare a b == EQ++instance (Reifies s (Def Real a)) => Ord (Lift Real s a) where+ compare a b = (compare_ . ordDef) REFLECT (lower a) (lower b)+ +instance (Reifies s (Def Real a)) => Num (Lift Real s a) where+ (+) = liftA2 ((+.) $ numDef REFLECT)+ (*) = liftA2 ((*.) $ numDef REFLECT)+ (-) = liftA2 ((-.) $ numDef REFLECT)+ negate = fmap (negate_ $ numDef REFLECT) + abs = fmap (abs_ $ numDef REFLECT) + signum = fmap (signum_ $ numDef REFLECT) + fromInteger = Lift . (fromInteger_ . numDef) REFLECT++instance Reifies s (Def Real a) => Real (Lift Real s a) where+ toRational a = toRational_ REFLECT (lower a)++instance ReifiableConstraint Real where+ data Def Real a = Real + { toRational_ :: a -> Rational+ , ordDef :: Def Ord a+ , numDef :: Def Num a + }+ reifiedIns = Sub Dict++{-+instance Reifies s (Def Integral a) => Real (Lift Integral s a) where+ toRational a = (toRational_ $ realDef REFLECT) (lower a)++instance Reifies s (Def Integral a) => Integral (Lift Integral s a) where+ quot a b = Lift $ quot_ REFLECT (lower a) (lower b)+ rem a b = Lift $ rem_ REFLECT (lower a) (lower b)+ div a b = Lift $ div_ REFLECT (lower a) (lower b)+ mod a b = Lift $ mod_ REFLECT (lower a) (lower b)+ quotRem a b = over both Lift $ quotRem_ REFLECT (lower a) (lower b)+ divMod a b = over both Lift $ divMod_ REFLECT (lower a) (lower b)+ toInteger a = toInteger_ REFLECT (lower a)+ +instance ReifiableConstraint Integral where+ data Def Integral a = Integral + { quot_ :: a -> a -> a+ , rem_ :: a -> a -> a+ , div_ :: a -> a -> a+ , mod_ :: a -> a -> a+ , quotRem_ :: a -> a -> (a, a)+ , divMod_ :: a -> a -> (a, a)+ , toInteger_ :: a -> Integer+ , realDef :: Def Real a+ }+ reifiedIns = Sub Dict++instance Reifies s (Def Fractional a) => Fractional (Lift Fractional s a) where+ (/) a b = Lift $ (/.) REFLECT (lower a) (lower b)+ recip a b = Lift $ recip REFLECT (lower a) (lower b)+ fromRational a b = Lift $ fromRational_ REFLECT (lower a) (lower b)++instance ReifiableConstraint Fractional where+ data Def Fractional a = Fractional + { (/.) :: a -> a -> a+ , recip_ :: a -> a+ , fromRational_ :: Rational -> a+ }+ reifiedIns = Sub Dict++instance Reifies s (Def Floating a) => Floating (Lift Floating s a) where+ pi = Lift $ pi_ reflect (Proxy :: Proxy s)+ exp a = Lift $ exp_ REFLECT (lower a) + sqrt a = Lift $ sqrt_ REFLECT (lower a) + log a = Lift $ log_ REFLECT (lower a) + (**) a b = Lift $ (**.) REFLECT (lower a) (lower b)+ logBase a b = Lift $ logBase_ REFLECT (lower a) (lower b)+ sin a = Lift $ sin_ REFLECT (lower a) + tan a = Lift $ tan_ REFLECT (lower a) + cos a = Lift $ cos_ REFLECT (lower a) + asin a = Lift $ asin_ REFLECT (lower a) + atan a = Lift $ atan_ REFLECT (lower a) + acos a = Lift $ acos_ REFLECT (lower a) + sinh a = Lift $ sinh_ REFLECT (lower a) + tanh a = Lift $ tanh_ REFLECT (lower a) + cosh a = Lift $ cosh_ REFLECT (lower a) + asinh a = Lift $ asinh_ REFLECT (lower a) + atanh a = Lift $ atanh_ REFLECT (lower a) + acosh a = Lift $ acosh_ REFLECT (lower a) ++instance ReifiableConstraint Floating where+ data Def Floating a = Floating + { pi_ :: a + , exp_ :: a -> a+ , sqrt_ :: a -> a+ , log_ :: a -> a+ , (**.) :: a -> a -> a+ , logBase_ :: a -> a -> a+ , sin_ :: a -> a+ , tan_ :: a -> a+ , cos_ :: a -> a + , asin_ :: a -> a+ , atan_ :: a -> a+ , acos_ :: a -> a+ , sinh_ :: a -> a+ , tanh_ :: a -> a+ , cosh_ :: a -> a+ , asinh_ :: a -> a + , atanh_ :: a -> a + , acosh_ :: a -> a+ }+ reifiedIns = Sub Dict++instance Reifies s (Def RealFrac a) => RealFrac (Lift RealFrac s a) where+ properFraction a = fmap Lift $ properFraction_ REFLECT (lower a)+ truncate a = Lift $ truncate_ REFLECT (lower a)+ round a = Lift $ round_ REFLECT (lower a)+ ceiling a = Lift $ ceiling_ REFLECT (lower a)+ floor a = Lift $ floor_ REFLECT (lower a)+ ++instance ReifiableConstraint RealFrac where+ data Def RealFrac a = RealFrac + { properFraction_ :: Integral b => a -> (b, a)+ , truncate_ :: Integral b => a -> b+ , round_ :: Integral b => a -> b+ , ceiling_ :: Integral b => a -> b+ , floor_ :: Integral b => a -> b+ }+ reifiedIns = Sub Dict++instance Reifies s (Def RealFloat a) => RealFloat (Lift RealFloat s a) where+ floatRadix a = floatRadix_ REFLECT (lower a) + floatDigits a = floatDigits_ REFLECT (lower a) + floatRange a = floatRange_ REFLECT (lower a) + decodeFloat a = decodeFloat_ REFLECT (lower a) + encodeFloat a b = encodeFloat_ (reflect b) (lower a) (lower b)+ exponent a = exponent_ REFLECT (lower a) + significand a b = significand_ (reflect b) (lower a) (lower b)+ scaleFloat a b = scaleFloat_ (reflect b) (lower a) (lower b)+ isInfinite a = isInfinite_ REFLECT (lower a) + isDenormalized a = isDenormalized_ REFLECT (lower a) + isNegativeZero a = isNegativeZero_ REFLECT (lower a) + isIEEE a = isIEEE_ REFLECT (lower a) + atan2 a = atan2_ REFLECT (lower a) ++instance ReifiableConstraint RealFloat where+ data Def RealFloat a = RealFloat + { floatRadix_ :: a -> Integer+ , floatDigits_ :: a -> Int+ , floatRange_ :: a -> (Int, Int)+ , decodeFloat_ :: a -> (Integer, Int)+ , encodeFloat_ :: Integer -> Int -> a+ , exponent_ :: a -> Int+ , significand_ :: Int -> a -> a+ , scaleFloat_ :: Int -> a -> a+ , isInfinite_ :: a -> Bool+ , isDenormalized_ :: a -> Bool+ , isNegativeZero_ :: a -> Bool+ , isIEEE_ :: a -> Bool+ , atan2_ :: a -> Bool+ }+ reifiedIns = Sub Dict+-}++{-+I think this will need a reifyable constraint1+instance Reifies s (Def Monad a) => Monad (Lift Monad s a) where+ (>>=) = + (>>) = + return = + fail = ++instance ReifiableConstraint Monad where+ data Def Monad a = Monad + { (>>=.) :: forall a b. m a -> (a -> m b) -> m b+ , (>>.) :: forall a b. m a -> m b -> m b+ , return :: a -> m a+ , fail :: String -> m a+ }+ reifiedIns = Sub Dict+-}++instance Reifies s (Def Show a) => Show (Lift Show s a) where+ show = show_ REFLECT . lower++instance ReifiableConstraint Show where+ data Def Show a = Show { show_ :: a -> String }+ reifiedIns = Sub Dict++instance ReifiableConstraint Read where+ data Def Read a = Read { readsPrec_ :: Int -> ReadS a, readList_ :: ReadS [a] }+ reifiedIns = Sub Dict++instance Reifies s (Def Read a) => Read (Lift Read s a) where+ readsPrec x s = over _1 Lift <$> readsPrec_ REFLECT x s+ readList s = over _1 (fmap Lift) + <$> readList_ REFLECT s++instance ReifiableConstraint Eq where+ data Def Eq a = Eq { eq_ :: a -> a -> Bool }+ reifiedIns = Sub Dict++instance Reifies s (Def Eq a) => Eq (Lift Eq s a) where+ x == y = eq_ REFLECT (lower x) (lower y) ++instance ReifiableConstraint Ord where+ data Def Ord a = Ord { compare_ :: a -> a -> Ordering }+ reifiedIns = Sub Dict++instance Reifies s (Def Ord a) => Eq (Lift Ord s a) where+ a == b = compare a b == EQ++instance Reifies s (Def Ord a) => Ord (Lift Ord s a) where+ compare a b = compare_ REFLECT (lower a) (lower b)++instance ReifiableConstraint Monoid where+ data Def Monoid a = Monoid { mappend_ :: a -> a -> a, mempty_ :: a }+ reifiedIns = Sub Dict++instance Reifies s (Def Monoid a) => Monoid (Lift Monoid s a) where+ mappend = liftA2 (mappend_ REFLECT) + mempty = pure $ mempty_ REFLECT++-- Aeson Instances+instance ReifiableConstraint FromJSON where+ data Def FromJSON a = FromJSON { parseJSON_ :: Value -> Parser a }+ reifiedIns = Sub Dict+ +instance Reifies s (Def FromJSON a) => FromJSON (Lift FromJSON s a) where+ parseJSON = fmap pure . parseJSON_ REFLECT++instance ReifiableConstraint ToJSON where+ data Def ToJSON a = ToJSON { toJSON_ :: a -> Value}+ reifiedIns = Sub Dict++instance Reifies s (Def ToJSON a) => ToJSON (Lift ToJSON s a) where+ toJSON a = toJSON_ REFLECT (lower a)