th-desugar 1.4.0 → 1.4.1

raw patch · 8 files changed

+320/−14 lines, 8 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

• CHANGES.md +7/−0
• Language/Haskell/TH/Desugar.hs +14/−4
• Language/Haskell/TH/Desugar/Core.hs +9/−1
• Language/Haskell/TH/Desugar/Expand.hs +13/−3
• Language/Haskell/TH/Desugar/Lift.hs +256/−0
• Language/Haskell/TH/Desugar/Sweeten.hs +13/−2
• Test/Splices.hs +1/−1
• th-desugar.cabal +7/−3

@@ -1,3 +1,10 @@+Version 1.4.1+-------------+* Added `Language.Haskell.TH.Desugar.Lift`, which provides `Lift` instances+for all of the th-desugar types, as well as several Template Haskell types.++* Added `applyDExp` and `applyDType` as convenience functions.+ Version 1.4.0 ------------- * All `Dec`s can now be desugared, to the new `DDec` type.

@@ -7,10 +7,19 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,              TypeSynonymInstances, FlexibleInstances #-} -{-|-Desugars full Template Haskell syntax into a smaller core syntax for further-processing. The desugared types and constructors are prefixed with a D.--}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar+-- Copyright   :  (C) 2014 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Desugars full Template Haskell syntax into a smaller core syntax for further+-- processing. The desugared types and constructors are prefixed with a D.+--+----------------------------------------------------------------------------  module Language.Haskell.TH.Desugar (   -- * Desugared data types@@ -34,6 +43,7 @@   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,     -- * Utility functions+  applyDExp, applyDType,   dPatToDExp, removeWilds, reifyWithWarning,   getDataD, dataConNameToDataName, dataConNameToCon,   nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,

@@ -160,7 +160,7 @@  #if __GLASGOW_HASKELL__ < 707 -- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility.-data Role = Nominal | Representational | Phantom+data Role = NominalR | RepresentationalR | PhantomR | InferR           deriving (Show, Typeable, Data)  -- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility.@@ -921,3 +921,11 @@ isUniversalPattern (DTildePa {}) = return True isUniversalPattern (DBangPa pat) = isUniversalPattern pat isUniversalPattern DWildPa       = return True++-- | Apply one 'DExp' to a list of arguments+applyDExp :: DExp -> [DExp] -> DExp+applyDExp = foldl DAppE++-- | Apply one 'DType' to a list of arguments+applyDType :: DType -> [DType] -> DType+applyDType = foldl DAppT

@@ -6,9 +6,19 @@  {-# LANGUAGE CPP #-} -{-| Expands type synonyms in desugared types, ignoring type families.-See also the package th-expand-syns for doing this to non-desugared types.--}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.Expand+-- Copyright   :  (C) 2014 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Expands type synonyms in desugared types, ignoring type families.+-- See also the package th-expand-syns for doing this to non-desugared types.+--+----------------------------------------------------------------------------  module Language.Haskell.TH.Desugar.Expand (   expand, expandType, substTy

@@ -0,0 +1,256 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.Lift+-- Copyright   :  (C) 2014 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines @Lift@ instances for the desugared language. This is defined+-- in a separate module because it also must define @Lift@ instances for+-- several TH types, which are orphans and may want another definition+-- downstream.+--+----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.Haskell.TH.Desugar.Lift () where++import Prelude hiding ( mod, words )+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Control.Applicative+import GHC.Exts+import GHC.Word++foldApp :: Exp -> [Exp] -> Exp+foldApp = foldl AppE+           +instance Lift DExp where+  lift (DVarE n)      = foldApp (ConE 'DVarE)  <$> sequence [lift n]+  lift (DConE n)      = foldApp (ConE 'DConE)  <$> sequence [lift n]+  lift (DLitE l)      = foldApp (ConE 'DLitE)  <$> sequence [lift l]+  lift (DAppE e1 e2)  = foldApp (ConE 'DAppE)  <$> sequence [lift e1, lift e2]+  lift (DLamE ns e)   = foldApp (ConE 'DLamE)  <$> sequence [lift ns, lift e]+  lift (DCaseE e ms)  = foldApp (ConE 'DCaseE) <$> sequence [lift e, lift ms]+  lift (DLetE decs e) = foldApp (ConE 'DLetE)  <$> sequence [lift decs, lift e]+  lift (DSigE e t)    = foldApp (ConE 'DSigE)  <$> sequence [lift e, lift t]++instance Lift DPat where+  lift (DLitPa l)    = foldApp (ConE 'DLitPa)   <$> sequence [lift l]+  lift (DVarPa n)    = foldApp (ConE 'DVarPa)   <$> sequence [lift n]+  lift (DConPa n ps) = foldApp (ConE 'DConPa)   <$> sequence [lift n, lift ps]+  lift (DTildePa p)  = foldApp (ConE 'DTildePa) <$> sequence [lift p]+  lift (DBangPa p)   = foldApp (ConE 'DBangPa)  <$> sequence [lift p]+  lift DWildPa       = return $ ConE 'DWildPa++instance Lift DType where+  lift (DForallT tvbs cxt t) =+    foldApp (ConE 'DForallT) <$> sequence [lift tvbs, lift cxt, lift t]+  lift (DAppT t1 t2) = foldApp (ConE 'DAppT) <$> sequence [lift t1, lift t2]+  lift (DSigT t k)   = foldApp (ConE 'DSigT) <$> sequence [lift t, lift k]+  lift (DVarT n)     = foldApp (ConE 'DVarT) <$> sequence [lift n]+  lift (DConT n)     = foldApp (ConE 'DConT) <$> sequence [lift n]+  lift DArrowT       = return $ ConE 'DArrowT+  lift (DLitT l)     = foldApp (ConE 'DLitT) <$> sequence [lift l]++instance Lift DKind where+  lift (DForallK ns k) = foldApp (ConE 'DForallK) <$> sequence [lift ns, lift k]+  lift (DVarK n)       = foldApp (ConE 'DVarK)    <$> sequence [lift n]+  lift (DConK n ks)    = foldApp (ConE 'DConK)    <$> sequence [lift n, lift ks]+  lift (DArrowK k1 k2) = foldApp (ConE 'DArrowK)  <$> sequence [lift k1, lift k2]+  lift DStarK          = return $ ConE 'DStarK++instance Lift DPred where+  lift (DAppPr p t) = foldApp (ConE 'DAppPr) <$> sequence [lift p, lift t]+  lift (DSigPr p k) = foldApp (ConE 'DSigPr) <$> sequence [lift p, lift k]+  lift (DVarPr n)   = foldApp (ConE 'DVarPr) <$> sequence [lift n]+  lift (DConPr n)   = foldApp (ConE 'DConPr) <$> sequence [lift n]++instance Lift DTyVarBndr where+  lift (DPlainTV n)    = foldApp (ConE 'DPlainTV)  <$> sequence [lift n]+  lift (DKindedTV n k) = foldApp (ConE 'DKindedTV) <$> sequence [lift n, lift k]++instance Lift DMatch where+  lift (DMatch p e) = foldApp (ConE 'DMatch) <$> sequence [lift p, lift e]++instance Lift DClause where+  lift (DClause ps e) = foldApp (ConE 'DClause) <$> sequence [lift ps, lift e]++instance Lift DLetDec where+  lift (DFunD n cs)  = foldApp (ConE 'DFunD)   <$> sequence [lift n, lift cs]+  lift (DValD p e)   = foldApp (ConE 'DValD)   <$> sequence [lift p, lift e]+  lift (DSigD n t)   = foldApp (ConE 'DSigD)   <$> sequence [lift n, lift t]+  lift (DInfixD f n) = foldApp (ConE 'DInfixD) <$> sequence [lift f, lift n]++instance Lift NewOrData where+  lift Newtype = return $ ConE 'Newtype+  lift Data    = return $ ConE 'Data++instance Lift DDec where+  lift (DLetDec dec) = foldApp (ConE 'DLetDec) <$> sequence [lift dec]+  lift (DDataD nd cxt n tvbs cons derivs) =+    foldApp (ConE 'DDataD) <$> sequence [ lift nd, lift cxt, lift n+                                        , lift tvbs, lift cons, lift derivs ]+  lift (DTySynD n tvbs ty) =+    foldApp (ConE 'DTySynD) <$> sequence [lift n, lift tvbs, lift ty]+  lift (DClassD cxt n tvbs fds decs) =+    foldApp (ConE 'DClassD) <$> sequence [ lift cxt, lift n, lift tvbs+                                         , lift fds, lift decs ]+  lift (DInstanceD cxt ty decs) =+    foldApp (ConE 'DInstanceD) <$> sequence [lift cxt, lift ty, lift decs]+  lift (DForeignD for) = foldApp (ConE 'DForeignD) <$> sequence [lift for]+  lift (DPragmaD prag) = foldApp (ConE 'DPragmaD) <$> sequence [lift prag]+  lift (DFamilyD flav n tvbs res) =+    foldApp (ConE 'DFamilyD) <$> sequence [lift flav, lift n, lift tvbs, lift res]+  lift (DDataInstD nd cxt n tys cons derivs) =+    foldApp (ConE 'DDataInstD) <$> sequence [ lift nd, lift cxt, lift n+                                            , lift tys, lift cons, lift derivs ]+  lift (DTySynInstD n eqn) = foldApp (ConE 'DTySynInstD) <$> sequence [lift n, lift eqn]+  lift (DClosedTypeFamilyD n tvbs res eqns) =+    foldApp (ConE 'DClosedTypeFamilyD) <$> sequence [ lift n, lift tvbs+                                                    , lift res, lift eqns ]+  lift (DRoleAnnotD n rs) =+    foldApp (ConE 'DRoleAnnotD) <$> sequence [lift n, lift rs]++instance Lift DCon where+  lift (DCon tvbs cxt n fields) =+    foldApp (ConE 'DCon) <$> sequence [lift tvbs, lift cxt, lift n, lift fields]++instance Lift DConFields where+  lift (DNormalC stys) = foldApp (ConE 'DNormalC) <$> sequence [lift stys]+  lift (DRecC vstys)   = foldApp (ConE 'DRecC)    <$> sequence [lift vstys]++instance Lift DForeign where+  lift (DImportF cc safe str n ty) =+    foldApp (ConE 'DImportF) <$> sequence [ lift cc, lift safe, lift str+                                          , lift n, lift ty ]+  lift (DExportF cc str n ty) =+    foldApp (ConE 'DExportF) <$> sequence [lift cc, lift str, lift n, lift ty]++instance Lift DPragma where+  lift (DInlineP n i rm phases) =+    foldApp (ConE 'DInlineP) <$> sequence [lift n, lift i, lift rm, lift phases]+  lift (DSpecialiseP n ty m_i phases) =+    foldApp (ConE 'DSpecialiseP) <$> sequence [ lift n, lift ty+                                              , lift m_i, lift phases ]+  lift (DSpecialiseInstP ty) = foldApp (ConE 'DSpecialiseInstP) <$> sequence [lift ty]+  lift (DRuleP str bndrs e1 e2 phases) =+    foldApp (ConE 'DRuleP) <$> sequence [ lift str, lift bndrs, lift e1+                                        , lift e2, lift phases ]+  lift (DAnnP targ e) = foldApp (ConE 'DAnnP) <$> sequence [lift targ, lift e]++instance Lift DRuleBndr where+  lift (DRuleVar n) = foldApp (ConE 'DRuleVar) <$> sequence [lift n]+  lift (DTypedRuleVar n ty) =+    foldApp (ConE 'DTypedRuleVar) <$> sequence [lift n, lift ty]++instance Lift DTySynEqn where+  lift (DTySynEqn lhs rhs) = foldApp (ConE 'DTySynEqn) <$> sequence [lift lhs, lift rhs]+                                 +-- Template Haskell liftings++instance Lift OccName where+  lift (OccName n) = foldApp (ConE 'OccName) <$> sequence [lift n]++instance Lift ModName where+  lift (ModName n) = foldApp (ConE 'ModName) <$> sequence [lift n]++instance Lift PkgName where+  lift (PkgName n) = foldApp (ConE 'PkgName) <$> sequence [lift n]++instance Lift NameSpace where+  lift VarName   = return $ ConE 'VarName+  lift DataName  = return $ ConE 'DataName+  lift TcClsName = return $ ConE 'TcClsName++instance Lift NameFlavour where+  lift NameS       = return $ ConE 'NameS+  lift (NameQ mod) = foldApp (ConE 'NameQ) <$> sequence [lift mod]+  lift (NameU n)   = return $ foldApp (ConE 'NameU) [LitE $ IntPrimL $ toInteger $ I# n]+  lift (NameL n)   = return $ foldApp (ConE 'NameL) [LitE $ IntPrimL $ toInteger $ I# n]+  lift (NameG ns pkg mod) =+    foldApp (ConE 'NameG) <$> sequence [lift ns, lift pkg, lift mod]++instance Lift Name where+  lift (Name occ flav) = foldApp (ConE 'Name) <$> sequence [lift occ, lift flav]+                                  +instance Lift Lit where+  lift (CharL ch)          = foldApp (ConE 'CharL)       <$> sequence [lift ch]+  lift (StringL str)       = foldApp (ConE 'StringL)     <$> sequence [lift str]+  lift (IntegerL i)        = foldApp (ConE 'IntegerL)    <$> sequence [lift i]+  lift (RationalL rat)     = foldApp (ConE 'RationalL)   <$> sequence [lift rat]+  lift (IntPrimL i)        = foldApp (ConE 'IntPrimL)    <$> sequence [lift i]+  lift (WordPrimL i)       = foldApp (ConE 'WordPrimL)   <$> sequence [lift i]+  lift (FloatPrimL rat)    = foldApp (ConE 'FloatPrimL)  <$> sequence [lift rat]+  lift (DoublePrimL rat)   = foldApp (ConE 'DoublePrimL) <$> sequence [lift rat]+  lift (StringPrimL words) = foldApp (ConE 'StringPrimL) <$> sequence [lift words]++instance Lift TyLit where+  lift (NumTyLit i) = foldApp (ConE 'NumTyLit) <$> sequence [lift i]+  lift (StrTyLit s) = foldApp (ConE 'StrTyLit) <$> sequence [lift s]++instance Lift Fixity where+  lift (Fixity i dir) = foldApp (ConE 'Fixity) <$> sequence [lift i, lift dir]++instance Lift FixityDirection where+  lift InfixL = return $ ConE 'InfixL+  lift InfixR = return $ ConE 'InfixR+  lift InfixN = return $ ConE 'InfixN++instance Lift Strict where+  lift IsStrict  = return $ ConE 'IsStrict+  lift NotStrict = return $ ConE 'NotStrict+  lift Unpacked  = return $ ConE 'Unpacked++instance Lift Callconv where+  lift CCall   = return $ ConE 'CCall+  lift StdCall = return $ ConE 'StdCall++instance Lift Safety where+  lift Unsafe = return $ ConE 'Unsafe+  lift Safe   = return $ ConE 'Safe+  lift Interruptible = return $ ConE 'Interruptible++instance Lift Inline where+  lift NoInline  = return $ ConE 'NoInline+  lift Inline    = return $ ConE 'Inline+  lift Inlinable = return $ ConE 'Inlinable++instance Lift RuleMatch where+  lift ConLike = return $ ConE 'ConLike+  lift FunLike = return $ ConE 'FunLike++instance Lift Phases where+  lift AllPhases       = return $ ConE 'AllPhases+  lift (FromPhase i)   = foldApp (ConE 'FromPhase)   <$> sequence [lift i]+  lift (BeforePhase i) = foldApp (ConE 'BeforePhase) <$> sequence [lift i]++instance Lift AnnTarget where+  lift ModuleAnnotation    = return $ ConE 'ModuleAnnotation+  lift (TypeAnnotation n)  = foldApp (ConE 'TypeAnnotation)  <$> sequence [lift n]+  lift (ValueAnnotation n) = foldApp (ConE 'ValueAnnotation) <$> sequence [lift n]++instance Lift FunDep where+  lift (FunDep lhs rhs) = foldApp (ConE 'FunDep) <$> sequence [lift lhs, lift rhs]++instance Lift FamFlavour where+  lift TypeFam = return $ ConE 'TypeFam+  lift DataFam = return $ ConE 'DataFam++instance Lift Role where+  lift NominalR          = return $ ConE 'NominalR+  lift RepresentationalR = return $ ConE 'RepresentationalR+  lift PhantomR          = return $ ConE 'PhantomR+  lift InferR            = return $ ConE 'InferR++-- Other type liftings:+                                      +instance Lift Rational where+  lift rat = return $ LitE $ RationalL rat++instance Lift Word8 where+  lift word = return $ foldApp (VarE 'fromInteger) [LitE $ IntegerL (toInteger word)]

@@ -8,8 +8,19 @@  {-# LANGUAGE CPP #-} -{-| The functions in this module convert desugared Template Haskell back into-    proper Template Haskell. -}+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.Sweeten+-- Copyright   :  (C) 2014 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- The functions in this module convert desugared Template Haskell back into+-- proper Template Haskell.+--+----------------------------------------------------------------------------  module Language.Haskell.TH.Desugar.Sweeten where 

@@ -199,7 +199,7 @@                 type instance Dec10 Int = Maybe                 type instance Dec10 Bool = [] |] -ds_role_test = DRoleAnnotD (mkName "Dec3") [Nominal]+ds_role_test = DRoleAnnotD (mkName "Dec3") [NominalR] role_test = [] #else dectest10 = [d| type family Dec10 a :: * -> * where

@@ -1,5 +1,5 @@ name:           th-desugar-version:        1.4.0+version:        1.4.1 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar@@ -26,7 +26,7 @@ source-repository this   type:     git   location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.4.0+  tag:      v1.4.1  library   build-depends:      @@ -35,18 +35,22 @@       containers >= 0.5,       mtl >= 2.1,       syb >= 0.4+  default-extensions: TemplateHaskell   exposed-modules:    Language.Haskell.TH.Desugar,                       Language.Haskell.TH.Desugar.Sweeten,-                      Language.Haskell.TH.Desugar.Expand+                      Language.Haskell.TH.Desugar.Expand,+                      Language.Haskell.TH.Desugar.Lift   other-modules:      Language.Haskell.TH.Desugar.Core,                       Language.Haskell.TH.Desugar.Util   default-language:   Haskell2010+  ghc-options:        -Wall   test-suite spec   type:               exitcode-stdio-1.0   ghc-options:        -Wall -Werror -main-is Test.Run   default-language:   Haskell2010+  default-extensions: TemplateHaskell   main-is:            Test/Run.hs   other-modules:      Test.Splices, Test.Dec, Test.DsDec