diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for th-abstraction +## 0.1.3.0 -- 2016-05-27 + +* Added `resolveInfixT` which uses reified fixity information to resolve `UInfixT` +* Added `asEqualPred` and `asClassPred` +* Fixed data-instance GADTs + ## 0.1.2.1 -- 2017-05-21 * Add eta reduction fixes to GHC 7.6 diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -64,16 +64,23 @@ -- * 'Pred' functions , equalPred , classPred + , asEqualPred + , asClassPred -- * Backward compatible data definitions , dataDCompat , arrowKCompat - -- * Convenience functions + -- * Type simplification , resolveTypeSynonyms + , resolveInfixT + + -- * Convenience functions , unifyTypes , tvName , datatypeType + , showFixity + , showFixityDirection ) where import Data.Data (Typeable, Data) @@ -81,9 +88,11 @@ import Data.List (find, union, (\\)) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Control.Monad (foldM) import GHC.Generics (Generic) import Language.Haskell.TH +import Language.Haskell.TH.Datatype.Internal import Language.Haskell.TH.Lib (arrowK) -- needed for th-2.4 #if !MIN_VERSION_base(4,8,0) @@ -128,10 +137,11 @@ -- | Construct a Type using the datatype's type constructor and type --- parameters. +-- parameters. Kind signatures are removed. datatypeType :: DatatypeInfo -> Type datatypeType di = foldl AppT (ConT (datatypeName di)) + $ map stripSigT $ datatypeVars di @@ -245,6 +255,12 @@ PlainTV t -> VarT t +-- | Remove the outermost 'SigT'. +stripSigT :: Type -> Type +stripSigT (SigT t _) = t +stripSigT t = t + + normalizeDec' :: Cxt {- ^ Datatype context -} -> Name {- ^ Type constructor -} -> @@ -253,8 +269,7 @@ DatatypeVariant {- ^ Extra information -} -> Q DatatypeInfo normalizeDec' context name params cons variant = - do let vs = freeVariables params - cons' <- concat <$> traverse (normalizeCon name vs) cons + do cons' <- concat <$> traverse (normalizeCon name params) cons pure DatatypeInfo { datatypeContext = context , datatypeName = name @@ -268,10 +283,10 @@ -- 'Dec'. normalizeCon :: Name {- ^ Type constructor -} -> - [Name] {- ^ Type parameters -} -> + [Type] {- ^ Type parameters -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo] -normalizeCon typename vars = go [] [] +normalizeCon typename params = go [] [] where go tyvars context c = case c of @@ -293,12 +308,12 @@ let fns = takeFieldNames xs in gadtCase ns innerType (takeFieldTypes xs) (RecordConstructor fns) where - gadtCase = normalizeGadtC typename vars tyvars context + gadtCase = normalizeGadtC typename params tyvars context normalizeGadtC :: Name {- ^ Type constructor -} -> - [Name] {- ^ Type parameters -} -> + [Type] {- ^ Type parameters -} -> [TyVarBndr] {- ^ Constructor parameters -} -> Cxt {- ^ Constructor context -} -> [Name] {- ^ Constructor names -} -> @@ -306,12 +321,12 @@ [Type] {- ^ Constructor field types -} -> ConstructorVariant {- ^ Constructor variant -} -> Q [ConstructorInfo] -normalizeGadtC typename vars tyvars context names innerType fields variant = +normalizeGadtC typename params 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 + let (substName, context1) = mergeArguments params ts subst = VarT <$> substName tyvars' = [ tv | tv <- tyvars, Map.notMember (tvName tv) subst ] @@ -322,14 +337,24 @@ _ -> fail "normalizeGadtC: Expected type constructor application" -mergeArguments :: [Name] -> [Type] -> (Map Name Name, Cxt) +mergeArguments :: + [Type] {- ^ outer parameters -} -> + [Type] {- ^ inner parameters (specializations ) -} -> + (Map Name Name, Cxt) mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts) where - aux (n,p) (subst, context) = + aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds?? + aux (x, SigT y _) sc = aux (x,y) sc + + aux (f `AppT` x, g `AppT` y) sc = + aux (x,y) (aux (f,g) sc) + + aux (VarT n,p) (subst, context) = case p of VarT m | Map.notMember m subst -> (Map.insert m n subst, context) _ -> (subst, EqualityT `AppT` VarT n `AppT` p : context) + aux _ sc = sc #endif -- | Expand all of the type synonyms in a type. @@ -337,38 +362,119 @@ resolveTypeSynonyms t = let f :| xs = decomposeType t - notTypeSynCase = foldl AppT f <$> traverse resolveTypeSynonyms xs + notTypeSynCase = foldl AppT f <$> traverse resolveTypeSynonyms xs in - 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' + 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 + _ -> notTypeSynCase + _ -> notTypeSynCase -- | Decompose a type into a list of it's outermost applications. This process -- forgets about infix application and explicit parentheses. -- +-- This operation should be used after all 'UInfixT' cases have been resolved +-- by 'resolveFixities' if the argument is being user generated. +-- -- > t ~= foldl1 AppT (decomposeType t) decomposeType :: Type -> NonEmpty Type -decomposeType = reverseNonEmpty . go +decomposeType = go [] where - go (AppT f x ) = x <| go f + go args (AppT f x) = go (x:args) f + go args t = t :| args + +-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally +-- saves dependencies for supporting older GHCs +data NonEmpty a = a :| [a] + + +-- | Resolve any infix type application in a type using the fixities that +-- are currently available. Starting in `template-haskell-2.11` types could +-- contain unresolved infix applications. +resolveInfixT :: Type -> Q Type + #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 +resolveInfixT (ForallT vs cx t) = forallT vs (traverse resolveInfixT cx) (resolveInfixT t) +resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x +resolveInfixT (ParensT t) = resolveInfixT t +resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r +resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k +resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t) +resolveInfixT t = pure t + +gatherUInfixT :: Type -> InfixList +gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r) +gatherUInfixT t = ILNil t + +-- This can fail due to incompatible fixities +resolveInfixT1 :: InfixList -> TypeQ +resolveInfixT1 = go [] + where + go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ + go ts (ILNil u) = pure (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts) + go ts (ILCons l o r) = + do ofx <- fromMaybe defaultFixity <$> reifyFixity o + let push = go ((l,o,ofx):ts) r + case ts of + (l1,o1,o1fx):ts' -> + case compareFixity o1fx ofx of + Just True -> go ((ConT o1 `AppT` l1 `AppT` l, o, ofx):ts') r + Just False -> push + Nothing -> fail (precedenceError o1 o1fx o ofx) + _ -> push + + compareFixity :: Fixity -> Fixity -> Maybe Bool + compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2) + compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2) + compareFixity (Fixity n1 _ ) (Fixity n2 _ ) = + case compare n1 n2 of + GT -> Just True + LT -> Just False + EQ -> Nothing + + precedenceError :: Name -> Fixity -> Name -> Fixity -> String + precedenceError o1 ofx1 o2 ofx2 = + "Precedence parsing error: cannot mix ‘" ++ + nameBase o1 ++ "’ [" ++ showFixity ofx1 ++ "] and ‘" ++ + nameBase o2 ++ "’ [" ++ showFixity ofx2 ++ + "] in the same infix type expression" + +data InfixList = ILCons Type Name InfixList | ILNil Type + +ilAppend :: InfixList -> Name -> InfixList -> InfixList +ilAppend (ILNil l) o r = ILCons l o r +ilAppend (ILCons l1 o1 r1) o r = ILCons l1 o1 (ilAppend r1 o r) + +#else +-- older template-haskell packages don't have UInfixT +resolveInfixT = pure #endif - go t = t :| [] +-- | Render a 'Fixity' as it would appear in Haskell source. +-- +-- Example: @infixl 5@ +showFixity :: Fixity -> String +showFixity (Fixity n d) = showFixityDirection d ++ " " ++ show n + + +-- | Render a 'FixityDirection' like it would appear in Haskell source. +-- +-- Examples: @infixl@ @infixr@ @infix@ +showFixityDirection :: FixityDirection -> String +showFixityDirection InfixL = "infixl" +showFixityDirection InfixR = "infixr" +showFixityDirection InfixN = "infix" + + -- | Extract the type variable name from a 'TyVarBndr' ignoring the -- kind signature if one exists. tvName :: TyVarBndr -> Name @@ -388,7 +494,6 @@ -- This code is careful to ensure that the order of the variables quantified -- is determined by their order of appearance in the type signature. (In -- contrast with being dependent upon the Ord instance for 'Name') --- quantifyType :: Type -> Type quantifyType t | null vs = t @@ -543,19 +648,30 @@ ClassP #endif ------------------------------------------------------------------------- --- 'NonEmpty' didn't move into base until 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) +-- | Match a 'Pred' representing an equality constraint. Returns +-- arguments to the equality constraint if successful. +asEqualPred :: Pred -> Maybe (Type,Type) +#if MIN_VERSION_template_haskell(2,10,0) +asEqualPred (EqualityT `AppT` x `AppT` y) = Just (x,y) +asEqualPred (ConT eq `AppT` x `AppT` y) | eq == eqTypeName = Just (x,y) +#else +asEqualPred (EqualP x y) = Just (x,y) +#endif +asEqualPred _ = Nothing -reverseNonEmpty :: NonEmpty a -> NonEmpty a -reverseNonEmpty (x :| xs) = y :| ys - where y:ys = reverse (x:xs) +-- | Match a 'Pred' representing a class constraint. +-- Returns the classname and parameters if successful. +asClassPred :: Pred -> Maybe (Name, [Type]) +#if MIN_VERSION_template_haskell(2,10,0) +asClassPred t = + case decomposeType t of + ConT f :| xs | f /= eqTypeName -> Just (f,xs) + _ -> Nothing +#else +asClassPred (ClassP f xs) = Just (f,xs) +asClassPred _ = Nothing +#endif ------------------------------------------------------------------------ diff --git a/src/Language/Haskell/TH/Datatype/Internal.hs b/src/Language/Haskell/TH/Datatype/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Datatype/Internal.hs @@ -0,0 +1,16 @@ +{-| +Module : Language.Haskell.TH.Datatype.Internal +Description : Backwards-compatible interface to reified information about datatypes. +Copyright : Eric Mertens 2017 +License : ISC +Maintainer : emertens@gmail.com + +Internal Template Haskell 'Name's. + +-} +module Language.Haskell.TH.Datatype.Internal where + +import Language.Haskell.TH.Syntax + +eqTypeName :: Name +eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" diff --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -1,5 +1,5 @@ name: th-abstraction -version: 0.1.2.1 +version: 0.1.3.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell @@ -17,7 +17,7 @@ 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 +tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 source-repository head type: git @@ -25,9 +25,10 @@ library exposed-modules: Language.Haskell.TH.Datatype + other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.5 && <5, ghc-prim, - template-haskell >=2.4 && <2.13, + template-haskell >=2.7 && <2.13, containers >=0.4 && <0.6 hs-source-dirs: src default-language: Haskell2010