multirec-alt-deriver (empty) → 0.1
raw patch · 7 files changed
+938/−0 lines, 7 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, multirec, syb, template-haskell, th-expand-syns
Files
- BalancedFold.hs +81/−0
- Generics/MultiRec/TH/Alt.hs +644/−0
- LICENSE +10/−0
- Setup.lhs +3/−0
- THUtils.hs +134/−0
- examples/Tree.hs +32/−0
- multirec-alt-deriver.cabal +34/−0
+ BalancedFold.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module BalancedFold where++-- import Test.QuickCheck+-- import Test.QuickCheck.Property+import Control.Exception++balancedFold :: (a -> a -> a) -> [a] -> a+balancedFold f = go+ where+ go [x] = x+ go xs = + let+ (l,r) = splitAt (length xs `div` 2) xs+ in+ f (go l) (go r) +++-- | @AscendFromLeaf l r leaf m i@ +-- \"descends\" to the /i/-th leaf -- counted from left to right, zero-based -- +-- of a tree with the same structure as +--+-- > @balancedFold Node (repeat m (Leaf ()))@+--+-- would produce. It then starts with the value /leaf/, and ascends back up, +-- applying /l/ to the value whenever ascending up a left-child edge +-- and /r/ when ascending up a right-child edge.+ascendFromLeaf :: (Integral int) => (t -> t) -> (t -> t) -> t -> int -> int -> t+ascendFromLeaf l r leaf = go+ where+ go 1 i = assert (i==0) $ leaf+ go m i = + let+ nl = m `div` 2+ nr = (m+1) `div` 2+ in if i < nl + then l (go nl i)+ else r (go nr (i-nl))+++-- * Testing++-- data Tree a = Node (Tree a) (Tree a) | Leaf a+-- deriving (Eq)+ +-- leftChild (Node x _) = x+-- leftChild x = error ("leftChild "++show x)+-- rightChild (Node _ x) = x+-- rightChild x = error ("leftChild "++show x)+ +-- instance Show a => Show (Tree a) where+-- show = go 0+-- where+-- go 0 x = case x of+-- Leaf y -> show y+-- Node x1 x2 -> "+\n"++go 1 x1++"\n"++go 1 x2+-- go n x = concat (replicate (n-1) "| ") ++ "+-" +++-- case x of+-- Leaf y -> show y+-- Node x1 x2 -> "+\n" ++ go (n+1) x1 ++ "\n" ++ go (n+1) x2++-- prop1 = do+-- n <- choose (1,100)+-- i <- choose (0,n-1)+-- let+-- tree :: Tree Int+-- tree = balancedFold Node [ Leaf i | i <- [0..n-1] ]+ +-- getter :: Tree Int -> Tree Int+-- getter = ascendFromLeaf +-- (\f -> f . leftChild) +-- (\f -> f . rightChild)+-- id+-- n+-- i+ + +-- return (whenFail (print (n,tree,i,getter tree)) $+-- getter tree == Leaf i)+ +---- END TESTING
+ Generics/MultiRec/TH/Alt.hs view
@@ -0,0 +1,644 @@++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MonomorphismRestriction #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS -fwarn-missing-signatures #-}++++{-|+Example usage:++@+import Generics.MultiRec+import Generics.MultiRec.TH.Alt+import Data.Tree++data TheFam :: (* -> *) where+ Tree_Int :: TheFam (Tree Int)+ Forest_Int :: TheFam (Forest Int)+ +$('deriveEverything'+ ('DerivOptions'+ [ ( [t| Tree Int |], \"Tree_Int\" )+ , ( [t| Forest Int |], \"Forest_Int\" )+ ]+ \"TheFam\"+ (\\t c -> \"CONSTRUCTOR_\" ++ t ++ \"_\" ++ c)+ \"ThePF\"+ True+ )+ )++type instance 'PF' TheFam = ThePF+@+-}++module Generics.MultiRec.TH.Alt+ ( + DerivOptions(..),+ deriveEverything,+ -- RQ, runRQ,+ -- deriveConstructors,+ -- deriveFamily,+ -- derivePF,+ -- deriveEl,+ -- deriveFam,+ -- deriveEqS+ ) where++import Generics.MultiRec.Base+import Generics.MultiRec.Constructor+import Language.Haskell.TH hiding (Fixity())+import Language.Haskell.TH.Syntax (Lift(..))+import Language.Haskell.TH.ExpandSyns+import Language.Haskell.TH.Ppr+import Control.Monad+import Control.Monad.Reader hiding (lift)+import qualified Control.Monad.Reader as Reader+import Control.Applicative+import Control.Arrow+import THUtils+import Data.Map as Map+import Data.Set as Set hiding(elems)+import qualified Data.Foldable as Fold+import BalancedFold++bALANCED_MODE :: Bool+bALANCED_MODE = True++data DerivOptions ft = + DerivOptions {+ -- | A list of:+ --+ -- > (type quotation, name of corresponding constructor of the family GADT)+ --+ -- This defines our mutually recursive family. The types must resolve to+ -- @data@types or @newtype@s of kind @*@ (type synonyms will be expanded).+ familyTypes :: ft+ -- | Name of the family GADT (this type has to be generated+ -- manually because TH doesn't support GADTs yet)+ , indexGadtName :: String+ -- | Scheme for producing names for the+ -- empty types corresponding to constructors. The first arg is the name+ -- of the type (as given in 'familyTypes'), the second arg is the name+ -- of the constructor (builtins will be called: @NIL@, @CONS@, @TUPLE2@, @TUPLE3@ ...)+ , constructorNameModifier :: String -> String -> String+ -- | Name of the pattern functor ('PF') to generate+ , patternFunctorName :: String+ -- | Print various informational messges?+ , verbose :: Bool+ -- , mkSanityChecks :: Bool+ }+ +instance Functor DerivOptions where+ fmap f d = d { familyTypes = (f . familyTypes) d }+ +cleanConstructorName :: [Char] -> [Char]+cleanConstructorName c =+ if head c == '(' && last c == ')' then ("TUPLE"++show (length c-1))+ else if c=="[]" then "NIL"+ else if c==":" then "CONS"+ else c+ +message :: String -> RQ ()+message x = + do+ b <- asks verbose+ when b (liftq . runIO . putStrLn $ x ++ "\n")+ +messageReport :: String -> RQ ()+messageReport x = + do+ b <- asks verbose+ when b (liftq . report False $ x ++ "\n")+ +-- checkOptions :: DerivOptions -> Q ()+-- checkOptions (DerivOptions{..}) = +-- do+-- when (null familyTypes) (fail "empty family")+ +type RQ = ReaderT (DerivOptions (Map AppliedTyCon String)) Q++liftq :: Q a -> RQ a+liftq = Reader.lift+ +foreachType :: ((AppliedTyCon,String) -> RQ a) -> RQ [a]+foreachType f = mapM f . Map.toList =<< asks familyTypes++foreachTypeNumbered :: (Int -> Int -> (AppliedTyCon,String) -> RQ a) -> RQ [a]+foreachTypeNumbered f = do+ ns <- Map.toList <$> asks familyTypes+ zipWithM (f (length ns)) [0..] ns + +collision :: AppliedTyCon -> String -> String -> a+collision k a b = error ("collision : "+ ++ "\n key = "++pprintUnqual k+ ++ "\n values = "++show(a,b)+ )+ ++runRQ :: RQ a -> DerivOptions [(TypeQ,String)] -> Q a+runRQ x opts = do+ ft' <- sequence+ . fmap (\(x,y) -> x >>= (\x' -> return (x',y))) + . familyTypes $ opts+ + :: Q [(Type,String)]+ + when (Prelude.null ft') (fail ("Empty family not supported."))+ + ft'' <- mapM (\(t,s) -> do+ t' <- toAppliedTyCon t+ case t' of+ Left err -> fail err+ Right t'' -> return (t'',s))+ ft'+ + let+ ft''' = Map.fromListWithKey collision ft''++ runReaderT x (fmap (const ft''') opts)++deriveEverything :: DerivOptions [(TypeQ, String)] -> Q [Dec]+deriveEverything opts = do+ -- let x | mkSanityChecks opts = makeSanityChecks+ -- | otherwise = return []+ + runRQ (concat <$> sequence [deriveConstructors, deriveFamily]) opts+ ++-- | Given a list of datatype names, derive datatypes and +-- instances of class 'Constructor'.++deriveConstructors :: RQ [Dec]+deriveConstructors =+ concat <$> foreachType constrInstance++-- | Given the name of the index GADT, the names of the+-- types in the family, and the name (as string) for the+-- pattern functor to derive, generate the 'Ix' and 'PF'+-- instances. /IMPORTANT/: It is assumed that the constructors+-- of the GADT have the same names as the datatypes in the+-- family.++deriveFamily :: RQ [Dec]+deriveFamily =+ do+ pf <- derivePF+ el <- deriveEl+ fam <- deriveFam+ eq <- deriveEqS+ return $ pf ++ el ++ fam ++ eq++-- | Derive only the 'PF' instance. Not needed if 'deriveFamily'+-- is used.++derivePF :: RQ [Dec]+derivePF =+ do+ branches <- foreachType pfType+ pfn <- asks patternFunctorName+ let + pf = [TySynD (mkName pfn) [] (sumT branches)]+ ++ famName <- asks indexGadtName+ + -- message $+ -- ( "*** The pattern functor is:\n"+ -- ++ pprint (cutNames pf)+ -- ++ "\n\n\n"+ -- )++ messageReport (+ "Reminder: Don't forget to add this line manually:\n"+ ++ " type instance PF "++famName++" = "++pfn+ )+ + return pf++ +sumT :: [Type] -> Type+sumT | bALANCED_MODE = balancedSumT+ | otherwise = rightSumT+ +rightSumT :: [Type] -> Type+rightSumT = foldr1 plusT+balancedSumT :: [Type] -> Type+balancedSumT = balancedFold plusT+ +plusT :: Type -> Type -> Type+plusT a b = ConT ''(:+:) @@ a @@ b+ +prodT :: [Type] -> Type+prodT = foldr1 timesT+ +timesT :: Type -> Type -> Type+timesT a b = ConT ''(:*:) @@ a @@ b+ +-- | Derive only the 'El' instances. Not needed if 'deriveFamily'+-- is used.++deriveEl :: RQ [Dec]+deriveEl = foreachType elInstance+ +indexGadtType :: RQ Type+indexGadtType = ConT . mkName <$> asks indexGadtName++-- | Dervie only the 'Fam' instance. Not needed if 'deriveFamily'+-- is used.++deriveFam :: RQ [Dec]+deriveFam =+ do+ fcs <- liftM concat $ foreachTypeNumbered mkFrom+ tcs <- foreachTypeNumbered mkTo+ s <- indexGadtType+ return [+ InstanceD [] (ConT ''Fam @@ s)+ [FunD 'from fcs, FunD 'to tcs]+ ]++-- | Derive only the 'EqS' instance. Not needed if 'deriveFamily'+-- is used.++deriveEqS :: RQ [Dec]+deriveEqS = do+ s <- indexGadtType+ ns <- Map.elems <$> asks familyTypes+ + return [+ InstanceD [] (ConT ''EqS @@ s)+ [FunD 'eqS (trues ns ++ falses ns)]+ ]+ where+ trueClause n = sClause [ConP (mkName n) [], ConP (mkName n) []] + ((ConE 'Just `AppE` ConE 'Refl)) + falseClause = sClause [WildP, WildP] + ((ConE 'Nothing)) + trues ns = fmap trueClause ns+ falses ns = if length (trues ns) == 1 then [] else [falseClause]++constrInstance :: (AppliedTyCon,String) -> RQ [Dec]+constrInstance (atc,s) =+ do+ cs <- liftq (atc2constructors atc)+ -- runIO (print i)+ + ds <- mapM (mkData s) cs+ is <- mapM (mkInstance s) cs+ return $ ds ++ is++stripRecordNames :: Con -> Con+stripRecordNames (RecC n f) =+ NormalC n (fmap (\(_, s, t) -> (s, t)) f)+stripRecordNames c = c++-- TODO: Handle colons in the constructor name+mkData :: String -> Con -> RQ Dec+mkData s (NormalC n _) = do+ modifier <- asks constructorNameModifier+ liftq $ dataD (cxt []) (mkName . modifier s . cleanConstructorName . nameBase $ n) [] [] [] +mkData s r@(RecC _ _) =+ mkData s (stripRecordNames r)+mkData s (InfixC t1 n t2) =+ mkData s (NormalC n [t1,t2])++instance Lift Fixity where+ lift Prefix = conE 'Prefix+ lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]++instance Lift Associativity where+ lift LeftAssociative = conE 'LeftAssociative+ lift RightAssociative = conE 'RightAssociative+ lift NotAssociative = conE 'NotAssociative++mkInstance :: String -> Con -> RQ Dec+mkInstance s (NormalC n _) =+ do+ modifier <- asks constructorNameModifier+ let n' = modifier s . cleanConstructorName . nameBase $ n++ liftq $+ instanceD (cxt []) + (appT (conT ''Constructor) (conT . mkName $ n'))+ [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []]]+ +mkInstance s r@(RecC _ _) =+ mkInstance s (stripRecordNames r)+mkInstance s (InfixC t1 n t2) =+ do+ modifier <- asks constructorNameModifier+ let n' = modifier s . cleanConstructorName . nameBase $ n++ i <- liftq (reify n)+ let fi = case i of+ DataConI _ _ _ f -> convertFixity f+ _ -> Prefix+ liftq $ + instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName n'))+ [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []],+ funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]+ where+ convertFixity (Fixity n d) = Infix (convertDirection d) n+ convertDirection InfixL = LeftAssociative+ convertDirection InfixR = RightAssociative+ convertDirection InfixN = NotAssociative++pfType :: (AppliedTyCon,String) -> RQ Type+pfType (atc,s) =+ do+ -- runIO $ putStrLn $ "processing " ++ show n+ cs <- liftq (atc2constructors atc)+ + guardEmptyData cs atc++ b <- sumT <$> mapM (pfCon s) cs+ + return $+ ConT ''(:>:) @@ b @@ fromAppliedTyCon atc+ ++ +pfCon :: String -> Con -> RQ Type+pfCon s (NormalC n fs) = do+ modifier <- asks constructorNameModifier+ let n' = mkName . modifier s . cleanConstructorName . nameBase $ n+ + fieldResults <- mapM (pfField . snd) fs+ + let rest = + case fs of+ [] -> ConT ''U+ _ -> prodT fieldResults+ + return $+ ConT ''C @@ ConT n' @@ rest+ ++pfCon s r@(RecC _ _) =+ pfCon s (stripRecordNames r)+pfCon s (InfixC t1 n t2) =+ pfCon s (NormalC n [t1,t2])++pfField :: Type -> RQ Type+pfField t = ifInFamily t (ConT ''I @@ t) (ConT ''K @@ t)++lookupFam :: Type -> RQ (Maybe String)+lookupFam t = + do+ + ts <- asks familyTypes+ t' <- liftq $ toAppliedTyCon t+ let res = case t' of+ Right t'' -> Map.lookup t'' ts+ Left _ -> Nothing+ + -- message ("familyTypes = "++show ts)+ -- message ("lookupFam "++show t'++" = "++show res)+ return res + +ifInFamily :: Type -> a -> a -> RQ a+ifInFamily n x y = ifInFamily' n (return x) (return y)++ifInFamily' :: Type -> RQ a -> RQ a -> RQ a+ifInFamily' t x y = maybe y (const x) + =<< lookupFam t+ ++elInstance :: (AppliedTyCon,String) -> RQ Dec+elInstance x@(atc,_) = do+ s <- indexGadtType+ prf <- mkProof x+ return $ InstanceD [] (ConT ''El @@ s @@ fromAppliedTyCon atc) [prf]++mkFrom :: Int -> Int -> (AppliedTyCon,String) -> RQ [Clause]+mkFrom m i (atc,s) =+ do+ -- ns <- fmap mkName . elems <$> asks familyTypes+ -- runIO $ putStrLn $ "processing " ++ show n+ cs <- liftq (atc2constructors atc)+ + let + wrapE = (\e -> lrE m i (ConE 'Tag @@@ e))+ + dn = mkName s -- (nameBase n)+ + zipWithM (fromCon wrapE dn (length cs)) [0..] cs+ ++mkTo :: Int -> Int -> (AppliedTyCon,String) -> RQ Clause+mkTo m i (atc,s) =+ do+ -- ns <- fmap mkName . elems <$> asks familyTypes+ -- runIO $ putStrLn $ "processing " ++ show n+ cs <- liftq (atc2constructors atc)+ pfname <- mkName <$> asks patternFunctorName+ + let + -- typeOfLamE = ArrowT @@+ -- (ConT pfname @@ ConT ''I0 @@ fromAppliedTyCon atc) @@+ -- (fromAppliedTyCon atc)+ + matchesOfCons <-+ zipWithM (toCon (length cs) atc) [0..] cs++ + xvar <- liftq (newName "x")+ convar <- liftq (newName "con")+ ++ + typeOfConvar <- + do+ t0 <- pfType (atc,s) + return (t0 @@ ConT ''I0 @@ fromAppliedTyCon atc)+ + + let+ typeOfXvar = ConT pfname @@ ConT ''I0 @@ fromAppliedTyCon atc+ + + body = LamE [VarP xvar]+ (CaseE (VarE xvar `SigE` typeOfXvar)+ [sMatch (lrP m i (VarP convar))+ (CaseE (VarE convar `SigE` typeOfConvar)+ matchesOfCons)+ ]+ )+ + return (sClause + [ConP (mkName s) []]+ body+ )+ ++ ++mkProof :: (AppliedTyCon,String) -> RQ Dec+mkProof (_,s) = return $+ FunD 'proof [sClause [] (ConE (mkName s)) ]++fromCon :: (Exp -> Exp) -> Name -> Int -> Int -> Con -> RQ Clause+fromCon wrap n m i (NormalC cn []) = return $+ -- Nullary constructor case+ sClause+ [ConP n [], ConP cn []]+ (wrap . lrE m i + $ ConE 'C @@@ ConE 'U)+ +fromCon wrap n m i (NormalC cn fs) =+ do+ rhs <- zipWithM fromField [0..] (snd <$> fs)+ + return $+ sClause+ [ ConP n [], + ConP cn (fmap (VarP . field) [0..length fs - 1])+ ]+ (wrap . lrE m i + $ ConE 'C @@@ foldr1 prod rhs) + where+ prod x y = ConE '(:*:) @@@ x @@@ y+ +fromCon wrap n m i r@(RecC _ _) =+ fromCon wrap n m i (stripRecordNames r)+ +fromCon wrap n m i (InfixC t1 cn t2) =+ fromCon wrap n m i (NormalC cn [t1,t2])++toCon :: + Int -- ^ Number of constructors+ -> AppliedTyCon+ -> Int -- ^ Index of this constructor+ -> Con+ -> RQ Match+toCon m atc i (NormalC cn []) = return $+ -- Nullary constructor case+ sMatch+ (ConP 'Tag [lrP m i $ ConP 'C [ConP 'U []]])+ + (+ ConE cn+ -- SigE (ConE cn) (fromAppliedTyCon atc) + ) + + +toCon m atc i (NormalC cn fs) =+ -- runIO (putStrLn ("constructor " ++ show ix)) >>+ do+ lhs <- zipWithM toField [0..] (fmap snd fs)+ + return $ + sMatch+ (ConP 'Tag [lrP m i $ ConP 'C [foldr1 prod lhs]])+ + (+ -- SigE (+ foldl AppE (ConE cn) + (fmap (VarE . field) [0..length fs - 1]) + -- )+ -- (fromAppliedTyCon atc)+ )+ where+ prod x y = ConP '(:*:) [x,y]+ +toCon m atc i r@(RecC _ _) =+ toCon m atc i (stripRecordNames r) + +toCon m atc i (InfixC t1 cn t2) =+ toCon m atc i (NormalC cn [t1,t2]) ++fromField :: Int -> Type -> RQ Exp+fromField nr t = + ifInFamily' t + (return (ConE 'I @@@ (ConE 'I0 @@@ VarE (field nr))))+ + (message ("* Info: Type not in family: " ++ pprintUnqual t) >>+ -- helper t >>+ return (ConE 'K @@@ VarE (field nr)))+ +toField :: Int -> Type -> RQ Pat+toField nr t =+ ifInFamily t+ (ConP 'I [ConP 'I0 [VarP (field nr)]])+ (ConP 'K [VarP (field nr)])++field :: Int -> Name+field n = mkName $ "f" ++ show n++lrP :: Int -> Int -> ( Pat -> Pat)+lrP m i p | bALANCED_MODE = ascendFromLeaf + (ConP 'L . (:[] {- robot monkey -})) + (ConP 'R . (:[])) + p+ m+ i++lrP 1 0 p = p+lrP m 0 p = ConP 'L [p]+lrP m i p = ConP 'R [lrP (m-1) (i-1) p]++lrE :: Int -> Int -> ( Exp -> Exp)+lrE m i e | bALANCED_MODE = ascendFromLeaf+ (ConE 'L @@@)+ (ConE 'R @@@)+ e+ m+ i+++lrE 1 0 e = e+lrE m 0 e = ConE 'L @@@ e+lrE m i e = ConE 'R @@@ lrE (m-1) (i-1) e++ +guardEmptyData :: [Con] -> AppliedTyCon -> RQ ()+guardEmptyData [] atc = fail ("Empty types not supported yet ("+++ show (fromAppliedTyCon atc))+guardEmptyData _ atc = return ()+++-- helper t = do+-- Right (AppliedTyCon n args) <- liftq (toAppliedTyCon t)+ +-- let prefix = "Prf_"+ +-- str <- if n == ''[]+-- then do+-- Right (AppliedTyCon n1 _) <- liftq (toAppliedTyCon (head args))+-- return ("T("++prefix++"List"++nameBase n1+-- ++",["++pprintUnqual (head args)++"])")+-- else+-- return ("T("++prefix++nameBase n+-- ++","++pprintUnqual t++")")++-- liftq . runIO $ appendFile "dump.dump" (str++"\n")++noSigE :: Exp -> Type -> Exp+x `noSigE` y = x++++-- makeSanityChecks :: RQ [Dec]+-- makeSanityChecks = concat <$> foreachType makeSanityCheck++-- makeSanityCheck :: (AppliedTyCon,String) -> RQ [Dec]+-- makeSanityCheck (atc,s) = do+-- famname <- mkName <$> asks indexGadtName+ +-- let+-- chkName = mkName ("sanityCheck"++s)+ +-- return [+-- SigD chkName (ConT famname @@ fromAppliedTyCon atc)+-- , ValD (VarP chkName)+-- (NormalB (ConE (mkName s)))+-- []+-- ]+
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2009, Daniel Schüssler+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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ THUtils.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE StandaloneDeriving #-}+module THUtils where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.ExpandSyns+import Control.Monad.Error+import Control.Applicative+import Data.Generics+import Control.Exception+ + +deriving instance Ord Type+#if __GLASGOW_HASKELL__ >= 611+deriving instance Ord Kind+deriving instance Ord Pred+deriving instance Ord TyVarBndr+#endif+ +-- name2constructors :: Name -> Q [Con]+-- name2constructors n = do+-- i <- reify n+-- case i of+-- TyConI d -> dec2constructors d+-- _ -> fail ("Not a type name: "++show n++"\nInfo for this name was: "++show i)++-- dec2constructors :: Dec -> Q [Con] +-- dec2constructors (DataD _ _ _ cs _) = return cs+-- dec2constructors (NewtypeD _ _ _ c _) = return [c]+-- -- dec2constructors (TySynD _ _ t) = type2constructors t+-- dec2constructors x = fail ("Don't know how to extract constructors from this Dec: "+-- ++ show x)+ +-- type2constructors :: Type -> Q [Con]+-- type2constructors (ForallT _ _ t) = type2constructors t+-- type2constructors (ConT n) = name2constructors n+-- type2constructors (AppT t _) = type2constructors t+-- type2constructors x = fail ("Don't know how to extract constructors from this Type: "+-- ++ show x)++(@@) = AppT+(@@@) = AppE+infixl 9 @@+infixl 9 @@@+++data AppliedTyCon = AppliedTyCon {+ atcHead :: Name+ , atcArgs :: [Type]+ }+ deriving (Eq,Ord,Show,Data,Typeable)+ +normaliseSpecialTyCons = everywhere (mkT f)+ where+ f ListT = ConT (''[])+ f (TupleT n) = ConT (tupleTypeName n)+ f ArrowT = ConT (''(->))+ f x = x+ ++-- | Expands synonyms, then tries to parse the type as an applied type constructor+toAppliedTyCon :: (MonadError String m) => Type -> Q (m AppliedTyCon)+toAppliedTyCon t = (go [] . normaliseSpecialTyCons) `fmap` expandSyns t+ where+ go acc (ConT n) = return (AppliedTyCon n acc)+ -- go acc ListT = return (AppliedTyCon ''[] acc)+ -- go acc (TupleT n) = return (AppliedTyCon (tupleTypeName n) acc)+ -- go acc ArrowT = return (AppliedTyCon ''(->) acc)+ + go acc (AppT t1 t2) = go (t2:acc) t1+ + go acc other = throwError ("Expected applied type constructor, got: "+ ++ show (foldl AppT other acc))++fromAppliedTyCon :: AppliedTyCon -> Type+fromAppliedTyCon (AppliedTyCon n ts) | n == ''[] = foldl AppT ListT ts+ | otherwise = foldl AppT (ConT n) ts+++-- | Get constructors with all type parameters instantiated as+-- described by the 'AppliedTyCon' argument+atc2constructors (AppliedTyCon n args) = do+ i <- reify n+ (params,cs) <- + case i of+ -- Note: Synonyms should already be expanded at this point by+ -- toAppliedTyCon+ + TyConI (DataD _ _ ps cs0 _) -> return (ps,cs0)+ TyConI (NewtypeD _ _ ps c0 _) -> return (ps,[c0])+ + _ -> fail ("Expected this name to refer to a data or newtype: "+ ++show n+ ++"\nBut info for this name was: "++show i)++ let+ substs = assert (length params == length args)+ (zip params args)+ + doSubsts x = foldr substInCon x substs+ ++ return (doSubsts <$> cs)++ ++cutNames = everywhere (mkT cutName)+ where+ cutName = mkName . nameBase+ +pprintUnqual = pprint . cutNames+++#define showQ(X)\+ $( (runIO . print =<< (X)) >> [d| showQ_dummy______ = ()|])+ ++-- showQ( liftM2 (==) (ConE ''[]) [| [] |] )+++instance Ppr AppliedTyCon where+ ppr (AppliedTyCon n args) = ppr (foldl AppT (ConT n) args)+++-- | 'Match' with normal body and no where clause+sMatch p b = Match p (NormalB b) []++-- | 'Clause' with normal body and no where clause+sClause ps b = Clause ps (NormalB b) []
+ examples/Tree.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Tree where++import Generics.MultiRec+import Generics.MultiRec.TH.Alt+import Data.Tree++data TheFam :: (* -> *) where+ Tree_Int :: TheFam (Tree Int)+ Forest_Int :: TheFam (Forest Int)+ Pair :: TheFam (Tree Int, Tree Int)+ +$(deriveEverything+ (DerivOptions+ [ ( [t| Tree Int |] , "Tree_Int" )+ , ( [t| Forest Int |] , "Forest_Int" )+ , ( [t| (Tree Int, Tree Int) |], "Pair" )+ ]+ "TheFam"+ (\t c -> "CONSTRUCTOR_" ++ t ++ "_" ++ c)+ "ThePF"+ True+ )+ )++type instance PF TheFam = ThePF
+ multirec-alt-deriver.cabal view
@@ -0,0 +1,34 @@+name: multirec-alt-deriver+version: 0.1+synopsis: Alternative multirec instances deriver+description: + New features/changes:+ .+ - Works with arbitrary monomorphic types, e.g. @([Int],String)@, not just names that refer to monomorphic types.+ .+ - The names of the \"proofs\" (= constructors of the family GADT) are now specified by the user; they don't need to be equal to the name of the types to which they correspond. (This is useful if you're working with existing code where the name is already taken)+ . + - The names of the empty types corresponding to constructors are now also customizable+ .+ - The type sums in the pattern functor are now balanced trees of @(:+:)@ rather than right-nested lists. This cuts down the size of the value-level code (and hopefully helps with compilation time).++category: Template Haskell, Generics+license: BSD3+license-file: LICENSE+author: Daniel Schüssler+maintainer: daniels@community.haskell.org+cabal-version: >= 1.6+build-type: Simple+extra-source-files: examples/Tree.hs++source-repository head+ type: darcs+ location: http://code.haskell.org/~daniels/multirec-alt-deriver++Library+ build-depends: base >= 4 && < 5, template-haskell, syb, + multirec, th-expand-syns,+ containers, mtl+ ghc-options: + exposed-modules: Generics.MultiRec.TH.Alt+ other-modules: THUtils, BalancedFold