multirec 0.7.6 → 0.7.7

raw patch · 4 files changed

+59/−10 lines, 4 filesdep +multirecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: multirec

API changes (from Hackage documentation)

Files

• examples/ASTExamples.hs +1/−0
• examples/All.hs +6/−1
• multirec.cabal +12/−2
• src/Generics/MultiRec/TH.hs +40/−7

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE LiberalTypeSynonyms  #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE GADTs                #-} 

@@ -1,5 +1,10 @@-module All where+module Main where  import GRose+import VarTypes+import J import SingleExamples import ASTExamples++main :: IO ()+main = return ()

@@ -1,5 +1,5 @@ name:                 multirec-version:              0.7.6+version:              0.7.7 license:              BSD3 license-file:         LICENSE author:               Alexey Rodriguez,@@ -37,7 +37,7 @@   stability:            experimental build-type:           Simple-cabal-version:        >= 1.6+cabal-version:        >= 1.10 tested-with:          GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 extra-source-files:   examples/All.hs                       examples/AST.hs@@ -80,5 +80,15 @@                       -- Extra                       Generics.MultiRec.TEq +  default-language:   Haskell2010+   build-depends:      base >= 3.0 && < 5,                       template-haskell >= 2.4 && < 2.12++test-suite examples+  type:               exitcode-stdio-1.0+  main-is:            All.hs+  hs-source-dirs:     examples+  default-language:   Haskell2010+  build-depends:      base >= 3.0 && < 5,+                      multirec

@@ -36,6 +36,8 @@ import Language.Haskell.TH hiding (Fixity()) import Control.Applicative import Control.Monad+import Data.Foldable (foldrM)+import Data.Maybe (fromJust)  -- | Given the name of the family index GADT, derive everything. deriveAll :: Name -> Q [Dec]@@ -44,6 +46,8 @@     info <- reify n     -- runIO (print info)     let ps  = init (extractParameters info)+    -- runIO (print $ ps)+    -- runIO (print $ extractConstructorNames ps info)     let nps = map (\ (n, ps) -> (remakeName n, ps)) (extractConstructorNames ps info)     let ns  = map fst nps     -- runIO (print nps)@@ -148,10 +152,13 @@ #endif   where     extractFrom :: Con -> [(Name, [Name])]-    extractFrom (ForallC _ eqs c) = map (\ (n, _) -> (n, concatMap extractEq eqs)) (extractFrom c)+    extractFrom (ForallC _ eqs c) = map (\ (n, ps) -> (n, ps ++ concatMap extractEq eqs)) (extractFrom c)     extractFrom (InfixC _ n _)    = [(n, [])]     extractFrom (RecC n _)        = [(n, [])]     extractFrom (NormalC n [])    = [(n, [])]+#if MIN_VERSION_template_haskell(2,11,0)+    extractFrom (GadtC ns _ t)    = map (\ n -> (n, extractType t)) ns+#endif     extractFrom _                 = []      extractEq :: Pred -> [Name]@@ -168,6 +175,22 @@     extractArgs (VarT n)          = [n]     extractArgs _                 = [] +    extractType :: Type -> [Name]+    extractType (AppT a1 a2) = combine (extractVars a1) (extractVars a2)+      where+        combine :: [Name] -> [Name] -> [Name]+        combine vs1 vs2 =+          let+            table = zip vs1 ps+          in+            map (fromJust . flip lookup table) vs2+    extractType _            = []++    extractVars :: Type -> [Name]+    extractVars (AppT t (VarT v)) = extractVars t ++ [v]+    extractVars (AppT t _)        = extractVars t+    extractVars _                 = []+ extractConstructorNames _  _                           = []  @@ -335,7 +358,9 @@     rename (VarT n)       | Just p <- lookup n ps          = varT p     rename t                           = return t-pfField ns ps t@(AppT f a)             = conT ''(:.:) `appT` return f `appT` pfField ns ps a+pfField ns ps t@(AppT f a)+  | TupleT n : ts <- unApp t           = foldrM (\ s t -> conT ''(:*:) `appT` pfField ns ps s `appT` return t) (ConT ''U) ts+  | otherwise                          = conT ''(:.:) `appT` return f `appT` pfField ns ps a pfField ns ps t@(VarT n)   | Just p <- lookup n ps              = {- runIO (print (ps, n)) >> -} conT ''K `appT` varT p pfField ns ps t                        = conT ''K `appT` return t@@ -440,7 +465,11 @@ fromFieldFun ns t   | ConT n : a <- unApp t, remakeName n `elem` ns                              = [| I . I0 |]-fromFieldFun ns t@(AppT f a) = [| D . fmap $(fromFieldFun ns a) |]+fromFieldFun ns t@(AppT f a)+  | TupleT n : ts <- unApp t = mapM (newName . ("x" ++) . show) [1..n] >>= \ vs ->+                               lam1E (tupP (varP <$> vs)) $+                               foldrM (\ (v, t) x -> conE '(:*:) `appE` (fromFieldFun ns t `appE` varE v) `appE` return x) (ConE 'U) (zip vs ts)+  | otherwise                = [| D . fmap $(fromFieldFun ns a) |] fromFieldFun ns t            = [| K |]  toField :: [Name] -> Int -> Type -> Q Exp@@ -448,12 +477,16 @@  toFieldFun :: [Name] -> Type -> Q Exp toFieldFun ns t@(ConT n)-  | remakeName n `elem` ns = [| unI0 . unI |]+  | remakeName n `elem` ns   = [| unI0 . unI |] toFieldFun ns t   | ConT n : a <- unApp t, remakeName n `elem` ns-                           = [| unI0 . unI |]-toFieldFun ns t@(AppT f a) = [| fmap $(toFieldFun ns a) . unD |]-toFieldFun ns t            = [| unK |]+                             = [| unI0 . unI |]+toFieldFun ns t@(AppT f a)+  | TupleT n : ts <- unApp t = mapM (newName . ("x" ++) . show) [1..n] >>= \ vs ->+                               lam1E (foldr (\ v p -> conP '(:*:) [varP v, p]) (conP 'U []) vs) $+                               tupE (zipWith (\ v t -> toFieldFun ns t `appE` varE v) vs ts)+  | otherwise                = [| fmap $(toFieldFun ns a) . unD |]+toFieldFun ns t              = [| unK |]  field :: Int -> Name field n = mkName $ "f" ++ show n