diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Language/Haskell/TH/Universe.hs b/src/Language/Haskell/TH/Universe.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Universe.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, NoMonomorphismRestriction, + FlexibleInstances, FlexibleContexts #-} +module Language.Haskell.TH.Universe ( + get_universe, + -- ** Utils ... Not sure how to hide these. + get_type_names, + filter_dups', + collect_new_dec_names, + collect_dec_type_names, + eval_state) where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) +import Control.Monad.State +import Control.Monad.Error +import Control.Monad.Trans +import Data.Generics.Uniplate.Data +import Data.List +import Data.Tuple.Select +import Control.Applicative +import Data.Composition +import Control.Monad + +type Universe = [(Name, Dec)] + +type ErrorStateType m e s a = ErrorT e (StateT s m) a + +newtype ErrorStateT e s m a = ErrorStateT { runErrorStateT :: ErrorStateType m e s a } + deriving (Monad, MonadState s, MonadError e, Functor, MonadPlus) + +instance MonadTrans (ErrorStateT String Universe) where + lift = ErrorStateT . lift . lift + +type UniverseState a = ErrorStateT String Universe Q a + +type Result a = Either String a + + +-- | Collect all the ancestor Dec's for whatever is passed in by name. +-- For instance if we have +-- +-- > data Otherthing = Otherthing Float +-- +-- > data Thing = Thing OtherThing Int +-- +-- then +-- +-- > get_universe ''Thing +-- +-- would return the Dec's for Thing, OtherThing, Int and Float +get_universe :: Name -> Q (Universe) +get_universe = exec_state . create_universe_name + + +create_universe_name :: Name -> UniverseState () +create_universe_name name = do + reify_result <- lift $ reify name + case reify_result of + ClassI dec _ -> create_universe_dec dec + ClassOpI _ _ dec_name _ -> create_universe_name dec_name + TyConI dec -> create_universe_dec dec + (PrimTyConI _ _ _) -> return () + DataConI _ _ dec_name _ -> create_universe_name dec_name + VarI _ _ m_dec _ -> maybe (return ()) create_universe_dec m_dec + TyVarI _ _ -> error "Don't know what a TyVarI is" + +-- | 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 + +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 + modify ((dec_name, dec):) + let type_names = collect_dec_type_names dec + --look them up if haven't looked them up before + filter_dups type_names + + +collect_dec_type_names :: Dec -> [Name] +collect_dec_type_names = concatMap get_type_names . nub . concatMap get_con_types . get_cons + +filter_dups' :: Eq a => [a] -> [(a, b)] -> [a] +filter_dups' names uni = names \\ (fst $ unzip uni) + +filter_dups :: (Eq a, MonadState [(a, b)] m) =>[a] -> m [a] +filter_dups names = gets (filter_dups' names) + +-------------------------------------------------------------------------------- +--utility functions without a home + +get_cons :: Dec -> [Con] +get_cons (NewtypeD _ _ _ con _) = [con] +get_cons (DataD _ _ _ cons _) = cons +get_cons (DataInstD _ _ _ cons _) = cons +get_cons (NewtypeInstD _ _ _ con _) = [con] +get_cons _ = [] + +get_con_types :: Con -> [Type] +get_con_types (NormalC _ st) = map snd st +get_con_types (RecC _ st) = map sel3 st +get_con_types (InfixC x _ y) = map snd [x, y] +get_con_types (ForallC _ _ con) = get_con_types con + +get_type_names :: Type -> [Name] +get_type_names = map (from_right . get_type_name) . get_constr_types + +from_right :: Either a b -> b +from_right (Right x) = x +from_right _ = error "from_right" + +get_type_name' :: Type -> Name +get_type_name' = from_right . get_type_name + +get_type_name :: Type -> Result Name +get_type_name (ForallT _ _ typ) = get_type_name typ +get_type_name (VarT n) = Right n +get_type_name (ConT n) = Right n +get_type_name x = Left ("No name for " ++ show x) + +get_constr_types :: Type -> [Type] +get_constr_types = filter is_cont . universe + +is_cont :: Type -> Bool +is_cont (ConT _) = True +is_cont _ = False + +get_dec_name :: (MonadError String m, Monad m) => Dec -> m Name +get_dec_name (FunD name _) = return name +get_dec_name (ValD _ _ _) = throwError "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 (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 (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)) [] + +eval_state :: Monad m => ErrorStateT e [a1] m a -> m (Either e a) +eval_state x = evalStateT (runErrorT (runErrorStateT x)) [] + + + + + + + + + + + + + + + diff --git a/universe-th.cabal b/universe-th.cabal new file mode 100644 --- /dev/null +++ b/universe-th.cabal @@ -0,0 +1,88 @@ +-- universe-th.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: universe-th + +-- 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.1 + +-- A short (one-line) description of the package. +Synopsis: Construct a Dec the ancestor list. + +-- A longer description of the package. +Description: This package provides the ability to pass in a name for a type and it will + return all of the Dec's that are necessary for the type and its ancestors to be + constructed. + +-- URL for the project homepage or repository. +Homepage: http://github.com/jfishcoff/universe-th + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Jonathan Fischoff + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: jonathangfischoff@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Language + +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.8 + + +Library + Hs-Source-Dirs: src + -- Modules exported by the library. + Exposed-modules: Language.Haskell.TH.Universe + + -- Packages needed in order to build this package. + Build-depends: base >= 4.0 && <= 6.0, + composition >= 1.0.1.0, + tuple >= 0.2.0.1, + uniplate >= 1.6.5, + mtl >= 2.0.1.0, + template-haskell >= 2.6.0.0 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +Test-Suite tests + Hs-Source-Dirs: src, tests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base >= 4.0 && <= 6.0, + template-haskell >= 2.6.0.0, + composition >= 1.0.1.0, + mtl >= 2.0.1.0, + DebugTraceHelpers >= 0.12, + QuickCheck >= 2.4.1.1, + tuple >= 0.2.0.1, + HUnit >= 1.2.4.2, + test-framework-quickcheck2 >= 0.2.10, + test-framework-hunit >= 0.2.7, + test-framework >= 0.4.1.1, + uniplate >= 1.6.5, + checkers >= 0.2.8, + th-instances >= 0.1.0.14 +