diff --git a/Generics/MultiRec/TH/Alt.hs b/Generics/MultiRec/TH/Alt.hs --- a/Generics/MultiRec/TH/Alt.hs +++ b/Generics/MultiRec/TH/Alt.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -19,18 +18,19 @@ import Data.Tree data TheFam :: (* -> *) where - Tree_Int :: TheFam (Tree Int) - Forest_Int :: TheFam (Forest Int) + TreeIntPrf :: TheFam ('Tree' Int) + ForestIntPrf :: TheFam ('Forest' Int) $('deriveEverything' - ('DerivOptions' - [ ( [t| Tree Int |], \"Tree_Int\" ) - , ( [t| Forest Int |], \"Forest_Int\" ) - ] - \"TheFam\" - (\\t c -> \"CONSTRUCTOR_\" ++ t ++ \"_\" ++ c) - \"ThePF\" - True + ('DerivOptions' { + 'familyTypes' = [ + ( [t| 'Tree' Int |], \"TreeIntPrf\" ), + ( [t| 'Forest' Int |], \"ForestIntPrf\" ) ], + 'indexGadtName' = \"TheFam\", + 'constructorNameModifier' = defaultConstructorNameModifier, + 'patternFunctorName' = \"ThePF\", + 'verbose' = True, + 'sumMode' = 'Balanced' ) ) @@ -41,18 +41,19 @@ module Generics.MultiRec.TH.Alt ( DerivOptions(..), + SumMode(..), + defaultConstructorNameModifier, deriveEverything, + module Generics.MultiRec.Base ) where -import Generics.MultiRec.TH.Alt.DerivOptions(DerivOptions(..)) +import Generics.MultiRec.TH.Alt.DerivOptions import THUtils(AppliedTyCon, (@@), (@@@), toAppliedTyCon, fromAppliedTyCon, atc2constructors, pprintUnqual, sMatch, sClause, cleanConstructorName) import BalancedFold(balancedFold, ascendFromLeaf) -import MonadRQ(RQ, message, messageReport, liftq, foreachType, - foreachTypeNumbered, runRQ) -import Generics.MultiRec.Base((:>:)(..), C(..), El(..), (:=:)(..), - I0(I0), (:*:)(..), (:+:)(..), EqS(..), Fam(..), I(I), K(K), U(..)) +import MonadRQ +import Generics.MultiRec.Base import Generics.MultiRec.Constructor(Associativity(..), Fixity(..), Constructor(..)) import Control.Monad.Reader(Monad(return, fail, (>>)), Functor(..), @@ -73,13 +74,11 @@ import qualified Language.Haskell.TH as TH -bALANCED_MODE :: Bool -bALANCED_MODE = False - -deriveEverything :: DerivOptions [(TypeQ, String)] -> Q [Dec] +-- | Main function. +deriveEverything :: DerivOptions -> Q [Dec] deriveEverything opts = do -- let x | mkSanityChecks opts = makeSanityChecks -- | otherwise = return [] @@ -117,12 +116,13 @@ derivePF = do branches <- foreachType pfType - pfn <- asks patternFunctorName + pfn <- asks (patternFunctorName . derivOptions) + sumT <- askSumT let pf = [TySynD (mkName pfn) [] (sumT branches)] - famName <- asks indexGadtName + famName <- asks (indexGadtName . derivOptions) -- message $ -- ( "*** The pattern functor is:\n" @@ -138,9 +138,12 @@ return pf -sumT :: [Type] -> Type -sumT | bALANCED_MODE = balancedSumT - | otherwise = rightSumT +askSumT :: RQ( [Type] -> Type ) +askSumT = do + m <- askSumMode + return (case m of + Balanced -> balancedSumT + RightNested -> rightSumT ) rightSumT :: [Type] -> Type rightSumT = foldr1 plusT @@ -163,7 +166,7 @@ deriveEl = foreachType elInstance indexGadtType :: RQ Type -indexGadtType = ConT . mkName <$> asks indexGadtName +indexGadtType = ConT . mkName <$> asks (indexGadtName . derivOptions) -- | Dervie only the 'Fam' instance. Not needed if 'deriveFamily' -- is used. @@ -185,7 +188,7 @@ deriveEqS :: RQ [Dec] deriveEqS = do s <- indexGadtType - ns <- elems <$> asks familyTypes + ns <- elems <$> asks familyTypesMap return [ InstanceD [] (ConT ''EqS @@ s) @@ -217,7 +220,7 @@ -- TODO: Handle colons in the constructor name mkData :: String -> Con -> RQ Dec mkData s (NormalC n _) = do - modifier <- asks constructorNameModifier + modifier <- askConstructorNameModifier liftq $ dataD (cxt []) (mkName . modifier s . cleanConstructorName . nameBase $ n) [] [] [] mkData s r@(RecC _ _) = mkData s (stripRecordNames r) @@ -236,7 +239,7 @@ mkInstance :: String -> Con -> RQ Dec mkInstance s (NormalC n _) = do - modifier <- asks constructorNameModifier + modifier <- askConstructorNameModifier let n' = modifier s . cleanConstructorName . nameBase $ n liftq $ @@ -248,7 +251,7 @@ mkInstance s (stripRecordNames r) mkInstance s (InfixC t1 n t2) = do - modifier <- asks constructorNameModifier + modifier <- askConstructorNameModifier let n' = modifier s . cleanConstructorName . nameBase $ n i <- liftq (reify n) @@ -273,6 +276,7 @@ guardEmptyData cs atc + sumT <- askSumT b <- sumT <$> mapM (pfCon s) cs return $ @@ -282,7 +286,7 @@ pfCon :: String -> Con -> RQ Type pfCon s (NormalC n fs) = do - modifier <- asks constructorNameModifier + modifier <- askConstructorNameModifier let n' = mkName . modifier s . cleanConstructorName . nameBase $ n fieldResults <- mapM (pfField . snd) fs @@ -308,7 +312,7 @@ lookupFam t = do - ts <- asks familyTypes + ts <- asks familyTypesMap t' <- liftq $ toAppliedTyCon t let res = case t' of Right t'' -> Map.lookup t'' ts @@ -338,6 +342,7 @@ -- ns <- fmap mkName . elems <$> asks familyTypes -- runIO $ putStrLn $ "processing " ++ show n cs <- liftq (atc2constructors atc) + lrE <- ask_lrE let wrapE = (\e -> lrE m i (ConE 'Tag @@@ e)) @@ -353,7 +358,7 @@ -- ns <- fmap mkName . elems <$> asks familyTypes -- runIO $ putStrLn $ "processing " ++ show n cs <- liftq (atc2constructors atc) - pfname <- mkName <$> asks patternFunctorName + pfname <- mkName <$> asks (patternFunctorName . derivOptions) let -- typeOfLamE = ArrowT @@ @@ -373,6 +378,8 @@ do t0 <- pfType (atc,s) return (t0 @@ ConT ''I0 @@ fromAppliedTyCon atc) + + lrP <- ask_lrP let @@ -400,15 +407,17 @@ FunD 'proof [sClause [] (ConE (mkName s)) ] fromCon :: (Exp -> Exp) -> Name -> Int -> Int -> Con -> RQ Clause -fromCon wrap n m i (NormalC cn []) = return $ +fromCon wrap n m i (NormalC cn []) = do + lrE <- ask_lrE -- Nullary constructor case - sClause + return $ sClause [ConP n [], ConP cn []] (wrap . lrE m i $ ConE 'C @@@ ConE 'U) fromCon wrap n m i (NormalC cn fs) = do + lrE <- ask_lrE rhs <- zipWithM fromField [0..] (snd <$> fs) return $ @@ -433,9 +442,10 @@ -> Int -- ^ Index of this constructor -> Con -> RQ Match -toCon m atc i (NormalC cn []) = return $ +toCon m atc i (NormalC cn []) = do + lrP <- ask_lrP -- Nullary constructor case - sMatch + return $ sMatch (ConP 'Tag [lrP m i $ ConP 'C [ConP 'U []]]) ( @@ -447,6 +457,7 @@ toCon m atc i (NormalC cn fs) = -- runIO (putStrLn ("constructor " ++ show ix)) >> do + lrP <- ask_lrP lhs <- zipWithM toField [0..] (fmap snd fs) return $ @@ -487,20 +498,37 @@ field :: Int -> Name field n = mkName $ "f" ++ show n -lrP :: Int -> Int -> ( Pat -> Pat) -lrP m i p | bALANCED_MODE = ascendFromLeaf +ask_lrP :: RQ (Int -> Int -> ( Pat -> Pat)) +ask_lrP = do + m <- askSumMode + return (case m of + Balanced -> lrP_balanced + RightNested -> lrP_rightNested ) + + +lrP_balanced :: (Int -> Int -> ( Pat -> Pat)) +lrP_balanced m i p = 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] +lrP_rightNested :: (Int -> Int -> ( Pat -> Pat)) +lrP_rightNested 1 0 p = p +lrP_rightNested m 0 p = ConP 'L [p] +lrP_rightNested m i p = ConP 'R [lrP_rightNested (m-1) (i-1) p] -lrE :: Int -> Int -> ( Exp -> Exp) -lrE m i e | bALANCED_MODE = ascendFromLeaf +ask_lrE :: RQ (Int -> Int -> ( Exp -> Exp)) +ask_lrE = do + m <- askSumMode + return (case m of + Balanced -> lrE_balanced + RightNested -> lrE_rightNested ) + + +lrE_balanced :: (Int -> Int -> ( Exp -> Exp)) +lrE_balanced m i e = ascendFromLeaf (ConE 'L @@@) (ConE 'R @@@) e @@ -508,9 +536,10 @@ 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 +lrE_rightNested :: (Int -> Int -> ( Exp -> Exp)) +lrE_rightNested 1 0 e = e +lrE_rightNested m 0 e = ConE 'L @@@ e +lrE_rightNested m i e = ConE 'R @@@ lrE_rightNested (m-1) (i-1) e guardEmptyData :: [Con] -> AppliedTyCon -> RQ () diff --git a/Generics/MultiRec/TH/Alt/DerivOptions.hs b/Generics/MultiRec/TH/Alt/DerivOptions.hs --- a/Generics/MultiRec/TH/Alt/DerivOptions.hs +++ b/Generics/MultiRec/TH/Alt/DerivOptions.hs @@ -9,20 +9,40 @@ module Generics.MultiRec.TH.Alt.DerivOptions ( + SumMode(..), DerivOptions(..), + defaultConstructorNameModifier ) where +import Language.Haskell.TH(TypeQ) +import Generics.MultiRec.Base((:+:)) +data SumMode = + RightNested -- ^ e.g. @ a ':+:' (b ':+:' (c ':+:' d))@ + | Balanced -- ^ e.g. @ (a ':+:' b) ':+:' (c ':+:' d)@ -data DerivOptions ft = +data DerivOptions = DerivOptions { -- | A list of: -- - -- > (type quotation, name of corresponding constructor of the family GADT) + -- > (type (quoted), name of the proof for this type (i.e. the name of the constructor of the family GADT)) -- + -- E.g. + -- + -- > data FooFam a where + -- > FooPrf :: FooFam Foo + -- > BarStrPrf :: FooFam (Bar String) + -- > + -- > ... DerivOptions { + -- > familyTypes = + -- > [ ( [t| Foo |], "FooPrf" ) ], + -- > ( [t| Bar String |], "BarStrPrf") ] ] + -- > ... + -- > } + -- -- 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 + familyTypes :: [(TypeQ,String)] -- | Name of the family GADT (this type has to be generated -- manually because TH doesn't support GADTs yet) , indexGadtName :: String @@ -35,8 +55,11 @@ , patternFunctorName :: String -- | Print various informational messges? , verbose :: Bool - -- , mkSanityChecks :: Bool + -- | The shape for trees of ':+:'s + , sumMode :: SumMode } - -instance Functor DerivOptions where - fmap f d = d { familyTypes = (f . familyTypes) d } + + +-- | Makes names like @CTOR_Either_Left@, @CTOR_Either_Right@ etc. +defaultConstructorNameModifier :: String -> String -> String +defaultConstructorNameModifier ty ctor = "CTOR_" ++ ty ++ "_" ++ ctor diff --git a/MonadRQ.hs b/MonadRQ.hs --- a/MonadRQ.hs +++ b/MonadRQ.hs @@ -12,8 +12,7 @@ module MonadRQ where -import Generics.MultiRec.TH.Alt.DerivOptions(DerivOptions(verbose, - familyTypes)) +import Generics.MultiRec.TH.Alt.DerivOptions import THUtils(AppliedTyCon, toAppliedTyCon, pprintUnqual) import Control.Monad.Reader(Monad(return, fail, (>>=)), Functor(..), (=<<), mapM, sequence, @@ -23,64 +22,77 @@ import Data.Map(Map, fromListWithKey, toList) import Control.Applicative((<$>)) +askConstructorNameModifier :: RQ (String -> String -> String) +askConstructorNameModifier = asks (constructorNameModifier . derivOptions) +askVerbose :: RQ Bool +askVerbose = asks (verbose . derivOptions) +askSumMode :: RQ SumMode +askSumMode = asks (sumMode . derivOptions) + message :: String -> RQ () message x = do - b <- asks verbose + b <- askVerbose when b (liftq . runIO . putStrLn $ x ++ "\n") messageReport :: String -> RQ () messageReport x = do - b <- asks verbose + b <- askVerbose when b (liftq . report False $ x ++ "\n") -- checkOptions :: DerivOptions -> Q () -- checkOptions (DerivOptions{..}) = -- do -- when (null familyTypes) (fail "empty family") + +data Env = Env { + derivOptions :: DerivOptions, + familyTypesMap :: Map AppliedTyCon String +} -type RQ = ReaderT (DerivOptions (Map AppliedTyCon String)) Q +type RQ = ReaderT Env Q liftq :: Q a -> RQ a liftq = lift foreachType :: ((AppliedTyCon,String) -> RQ a) -> RQ [a] -foreachType f = mapM f . toList =<< asks familyTypes +foreachType f = mapM f . toList =<< asks familyTypesMap foreachTypeNumbered :: (Int -> Int -> (AppliedTyCon,String) -> RQ a) -> RQ [a] foreachTypeNumbered f = do - ns <- toList <$> asks familyTypes + ns <- toList <$> asks familyTypesMap 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 :: RQ a -> DerivOptions -> 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' <- sequence + . fmap (\(x,y) -> x >>= (\x' -> return (x',y))) + . familyTypes $ opts - ft'' <- mapM (\(t,s) -> do - t' <- toAppliedTyCon t - case t' of - Left err -> fail err - Right t'' -> return (t'',s)) - ft' - - let - ft''' = fromListWithKey collision ft'' + :: 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 + ftm = fromListWithKey collision ft'' - runReaderT x (fmap (const ft''') opts) + runReaderT x Env { derivOptions = opts, familyTypesMap = ftm } + where + collision :: AppliedTyCon -> String -> String -> a + collision k a b = error ("collision : " + ++ "\n key = "++pprintUnqual k + ++ "\n values = "++show(a,b) + ) diff --git a/multirec-alt-deriver.cabal b/multirec-alt-deriver.cabal --- a/multirec-alt-deriver.cabal +++ b/multirec-alt-deriver.cabal @@ -1,16 +1,16 @@ name: multirec-alt-deriver -version: 0.1.2 +version: 0.1.3 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. In other words, a proof now doesn't need to have the same name as the type whose family-membership it proves anymore. This is useful if you're working with existing code where the type's name is already taken on the value level. + - The names of the \"proof\" constructors (= constructors of the family GADT) are now specified by the user. This is useful if you're working with existing code where some type's name is already taken on the value level, so you can't have a proof of that name. . - The names of the constructor-representing empty types are also customizable now. . - - 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). + - Optionally, the type sums in the pattern functor are /balanced/ trees of @(:+:)@ rather than right-nested ones. This cuts down the size of the value-level code (and hopefully helps with compilation time). category: Template Haskell, Generics license: BSD3 @@ -35,6 +35,9 @@ mtl ghc-options: exposed-modules: Generics.MultiRec.TH.Alt - , Generics.MultiRec.TH.Alt.DerivOptions - other-modules: THUtils, BalancedFold, MonadRQ + + other-modules: THUtils, + BalancedFold, + MonadRQ, + Generics.MultiRec.TH.Alt.DerivOptions