type-tree 0.1.0.1 → 0.2.0.0
raw patch · 7 files changed
+299/−471 lines, 7 filesdep +zencdep −Cabaldep ~basedep ~base-compat
Dependencies added: zenc
Dependencies removed: Cabal
Dependency ranges changed: base, base-compat
Files
- ChangeLog.md +12/−2
- src/Language/Haskell/TypeTree.hs +194/−395
- src/Language/Haskell/TypeTree/CheatingLift.hs +33/−6
- src/Language/Haskell/TypeTree/Datatype.hs +12/−35
- src/Language/Haskell/TypeTree/ExampleDatatypes.hs +21/−0
- src/Language/Haskell/TypeTree/Leaf.hs +21/−28
- type-tree.cabal +6/−5
ChangeLog.md view
@@ -1,5 +1,15 @@ # Revision history for type-tree -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0 -- 2018-04-07 -* First version. Released on an unsuspecting world.+* Moved from Tree to Forest representation of types+* Type variable resolution has been removed as it's unneeded+* Cycle detection is now a lot more straightforward++## 0.1.0.1 -- 2018-03-29++* Fixing a minor documentation typo++## 0.1.0.0 -- 2018-03-27++* Initial release
src/Language/Haskell/TypeTree.hs view
@@ -1,450 +1,249 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-}-{-# Language CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-} +#if !MIN_VERSION_containers(0,5,9)+{-# LANGUAGE StandaloneDeriving #-}+#endif++#if !MIN_VERSION_containers(0,5,9)+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif++#if MIN_VERSION_template_haskell(2,11,0)+#define _KIND _+#else+#define _KIND+#endif+ module Language.Haskell.TypeTree ( -- ** GHCi setup -- $setup -- * Usage -- $usage+ ReifyOpts(..)+ , defaultOpts - -- * Reify input- IsDatatype(..)- , Binding(..)- , guess- -- * Producing trees- , ttReify+ -- * Building trees , ttReifyOpts- , ttLit+ , ttReify+ , ttLitOpts- -- ** Debugging trees- , ttDescribe+ , ttLit+ , ttDescribeOpts- -- ** Building graphs- , Key- , Arity- , ttEdges+ , ttDescribe++ -- * Graph utilities+ , ttConnCompOpts , ttConnComp- -- * Customizing trees++ -- * Datatypes , Leaf(..)- , ReifyOpts(..)- , defaultOpts+ , IsDatatype(..) ) where -import Control.Monad-import Control.Monad.Reader+import Control.Monad.Compat+import Data.Char import Data.Graph-import Data.List-import Data.Map (Map)+import Data.List.Compat import qualified Data.Map as M-import Data.Maybe import qualified Data.Set as S import Data.Tree-import Language.Haskell.TH hiding (Arity)-import Language.Haskell.TH.PprLib-import Language.Haskell.TH.Syntax hiding (Arity, lift)-import qualified Language.Haskell.TH.Syntax as TH-import Language.Haskell.TypeTree.CheatingLift+import Language.Haskell.TH hiding (prim)+import Language.Haskell.TH.Syntax import Language.Haskell.TypeTree.Datatype import Language.Haskell.TypeTree.Leaf import Prelude.Compat-import qualified Text.PrettyPrint as HPJ -data ReifyOpts = ReifyOpts- { expandPrim :: Bool -- ^ Descend into primitive type constructors?- , terminals :: S.Set Name -- ^ If a name in this set is encountered, stop descending.- } deriving (Show, Eq)---- | Default reify options.------ @--- defaultOpts = "ReifyOpts"--- { expandPrim = False--- , terminals = mempty--- }--- @-defaultOpts :: ReifyOpts-defaultOpts = ReifyOpts {expandPrim = False, terminals = mempty}---- | Produces a string literal representing a type tree. Useful for--- debugging purposes.-ttDescribe :: IsDatatype t => t -> ExpQ-ttDescribe = ttDescribeOpts defaultOpts---- | 'ttDescribe' with the given options.-ttDescribeOpts :: IsDatatype t => ReifyOpts -> t -> ExpQ-ttDescribeOpts o n = do- tree <- ttReifyOpts o n- stringE $- HPJ.renderStyle- HPJ.Style- {HPJ.mode = HPJ.LeftMode, HPJ.lineLength = 0, HPJ.ribbonsPerLine = 5} $- to_HPJ_Doc $ treeDoc tree---- | Embed the produced tree as an expression.-ttLit :: IsDatatype t => t -> ExpQ-ttLit = liftTree <=< ttReify---- | Some type and its arguments, as representable in a graph.-type Key = (Name, [Type])---- | Type constructor arity.-type Arity = Int---- | @$(ttEdges ''Foo) :: [(('Name', 'Arity'), 'Key', ['Key'])]@------ @$(ttEdges ''Foo)@ produces a list suitable for passing to 'graphFromEdges'.-ttEdges :: IsDatatype t => t -> ExpQ-ttEdges name = do- tr <- ttReify name- sigE (listE $ map lift_ $ node tr) [t|[((Name, Arity), Key, [Key])]|]- where- lift_ ((x, n), y, zs) = [|(($(liftName x), n), $(tup y), $(listE $ map tup zs))|]- tup (n, t) = [|($(liftName n), $(listE $ map liftType t))|]---- | @$(ttConnComp ''Foo) :: ['SCC' ('Name', 'Arity')]@------ @$(ttConnComp ''Foo)@ produces a topologically sorted list--- of the strongly connected components of the graph representing @Foo@.-ttConnComp :: IsDatatype t => t -> ExpQ-ttConnComp name = [|stronglyConnComp $(ttEdges name)|]--node :: Tree Leaf -> [((Name, Arity), Key, [Key])]-node = nubBy (\(x, _, _) (y, _, _) -> x == y) . go- where- go (Node ty xs) =- (second length $ unCon ty, unCon ty, map (unCon . rootLabel) xs) : concatMap go xs- second f (a, b) = (a, f b)--unCon :: Leaf -> (Name, [Type])-unCon (TypeL (x, y)) = (unBinding x, y)-unCon (Recursive r) = unCon r---- | 'ttLit' with provided opts.-ttLitOpts :: IsDatatype t => ReifyOpts -> t -> ExpQ-ttLitOpts opts = liftTree <=< ttReifyOpts opts--liftTree :: Lift t => Tree t -> ExpQ-liftTree (Node n xs) = [|Node $(TH.lift n) $(listE $ map liftTree xs)|]--data ReifyEnv = ReifyEnv- { typeEnv :: Map Name Type- , nodes :: S.Set (Binding, [Type])- } deriving (Show)---- | Build a "type tree" of the given datatype.------ Occurrences of a given node after the first will be wrapped in--- 'Recursive' and have no children.-ttReify :: IsDatatype t => t -> Q (Tree Leaf)-ttReify = ttReifyOpts defaultOpts---- | 'ttReify' with the provided options.-ttReifyOpts :: IsDatatype t => ReifyOpts -> t -> Q (Tree Leaf)-ttReifyOpts opts t = do- (a, b) <- asDatatype t- fromJust <$> runReaderT (go a b) (ReifyEnv mempty mempty)- where- go n args = do- go' n args- go' v@(Unbound n) gargs- | n `S.member` terminals opts = pure $ Just (Node (TypeL (v, gargs)) [])- | otherwise =- withVisit v gargs $ \givenArgs ->- Just . Node (TypeL (Unbound n, givenArgs)) <$>- mapMaybeM (uncurry resolve . unwrap) givenArgs- go' v@(Bound n) gargs- | n `S.member` terminals opts = pure $ Just (Node (TypeL (v, gargs)) [])- | otherwise =- withVisit v gargs $ \givenArgs -> do- dec <- lift $ reify n- case dec of- PrimTyConI n' _ _- | expandPrim opts || n' == ''(->) ->- Just . Node (TypeL (v, givenArgs)) <$>- mapMaybeM (uncurry resolve . unwrap) givenArgs- | otherwise -> pure Nothing- TyConI x -> processDec x n givenArgs- FamilyI _ insts ->- case findMatchingInstance givenArgs insts of- Just dec -> processDec dec n givenArgs- Nothing ->- fail $- "sorry, I cannot find a data/type instance " ++- "in scope which matches: " ++- show (treeDoc (Node (TypeL (v, givenArgs)) []))- DataConI {} -> badInput "a data constructor"- ClassOpI {} -> badInput "a class method"- ClassI {} -> badInput "a class name"-#if MIN_VERSION_template_haskell(2,12,0)- PatSynI {} -> badInput "a pattern synonym"+#if !MIN_VERSION_containers(0,5,9)+deriving instance Show a => Show (SCC a) #endif- TyVarI {} ->- badInput "an unbound type variable (how did you get here?)"- VarI {} -> badInput "an ordinary value"- badInput s = fail $ "ttReify expects a type constructor, but was given " ++ s- processDec x n givenArgs = do- let (_, wantedArgs) = decodeHead givenArgs x- cons <- decodeBody x- withReaderT (\m -> foldr instantiate m $ zip wantedArgs givenArgs) $- -- invariant: constructor fields (obviously) must be of- -- kind *. if the type isn't fully applied, generate some- -- placeholders and recurse. this happens when you pass in- -- type function at top level (like ttReify ''Maybe)- do- if length givenArgs < length wantedArgs- then do- vars <-- lift $ sequence (fillVar <$> drop (length givenArgs) wantedArgs)- go (Bound n) (givenArgs ++ vars)- else Just . Node (TypeL (Bound n, givenArgs)) <$>- mapMaybeM (uncurry resolve) cons- mapMaybeM m xs = catMaybes <$> mapM m xs- fillVar (VarT n) = VarT <$> newName (nameBase n)- fillVar x = pure x- simplify r@ReifyEnv {typeEnv = te} (VarT n) =- case M.lookup n te of- Just ty -> simplify r ty- Nothing -> VarT n- simplify _ x@ConT {} = x- simplify r (AppT x y) = AppT (simplify r x) (simplify r y)- simplify _ x@TupleT {} = x- simplify _ x@UnboxedTupleT {} = x- simplify _ ListT = ListT- simplify _ ArrowT = ArrowT- simplify r (SigT t k) = SigT (simplify r t) k- simplify _ x = error $ show x- decodeHead _ (DataInstD _ n tys _ _ _) = (n, tys)- decodeHead _ (DataD _ n holes _ cons _)- | any isGadtCon cons = (n, [])- | otherwise = (n, map unTV holes)- decodeHead _ (NewtypeD _ n holes _ _ _) = (n, map unTV holes)- decodeHead _ (TySynD n holes _) = (n, map unTV holes)- decodeHead _ (TySynInstD n (TySynEqn holes _)) = (n, holes)- decodeHead _ x = error $ "decodeHead " ++ show x- decodeBody (DataD _ decName _ _ cons _) = concat <$> mapM (getFieldTypes decName) cons- decodeBody (DataInstD _ decName _ _ cons _) =- concat <$> mapM (getFieldTypes decName) cons- decodeBody (NewtypeD _ decName _ _ con _) = getFieldTypes decName con- decodeBody (TySynD _ _ ty) = pure [unwrap ty]- decodeBody (TySynInstD _ (TySynEqn _ ty)) = pure [unwrap ty]- decodeBody x = error $ "decodeBody " ++ show x- findMatchingInstance typeArgs (d@(DataInstD _ _ tys _ _ _):ds)- | matchesTypeInstance typeArgs tys = Just d- | otherwise = findMatchingInstance typeArgs ds- findMatchingInstance typeArgs (d@(TySynInstD _ (TySynEqn lhs _)):ds)- | matchesTypeInstance typeArgs lhs = Just d- | otherwise = findMatchingInstance typeArgs ds- findMatchingInstance _ [] = Nothing- findMatchingInstance _ _ =- error "FamilyI contained a Dec of the wrong type, this shouldn't happen"- getFieldTypes _ (NormalC _ xs) = pure $ map (\(_, y) -> unwrap y) xs- getFieldTypes _ (RecC _ xs) = pure $ map (\(_, _, y) -> unwrap y) xs- getFieldTypes _ (InfixC (_, a) nm (_, b))- | nameBase nm == ":" = pure [unwrap a]- | otherwise = pure [unwrap a, unwrap b]- getFieldTypes decName (GadtC _ fs ret) =- case unwrap ret of- (retN, retTys)- | retN == Bound decName ->- pure $ map (\(_, y) -> unwrap y) fs ++ map unwrap retTys- | otherwise ->- fail $- "sorry, GADT constructor return type must exactly " ++- "match datatype (this is a limitation in type-tree)"- getFieldTypes decName (ForallC _ _ cn) = getFieldTypes decName cn- getFieldTypes _ x = error $ show x- isGadtCon GadtC {} = True- isGadtCon RecGadtC {} = True- isGadtCon (ForallC _ _ c) = isGadtCon c- isGadtCon _ = False- unTV (KindedTV n _) = VarT n- unTV (PlainTV n) = VarT n- instantiate (VarT x, y) r@ReifyEnv {typeEnv = t} = r {typeEnv = M.insert x y t}- instantiate (AppT a b, AppT c d) r = instantiate (a, c) (instantiate (b, d) r)- instantiate _ r = r- withVisit a b m = do- r@ReifyEnv {nodes = nodes'} <- ask- let b' = map (simplify r) b- a' =- case simplify- r- (case a of- Bound x -> ConT x- Unbound x -> VarT x) of- ConT n -> Bound n- VarT n -> Unbound n- _ -> undefined- if S.member (a', b') nodes'- then pure $ Just $ Node (Recursive $ TypeL (a', b')) []- else withReaderT (\q -> q {nodes = S.insert (a', b') (nodes q)}) $ m b'- resolve (Bound x) args = go (Bound x) args- resolve (Unbound x) args = go' x args []- where- go' x' args' xs = do- m <- asks typeEnv- case M.lookup x' m of- Just (VarT y)- | elem y xs ->- pure $ Just $ Node (Recursive $ TypeL (Unbound x', args')) []- | otherwise -> go' y args' (y : xs)- Just (unwrap -> (h, args'')) -> go h (args'' ++ args')- Nothing -> go (Unbound x') args' -matchesTypeInstance [] [] = True-matchesTypeInstance xs (VarT _:ys) = matchesTypeInstance (drop 1 xs) ys-matchesTypeInstance (ConT x:xs) (ConT y:ys)- | x == y = matchesTypeInstance xs ys- | otherwise = False-matchesTypeInstance (AppT a b:xs) (AppT c d:ys) =- matchesTypeInstance [a] [c] &&- matchesTypeInstance [b] [d] && matchesTypeInstance xs ys-matchesTypeInstance (x:xs) (y:ys) = x == y && matchesTypeInstance xs ys-matchesTypeInstance _ _ = False {- $setup-->>> :set -XTemplateHaskell -XTypeFamilies -XGADTs-+>>> :set -XTemplateHaskell -XGADTs -XTypeFamilies -} {- $usage -== Basic usage--'ttReify' allows you to build a 'Tree' containing type information for-each field of any given datatype, which can then be examined if you want-to, for example, generate class instances for a deeply nested datatype.-(The idea for this package came about when I was trying to figure out the easiest-way to generate several dozen instances for Cabal's @GenericPackageDescription@.)+@type-tree@ provides a way to build tree structures from datatypes. -=== Plain constructors+== Basic usage ->>> data Foo a = Foo { field1 :: Either a Int }+>>> data Foo a = Foo { field1 :: a, field2 :: Either String Int } >>> putStr $(ttDescribe ''Foo)-Ghci4.Foo a_0+Foo :: * -> * |-`- Data.Either.Either a_0 GHC.Types.Int- |- +- $a_0- |- `- GHC.Types.Int--=== Passing type arguments++- Either :: * -> * -> *+|++- [] :: * -> *+| |+| `- ...[] :: * -> *+|++- Char :: *+|+`- Int :: * -@ttReify@ and friends accept any value with an 'IsDatatype' instance.+'ttReify' passes through type synonyms by default: ->>> putStr $(ttDescribe [t|Maybe Int|])-GHC.Base.Maybe GHC.Types.Int+>>> putStr $(ttDescribe ''FilePath) -- FilePath --> String --> [Char]+[] :: * -> * |-`- GHC.Types.Int+`- ...[] :: * -> *+<BLANKLINE>+Char :: * -=== GADTs+but this behavior can be disabled: ->>> data MyGADT a where Con1 :: String -> MyGADT String; Con2 :: Int -> MyGADT [Int]->>> putStr $(ttDescribe ''MyGADT)-Ghci10.MyGADT-|-+- GHC.Base.String-| |-| `- GHC.Types.[] GHC.Types.Char-| |-| `- GHC.Types.Char-|-+- GHC.Base.String-| |-| `- GHC.Types.[] GHC.Types.Char-| |-| `- GHC.Types.Char-|-+- GHC.Types.Int+>>> putStr $(ttDescribeOpts defaultOpts { synonyms = True } ''FilePath)+FilePath :: * |-`- GHC.Types.[] GHC.Types.Int+`- String :: * |- `- GHC.Types.Int+ +- [] :: * -> *+ | |+ | `- ...[] :: * -> *+ |+ `- Char :: *+-} -When reifying GADTs, constructors' return types are treated as another-field.+-- | 'ttDescribeOpts' with default options.+ttDescribe :: IsDatatype a => a -> ExpQ+ttDescribe = ttDescribeOpts defaultOpts -=== Data/type family instances+-- | Produce a string representation of the forest generated by+-- @$(ttReifyOpts opts ''SomeName)@. Useful for debugging purposes.+ttDescribeOpts :: IsDatatype a => ReifyOpts -> a -> ExpQ+ttDescribeOpts o x = do+ ts <- ttReifyOpts o x+ stringE $ reverse $ dropWhile isSpace $ reverse $ drawForest $ map (fmap show) ts ->>> class Foo a where data Bar a :: * -> *->>> instance Foo Int where data Bar Int a = IntBar { bar :: Maybe (Int, a) }->>> putStr $(ttDescribe [t|Bar Int|])-Ghci14.Bar GHC.Types.Int a_0-|-`- GHC.Base.Maybe (GHC.Types.Int, a_0)- |- `- GHC.Tuple.(,) GHC.Types.Int a_0- |- +- GHC.Types.Int- |- `- $a_0+-- | 'ttLitOpts' with default options.+ttLit :: IsDatatype a => a -> ExpQ+ttLit = ttLitOpts defaultOpts ->>> :module +GHC.Exts->>> putStr $(ttDescribe [t|Item [Int]|])-GHC.Exts.Item ([GHC.Types.Int])-|-`- GHC.Types.Int+-- | Embed the produced 'Forest' as an expression.+ttLitOpts :: IsDatatype a => ReifyOpts -> a -> ExpQ+ttLitOpts o n = do+ tr <- ttReifyOpts o n+ [|$(listE (map liftTree tr)) :: Forest Leaf|]+ where+ liftTree (Node n ns) = [|Node $(lift n) $(listE $ map liftTree ns)|] -=== Recursive datatypes+-- | 'ttConnCompOpts' with default opts+ttConnComp :: IsDatatype a => a -> ExpQ+ttConnComp = ttConnCompOpts defaultOpts ->>> data Foo a = Foo { a :: Either Int (Bar a) }; data Bar b = Bar { b :: Either (Foo b) Int }->>> putStr $(ttDescribe ''Foo)-Ghci23.Foo a_0-|-`- Data.Either.Either GHC.Types.Int (Ghci23.Bar a_0)- |- +- GHC.Types.Int- |- `- Ghci23.Bar a_0- |- `- Data.Either.Either (Ghci23.Foo a_0) GHC.Types.Int- |- +- <recursive Ghci23.Foo a_0>- |- `- GHC.Types.Int+-- | 'ttConnCompOpts' is useful for the usecase which I had in mind when+-- I originally wrote this package, namely:+--+-- /Given some datatype, I need a topologically sorted list of all types contained in that datatype for which an instance of some class must be defined if I wish to define an instance for that datatype (and likewise for each subtype, etc.)/+--+-- Here's an example using 'Language.Haskell.TypeTree.ExampleDatatypes.CondTree',+-- which is a useful datatype for an example, as it's both mutually recursive+-- and refers to other recursive types.+--+-- >>> :m +Language.Haskell.TypeTree.ExampleDatatypes+-- >>> mapM_ print $(ttConnComp ''CondTree)+-- AcyclicSCC ([] :: * -> *,[])+-- AcyclicSCC (Bool :: *,[])+-- AcyclicSCC (Condition :: * -> *,[Bool :: *])+-- AcyclicSCC (Maybe :: * -> *,[])+-- CyclicSCC [(CondBranch :: * -> * -> * -> *,[Condition :: * -> *,CondTree :: * -> * -> * -> *,Maybe :: * -> *]),(CondTree :: * -> * -> * -> *,[[] :: * -> *,CondBranch :: * -> * -> * -> *])]+ttConnCompOpts :: IsDatatype a => ReifyOpts -> a -> ExpQ+ttConnCompOpts o name = do+ trs <- ttReifyOpts o name+ [|map (fmap (\(a, _, c) -> (a, nub c))) $+ stronglyConnCompR+ $(lift $ nubBy (\(x, _, _) (y, _, _) -> x == y) $ concatMap go trs)|]+ where+ go (Node ty xs) =+ (unRec ty, unRec ty, filter (/= unRec ty) $ map (unRec . rootLabel) xs) :+ concatMap go xs -== Passing options+data ReifyOpts = ReifyOpts+ { stop :: S.Set Name+ -- ^ If a name in this set is encountered, stop recursing.+ , prim :: Bool+ -- ^ Expand primitive type constructors (i.e. 'Int' → 'GHC.Prim.Int#')?+ , synonyms :: Bool+ -- ^ If 'True', type synonyms are present in the resulting 'Forest';+ -- if 'False', a synonym will be expanded and its RHS will appear in+ -- the out-list instead.+ } -If needed, @type-tree@ allows you to specify that primitive type constructors-should be included in its output.+-- |+-- @+-- defaultOpts = ReifyOpts+-- { stop = S.fromList []+-- , prim = False+-- , synonyms = False+-- }+-- @+defaultOpts :: ReifyOpts+defaultOpts = ReifyOpts mempty False False ->>> data Baz = Baz { field :: [Int] }->>> putStr $(ttDescribeOpts defaultOpts { expandPrim = True } ''Baz)-Ghci27.Baz-|-`- GHC.Types.[] GHC.Types.Int- |- `- GHC.Types.Int- |- `- GHC.Prim.Int#+-- | 'ttReifyOpts' with default options.+ttReify :: IsDatatype a => a -> Q (Forest Leaf)+ttReify = ttReifyOpts defaultOpts -Note that the function arrow @(->)@, despite being a primitive type constructor,-will always be included even with @'expandPrim' = False@, as otherwise you-would never be able to get useful information out of a field with a function type.+-- | Build a 'Forest' of constructor names contained in the given type.+ttReifyOpts :: IsDatatype a => ReifyOpts -> a -> Q (Forest Leaf)+ttReifyOpts args n' = fmap concat . mapM (go mempty) =<< asDatatype n'+ where+ go xs ty+ | ty `S.member` stop args = do+ m <- getArity ty+ pure [Node (TypeL ty m) []]+ | Just r <- M.lookup ty xs = pure [Node (Recursive r) []]+ | otherwise = do+ x <- reify ty+ case x of+ TyConI dec -> do+ let cons = decode dec+ n = TypeL ty (arity dec)+ children <- concat <$> mapM (go (M.insert ty n xs)) cons+ if isTySyn dec && not (synonyms args)+ then pure children+ else pure [Node n children]+ PrimTyConI n arr _+ | prim args -> pure [Node (TypeL n arr) []]+ | otherwise -> pure []+ ClassOpI {} -> fail "can't reify a class method"+ ClassI {} -> fail "can't reify a typeclass"+ DataConI {} -> fail "can't reify a data constructor"+ VarI {} -> fail "can't reify an ordinary function/variable"+ FamilyI {} -> fail "sorry, data/type instances are currently unsupported"+ x -> error $ show x+ where+ isTySyn TySynD {} = True+ isTySyn _ = False -You can also specify a set of names where @type-tree@ should stop descending, if,-for example, you have no desire to see @String -> [] -> Char@ ad nauseam in-your tree.+getArity n = do+ x <- reify n+ case x of+ TyConI dec -> pure (arity dec)+ PrimTyConI _ n _ -> pure n+ _ -> undefined ->>> data Bar = Bar (Either String [String])->>> putStr $(ttDescribeOpts defaultOpts { terminals = S.fromList [''String] } ''Bar)-Ghci31.Bar-|-`- Data.Either.Either GHC.Base.String ([GHC.Base.String])- |- +- GHC.Base.String- |- `- GHC.Types.[] GHC.Base.String- |- `- GHC.Base.String+arity (DataD _ _ xs _KIND _ _) = length xs+arity (NewtypeD _ _ xs _KIND _ _) = length xs+arity (TySynD _ xs _) = length xs+arity x = error $ show x --}+decode (DataD _ _ _ _KIND cons _) = concatMap decodeCon cons+decode (NewtypeD _ _ _ _KIND con _) = decodeCon con+decode (TySynD _ _ x) = getTypes x+decode x = error $ show x++decodeCon (NormalC _ fs) = concatMap (\(_, b) -> getTypes b) fs+decodeCon (RecC _ fs) = concatMap (\(_, _, b) -> getTypes b) fs+decodeCon (InfixC (_, f1) _ (_, f2)) = getTypes f1 ++ getTypes f2+#if MIN_VERSION_template_haskell(2,11,0)+decodeCon (GadtC _ cons ty) = concatMap (\(_, b) -> getTypes b) cons ++ getTypes ty+decodeCon (RecGadtC _ cons ty) = concatMap (\(_, _, b) -> getTypes b) cons ++ getTypes ty+#endif+decodeCon (ForallC _ _ c) = decodeCon c
src/Language/Haskell/TypeTree/CheatingLift.hs view
@@ -1,4 +1,6 @@-{-# Language TemplateHaskell #-}+{-# Language MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {- - using TH to make a cheating version of `lift` for Name@@ -14,7 +16,17 @@ import Language.Haskell.TH.Syntax import Prelude.Compat -$(do TyConI (DataD _ _ _ _ [NormalC x _] _) <- reify ''Name+#if !MIN_VERSION_template_haskell(2,10,0)+import GHC.Exts+#endif++#if MIN_VERSION_template_haskell(2,11,0)+#define _KIND _+#else+#define _KIND+#endif++$(do TyConI (DataD _ _ _ _KIND [NormalC x _] _) <- reify ''Name arg1 <- newName "arg" arg2 <- newName "arg" sequence@@ -25,7 +37,7 @@ [conP x [varP arg1, varP arg2]] (normalB [|appsE- [ conE $(liftData x)+ [ conE (mkName "Name") , $(appE (varE $ mkName "liftOcc") (varE arg1)) , $(appE (varE $ mkName "liftFlv") (varE arg2)) ]|])@@ -39,7 +51,22 @@ liftFlv :: NameFlavour -> ExpQ liftFlv NameS = [|NameS|] liftFlv (NameG x (PkgName s) (ModName y)) =- [|NameG $(liftData x) (PkgName $(stringE s)) (ModName $(stringE y))|]+ [|NameG $(liftNS x) (PkgName $(stringE s)) (ModName $(stringE y))|] liftFlv (NameQ (ModName x)) = [|NameQ (ModName $(stringE x))|]-liftFlv (NameU i) = [|NameU i|]-liftFlv (NameL i) = [|NameL i|]+liftFlv (NameU i) = [|NameU $(litE $ intPrimL i')|]+ where+ i' = intPrimToInt i+liftFlv (NameL i) = [|NameL $(litE $ intPrimL i')|]+ where+ i' = intPrimToInt i++#if MIN_VERSION_template_haskell(2,10,0)+intPrimToInt = fromIntegral+#else+-- GHC <7.10 doesn't have kind-polymorphic `lift'+intPrimToInt i = fromIntegral (I# i)+#endif++liftNS VarName = [|VarName|]+liftNS DataName = [|DataName|]+liftNS TcClsName = [|TcClsName|]
src/Language/Haskell/TypeTree/Datatype.hs view
@@ -5,47 +5,24 @@ module Language.Haskell.TypeTree.Datatype where -import Data.Data-import Data.Maybe import Language.Haskell.TH import Prelude.Compat --- | More ergonomic representation of bound and unbound names of things.-data Binding- = Bound { unBinding :: Name }- -- ^ We know this name refers to a specific thing (i.e. it's- -- a constructor)- | Unbound { unBinding :: Name }- -- ^ We don't know what this is (i.e. a type variable)- deriving (Show, Ord, Eq, Data)- class IsDatatype a where- -- | Produce binding info and a list of type arguments- asDatatype :: a -> Q (Binding, [Type])+ -- | Produce a list of constructor names+ asDatatype :: a -> Q [Name] instance IsDatatype Name where- asDatatype n = pure (guess n, [])+ asDatatype = return . return instance IsDatatype TypeQ where- asDatatype = fmap unwrap--unwrap :: Type -> (Binding, [Type])-unwrap = go- where- go (ConT x) = (Bound x, [])- go (VarT y) = (Unbound y, [])- go (ForallT _ _ x) = go x- go (AppT x y) =- let (hd, args) = go x- in (hd, args ++ [y])- go ListT = (Bound ''[], [])- go ArrowT = (Bound ''(->), [])- go (TupleT n) = (Bound (tupleTypeName n), [])- go (UnboxedTupleT n) = (Bound (unboxedTupleTypeName n), [])- go (SigT t _k) = go t- go z = error $ show z+ asDatatype = fmap getTypes --- | Convenience function.-guess n- | isNothing (nameSpace n) = Unbound n- | otherwise = Bound n+getTypes (ConT x) = [x]+getTypes (VarT _) = []+getTypes ListT = [''[]]+getTypes ArrowT = [''(->)]+getTypes (TupleT n) = [tupleTypeName n]+getTypes (UnboxedTupleT n) = [unboxedTupleTypeName n]+getTypes (AppT x y) = getTypes x ++ getTypes y+getTypes x = error $ show x
+ src/Language/Haskell/TypeTree/ExampleDatatypes.hs view
@@ -0,0 +1,21 @@+module Language.Haskell.TypeTree.ExampleDatatypes where++import Prelude++data CondTree v c a = CondNode+ { condTreeData :: a+ , condTreeConstraints :: c+ , condTreeComponents :: [CondBranch v c a]+ }++data CondBranch v c a = CondBranch+ { condBranchCondition :: Condition v+ , condBranchIfTrue :: CondTree v c a+ , condBranchIfFalse :: Maybe (CondTree v c a)+ }++data Condition c+ = Var c+ | Lit Bool+ | CAnd (Condition c)+ (Condition c)
src/Language/Haskell/TypeTree/Leaf.hs view
@@ -4,14 +4,11 @@ module Language.Haskell.TypeTree.Leaf where import Data.Data-import Data.Tree+import Data.List.Compat import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Language.Haskell.TypeTree.CheatingLift-import Language.Haskell.TypeTree.Datatype-import Prelude.Compat hiding ((<>))+import Prelude.Compat liftType :: Type -> ExpQ liftType (VarT x) = [|VarT $(liftName x)|]@@ -23,31 +20,27 @@ liftType (UnboxedTupleT n) = [|UnboxedTupleT n|] liftType x = error $ show x -liftBinding (Bound n) = [|Bound $(liftName n)|]-liftBinding (Unbound n) = [|Unbound $(liftName n)|]- data Leaf- = TypeL (Binding, [Type])- -- ^ @TypeL (name, xs)@ is a field with type @name@ applied to types @xs@.+ = TypeL Name+ Arity+ -- ^ @TypeL name arr@ represents the type constructor @name@, which has+ -- arity @arr@. | Recursive Leaf -- ^ Recursive field.- deriving (Eq, Data, Ord, Show)+ deriving (Eq, Data, Ord, Typeable) +leafName (TypeL n _) = n+leafName (Recursive l) = leafName l++instance Show Leaf where+ showsPrec p (TypeL n rs) =+ showParen (p > 10) $+ showString (nameBase n) .+ showString " :: " . showString (intercalate " -> " (replicate (rs + 1) "*"))+ showsPrec p (Recursive r) = showString "..." . showsPrec p r++unRec (Recursive t) = unRec t+unRec x = x+ instance Lift Leaf where- lift (TypeL (n, x)) = [|TypeL ($(liftBinding n), $(listE $ map liftType x))|]+ lift (TypeL n x) = [|TypeL $(liftName n) x|] lift (Recursive r) = [|Recursive $(lift r)|]--treeDoc :: Tree Leaf -> Doc-treeDoc = vcat . go- where- go (Node x ts0) = leafDoc x : drawSubtrees ts0- leafDoc (TypeL (n, [a,b]))- | unBinding n == ''(->) = pprParendType a <+> text "->" <+> pprParendType b- leafDoc (TypeL (n, x)) = pprBind n <+> hsep (map pprParendType x)- leafDoc (Recursive x) = text "<" <> text "recursive" <+> leafDoc x <> text ">"- drawSubtrees [] = mempty- drawSubtrees [t] = char '|' : shift (text "`- ") (text " ") (go t)- drawSubtrees (t:ts) =- char '|' : shift (text "+- ") (text "| ") (go t) ++ drawSubtrees ts- shift first other = zipWith (<>) (first : repeat other)- pprBind (Bound n) = pprName n- pprBind (Unbound n) = text "$" <> pprName n
type-tree.cabal view
@@ -1,5 +1,5 @@ name: type-tree-version: 0.1.0.1+version: 0.2.0.0 synopsis: Tree representations of datatypes description: @type-tree@ provides TH splices for generating tree representations of the types contained in datatypes. This is useful for, for example,@@ -8,7 +8,7 @@ license-file: LICENSE author: Jude Taylor maintainer: me@jude.xyz-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 category: Language homepage: https://github.com/pikajude/type-tree build-type: Custom@@ -24,17 +24,18 @@ library exposed-modules: Language.Haskell.TypeTree+ Language.Haskell.TypeTree.ExampleDatatypes other-modules: Language.Haskell.TypeTree.CheatingLift Language.Haskell.TypeTree.Datatype Language.Haskell.TypeTree.Leaf hs-source-dirs: src- build-depends: base >= 4.9 && < 5- , Cabal- , base-compat+ build-depends: base >= 4.7 && < 5+ , base-compat == 0.10.* , containers , mtl , pretty , template-haskell+ , zenc default-language: Haskell2010 default-extensions: NoImplicitPrelude other-extensions: FlexibleInstances