th-sccs 0.0.0.20110310 → 0.0.0.20110723

raw patch · 3 files changed

+53/−38 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Language/Haskell/TH/SCCs.hs +45/−30
• th-sccs.cabal +7/−7

@@ -1,4 +1,4 @@-Copyright (c) 2010 The University of Kansas+Copyright (c) 2010 Nicolas Frisby All rights reserved.  Redistribution and use in source and binary forms, with or without modification,

@@ -1,7 +1,8 @@ module Language.Haskell.TH.SCCs   (binding_group, binding_groups,    scc, sccs,-   Dependencies(..), type_dependencies,+   Dependencies(..), type_dependencies, td_recur, td_descend,+   Named(..),    printQ   ) where @@ -15,26 +16,21 @@ import Data.Graph (stronglyConnComp, SCC(..))  -+-- | Helpful for debugging generated code+printQ :: Show a => Maybe String -> Q a -> Q [Dec] printQ s m = do  x <- m  runIO (maybe (return ()) putStr s >> print x) >> return []  --binding_group :: Name -> Q (Set Name)-binding_group = liftM binding_group' . scc--binding_groups :: [Name] -> Q [Set Name]-binding_groups ns = (filter relevant . map binding_group') `liftM` sccs ns-  where relevant bg = not (Set.null (Set.intersection (Set.fromList ns) bg))--binding_group' = either Set.singleton id-+-- | Computes the SCC that includes the declaration of the given name; @Left@+-- is a singly acyclic declaration, @Right@ is a mutually recursive group+-- (possibly of size one: singly recursion). scc :: Name -> Q (Either Name (Set Name)) scc n = (head . filter (either (==n) (Set.member n))) `liftM` sccs [n]-   ++-- | Computes all SCCs for the given names (including those it dominates) sccs :: [Name] -> Q [Either Name (Set Name)] sccs ns = do   let withK f k = (,) k `liftM` f k@@ -45,14 +41,27 @@                | otherwise = Map.union m `liftM` analyze fringe >>= loop           where fringe =                   Set.unions (Map.elems m) `Set.difference` Map.keysSet m-  names <- chaotic (type_dependencies <=< reify) (Set.fromList ns)+  names <- chaotic (fmap type_dependencies . reify) (Set.fromList ns)   let listify (AcyclicSCC v) = Left v       listify (CyclicSCC vs) = Right (Set.fromList vs)   return (map listify (stronglyConnComp [(n, n, Set.toList deps) |                                          (n, deps) <- Map.assocs names])) +-- | Wrapper for 'scc' that forgets the distinction between a single acyclic+-- SCC and a singly recursive SCC+binding_group :: Name -> Q (Set Name)+binding_group = liftM binding_group' . scc +-- | Wrapper for 'sccs' that forgets the distinction between a single acyclic+-- SCC and a singly recursive SCC+binding_groups :: [Name] -> Q [Set Name]+binding_groups ns = (filter relevant . map binding_group') `liftM` sccs ns+  where relevant bg = not (Set.null (Set.intersection (Set.fromList ns) bg)) +binding_group' = either Set.singleton id++-- | This is semantically murky: it's just the name of anything that+-- \"naturally\" /defines/ a name; error if it doesn't. class Named t where name_of :: t -> Name  instance Named Info where@@ -92,30 +101,36 @@   --- | Calculate the type declaration upon which this syntactic construct--- syntactically dependends.+-- | Calculate the type declarations upon which this construct syntactically+-- depends. The first argument tracks the bindings traversed; use 'td_descend'+-- to maintain it. class Dependencies t where-  type_dependencies' :: [Name] -> t -> Q (Set Name)+  type_dependencies' :: [Name] -> t -> Set Name -type_dependencies :: Dependencies t => t -> Q (Set Name)+type_dependencies :: Dependencies t => t -> Set Name type_dependencies = type_dependencies' []  +-- | Just a bit shorter than 'type_dependencies''+td_recur :: Dependencies t => [Name] -> t -> Set Name+td_recur ns = type_dependencies' ns -recur ns = type_dependencies' ns-recur' ns x = type_dependencies' (ns ++ [name_of x])+-- | Shorter than 'type_dependencies'' and also adds the name of the seconda+-- argument to the tracked bindings+td_descend :: (Named a, Dependencies t) => [Name] -> a -> t -> Set Name+td_descend ns x = type_dependencies' (ns ++ [name_of x])  instance Dependencies Info where   type_dependencies' ns i = case i of-    TyConI d -> recur' ns i d-    PrimTyConI n _ _ -> return Set.empty+    TyConI d -> td_descend ns i d+    PrimTyConI n _ _ -> Set.empty     _ -> error $ "This version of th-sccs only calculates mutually " ++                  "recursive groups for types; " ++ show (name_of i) ++                  " is not a type."  instance Dependencies Dec where   type_dependencies' ns d = case d of-    DataD _ _ _ cons _ -> Set.unions `liftM` mapM w cons+    DataD _ _ _ cons _ -> Set.unions (map w cons)     NewtypeD _ _ _ c _ -> w c     TySynD _ _ ty -> w ty     FamilyD {} ->@@ -123,7 +138,7 @@               "groups for types involving type families; " ++               show (last ns) ++ " uses " ++ show (name_of d) ++ "."     o -> error $ "Unexpected declaration: " ++ show o ++ "."-    where w x = recur' ns d x+    where w x = td_descend ns d x  instance Dependencies Con where   type_dependencies' ns c = case c of@@ -131,18 +146,18 @@     RecC _ vsts -> w $ map (\ (n, _, t) -> RecordField n t) vsts     InfixC stL _ stR -> w $ map snd [stL, stR]     ForallC _ _ c -> type_dependencies' ns c-    where w xs = Set.unions `liftM` mapM (recur' ns c) xs+    where w xs = Set.unions (map (td_descend ns c) xs)  data RecordField = RecordField Name Type instance Named RecordField where name_of (RecordField n _) = n instance Dependencies RecordField where-  type_dependencies' ns rf@(RecordField _ ty) = recur' ns rf ty+  type_dependencies' ns rf@(RecordField _ ty) = td_descend ns rf ty  instance Dependencies Type where   type_dependencies' ns t = case t of     ForallT _ _ t -> w t-    ConT n -> return (Set.singleton n)-    AppT tfn targ -> liftM2 Set.union (w tfn) (w targ)+    ConT n -> Set.singleton n+    AppT tfn targ -> Set.union (w tfn) (w targ)     SigT t _ -> w t-    _ -> return Set.empty-    where w x = recur ns x+    _ -> Set.empty+    where w x = td_recur ns x

@@ -1,5 +1,5 @@ Name:          th-sccs-Version:       0.0.0.20110310+Version:       0.0.0.20110723  Stability:     experimental @@ -13,10 +13,10 @@              constructor names that occur within a TH @Info@\/@Dec@\/@Type@              value. -Author:        nfrisby@ittc.ku.edu-Maintainer:    nfrisby@ittc.ku.edu+Author:        nicolas.frisby@gmail.com+Maintainer:    nicolas.frisby@gmail.com -Copyright:     (c) 2011 The University of Kansas+Copyright:     (c) 2011 Nicolas Frisby License:       BSD3 License-File:  LICENSE @@ -29,9 +29,9 @@   -source-repository head-  type: git-  location: git@gitsldg.ittc.ku.edu:th-kind-workaround/th-sccs.git+--source-repository head+--  type: git+--  location: git@gitsldg.ittc.ku.edu:th-kind-workaround/th-sccs.git  Library   Build-Depends: base >= 4 && < 5