th-abstraction 0.1.2.1 → 0.1.3.0

raw patch · 4 files changed

+185/−46 lines, 4 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• src/Language/Haskell/TH/Datatype.hs +159/−43
• src/Language/Haskell/TH/Datatype/Internal.hs +16/−0
• th-abstraction.cabal +4/−3

@@ -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

@@ -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  ------------------------------------------------------------------------ 

@@ -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" "~"

@@ -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