universe-th (empty) → 0.0.0.1
raw patch · 4 files changed
+282/−0 lines, 4 filesdep +DebugTraceHelpersdep +HUnitdep +QuickChecksetup-changed
Dependencies added: DebugTraceHelpers, HUnit, QuickCheck, base, checkers, composition, mtl, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, th-instances, tuple, uniplate
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Language/Haskell/TH/Universe.hs +162/−0
- universe-th.cabal +88/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Language/Haskell/TH/Universe.hs view
@@ -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)) []+++++++++++++++
+ universe-th.cabal view
@@ -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 +