specialize-th (empty) → 0.0.0.1
raw patch · 4 files changed
+479/−0 lines, 4 filesdep +DebugTraceHelpersdep +HUnitdep +MissingHsetup-changed
Dependencies added: DebugTraceHelpers, HUnit, MissingH, QuickCheck, base, checkers, composition, derive, mtl, newtype, newtype-th, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, th-expand-syns, type-sub-th, uniplate, universe-th
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- specialize-th.cabal +91/−0
- src/Language/Haskell/TH/Specialize.hs +356/−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
+ specialize-th.cabal view
@@ -0,0 +1,91 @@+-- specialize-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: specialize-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: Create specialized types from polymorphic ones using TH++-- A longer description of the package.+Description: Very Alpha. Minimal Testing. Will test more this week. ++-- URL for the project homepage or repository.+Homepage: https://github.com/jfischoff/specialize-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+ -- Modules exported by the library.+ Exposed-modules: Language.Haskell.TH.Specialize+ + Hs-Source-Dirs: src+ + Build-depends: base > 4.0.0 && <= 5.0,+ template-haskell >= 2.6.0,+ mtl >= 2.0.1.0,+ derive >= 2.5.4,+ composition >= 1.0.1.0,+ th-expand-syns >= 0.3.0.3,+ newtype-th >= 0.3.2,+ newtype >= 0.2,+ MissingH >= 1.1.1.0,+ uniplate >= 1.6.5,+ type-sub-th >= 0.1.0.5,+ universe-th >= 0.0.0.2+ ghc-options: -Wall+ +Test-Suite tests+ Hs-Source-Dirs: src, tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends: base > 4.0.0 && <= 5.0,+ DebugTraceHelpers >= 0.12,+ test-framework-quickcheck2 >= 0.2.10,+ test-framework-hunit >= 0.2.7,+ test-framework >= 0.4.1.1,+ HUnit >= 1.2.4.2,+ QuickCheck >= 2.4.1.1,+ mtl >= 2.0.1.0,+ template-haskell >= 2.6.0,+ checkers >= 0.2.8,+ derive >= 2.5.4,+ composition >= 1.0.1.0,+ th-expand-syns >= 0.3.0.3,+ newtype-th >= 0.3.2,+ newtype >= 0.2,+ MissingH >= 1.1.1.0,+ uniplate >= 1.6.5,+ type-sub-th >= 0.1.0.5,+ universe-th >= 0.0.0.2
+ src/Language/Haskell/TH/Specialize.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving,+ TemplateHaskell #-}+module Language.Haskell.TH.Specialize +(+-- ** Main Interface+expand_and_specialize,+ expand_and_specialize',+-- *** Helper Types+ ConstructorName (..),+ TypeName (..),+-- *** Renamer Interface+ DecRenamer,+ ConstrRenamer,+-- *** Stock Renamers+ mk_new_dec_name,+ id_constr_renamer,++ -- ** Utils ... Pretend these are not here+ sub_dec_and_rename,+ create_dec_from_type,+ find_con,++ get_con_vars,+ get_ty_vars,+ concat_type_names,+ rename_dec,+ run_state',+ Result+ ) where+ +import Language.Haskell.TH+import Language.Haskell.TH.Universe+import Language.Haskell.TH.TypeSub+import Control.Monad.Error+import Control.Monad.State+import Data.Generics.Uniplate.Data+import Data.List+import Control.Applicative+import Data.List.Utils+import Control.Applicative+import Control.Newtype+import Control.Newtype.TH+import Language.Haskell.TH.ExpandSyns+import Data.Composition+import Data.List+++++-- | Expand all the type syn's and create specialize types for any polymorphic types.+-- All of the new specialized declarations are returned, along with the original dec +-- with subbed types and a new name. +-- The first Name is the name of the Dec to create specialize instances for.+-- The second Name, is the new name for the Dec.+-- use mk_new_dec_name for the Dec renaming and id_constr_renamer for the constructor renaming.+expand_and_specialize :: Name -> Name -> Q [Dec]+expand_and_specialize = expand_and_specialize' mk_new_dec_name id_constr_renamer++-- | Expand all the type syn's and create specialize types for any polymorphic types.+-- All of the new specialized declarations are returned, along with the original dec +-- with subbed types and a new name. +-- The first Name is the name of the Dec to create specialize instances for.+-- The second Name, is the new name for the Dec.+-- The DecRenamer and ConstrRenamer are used to rename Dec's and Con's respectively.+expand_and_specialize' :: DecRenamer -> ConstrRenamer -> Name -> Name -> Q [Dec]+expand_and_specialize' dr cr name new_name = do+ universe <- map snd <$> get_universe name+ decs <- expand_type_syn_decs universe+ + (new_dec, new_decs) <- run_state' (create_decs_from_name dr cr (TypeName name)) decs+ + let result = case new_dec of+ Right x -> (from_right $ set_dec_name (pack new_name) x):new_decs+ Left _ -> new_decs+ + return $ (nub result) \\ decs+ +expand_type_syn_decs :: [Dec] -> Q [Dec]+expand_type_syn_decs decs = mapM expand_type_syn_dec decs++expand_type_syn_dec :: Dec -> Q Dec+expand_type_syn_dec dec = (from_right . (flip set_cons) dec) <$> (mapM expand_type_syn_con $ get_cons dec)++expand_type_syn_con :: Con -> Q Con+expand_type_syn_con con = set_con_types' con <$> (mapM expand_type_syn_type $ + get_con_types con)+ +expand_type_syn_type :: Type -> Q Type+expand_type_syn_type = expandSyns++find_dec :: [Dec] -> TypeName -> Result Dec+find_dec decs name = maybe_to_either "could not find dec" $ find (is_dec_name name) decs++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++find_dec_from_constr :: (Monad m, Functor m, MonadError String m) => [Dec] -> ConstructorName -> m Dec+find_dec_from_constr decs name = throw_maybe "could not find dec" $ + find (has_constr name) decs++has_constr :: ConstructorName -> Dec -> Bool+has_constr name dec = result where+ found = find (\x -> name == get_con_name x) $ get_cons dec+ result = case found of + Just _ -> True+ Nothing -> False++create_decs_from_name :: (Functor m, Monad m, MonadState [Dec] m, MonadError String m) => + DecRenamer -> ConstrRenamer -> TypeName -> m Dec+create_decs_from_name dr cr name = do+ decs <- get+ dec <- throw_either $ find_dec decs name+ create_decs_from_dec dr cr dec++create_decs_from_dec :: (Functor m, Monad m, MonadState [Dec] m, MonadError String m) => + DecRenamer -> ConstrRenamer -> Dec -> m Dec +create_decs_from_dec dr cr dec = (from_right . (flip set_cons) dec) <$> + (mapM (create_decs_from_con dr cr) $ get_cons dec)+ +create_decs_from_con :: (Functor m, Monad m, MonadState [Dec] m, MonadError String m) => + DecRenamer -> ConstrRenamer -> Con -> m Con +create_decs_from_con dr cr con = set_con_types' con <$> (mapM (create_dec_from_type dr cr) $ + get_con_types con)+ +create_dec_from_type :: (Functor m, Monad m, MonadState [Dec] m, MonadError String m) => + DecRenamer -> ConstrRenamer -> Type -> m Type+create_dec_from_type dr cr typ@(AppT _ _) = do + let x:args = collect_type_args typ+ create_dec_from_type' dr cr x =<< (mapM (create_dec_from_type dr cr) args)+create_dec_from_type dr cr typ = return typ++type DecRenamer = ([Type] -> TypeName -> Result TypeName)+type ConstrRenamer = ([Type] -> Con -> Con)++has_dec :: (Monad m, MonadState [Dec] m) => TypeName -> m Bool+has_dec name = gets (any (is_dec_name name))++add_dec dec = modify (dec:) ++-- | Default Con renamer+id_constr_renamer :: [Type] -> Con -> Con+id_constr_renamer x y = y++newtype ConstructorName = ConstructorName { runConstructorName :: Name }+ deriving(Show, Eq)+newtype TypeName = TypeName { runTypeName :: Name }+ deriving(Show, Eq)++create_dec_from_type' :: (Monad m, MonadState [Dec] m, Functor m,+ MonadError String m) => + DecRenamer -> ConstrRenamer -> Type -> [Type] -> m Type+create_dec_from_type' dr cr (ConT name) args = do+ decs <- get + dec <- throw_either $ find_dec decs $ TypeName name+ dec_name <- throw_either $ get_dec_name dec + new_dec_name <- throw_either $ dr args dec_name+ has_dec' <- has_dec new_dec_name+ when (not has_dec') $ do + new_dec <- sub_dec_and_rename cr dec args+ add_dec new_dec ++ return $ ConT $ runTypeName new_dec_name+create_dec_from_type' dr cr ListT args = + create_dec_from_type' dr cr (ConT $ mkName "GHC.Types.[]") args +create_dec_from_type' dr cr (TupleT count) args = + create_dec_from_type' dr cr (ConT $ mkName ("GHC.Types.(" ++ + (concat $ take count (cycle [","])) ++ ")")) args+create_dec_from_type' dr cr t@(AppT _ _) args = do+ typ <- (create_dec_from_type dr cr t)+ create_dec_from_type' dr cr typ args+create_dec_from_type' dr cr (SigT t _) args = do+ typ <- (create_dec_from_type dr cr t)+ create_dec_from_type' dr cr typ args+create_dec_from_type' dr cr (ForallT _ _ t) args = do+ typ <- (create_dec_from_type dr cr t)+ create_dec_from_type' dr cr typ args+create_dec_from_type' dr cr t args = + --just return what was passed in if we can't do anything+ return $ foldl' AppT t args ++rename_cons :: (Con -> Con) -> Dec -> Result Dec+rename_cons cr dec = result where+ new_cons = map cr $ get_cons dec+ result = set_cons new_cons dec+ +set_cons :: [Con] -> Dec -> Result Dec+set_cons (con:[]) (NewtypeD x y z _ w) = Right $ NewtypeD x y z con w+set_cons cons (NewtypeD _ _ _ _ _) = Left $ show cons ++ " is not a appropiate arg for setting the NewtypeD's constructor arg"+set_cons cons (DataD x y z _ w) = Right $ DataD x y z cons w+set_cons cons (DataInstD x y z _ w) = Right $ DataInstD x y z cons w+set_cons (con:[]) (NewtypeInstD x y z _ w) = Right $ NewtypeInstD x y z con w+set_cons cons (NewtypeInstD x y z _ w) = Left $ show cons ++ " is not a appropiate arg for setting the NewtypeInstD's constructor arg"+set_cons _ x = Left $ "Can't set the constructors for " ++ show x++get_ty_vars :: Dec -> [TyVarBndr]+get_ty_vars (NewtypeD _ _ ty_vars _ _) = ty_vars+get_ty_vars (DataD _ _ ty_vars _ _) = ty_vars+get_ty_vars (TySynD _ ty_vars _) = ty_vars+get_ty_vars (ClassD _ _ ty_vars _ _) = ty_vars+get_ty_vars (FamilyD _ _ ty_vars _ ) = ty_vars+get_ty_vars _ = []++ty_var_name :: TyVarBndr -> Name+ty_var_name (KindedTV name _ ) = name+ty_var_name (PlainTV name) = name++sub_dec_by_con :: (Monad m, MonadError String m) => + ConstrRenamer -> Dec -> [Type] -> m Dec+sub_dec_by_con cr dec args = do+ --get the names of the ty vars+ let tv_vars = get_ty_vars dec+ --subsistute the types into the dec+ throw_either $ rename_cons (cr args) $ foldl' sub_type_dec' dec $ zip args $ + map (VarT . ty_var_name) tv_vars+ +sub_dec_and_rename :: (Monad m, Functor m, MonadError String m) => + ConstrRenamer -> Dec -> [Type] -> m Dec +sub_dec_and_rename cr dec types = rename_dec types =<< sub_dec_by_con cr dec types++concat_type_names :: [Type] -> String+concat_type_names types = concat $ intersperse "_" $ map (replace " " "_" . show) types ++-- | Default Dec renamer+mk_new_dec_name :: [Type] -> TypeName -> Result TypeName+mk_new_dec_name types dec_name = do+ let suffix = concat_type_names types+ let dec_name_string = show $ unpack dec_name+ let name_string = if isSuffixOf "[]" dec_name_string+ then suffix ++ "_List"+ else dec_name_string ++ "_" ++ suffix+ + return $ pack $ mkName $ name_string+ ++rename_dec :: (Monad m, MonadError String m) => [Type] -> Dec -> m Dec+rename_dec types dec = do+ new_name <- (throw_either . mk_new_dec_name types) =<< (throw_either $ get_dec_name dec)+ set_dec_name new_name dec++sub_type_dec' dec (new, old) = sub_type_dec new old dec++find_con :: (Monad m, MonadError String m) => ConstructorName -> Dec -> m Con+find_con name dec = throw_maybe err_msg $ find (\x -> name == get_con_name x) $ get_cons dec where+ err_msg = "constructor " ++ show name ++ "not found"+ +throw_maybe :: (Monad m, MonadError String m) => String -> Maybe a -> m a+throw_maybe _ (Just x) = return x+throw_maybe err Nothing = throwError err++maybe_to_either :: String -> Maybe a -> Result a+maybe_to_either msg (Just a) = Right a+maybe_to_either msg Nothing = Left msg++throw_either :: (Monad m, MonadError String m) => Result a -> m a+throw_either (Right x) = return x+throw_either (Left x) = throwError x++is_vart (VarT _) = True+is_vart _ = False++get_con_name :: Con -> ConstructorName+get_con_name (NormalC n _) = pack n+get_con_name (RecC n _) = pack n+get_con_name (InfixC _ n _) = pack n+get_con_name (ForallC _ _ con) = get_con_name con++get_con_vars :: Con -> [Type]+get_con_vars = filter is_vart . concatMap universe . get_con_types ++collect_type_args :: Type -> [Type]+collect_type_args (AppT x y) = x:(collect_type_args y)+collect_type_args x = [x]++run_state' x xs = runStateT (runErrorT (runErrorStateT x)) xs++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 [Dec]) where+ lift = ErrorStateT . lift . lift++collect_constr :: [Dec] -> [(TypeName, [Con])]+collect_constr decs = right_only $ map get_cons_pair decs++is_right :: Either a b -> Bool+is_right (Right _) = True+is_right (Left _) = False++from_right :: Either a b -> b+from_right (Right x) = x+from_right (Left _) = error "from_right"++right_only :: [Either a b] -> [b]+right_only = map from_right . filter is_right++--get_cons_pair :: (Monad m, MonadError String m) => Dec -> m (Name, [Con])+get_cons_pair :: Dec -> Result (TypeName, [Con])+get_cons_pair dec = do+ name <- get_dec_name dec+ let cons = get_cons dec+ return (name, cons)++--get_dec_name :: (Monad m, MonadError String m) => Dec -> m Name+get_dec_name :: Dec -> Result TypeName+get_dec_name (FunD name _) = Right $ pack name+get_dec_name (ValD _ _ _) = Left "ValD does not have a name"+get_dec_name (DataD _ name _ _ _) = Right $ pack name+get_dec_name (NewtypeD _ name _ _ _) = Right $ pack name+get_dec_name (TySynD name _ _) = Right $ pack name+get_dec_name (ClassD _ name _ _ _) = Right $ pack name+get_dec_name (InstanceD _ _ _) = Left "InstanceD does not have a name"+get_dec_name (SigD name _) = Right $ pack 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 _ _) = Right $ pack name+get_dec_name (DataInstD _ name _ _ _ ) = Right $ pack name++set_dec_name :: (Monad m, MonadError String m) => TypeName -> Dec -> m Dec+set_dec_name name (FunD _ x) = return $ FunD (unpack name) x+set_dec_name name (ValD _ _ _) = throwError "ValD does not have a name"+set_dec_name name (DataD x _ y z w) = return $ DataD x (unpack name) y z w+set_dec_name name (NewtypeD x _ y z w) = return $ NewtypeD x (unpack name) y z w+set_dec_name name (TySynD _ x y) = return $ TySynD (unpack name) x y+set_dec_name name (ClassD x _ y z w) = return $ ClassD x (unpack name) y z w+set_dec_name name (InstanceD _ _ _) = throwError "InstanceD does not have a name"+set_dec_name name (SigD _ x) = return $ SigD (unpack name) x+set_dec_name name (ForeignD _) = throwError "ForeignD does not have a name"+set_dec_name name (PragmaD _ ) = throwError "PragmaD does not have a name"+set_dec_name name (FamilyD x _ y z) = return $ FamilyD x (unpack name) y z+set_dec_name name (DataInstD x _ y z w ) = return $ DataInstD x (unpack name) y z w++set_con_types' :: Con -> [Type] -> Con+set_con_types' (NormalC n st) types = NormalC n $ zipWith (\(x, _) t -> (x, t)) st types+set_con_types' (RecC n st) types = RecC n $ zipWith (\(x, y, _) t -> (x,y,t)) st types+set_con_types' (InfixC (x, _) n (y, _)) [a, b] = InfixC (x, a) n (y, b)+set_con_types' (ForallC x y con) types = ForallC x y $ set_con_types' con types++$(mkNewTypes [''ConstructorName, ''TypeName])+++++++++++++