instance-control 0.1.1.1 → 0.1.2.0

raw patch · 3 files changed

+77/−85 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Control/Instances/Morph.hs +62/−63
• Control/Instances/ShortestPath.hs +14/−21
• instance-control.cabal +1/−1

@@ -1,17 +1,16 @@-{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses
+           , FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes
+           , RankNTypes, ScopedTypeVariables, FlexibleContexts, ConstraintKinds #-}
 
-module Control.Instances.Morph (GenMorph(..), Morph(..)) where
+module Control.Instances.Morph (GenMorph(..), DB, db, Morph, morph) where
 
 import Control.Instances.ShortestPath
 
 import Control.Monad.Identity
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.List
-import Control.Monad.State
 import Data.Maybe
 import Data.Proxy
-import GHC.TypeLits
-import Control.Instances.TypeLevelPrelude
 
 -- | States that 'm1' can be represented with 'm2'.
 -- That is because 'm2' contains more infromation than 'm1'.
@@ -21,99 +20,101 @@ --
 -- > morph (return x)  =  return x
 -- > morph (m >>= f)   =  morph m >>= morph . f
--- 
+--
 -- It is a reflexive and transitive relation.
 --
-class Morph (m1 :: * -> *) (m2 :: * -> *) where
-  -- | Lifts the first monad into the second.
-  morph :: m1 a -> m2 a
-  
-instance GenMorph DB m1 m2 => Morph m1 m2 where
-  morph = genMorph db
-  
+type Morph m1 m2 = GenMorph DB m1 m2
+
+-- | Lifts the first monad into the second.
+morph :: Morph m1 m2 => m1 a -> m2 a
+morph = genMorph db
+
+-- instance GenMorph DB m1 m2 => Morph m1 m2 where
+--   morph = genMorph db
+
 -- | A generalized version of 'Morph'. Can work on different
 -- rulesets, so this should be used if the ruleset is to be extended.
-class GenMorph db (m1 :: * -> *) (m2 :: * -> *) where
-  -- | Lifts the first monad into the second.
-  genMorph :: db -> m1 a -> m2 a
-  
-instance ( fl ~ (TransformPath (PathFromList (ShortestPath (ToMorphRepo DB) x y)))
-         , CorrectPath x y fl
-         , GeneratableMorph DB fl
-         , Morph' fl x y
-         ) => GenMorph DB x y where
-  genMorph db = repr (generateMorph db :: fl)
-  
+type GenMorph db m1 m2 = ( CorrectPath m1 m2 (Path db m1 m2)
+                         , GeneratableMorph db (Path db m1 m2)
+                         , Morph' (Path db m1 m2) m1 m2
+                         )
+
+type Path db m1 m2 = TransformPath (PathFromList (ShortestPath (ToMorphRepo db) m1 m2))
+
+-- | Lifts the first monad into the second.
+genMorph :: forall db m1 m2 a . GenMorph db m1 m2 => db -> m1 a -> m2 a
+genMorph db = repr (generateMorph db :: (Path db m1 m2))
+
 class Morph' fl x y where
   repr :: fl -> x a -> y a
-  
+
 instance Morph' r y z => Morph' (ConnectMorph x y :+: r) x z where
   repr (ConnectMorph m :+: r) = repr r . m
- 
+
 instance (Morph' r m x, Monad m) => Morph' (IdentityMorph m :+: r) Identity x where
   repr (IdentityMorph :+: r) = (repr r :: forall a . m a -> x a) . return . runIdentity
-  
+
 instance Morph' (MUMorph m :+: r) m Proxy where
   repr (MUMorph :+: _) = const Proxy
- 
+
 instance Morph' NoMorph x x where
-  repr fl = id
-  
+  repr _ = id
+
 infixr 6 :+:
-data a :+: r = a :+: r 
+data a :+: r = a :+: r
 
 data NoMorph = NoMorph
-  
+
 type family ToMorphRepo db where
   ToMorphRepo (cm :+: r) = TranslateConn cm ': ToMorphRepo r
   ToMorphRepo NoMorph = '[]
-   
+
 type DB = ConnectMorph_2m Maybe MaybeT
-           :+: ConnectMorph_mt MaybeT 
-           :+: ConnectMorph Maybe [] 
+           :+: ConnectMorph_mt MaybeT
+           :+: ConnectMorph Maybe []
            :+: ConnectMorph_2m [] ListT
            :+: ConnectMorph (MaybeT IO) (ListT IO)
            :+: NoMorph
- 
-db :: DB 
-db = ConnectMorph_2m (MaybeT . return) 
-       :+: ConnectMorph_mt (MaybeT . liftM Just) 
-       :+: ConnectMorph (maybeToList) 
-       :+: ConnectMorph_2m (ListT . return) 
-       :+: ConnectMorph (ListT . liftM maybeToList . runMaybeT) 
+
+db :: DB
+db = ConnectMorph_2m (MaybeT . return)
+       :+: ConnectMorph_mt (MaybeT . liftM Just)
+       :+: ConnectMorph (maybeToList)
+       :+: ConnectMorph_2m (ListT . return)
+       :+: ConnectMorph (ListT . liftM maybeToList . runMaybeT)
        :+: NoMorph
-  
+
 -- | This class provides a way to construct the value-level transformations
 -- from the type-level path and a rulebase.
 class GeneratableMorph db ch where
   generateMorph :: db -> ch
-    
+
 instance GeneratableMorph db NoMorph where
   generateMorph _ = NoMorph
-  
-instance GeneratableMorph db r 
+
+instance GeneratableMorph db r
       => GeneratableMorph db ((IdentityMorph m) :+: r) where
   generateMorph db = IdentityMorph :+: generateMorph db
-  
-instance GeneratableMorph db r 
+
+instance GeneratableMorph db r
       => GeneratableMorph db (MUMorph m :+: r) where
   generateMorph db = MUMorph :+: generateMorph db
-  
-instance (HasMorph db (ConnectMorph a b), GeneratableMorph db r) 
+
+instance (HasMorph db (ConnectMorph a b), GeneratableMorph db r)
       => GeneratableMorph db (ConnectMorph a b :+: r) where
   generateMorph db = getMorph db :+: generateMorph db
-  
+
 -- | This class extracts a given morph from the set of rules
-class HasMorph r m where 
+class HasMorph r m where
   getMorph :: r -> m
 instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_2m a b :+: r) (ConnectMorph a (b k)) where
-  getMorph (ConnectMorph_2m f :+: r) = ConnectMorph f
+  getMorph (ConnectMorph_2m f :+: _) = ConnectMorph f
 instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_mt t :+: r) (ConnectMorph k (t k)) where
-  getMorph (ConnectMorph_mt f :+: r) = ConnectMorph f
+  getMorph (ConnectMorph_mt f :+: _) = ConnectMorph f
 instance {-# OVERLAPS #-} HasMorph r m => HasMorph (c :+: r) m where
-  getMorph (c :+: r) = getMorph r
+  getMorph (_ :+: r) = getMorph r
 instance {-# OVERLAPPABLE #-} HasMorph (m :+: r) m where
-  getMorph (c :+: r) = c
+  getMorph (c :+: _) = c
 
 -- | Checks if the path is found to provide usable error messages
 class CorrectPath from to path
@@ -121,9 +122,9 @@ instance CorrectPath from to (a :+: b)
 instance CorrectPath from to NoMorph
 
-data ConnectMorph m1 m2 = ConnectMorph { fromConnectMorph :: forall a . m1 a -> m2 a }
-data ConnectMorph_2m m1 m2 = ConnectMorph_2m { fromConnectMorph_2m :: forall a k . Monad k => m1 a -> m2 k a }
-data ConnectMorph_mt mt = ConnectMorph_mt { fromConnectMorph_mt :: forall a k . Monad k => k a -> mt k a }
+data ConnectMorph m1 m2 = ConnectMorph (forall a . m1 a -> m2 a)
+data ConnectMorph_2m m1 m2 = ConnectMorph_2m (forall a k . Monad k => m1 a -> m2 k a)
+data ConnectMorph_mt mt = ConnectMorph_mt (forall a k . Monad k => k a -> mt k a)
 data IdentityMorph (m :: * -> *) = IdentityMorph
 data MUMorph m = MUMorph
 
@@ -132,7 +133,7 @@   TranslateConn (ConnectMorph m1 m2) = Connect m1 m2
   TranslateConn (ConnectMorph_2m m1 m2) = Connect_2m m1 m2
   TranslateConn (ConnectMorph_mt mt) = Connect_mt mt
-  
+
 -- | Transforms the path from the generic format to the specific one
 type family TransformPath m where
   TransformPath (Connect m1 m2 :+: r) = ConnectMorph m1 m2 :+: TransformPath r
@@ -140,10 +141,8 @@   TransformPath (Connect_MU m :+: r) = MUMorph m :+: TransformPath r
   TransformPath NoMorph = NoMorph
   TransformPath NoPathFound = NoPathFound
-  
+
 type family PathFromList ls where
   PathFromList '[] = NoMorph
   PathFromList '[ NoPathFound ] = NoPathFound
   PathFromList (c ': ls) = c :+: PathFromList ls
-
-

@@ -3,16 +3,11 @@ module Control.Instances.ShortestPath where
 
 import Control.Monad.Identity
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.List
-import Control.Monad.State
-import Data.Maybe
 import Data.Proxy
-import GHC.TypeLits
 import Control.Instances.TypeLevelPrelude
 
 -- * Generic datatypes to store connections
-  
+
 data Connect m1 m2
 data Connect_2m m1 m2
 data Connect_mt mt
@@ -22,21 +17,21 @@ -- | Marks that there is no legal path between the two types according
 -- to the rulebase.
 data NoPathFound
-  
+
 type family ShortestPath (e :: [*]) (s :: * -> *) (t :: * -> *) :: [*] where
   ShortestPath e t t = '[]
   ShortestPath e Identity t = '[ Connect_id t ]
   ShortestPath e s Proxy = '[ Connect_MU s ]
   ShortestPath e s t = ShortestPath' e s (InitCurrent e t)
-  
+
 type family ShortestPath' (e :: [*]) (s :: * -> *) (c :: [[*]]) :: [*] where
   ShortestPath' e s '[] = '[ NoPathFound ]
   ShortestPath' e s c = FromMaybe (ShortestPath' e s (ApplyEdges e c c))
-                                  (GetFinished s c) 
-                                  
-                                      
+                                  (GetFinished s c)
+
+
 type family GetFinished s c where
-  GetFinished s ((Connect s b ': p) ': lls) 
+  GetFinished s ((Connect s b ': p) ': lls)
     = Just (Connect s b ': p)
   GetFinished s (p ': lls) = GetFinished s lls
   GetFinished s '[] = Nothing
@@ -44,17 +39,17 @@ type family InitCurrent (e :: [*]) (t :: * -> *) :: [[*]] where
   InitCurrent '[] t = '[]
   InitCurrent (e ': es) t = IfJust (ApplyEdge e t)
-                                   ('[ MonomorphEnd e t ] ': InitCurrent es t) 
+                                   ('[ MonomorphEnd e t ] ': InitCurrent es t)
                                    (InitCurrent es t)
-  
+
 type family ApplyEdges (e :: [*]) (co :: [[*]]) (c :: [[*]]) :: [[*]] where
-  ApplyEdges (e ': es) co ((Connect s b ': p) ': cs) 
-    = AppendJust (IfThenJust (IsJust (ApplyEdge e s)) 
-                                (MonomorphEnd e s ': Connect s b ': p)) 
+  ApplyEdges (e ': es) co ((Connect s b ': p) ': cs)
+    = AppendJust (IfThenJust (IsJust (ApplyEdge e s))
+                                (MonomorphEnd e s ': Connect s b ': p))
                  (ApplyEdges (e ': es) co cs)
   ApplyEdges (e ': es) co '[] = ApplyEdges es co co
-  ApplyEdges '[] co cr = '[]  
-  
+  ApplyEdges '[] co cr = '[]
+
 type family ApplyEdge e t :: Maybe (* -> *) where
   ApplyEdge (Connect ms mr) mr = Just ms
   ApplyEdge (Connect_2m ms mt) (mt m) = Just ms
@@ -65,5 +60,3 @@   MonomorphEnd (Connect_2m m m') v = Connect m v
   MonomorphEnd (Connect_mt t) (t m) = Connect m (t m)
   MonomorphEnd c v = c
-
-

@@ -1,6 +1,6 @@ 
 name:                instance-control
-version:             0.1.1.1
+version:             0.1.2.0
 synopsis:            Controls how the compiler searches for instances using type families.
 description:         GHC has no capability to perform graph searches on instance definition. Because of that,
                      transitive rules for type classes cannot be defined. This package solves the issue with