diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/src/Language/Haskell/TypeTree.hs b/src/Language/Haskell/TypeTree.hs --- a/src/Language/Haskell/TypeTree.hs +++ b/src/Language/Haskell/TypeTree.hs @@ -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 +`- ...[] :: * -> * + +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 - | - +- - | - `- 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 diff --git a/src/Language/Haskell/TypeTree/CheatingLift.hs b/src/Language/Haskell/TypeTree/CheatingLift.hs --- a/src/Language/Haskell/TypeTree/CheatingLift.hs +++ b/src/Language/Haskell/TypeTree/CheatingLift.hs @@ -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|] diff --git a/src/Language/Haskell/TypeTree/Datatype.hs b/src/Language/Haskell/TypeTree/Datatype.hs --- a/src/Language/Haskell/TypeTree/Datatype.hs +++ b/src/Language/Haskell/TypeTree/Datatype.hs @@ -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 diff --git a/src/Language/Haskell/TypeTree/ExampleDatatypes.hs b/src/Language/Haskell/TypeTree/ExampleDatatypes.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TypeTree/ExampleDatatypes.hs @@ -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) diff --git a/src/Language/Haskell/TypeTree/Leaf.hs b/src/Language/Haskell/TypeTree/Leaf.hs --- a/src/Language/Haskell/TypeTree/Leaf.hs +++ b/src/Language/Haskell/TypeTree/Leaf.hs @@ -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 diff --git a/type-tree.cabal b/type-tree.cabal --- a/type-tree.cabal +++ b/type-tree.cabal @@ -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