multirec-alt-deriver 0.1.2 → 0.1.3

raw patch · 4 files changed

+156/−89 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Generics/MultiRec/TH/Alt.hs +76/−47
• Generics/MultiRec/TH/Alt/DerivOptions.hs +30/−7
• MonadRQ.hs +42/−30
• multirec-alt-deriver.cabal +8/−5

@@ -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 ()

@@ -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                    

@@ -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)+                            )

@@ -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