multirec-alt-deriver 0.1 → 0.1.1

raw patch · 7 files changed

+258/−139 lines, 7 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• BalancedFold.hs +12/−1
• Generics/MultiRec/TH/Alt.hs +31/−116
• Generics/MultiRec/TH/Alt/DerivOptions.hs +42/−0
• MonadRQ.hs +86/−0
• THUtils.hs +36/−3
• examples/Tree.hs +43/−13
• multirec-alt-deriver.cabal +8/−6

@@ -5,9 +5,20 @@ -- import Test.QuickCheck.Property import Control.Exception -balancedFold :: (a -> a -> a) -> [a] -> a+-- | Conceptually,this turns the second arg into a balanced binary tree (with data at the leafs) and then folds this tree with the first arg. +--+--+-- Example:+--+-- > balancedFold (-) [1,2,4,8] = (1-2)-(4-8) (= 3)+--+-- For nodes which cover an odd number of elements, the leftover element goes to the right subtree.+balancedFold :: (a -> a -> a) + -> [a] -- ^ PARTIALITY WARNING: List must be nonempty+ -> a balancedFold f = go     where+      go [] = error "balancedFold of an empty list is undefined"       go [x] = x       go xs =            let

@@ -42,128 +42,43 @@   (      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+import Generics.MultiRec.TH.Alt.DerivOptions(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 Generics.MultiRec.Constructor(Associativity(..), Fixity(..),+                                     Constructor(..))+import Control.Monad.Reader(Monad(return, fail, (>>)), Functor(..),+                            (=<<), mapM, sequence, liftM, zipWithM, asks)+import Language.Haskell.TH.Syntax(Lift(..))+import Language.Haskell.TH(newName, mkName, wildP, clause, conE,+                           appE, normalB, funD, dataD, instanceD, cxt, conT, appT,+                           Exp(VarE, SigE, LamE, ConE, CaseE, AppE), Match, Clause, Q,+                           Pat(WildP, VarP, ConP), TypeQ, Type(ConT),+                           Dec(TySynD, InstanceD, FunD), Name, +                           Con(RecC, NormalC, InfixC),+                           FixityDirection(..),+                           Info(DataConI), nameBase, reify, stringE)+import Data.Map(lookup, elems)+import Control.Applicative((<$>)) +import qualified Data.Map as Map+import qualified Language.Haskell.TH as TH++ bALANCED_MODE :: Bool-bALANCED_MODE = True+bALANCED_MODE = False -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@@ -270,7 +185,7 @@ deriveEqS :: RQ [Dec] deriveEqS = do   s <- indexGadtType-  ns <- Map.elems <$> asks familyTypes+  ns <- elems <$> asks familyTypes      return [     InstanceD [] (ConT ''EqS @@ s)@@ -345,7 +260,7 @@         [funD 'conName   [clause [wildP] (normalB (stringE (nameBase n))) []],          funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]   where-    convertFixity (Fixity n d) = Infix (convertDirection d) n+    convertFixity (TH.Fixity n d) = Infix (convertDirection d) n     convertDirection InfixL = LeftAssociative     convertDirection InfixR = RightAssociative     convertDirection InfixN = NotAssociative

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MonomorphismRestriction #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS -fwarn-missing-signatures #-}++module Generics.MultiRec.TH.Alt.DerivOptions+  ( +    DerivOptions(..),+  ) where+++    +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 }

@@ -0,0 +1,86 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MonomorphismRestriction #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS -fwarn-missing-signatures #-}++++module MonadRQ+   where++import Generics.MultiRec.TH.Alt.DerivOptions(DerivOptions(verbose,+                                                          familyTypes))+import THUtils(AppliedTyCon, toAppliedTyCon, pprintUnqual)+import Control.Monad.Reader(Monad(return, fail, (>>=)),+                            Functor(..), (=<<), mapM, sequence, +                            MonadTrans(..), when, zipWithM,+                            ReaderT(runReaderT), asks)+import Language.Haskell.TH(Q, TypeQ, Type, report, runIO)+import Data.Map(Map, fromListWithKey, toList)+import Control.Applicative((<$>))+++++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 = lift+        +foreachType :: ((AppliedTyCon,String) -> RQ a) -> RQ [a]+foreachType f = mapM f . toList =<< asks familyTypes++foreachTypeNumbered :: (Int -> Int -> (AppliedTyCon,String) -> RQ a) -> RQ [a]+foreachTypeNumbered f = do+  ns <- 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''' = fromListWithKey collision ft''++  runReaderT x (fmap (const ft''') opts)

@@ -13,6 +13,8 @@ import Control.Applicative import Data.Generics import Control.Exception+import Data.List(intersperse)+import Data.Char(ord)           deriving instance Ord Type@@ -20,7 +22,17 @@ deriving instance Ord Kind deriving instance Ord Pred deriving instance Ord TyVarBndr++deKindSigify :: TyVarBndr -> Name+deKindSigify (PlainTV t) = t+deKindSigify (KindedTV t _) = t++#else+deKindSigify :: Name -> Name+deKindSigify = id+ #endif+      -- name2constructors :: Name -> Q [Con] -- name2constructors n = do@@ -48,13 +60,15 @@ infixl 9 @@ infixl 9 @@@ -+-- | A type constructor applied to some argument types data AppliedTyCon = AppliedTyCon {       atcHead :: Name     , atcArgs :: [Type]     }                   deriving (Eq,Ord,Show,Data,Typeable)                            +-- | Rewrite 'ListT','TupleT' and 'ArrowT' to ordinary 'ConT's+normaliseSpecialTyCons ::  (Data a) => a -> a normaliseSpecialTyCons = everywhere (mkT f)     where       f ListT = ConT (''[])@@ -84,6 +98,7 @@  -- | Get constructors with all type parameters instantiated as -- described by the 'AppliedTyCon' argument+atc2constructors ::  AppliedTyCon -> Q [Con] atc2constructors (AppliedTyCon n args) = do   i <- reify n   (params,cs) <- @@ -99,8 +114,9 @@                   ++"\nBut info for this name was: "++show i)    let+      substs :: [(Name,Type)]       substs = assert (length params == length args)-               (zip params args)+               (zip (fmap deKindSigify params) args)                       doSubsts x = foldr substInCon x substs       @@ -108,11 +124,13 @@   return (doSubsts <$> cs)    -+-- | Apply 'nameBase' to all the 'Name'-typed subvalues+cutNames ::  (Data a) => a -> a cutNames = everywhere (mkT cutName)     where       cutName = mkName . nameBase                 +pprintUnqual ::  (Ppr a, Data a) => a -> String pprintUnqual = pprint . cutNames  @@ -128,7 +146,22 @@   -- | 'Match' with normal body and no where clause+sMatch ::  Pat -> Exp -> Match sMatch p b = Match p (NormalB b) []  -- | 'Clause' with normal body and no where clause+sClause ::  [Pat] -> Exp -> Clause sClause ps b = Clause ps (NormalB b) []++cleanConstructorName :: [Char] -> [Char]+cleanConstructorName c =+ case c of+    ('(':_) | last c == ')' -> "TUPLE"++show (length c-1)+    "[]" -> "NIL"+    ":" -> "CONS"++    -- Better than nothing, I guess+    (':':c1) -> "INFIX_CTOR" ++ concatMap (\x -> "_" ++ (show . ord) x ) c1 ++    _ -> c+

@@ -10,23 +10,53 @@ import Generics.MultiRec import Generics.MultiRec.TH.Alt import Data.Tree+    +-- data HRPF r ix where+--     CaseTree :: CaseTree r -> HRPF r (Tree Int)+--     CaseForest :: CaseForest r -> HRPF r (Forest Int) +data family HRPF (phi :: (* -> *)) (r :: (* -> *)) ix :: *++class HasHRPF (phi :: * -> *) where+    to :: phi ix -> HRPF phi I0 ix -> ix+    from :: phi ix -> ix -> HRPF phi I0 ix++data instance HRPF TheFam r (Tree Int) =+    CaseNode Int (r (Forest Int))++data instance HRPF TheFam r (Forest Int) = +      CaseNil+    | CaseCons (r (Tree Int)) (r (Forest Int))++instance HasHRPF TheFam where+    to Tree_Int (CaseNode i (I0 f)) = Node i f+    to Forest_Int CaseNil = []+    to Forest_Int (CaseCons (I0 u) (I0 v)) = u:v++    from Tree_Int (Node i f) = CaseNode i (I0 f)+    from Forest_Int [] = CaseNil+    from Forest_Int (u:v) = CaseCons (I0 u) (I0 v)+                                               ++-- from :: TheFam ix -> ix -> HRPF I0 ix+-- from (Node i f) = CaseTree (CaseNode + 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-  )- )+-- $(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+-- type instance PF TheFam = ThePF

@@ -1,16 +1,16 @@ name:                multirec-alt-deriver-version:             0.1+version:             0.1.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 \"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 empty types corresponding to constructors are now also customizable+ - 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).+ - 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@@ -26,9 +26,11 @@  location: http://code.haskell.org/~daniels/multirec-alt-deriver  Library-    build-depends:       base >= 4 && < 5, template-haskell, syb, +    build-depends:       base >= 4 && < 5, template-haskell < 2.5, syb,                           multirec, th-expand-syns,                          containers, mtl     ghc-options:              exposed-modules:     Generics.MultiRec.TH.Alt-    other-modules:       THUtils, BalancedFold+                       , Generics.MultiRec.TH.Alt.DerivOptions+                       +    other-modules:       THUtils, BalancedFold, MonadRQ