diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for type-tree + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Jude Taylor + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +module Main (main) where + +#if MIN_VERSION_cabal_doctest(1,0,0) +import Distribution.Extra.Doctest (defaultMainWithDoctests) +#else +#ifdef MIN_VERSION_Cabal +import Warning () +#endif +import Distribution.Simple +defaultMainWithDoctests _ = defaultMain +#endif + +main = defaultMainWithDoctests "doctest" diff --git a/src/Language/Haskell/TypeTree.hs b/src/Language/Haskell/TypeTree.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TypeTree.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# Language CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.TypeTree + ( -- ** GHCi setup + -- $setup + + -- * Usage + -- $usage + + -- * Reify input + IsDatatype(..) + , Binding(..) + , guess + -- * Producing trees + , ttReify + , ttReifyOpts + , ttLit + , ttLitOpts + -- ** Debugging trees + , ttDescribe + , ttDescribeOpts + -- ** Building graphs + , Key + , Arity + , ttEdges + , ttConnComp + -- * Customizing trees + , Leaf(..) + , ReifyOpts(..) + , defaultOpts + ) where + +import Control.Monad +import Control.Monad.Reader +import Data.Graph +import Data.List +import Data.Map (Map) +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.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. +-- +-- Concrete types will appear in the tree as 'ConL'. Unbound variables +-- will appear as 'VarL'. If the datastructure is recursive, occurrences +-- of the node after the first will be wrapped in 'Recursive'. +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" +#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 + +-} +{- $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@.) + +=== Plain constructors + +>>> data Foo a = Foo { field1 :: Either a Int } +>>> putStr $(ttDescribe ''Foo) +Ghci4.Foo a_0 +| +`- Data.Either.Either a_0 GHC.Types.Int + | + +- $a_0 + | + `- GHC.Types.Int + +=== Passing type arguments + +@ttReify@ and friends accept any value with an 'IsDatatype' instance. + +>>> putStr $(ttDescribe [t|Maybe Int|]) +GHC.Base.Maybe GHC.Types.Int +| +`- GHC.Types.Int + +=== GADTs + +>>> 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 +| +`- GHC.Types.[] GHC.Types.Int + | + `- GHC.Types.Int + +When reifying GADTs, constructors' return types are treated as another +field. + +=== Data/type family instances + +>>> 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 + +>>> :module +GHC.Exts +>>> putStr $(ttDescribe [t|Item [Int]|]) +GHC.Exts.Item ([GHC.Types.Int]) +| +`- GHC.Types.Int + +=== Recursive datatypes + +>>> 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 + +== Passing options + +If needed, @type-tree@ allows you to specify that primitive type constructors +should be included in its output. + +>>> data Baz = Baz { field :: [Int] } +>>> putStr $(ttDescribeOpts defaultOpts { expandPrim = True } ''Baz) +Ghci27.Baz +| +`- GHC.Types.[] GHC.Types.Int + | + `- GHC.Types.Int + | + `- GHC.Prim.Int# + +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. + +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. + +>>> 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 + +-} diff --git a/src/Language/Haskell/TypeTree/CheatingLift.hs b/src/Language/Haskell/TypeTree/CheatingLift.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TypeTree/CheatingLift.hs @@ -0,0 +1,45 @@ +{-# Language TemplateHaskell #-} + +{- +- using TH to make a cheating version of `lift` for Name +- GHC expands all the strings contained in a Name into huge cons-trees, but +- it appears that if we use stringE in those cases instead it massively +- speeds up compilation and prevents stack overflows +-} +module Language.Haskell.TypeTree.CheatingLift + ( liftName + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Prelude.Compat + +$(do TyConI (DataD _ _ _ _ [NormalC x _] _) <- reify ''Name + arg1 <- newName "arg" + arg2 <- newName "arg" + sequence + [ sigD (mkName "liftName") [t|Name -> ExpQ|] + , funD + (mkName "liftName") + [ clause + [conP x [varP arg1, varP arg2]] + (normalB + [|appsE + [ conE $(liftData x) + , $(appE (varE $ mkName "liftOcc") (varE arg1)) + , $(appE (varE $ mkName "liftFlv") (varE arg2)) + ]|]) + [] + ] + ]) + +liftOcc :: OccName -> ExpQ +liftOcc (OccName s) = [|OccName $(stringE s)|] + +liftFlv :: NameFlavour -> ExpQ +liftFlv NameS = [|NameS|] +liftFlv (NameG x (PkgName s) (ModName y)) = + [|NameG $(liftData 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|] diff --git a/src/Language/Haskell/TypeTree/Datatype.hs b/src/Language/Haskell/TypeTree/Datatype.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TypeTree/Datatype.hs @@ -0,0 +1,51 @@ +{-# Language DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +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]) + +instance IsDatatype Name where + asDatatype n = pure (guess n, []) + +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 + +-- | Convenience function. +guess n + | isNothing (nameSpace n) = Unbound n + | otherwise = Bound n diff --git a/src/Language/Haskell/TypeTree/Leaf.hs b/src/Language/Haskell/TypeTree/Leaf.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TypeTree/Leaf.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Language.Haskell.TypeTree.Leaf where + +import Data.Data +import Data.Tree +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 ((<>)) + +liftType :: Type -> ExpQ +liftType (VarT x) = [|VarT $(liftName x)|] +liftType (ConT x) = [|ConT $(liftName x)|] +liftType (AppT x y) = [|AppT $(liftType x) $(liftType y)|] +liftType (TupleT n) = [|TupleT n|] +liftType ListT = [|ListT|] +liftType (SigT t k) = [|SigT $(liftType t) $(liftType k)|] +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@. + | Recursive Leaf -- ^ Recursive field. + deriving (Eq, Data, Ord, Show) + +instance Lift Leaf where + lift (TypeL (n, x)) = [|TypeL ($(liftBinding n), $(listE $ map liftType 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/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,11 @@ +module Main where + +import Build_doctests (flags, module_sources, pkgs) +import Data.Foldable (traverse_) +import Test.DocTest (doctest) + +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/type-tree.cabal b/type-tree.cabal new file mode 100644 --- /dev/null +++ b/type-tree.cabal @@ -0,0 +1,48 @@ +name: type-tree +version: 0.1.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, + generating class instances for a deeply nested datatype. +license: MIT +license-file: LICENSE +author: Jude Taylor +maintainer: me@jude.xyz +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 +category: Language +homepage: https://github.com/pikajude/type-tree +build-type: Custom +extra-source-files: ChangeLog.md +cabal-version: >= 1.10 + +custom-setup + setup-depends: base == 4.*, Cabal, cabal-doctest >= 1 && < 1.1 + +library + exposed-modules: Language.Haskell.TypeTree + 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 + , containers + , mtl + , pretty + , template-haskell + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + other-extensions: FlexibleInstances + CPP + TypeSynonymInstances + TemplateHaskell + DeriveDataTypeable + ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: tests + build-depends: base, doctest + default-language: Haskell2010