diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for th-abstraction + +## 0.1.0.0 -- 2017-04-26 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2017 Eric Mertens + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Datatype.hs @@ -0,0 +1,496 @@ +{-# Language CPP, DeriveGeneric, DeriveDataTypeable #-} + +{-| +Module : Language.Haskell.TH.Datatype +Description : Backwards-compatible interface to reified information about datatypes. +Copyright : Eric Mertens 2017 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a flattened view of information about data types +and newtypes that can be supported uniformly across multiple verisons +of the template-haskell package. + +Sample output for @'reifyDatatype' ''Maybe@ + +@ +'DatatypeInfo' + { 'datatypeContext' = [] + , 'datatypeName' = GHC.Base.Maybe + , 'datatypeVars' = [ 'VarT' a_3530822107858468866 ] + , 'datatypeVariant' = 'Datatype' + , 'datatypeCons' = + [ 'ConstructorInfo' + { 'constructorName' = GHC.Base.Nothing + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [] + , 'constructorVariant' = 'NormalConstructor' + } + , 'ConstructorInfo' + { 'constructorName' = GHC.Base.Just + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] + , 'constructorVariant' = 'NormalConstructor' + } + ] + } +@ + +Datatypes declared with GADT syntax are normalized to constructors with existentially +quantified type variables and equality constraints. + +-} +module Language.Haskell.TH.Datatype + ( + -- * Types + DatatypeInfo(..) + , ConstructorInfo(..) + , DatatypeVariant(..) + , ConstructorVariant(..) + + -- * Normalization functions + , reifyDatatype + , normalizeInfo + , normalizeDec + , normalizeCon + + -- * Type variable manipulation + , TypeSubstitution(..) + , quantifyType + , freshenFreeVariables + + -- * 'Pred' functions + , equalPred + , classPred + + + -- * Convenience functions + , resolveTypeSynonyms + , unifyTypes + , tvName + , datatypeType + ) where + +import Data.Data (Typeable, Data) +import Data.Foldable (foldMap, foldl') +import Data.List (union, (\\)) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad (foldM) +import GHC.Generics (Generic) +import Language.Haskell.TH + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..), (<$>)) +import Data.Traversable (traverse, sequenceA) +#endif + +-- | Normalized information about newtypes and data types. +data DatatypeInfo = DatatypeInfo + { datatypeContext :: Cxt -- ^ Data type context (deprecated) + , datatypeName :: Name -- ^ Type constructor + , datatypeVars :: [Type] -- ^ Type parameters + , datatypeVariant :: DatatypeVariant -- ^ Extra information + , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information + } + deriving (Show, Eq, Typeable, Data, Generic) + +-- | Possible variants of data type declarations. +data DatatypeVariant + = Datatype -- ^ Type declared with @data@ + | Newtype -- ^ Type declared with @newtype@ + | DataInstance -- ^ Type declared with @data instance@ + | NewtypeInstance -- ^ Type declared with @newtype instance@ + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +-- | Normalized information about constructors associated with newtypes and +-- data types. +data ConstructorInfo = ConstructorInfo + { constructorName :: Name -- ^ Constructor name + , constructorVars :: [TyVarBndr] -- ^ Constructor type parameters + , constructorContext :: Cxt -- ^ Constructor constraints + , constructorFields :: [Type] -- ^ Constructor fields + , constructorVariant :: ConstructorVariant -- ^ Extra information + } + deriving (Show, Eq, Typeable, Data, Generic) + +-- | Possible variants of data constructors. +data ConstructorVariant + = NormalConstructor -- ^ Constructor without field names + | RecordConstructor [Name] -- ^ Constructor with field names + deriving (Show, Eq, Ord, Typeable, Data, Generic) + + +-- | Construct a Type using the datatype's type constructor and type +-- parameteters. +datatypeType :: DatatypeInfo -> Type +datatypeType di + = foldl AppT (ConT (datatypeName di)) + $ datatypeVars di + + +-- | Compute a normalized view of the metadata about a data type or newtype +-- given a type constructor. +reifyDatatype :: + Name {- ^ type constructor -} -> + Q DatatypeInfo +reifyDatatype n = normalizeInfo =<< reify n + + +-- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'. +-- Fail in 'Q' otherwise. +normalizeInfo :: Info -> Q DatatypeInfo +normalizeInfo (TyConI dec) = normalizeDec dec +normalizeInfo _ = fail "reifyDatatype: Expected a type constructor" + + +-- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. +-- Fail in 'Q' otherwise. +normalizeDec :: Dec -> Q DatatypeInfo +#if MIN_VERSION_template_haskell(2,12,0) +normalizeDec (NewtypeD context name tyvars _kind con _derives) = + normalizeDec' context name (bndrParams tyvars) [con] Newtype +normalizeDec (DataD context name tyvars _kind cons _derives) = + normalizeDec' context name (bndrParams tyvars) cons Datatype +normalizeDec (NewtypeInstD context name params _kind con _derives) = + normalizeDec' context name params [con] NewtypeInstance +normalizeDec (DataInstD context name params _kind cons _derives) = + normalizeDec' context name params cons DataInstance +#elif MIN_VERSION_template_haskell(2,11,0) +normalizeDec (NewtypeD context name tyvars _kind con _derives) = + normalizeDec' context name (bndrParams tyvars) [con] Newtype +normalizeDec (DataD context name tyvars _kind cons _derives) = + normalizeDec' context name (bndrParams tyvars) cons Datatype +normalizeDec (NewtypeInstD context name params _kind con _derives) = + normalizeDec' context name params [con] NewtypeInstance +normalizeDec (DataInstD context name params _kind cons _derives) = + normalizeDec' context name params cons DataInstance +#else +normalizeDec (NewtypeD context name tyvars con _derives) = + normalizeDec' context name (bndrParams tyvars) [con] Newtype +normalizeDec (DataD context name tyvars cons _derives) = + normalizeDec' context name (bndrParams tyvars) cons Datatype +normalizeDec (NewtypeInstD context name params con _derives) = + normalizeDec' context name params [con] NewtypeInstance +normalizeDec (DataInstD context name params cons _derives) = + normalizeDec' context name params cons DataInstance +#endif +normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required" + +bndrParams :: [TyVarBndr] -> [Type] +bndrParams = map (VarT . tvName) + + +normalizeDec' :: + Cxt {- ^ Datatype context -} -> + Name {- ^ Type constructor -} -> + [Type] {- ^ Type parameters -} -> + [Con] {- ^ Constructors -} -> + DatatypeVariant {- ^ Extra information -} -> + Q DatatypeInfo +normalizeDec' context name params cons variant = + do let vs = freeVariables params + cons' <- concat <$> traverse (normalizeCon name vs) cons + pure DatatypeInfo + { datatypeContext = context + , datatypeName = name + , datatypeVars = params + , datatypeCons = cons' + , datatypeVariant = variant + } + +-- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of +-- the type and parameters of the constructor as extracted from the outer +-- 'Dec'. +normalizeCon :: + Name {- ^ Type constructor -} -> + [Name] {- ^ Type parameters -} -> + Con {- ^ Constructor -} -> + Q [ConstructorInfo] +normalizeCon typename vars = go [] [] + where + go tyvars context c = + case c of + NormalC n xs -> + pure [ConstructorInfo n tyvars context (map snd xs) NormalConstructor] + InfixC l n r -> + pure [ConstructorInfo n tyvars context [snd l,snd r] NormalConstructor] + RecC n xs -> + let fns = takeFieldNames xs in + pure [ConstructorInfo n tyvars context + (takeFieldTypes xs) (RecordConstructor fns)] + ForallC tyvars' context' c' -> + go (tyvars'++tyvars) (context'++context) c' + +#if MIN_VERSION_template_haskell(2,11,0) + GadtC ns xs innerType -> + gadtCase ns innerType (map snd xs) NormalConstructor + RecGadtC ns xs innerType -> + let fns = takeFieldNames xs in + gadtCase ns innerType (takeFieldTypes xs) (RecordConstructor fns) + where + gadtCase = normalizeGadtC typename vars tyvars context + + +normalizeGadtC :: + Name {- ^ Type constructor -} -> + [Name] {- ^ Type parameters -} -> + [TyVarBndr] {- ^ Constructor parameters -} -> + Cxt {- ^ Constructor context -} -> + [Name] {- ^ Constructor names -} -> + Type {- ^ Declared type of constructor -} -> + [Type] {- ^ Constructor field types -} -> + ConstructorVariant {- ^ Constructor variant -} -> + Q [ConstructorInfo] +normalizeGadtC typename vars tyvars context names innerType fields variant = + do innerType' <- resolveTypeSynonyms innerType + case decomposeType innerType' of + ConT innerTyCon :| ts | typename == innerTyCon -> + + let (substName, context1) = mergeArguments vars ts + subst = VarT <$> substName + tyvars' = [ tv | tv <- tyvars, Map.notMember (tvName tv) subst ] + + context2 = applySubstitution subst (context1 ++ context) + fields' = applySubstitution subst fields + in pure [ConstructorInfo name tyvars' context2 fields' variant + | name <- names] + + _ -> fail "normalizeGadtC: Expected type constructor application" + +mergeArguments :: [Name] -> [Type] -> (Map Name Name, Cxt) +mergeArguments ns ts = foldl' aux (Map.empty, []) (zip ns ts) + where + aux (subst, context) (n,p) = + case p of + VarT m | Map.notMember m subst -> (Map.insert m n subst, context) + _ -> (subst, EqualityT `AppT` VarT n `AppT` p : context) + +#endif + +-- | Expand all of the type synonyms in a type. +resolveTypeSynonyms :: Type -> Q Type +resolveTypeSynonyms t = + let f :| xs = decomposeType t + + notTypeSynCase = foldl AppT f <$> traverse resolveTypeSynonyms xs + + in case f of + ConT n -> + do info <- reify n + case info of + TyConI (TySynD _ synvars def) -> + let argNames = map tvName synvars + (args,rest) = splitAt (length argNames) xs + subst = Map.fromList (zip argNames args) + t' = foldl AppT (applySubstitution subst def) rest + in resolveTypeSynonyms t' + + _ -> notTypeSynCase + _ -> notTypeSynCase + +-- | Decompose a type into a list of it's outermost applications. This process +-- forgets about infix application and explicit parentheses. +-- +-- > t ~= foldl1 AppT (decomposeType t) +decomposeType :: Type -> NonEmpty Type +decomposeType = reverseNonEmpty . go + where + go (AppT f x ) = x <| go f +#if MIN_VERSION_template_haskell(2,11,0) + go (InfixT l f r) = ConT f :| [l,r] + go (UInfixT l f r) = ConT f :| [l,r] + go (ParensT t ) = decomposeType t +#endif + go t = t :| [] + + +-- | Extract the type variable name from a 'TyVarBndr' ignoring the +-- kind signature if one exists. +tvName :: TyVarBndr -> Name +tvName (PlainTV name ) = name +tvName (KindedTV name _) = name + +takeFieldNames :: [(Name,a,b)] -> [Name] +takeFieldNames xs = [a | (a,_,_) <- xs] + +takeFieldTypes :: [(a,b,Type)] -> [Type] +takeFieldTypes xs = [a | (_,_,a) <- xs] + +------------------------------------------------------------------------ + +-- | Add universal quantifier for all free variables in the type. This is +-- useful when constructing a type signature for a declaration. +-- This code is careful to ensure that the order of the variables quantified +-- is determined by their order of appearance in the type singnature. (In +-- contrast with being dependent upon the Ord instance for 'Name') +-- +quantifyType :: Type -> Type +quantifyType t + | null vs = t + | otherwise = ForallT (PlainTV <$> vs) [] t + where + vs = freeVariables t + + +-- | Substitute all of the free variables in a type with fresh ones +freshenFreeVariables :: Type -> Q Type +freshenFreeVariables t = + do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t] + subst <- sequenceA (Map.fromList xs) + return (applySubstitution subst t) + + +-- | Class for types that support type variable substitution. +class TypeSubstitution a where + -- | Apply a type variable substitution + applySubstitution :: Map Name Type -> a -> a + -- | Compute the free type variables + freeVariables :: a -> [Name] + +instance TypeSubstitution a => TypeSubstitution [a] where + freeVariables = foldMap freeVariables + applySubstitution = fmap . applySubstitution + +instance TypeSubstitution Type where + applySubstitution subst = go + where + go (ForallT tvs context t) = + let subst' = foldl' (flip Map.delete) subst (map tvName tvs) in + ForallT tvs (applySubstitution subst' context) + (applySubstitution subst' t) + go (AppT f x) = AppT (go f) (go x) + go (SigT t k) = SigT (go t) (applySubstitution subst k) -- k could be Kind + go (VarT v) = Map.findWithDefault (VarT v) v subst +#if MIN_VERSION_template_haskell(2,11,0) + go (InfixT l c r) = InfixT (go l) c (go r) + go (UInfixT l c r) = UInfixT (go l) c (go r) + go (ParensT t) = ParensT (go t) +#endif + go t = t + + freeVariables t = + case t of + ForallT tvs context t' -> + (freeVariables context `union` freeVariables t') + \\ map tvName tvs + AppT f x -> freeVariables f `union` freeVariables x + SigT t' k -> freeVariables t' `union` freeVariables k + VarT v -> [v] +#if MIN_VERSION_template_haskell(2,11,0) + InfixT l _ r -> freeVariables l `union` freeVariables r + UInfixT l _ r -> freeVariables l `union` freeVariables r + ParensT t' -> freeVariables t' +#endif + _ -> [] + +instance TypeSubstitution ConstructorInfo where + freeVariables ci = + (freeVariables (constructorContext ci) `union` + freeVariables (constructorFields ci)) + \\ (tvName <$> constructorVars ci) + + applySubstitution subst ci = + let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in + ci { constructorContext = applySubstitution subst' (constructorContext ci) + , constructorFields = applySubstitution subst' (constructorFields ci) + } + +-- Pred became a type synonym for Type +#if !MIN_VERSION_template_haskell(2,10,0) +instance TypeSubstitution Pred where + freeVariables (ClassP _ xs) = freeVariables xs + freeVariables (EqualP x y) = freeVariables x `union` freeVariables y + + applySubstitution p (ClassP n xs) = ClassP n (applySubstitution p xs) + applySubstitution p (EqualP x y) = EqualP (applySubstitution p x) + (applySubstitution p y) +#endif + +-- Kind became a type synonym for Type. Previously there were no kind variables +#if !MIN_VERSION_template_haskell(2,8,0) +instance TypeSubstitution Kind where + freeVariables _ = [] + applySubstitution _ k = k +#endif + +------------------------------------------------------------------------ + +combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type +combineSubstitutions x y = Map.union (fmap (applySubstitution y) x) y + +-- | Compute the type variable substitution that unifies a list of types, +-- or fail in 'Q'. +unifyTypes :: [Type] -> Q (Map Name Type) +unifyTypes [] = pure Map.empty +unifyTypes (t:ts) = + do t':ts' <- traverse resolveTypeSynonyms (t:ts) + let aux sub u = + do sub' <- unify' (applySubstitution sub t') + (applySubstitution sub u) + return (combineSubstitutions sub sub') + + case foldM aux Map.empty ts' of + Right m -> return m + Left (x,y) -> + fail $ showString "Unable to unify types " + . showsPrec 11 x + . showString " and " + . showsPrec 11 y + $ "" + +unify' :: Type -> Type -> Either (Type,Type) (Map Name Type) + +unify' (VarT n) (VarT m) | n == m = pure Map.empty +unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t) + | otherwise = pure (Map.singleton n t) +unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t) + | otherwise = pure (Map.singleton n t) + +unify' (ConT n) (ConT m) | n == m = pure Map.empty + +unify' (AppT f1 x1) (AppT f2 x2) = + do sub1 <- unify' f1 f2 + sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2) + return (combineSubstitutions sub1 sub2) + +unify' (TupleT n) (TupleT m) | n == m = pure Map.empty + +unify' t u = Left (t,u) + + +-- | Construct an equality constraint. The implementation of 'Pred' varies +-- across versions of Template Haskell. +equalPred :: Type -> Type -> Pred +equalPred x y = +#if MIN_VERSION_template_haskell(2,10,0) + AppT (AppT EqualityT x) y +#else + EqualP x y +#endif + +-- | Construct a typeclass constraint. The implementation of 'Pred' varies +-- across versions of Template Haskell. +classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred +classPred = +#if MIN_VERSION_template_haskell(2,10,0) + foldl AppT . ConT +#else + ClassP +#endif + +------------------------------------------------------------------------ + +-- NonEmpty didn't move into base into recently. Reimplementing it locally +-- saves dependencies for supporting older GHCs + +data NonEmpty a = a :| [a] + +(<|) :: a -> NonEmpty a -> NonEmpty a +x <| (y :| ys) = x :| (y : ys) + +reverseNonEmpty :: NonEmpty a -> NonEmpty a +reverseNonEmpty (x :| xs) = y :| ys + where y:ys = reverse (x:xs) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,85 @@ +{-# Language TemplateHaskell, GADTs #-} + +module Main (main) where + +import Control.Monad +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +type Gadt1Int = Gadt1 Int + +data Gadt1 a where + Gadtc1 :: Int -> Gadt1Int + Gadtc2 :: (a,a) -> Gadt1 a + +data Adt1 a b = Adtc1 (a,b) | Bool `Adtc2` Int + +data Gadtrec1 a where + Gadtrecc1 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) + +return [] -- segment type declarations above from refiy below + +main :: IO () +main = + do adt1Test + gadt1Test + gadtrec1Test + +adt1Test :: IO () +adt1Test = + $(do info <- reifyDatatype ''Adt1 + + let [a,b] = freeVariables (datatypeVars info) + [c1,c2] = datatypeCons info + + unless (datatypeName info == ''Adt1) (fail "bad name adt1") + unless (datatypeVariant info == Datatype) (fail "bad variant adt1") + + unless (c1 == ConstructorInfo 'Adtc1 [] [] [AppT (AppT (TupleT 2) (VarT a)) (VarT b)] NormalConstructor) + (fail "Bad adtc1") + + unless (c2 == ConstructorInfo 'Adtc2 [] [] [ConT ''Bool, ConT ''Int] NormalConstructor) + (fail "Bad adtc2") + + [| putStrLn "Adt1 tests passed" |] + ) + +gadt1Test :: IO () +gadt1Test = + $(do info <- reifyDatatype ''Gadt1 + + let [a] = freeVariables (datatypeVars info) + [c1,c2] = datatypeCons info + + unless (c1 == ConstructorInfo 'Gadtc1 [] [equalPred (VarT a) (ConT ''Int)] + [ConT ''Int] NormalConstructor) + (fail ("bad Gadtc1 " ++ show c1)) + + unless (c2 == ConstructorInfo 'Gadtc2 [] [] + [AppT (AppT (TupleT 2) (VarT a)) (VarT a)] + NormalConstructor) + (fail ("bad Gadtc2 " ++ show c2)) + + [| putStrLn "Gadt1 tests passed" |] + ) + +gadtrec1Test :: IO () +gadtrec1Test = + $(do info <- reifyDatatype ''Gadtrec1 + + let [a] = freeVariables (datatypeVars info) + [c] = datatypeCons info + [v1,v2] = constructorVars c + + expectedCxt = [equalPred + (VarT a) + (AppT (AppT (TupleT 2) (VarT (tvName v1))) + (VarT (tvName v2)))] + + unless (c == ConstructorInfo 'Gadtrecc1 [v1,v2] expectedCxt + [VarT (tvName v1), VarT (tvName v2)] + (RecordConstructor [ 'gadtrec1a, 'gadtrec1b ])) + (fail ("bad constructor for gadtrec1" ++ show c)) + + [| putStrLn "Gadtrecc1 tests" |] + ) diff --git a/th-abstraction.cabal b/th-abstraction.cabal new file mode 100644 --- /dev/null +++ b/th-abstraction.cabal @@ -0,0 +1,38 @@ +name: th-abstraction +version: 0.1.0.0 +synopsis: Nicer interface to reified information about data types +description: This package normalizes variations in the interface for + inspecting datatype information via Template Haskell + so that packages and support a single, easier to use + informational datatype while supporting many versions + of Template Haskell. +license: ISC +license-file: LICENSE +author: Eric Mertens +maintainer: emertens@gmail.com +copyright: 2017 Eric Mertens +category: Development +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.4.2 + +source-repository head + type: git + location: https://github.com/glguy/th-abstraction.git + +library + exposed-modules: Language.Haskell.TH.Datatype + build-depends: base >=4.5 && <5, + ghc-prim, + template-haskell >=2.4 && <2.13, + containers >=0.4 && <0.6 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: th-abstraction, base, template-haskell + hs-source-dirs: test + default-language: Haskell2010