diff --git a/src/Language/Haskell/TH/Universe.hs b/src/Language/Haskell/TH/Universe.hs --- a/src/Language/Haskell/TH/Universe.hs +++ b/src/Language/Haskell/TH/Universe.hs @@ -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)) []) [] diff --git a/universe-th.cabal b/universe-th.cabal --- a/universe-th.cabal +++ b/universe-th.cabal @@ -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.