universe-th 0.0.0.2 → 0.0.0.3

raw patch · 2 files changed

+60/−17 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Language/Haskell/TH/Universe.hs +59/−16
• universe-th.cabal +1/−1

@@ -2,12 +2,14 @@     FlexibleInstances, FlexibleContexts #-} module Language.Haskell.TH.Universe (     get_universe, +    sub_universe,     -- ** Utils ... Not sure how to hide these.     get_type_names,     filter_dups',     collect_new_dec_names,     collect_dec_type_names,-    eval_state) where+    eval_state,+    Universe) where import Language.Haskell.TH import Language.Haskell.TH.Syntax hiding (lift) import Control.Monad.State@@ -19,16 +21,23 @@ import Control.Applicative import Data.Composition import Control.Monad+import Control.Monad.Reader+import Control.Monad.Identity +--TODO fix this so that I have a RWST monad+--and write to the monad instead of +--that's how you will get the sub_universe+ type Universe = [(Name, Dec)] -type ErrorStateType m e s a = ErrorT e (StateT s m) a+--TODO add a reader monad+type ErrorStateType m e s a = ErrorT e (StateT s (ReaderT s m)) a  newtype ErrorStateT e s m a = ErrorStateT { runErrorStateT :: ErrorStateType m e s a }-    deriving (Monad, MonadState s, MonadError e, Functor, MonadPlus)+    deriving (Monad, MonadState s, MonadError e, Functor, MonadPlus, MonadReader s)      instance MonadTrans (ErrorStateT String Universe) where-    lift = ErrorStateT . lift . lift+    lift = ErrorStateT . lift . lift . lift  type UniverseState a = ErrorStateT String Universe Q a  @@ -48,9 +57,37 @@ -- -- would return the Dec's for Thing, OtherThing, Int and Float get_universe :: Name -> Q (Universe)-get_universe = exec_state . create_universe_name+get_universe = exec_state . create_universe_name  +-- | Find the type in the passed in universe of Decs ([Dec]), and all of the ancestors in the universe.  +sub_universe :: [Dec] -> Name -> Universe+sub_universe decs name = nub $ snd $ runIdentity $ runReaderT (runStateT (runErrorT (runErrorStateT (sub_universe' name))) []) $ make_dec_dict decs  +make_dec_dict :: [Dec] -> [(Name, Dec)]+make_dec_dict decs = map (\x -> (from_right $ get_dec_name x, x)) decs++get_all_decs = do+    decs <- get+    other_decs <- ask+    return $ decs ++ other_decs++sub_universe' :: (Monad m, Functor m,+    MonadState Universe m, +    MonadError String   m,+    MonadReader Universe m) => Name -> m ()+sub_universe' name = do+    decs <- map snd <$> get_all_decs+    let found = find (is_dec_name name) decs   +    case found of +                Just x -> create_universe_dec' sub_universe' x+                Nothing -> return ()++is_dec_name name dec = result where+    dec_name_result = get_dec_name dec+    result = case dec_name_result of +                Right x -> x == name+                Left _  -> False+ create_universe_name :: Name -> UniverseState () create_universe_name name = do     reify_result <- lift $ reify name @@ -65,13 +102,15 @@          -- | Collect all the ancestor Dec's for the given Dec create_universe_dec :: Dec -> UniverseState ()-create_universe_dec dec = mapM_ create_universe_name =<< collect_new_dec_names dec+create_universe_dec dec = create_universe_dec' create_universe_name dec +create_universe_dec' f dec = mapM_ f =<< collect_new_dec_names dec+ collect_new_dec_names :: (Monad m,     MonadState Universe m,      MonadError String   m) => Dec -> m [Name] collect_new_dec_names dec = do-    dec_name <- get_dec_name dec +    dec_name <- throw_either $ get_dec_name dec      modify ((dec_name, dec):)     let type_names = collect_dec_type_names dec     --look them up if haven't looked them up before@@ -86,6 +125,10 @@      filter_dups :: (Eq a, MonadState [(a, b)] m) =>[a] -> m [a] filter_dups names = gets (filter_dups' names) ++throw_either :: (Monad m, MonadError String m) => Result a -> m a+throw_either (Right x) = return x+throw_either (Left x)  = throwError x      -------------------------------------------------------------------------------- --utility functions without a home@@ -126,25 +169,25 @@ is_cont (ConT _) = True is_cont _        = False -get_dec_name :: (MonadError String m, Monad m) => Dec -> m Name+get_dec_name :: Dec -> Result Name get_dec_name (FunD name _)            = return name-get_dec_name (ValD _ _ _)             = throwError "InstanceD does not have a name"+get_dec_name (ValD _ _ _)             = Left "InstanceD does not have a name" get_dec_name (DataD _ name _ _ _)     = return name get_dec_name (NewtypeD _ name _ _ _)  = return name get_dec_name (TySynD name _ _)        = return name get_dec_name (ClassD _ name _ _ _ )   = return name-get_dec_name (InstanceD _ _ _)        = throwError "InstanceD does not have a name"+get_dec_name (InstanceD _ _ _)        = Left "InstanceD does not have a name" get_dec_name (SigD name _)            = return name-get_dec_name (ForeignD _)             = throwError "ForeignD does not have a name"-get_dec_name (PragmaD  _)             = throwError "PragmaD does not have a name"+get_dec_name (ForeignD _)             = Left "ForeignD does not have a name"+get_dec_name (PragmaD  _)             = Left "PragmaD does not have a name" get_dec_name (FamilyD _ name _ _)     = return name get_dec_name (DataInstD _ name _ _ _) = return name -exec_state :: Monad m => ErrorStateT e [a1] m a -> m [a1]-exec_state x = execStateT (runErrorT (runErrorStateT x)) []+exec_state :: (Monad m, Functor m) => ErrorStateT e [a1] m a -> m ([a1])+exec_state x = snd <$> runReaderT (runStateT (runErrorT (runErrorStateT x)) []) [] -eval_state :: Monad m => ErrorStateT e [a1] m a -> m (Either e a)-eval_state x = evalStateT (runErrorT (runErrorStateT x)) []+eval_state :: (Monad m, Functor m) => ErrorStateT e [a1] m a -> m (Either e a)+eval_state x = fst <$> runReaderT (runStateT (runErrorT (runErrorStateT x)) []) []   

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.0.0.2+Version:             0.0.0.3  -- A short (one-line) description of the package. Synopsis:            Construct a Dec's ancestor list.