th-desugar-1.9/0000755000000000000000000000000013350246155011620 5ustar0000000000000000th-desugar-1.9/th-desugar.cabal0000644000000000000000000000623413350246155014654 0ustar0000000000000000name: th-desugar version: 1.9 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar category: Template Haskell author: Richard Eisenberg maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/th-desugar/issues stability: experimental extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple tested-with: GHC == 7.6.3 , GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3 , GHC == 8.6.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. This desugaring discards surface syntax information (such as the use of infix operators) but retains the original meaning of the TH code. The intended use of this package is as a preprocessor for more advanced code manipulation tools. Note that the input to any of the ds... functions should be produced from a TH quote, using the syntax [| ... |]. If the input to these functions is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. source-repository this type: git location: https://github.com/goldfirere/th-desugar.git tag: v1.9 source-repository head type: git location: https://github.com/goldfirere/th-desugar.git branch: master library build-depends: base >= 4 && < 5, template-haskell >= 2.8 && < 2.15, containers >= 0.5, mtl >= 2.1, syb >= 0.4, th-lift >= 0.6.1, th-orphans >= 0.9.1, th-expand-syns >= 0.3.0.6 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar, Language.Haskell.TH.Desugar.Sweeten, Language.Haskell.TH.Desugar.Lift, Language.Haskell.TH.Desugar.Expand, Language.Haskell.TH.Desugar.Subst other-modules: Language.Haskell.TH.Desugar.AST, Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Match, Language.Haskell.TH.Desugar.Util, Language.Haskell.TH.Desugar.Reify default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall default-language: Haskell2010 default-extensions: TemplateHaskell hs-source-dirs: Test main-is: Run.hs other-modules: Splices, Dec, DsDec build-depends: base >= 4 && < 5, template-haskell, containers >= 0.5, mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3, th-desugar, th-lift >= 0.6.1, th-orphans >= 0.9.1, th-expand-syns >= 0.3.0.6 th-desugar-1.9/README.md0000644000000000000000000000261413350246155013102 0ustar0000000000000000`th-desugar` Package ==================== [![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) [![Build Status](https://travis-ci.org/goldfirere/th-desugar.svg?branch=master)](https://travis-ci.org/goldfirere/th-desugar) This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. This desugaring discards surface syntax information (such as the use of infix operators) but retains the original meaning of the TH code. The intended use of this package is as a preprocessor for more advanced code manipulation tools. Note that the input to any of the `ds...` functions should be produced from a TH quote, using the syntax `[| ... |]`. If the input to these functions is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. One explicit goal of this package is to reduce the burden of supporting multiple GHC / TH versions. Thus, the desugared language is the same across all GHC versions, and any inconsistencies are handled internally. The package was designed for use with the `singletons` package, so some design decisions are based on that use case, when more than one design choice was possible. I will try to keep this package up-to-date with respect to changes in GHC. th-desugar-1.9/CHANGES.md0000644000000000000000000002433513350246155013221 0ustar0000000000000000`th-desugar` release notes ========================== Version 1.9 ----------- * Suppose GHC 8.6. * Add support for `DerivingVia`. Correspondingly, there is now a `DDerivStrategy` data type. * Add support for `QuantifiedConstraints`. Correspondingly, there is now a `DForallPr` constructor in `DPred` to represent quantified constraint types. * Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`. Two utility functions have been added to `Language.Haskell.TH.Desugar` to ease this transition: * `isTypeKindName`: returns `True` if the argument `Name` is that of `Type` or `★` (or `*`, to support older GHCs). * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older GHCs). * `th-desugar` now desugars all data types to GADT syntax. The most significant API-facing changes resulting from this new design are: * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec` now have `Maybe DKind` fields that either have `Just` an explicit return kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`) or `Nothing` (if lacking an explicit return kind). * The `DCon` constructor previously had a field of type `Maybe DType`, since there was a possibility it could be a GADT (with an explicit return type) or non-GADT (without an explicit return type) constructor. Since all data types are desugared to GADTs now, this field has been changed to be simply a `DType`. * The type signature of `dsCon` was previously: ```haskell dsCon :: DsMonad q => Con -> q [DCon] ``` However, desugaring constructors now needs more information than before, since GADT constructors have richer type signatures. Accordingly, the type of `dsCon` is now: ```haskell dsCon :: DsMonad q => [DTyVarBndr] -- ^ The universally quantified type variables -- (used if desugaring a non-GADT constructor) -> DType -- ^ The original data declaration's type -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] ``` The `instance Desugar [Con] [DCon]` has also been removed, as the previous implementation of `desugar` (`concatMapM dsCon`) no longer has enough information to work. Some other utility functions have also been added as part of this change: * A `conExistentialTvbs` function has been introduced to determine the existentially quantified type variables of a `DCon`. Note that this function is not 100% accurate—refer to the documentation for `conExistentialTvbs` for more information. * A `mkExtraDKindBinders` function has been introduced to turn a data type's return kind into explicit, fresh type variable binders. * A `toposortTyVarsOf` function, which finds the free variables of a list of `DType`s and returns them in a well scoped list that has been sorted in reverse topological order. * `th-desugar` now desugars partial pattern matches in `do`-notation and list/monad comprehensions to the appropriate invocation of `fail`. (Previously, these were incorrectly desugared into `case` expressions with incomplete patterns.) * Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using a list of `DPat` arguments and a `DExp` body. * Add an `unravel` function for decomposing a function type into its `forall`'d type variables, its context, its argument types, and its result type. * Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`, which substitutes over type variable binders in a capture-avoiding fashion. * `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a result, the contexts in their type signatures have been strengthened from `Quasi` to `DsMonad`. * Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a `DType`, which preserves its kind. * Previously, `th-desugar` would silently accept illegal uses of record construction with fields that did not belong to the constructor, such as `Identity { notAField = "wat" }`. This is now an error. Version 1.8 ----------- * Support GHC 8.4. * `substTy` now properly substitutes into kind signatures. * Expose `fvDType`, which computes the free variables of a `DType`. * Incorporate a `DDeclaredInfix` field into `DNormalC` to indicate if it is a constructor that was declared infix. * Implement `lookupValueNameWithLocals`, `lookupTypeNameWithLocals`, `mkDataNameWithLocals`, and `mkTypeNameWithLocals`, counterparts to `lookupValueName`, `lookupTypeName`, `mkDataName`, and `mkTypeName` which have access to local Template Haskell declarations. * Implement `reifyNameSpace` to determine a `Name`'s `NameSpace`. * Export `reifyFixityWithLocals` from `Language.Haskell.TH.Desugar`. * Export `matchTy` (among other goodies) from new module `Language.Haskell.TH.Subst`. This function matches a type template against a target. Version 1.7 ----------- * Support for TH's support for `TypeApplications`, thanks to @RyanGlScott. * Support for unboxed sums, thanks to @RyanGlScott. * Support for `COMPLETE` pragmas. * `getRecordSelectors` now requires a list of `DCon`s as an argument. This makes it easier to return correct record selector bindings in the event that a record selector appears in multiple constructors. (See [goldfirere/singletons#180](https://github.com/goldfirere/singletons/issues/180) for an example of where the old behavior of `getRecordSelectors` went wrong.) * Better type family expansion (expanding an open type family with variables works now). Version 1.6 ----------- * Work with GHC 8, with thanks to @christiaanb for getting this change going. This means that several core datatypes have changed: partcularly, we now have `DTypeFamilyHead` and fixities are now reified separately from other things. * `DKind` is merged with `DType`. * `Generic` instances for everything. Version 1.5.5 ------------- * Fix issue #34. This means that desugaring (twice) is idempotent over expressions, after the second time. That is, if you desugar an expression, sweeten it, desugar again, sweeten again, and then desugar a third time, you get the same result as when you desugared the second time. (The extra round-trip is necessary there to make the output smaller in certain common cases.) Version 1.5.4.1 --------------- * Fix issue #32, concerning reification of classes with default methods. Version 1.5.4 ------------- * Added `expandUnsoundly` Version 1.5.3 ------------- * More `DsMonad` instances, thanks to David Fox. Version 1.5.2 ------------- * Sweeten kinds more, too. Version 1.5.1 ------------- * Thanks to David Fox (@ddssff), sweetening now tries to use more of TH's `Type` constructors. * Also thanks to David Fox, depend usefully on the th-orphans package. Version 1.5 ----------- * There is now a facility to register a list of `Dec` that internal reification should use when necessary. This avoids the user needing to break up their definition across different top-level splices. See `withLocalDeclarations`. This has a side effect of changing the `Quasi` typeclass constraint on many functions to be the new `DsMonad` constraint. Happily, there are `DsMonad` instances for `Q` and `IO`, the two normal inhabitants of `Quasi`. * "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove any nested pattern matches. * More is now exported from `Language.Haskell.TH.Desugar` for ease of use. * `expand` can now expand closed type families! It still requires that the type to expand contain no type variables. * Support for standalone-deriving and default signatures in GHC 7.10. This means that there are now two new constructors for `DDec`. * Support for `static` expressions, which are new in GHC 7.10. Version 1.4.2 ------------- * `expand` functions now consider open type families, as long as the type to be expanded has no free variables. 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. * Sweetening `Dec`s that do not exist in GHC 7.6.3- works on a "best effort" basis: closed type families are sweetened to open ones, and role annotations are dropped. * `Info`s can now be desugared. Desugaring takes into account GHC bug #8884, which meant that reifying poly-kinded type families in GHC 7.6.3- was subtly wrong. * There is a new function `flattenDValD` which takes a binding like `let (a,b) = foo` and breaks it apart into separate assignments for `a` and `b`. * There is a new `Desugar` class with methods `desugar` and `sweeten`. See the documentation in `Language.Haskell.TH.Desugar`. * Variable names that are distinct in desugared code are now guaranteed to have distinct answers to `nameBase`. * Added a new function `getRecordSelectors` that extracts types and definitions of record selectors from a datatype definition. Version 1.3.1 ------------- * Update cabal file to include testing files in sdist. Version 1.3.0 ------------- * Update to work with `type Pred = Type` in GHC 7.9. This changed the `DPred` type for all GHC versions, though. Version 1.2.0 ------------- * Generalized interface to allow any member of the `Qausi` class, instead of just `Q`. Version 1.1.1 ------------- * Made compatible with HEAD after change in role annotation syntax. Version 1.1 ----------- * Added module `Language.Haskell.TH.Desugar.Expand`, which allows for expansion of type synonyms in desugared types. * Added `Show`, `Typeable`, and `Data` instances to desugared types. * Fixed bug where an as-pattern in a `let` statement was scoped incorrectly. * Changed signature of `dsPat` to be more specific to as-patterns; this allowed for fixing the `let` scoping bug. * Created new functions `dsPatOverExp` and `dsPatsOverExp` to allow for easy desugaring of patterns. * Changed signature of `dsLetDec` to return a list of `DLetDec`s. * Added `dsLetDecs` for convenience. Now, instead of using `mapM dsLetDec`, you should use `dsLetDecs`. Version 1.0 ----------- * Initial release th-desugar-1.9/LICENSE0000644000000000000000000000270513350246155012631 0ustar0000000000000000Copyright (c) 2013, Richard Eisenberg All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.th-desugar-1.9/Setup.hs0000644000000000000000000000005613350246155013255 0ustar0000000000000000import Distribution.Simple main = defaultMain th-desugar-1.9/Test/0000755000000000000000000000000013350246155012537 5ustar0000000000000000th-desugar-1.9/Test/Run.hs0000644000000000000000000005057113350246155013647 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP, RankNTypes, TypeFamilies, DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses, FlexibleInstances, ExistentialQuantification, ScopedTypeVariables, GADTs, ViewPatterns #-} {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-unused-matches -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-missing-fields #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} #endif module Main where import Prelude hiding ( exp ) import Test.HUnit import Test.Hspec hiding ( runIO ) -- import Test.Hspec.HUnit import Splices import qualified DsDec import qualified Dec import Dec ( RecordSel ) import Language.Haskell.TH.Desugar #if __GLASGOW_HASKELL__ >= 707 import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) #endif import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( lift ) import Control.Monad #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.Generics ( geq ) import Data.Function ( on ) import qualified Data.Map as M import qualified Data.Set as S #if __GLASGOW_HASKELL__ >= 707 import Data.Proxy #endif -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec. fromHUnitTest :: Test -> Spec -- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs fromHUnitTest t = case t of TestList xs -> mapM_ go xs x -> go x where go :: Test -> Spec go t_ = case t_ of TestLabel s (TestCase e) -> it s e TestLabel s (TestList xs) -> describe s (mapM_ go xs) TestLabel s x -> describe s (go x) TestList xs -> describe "" (mapM_ go xs) TestCase e -> it "" e tests :: Test tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections) , "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats) , "lamcase" ~: $test3_lamcase @=? $(dsSplice test3_lamcase) -- Must fix nested pattern-matching for this to work. Argh. -- , "tuples" ~: $test4_tuples @=? $(dsSplice test4_tuples) , "ifs" ~: $test5_ifs @=? $(dsSplice test5_ifs) , "ifs2" ~: $test6_ifs2 @=? $(dsSplice test6_ifs2) , "let" ~: $test7_let @=? $(dsSplice test7_let) , "case" ~: $test8_case @=? $(dsSplice test8_case) , "do" ~: $test9_do @=? $(dsSplice test9_do) , "comp" ~: $test10_comp @=? $(dsSplice test10_comp) #if __GLASGOW_HASKELL__ >= 707 , "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp) , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2) #endif , "sig" ~: $test13_sig @=? $(dsSplice test13_sig) , "record" ~: $test14_record @=? $(dsSplice test14_record) , "litp" ~: $test15_litp @=? $(dsSplice test15_litp) , "tupp" ~: $test16_tupp @=? $(dsSplice test16_tupp) , "infixp" ~: $test17_infixp @=? $(dsSplice test17_infixp) , "tildep" ~: $test18_tildep @=? $(dsSplice test18_tildep) , "bangp" ~: $test19_bangp @=? $(dsSplice test19_bangp) , "asp" ~: $test20_asp @=? $(dsSplice test20_asp) , "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp) , "listp" ~: $test22_listp @=? $(dsSplice test22_listp) #if __GLASGOW_HASKELL__ >= 801 , "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp) #endif , "fun" ~: $test24_fun @=? $(dsSplice test24_fun) , "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2) , "forall" ~: $test26_forall @=? $(dsSplice test26_forall) , "kisig" ~: $test27_kisig @=? $(dsSplice test27_kisig) , "tupt" ~: $test28_tupt @=? $(dsSplice test28_tupt) , "listt" ~: $test29_listt @=? $(dsSplice test29_listt) , "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted) , "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint) , "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit) , "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs) , "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as) #if __GLASGOW_HASKELL__ >= 709 , "pred" ~: $test37_pred @=? $(dsSplice test37_pred) , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2) , "eq" ~: $test39_eq @=? $(dsSplice test39_eq) #endif #if __GLASGOW_HASKELL__ >= 711 , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards) #endif #if __GLASGOW_HASKELL__ >= 801 , "typeapps" ~: $test41_typeapps @=? $(dsSplice test41_typeapps) , "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs) , "ubx_sums" ~: $test43_ubx_sums @=? $(dsSplice test43_ubx_sums) #endif , "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma) -- , "empty_rec" ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con) -- This one can't be tested by this means, because it contains an "undefined" #if __GLASGOW_HASKELL__ >= 803 , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label) #endif , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match) #if __GLASGOW_HASKELL__ >= 805 , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints) #endif ] test35a = $test35_expand test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH) test36a = $test36_expand test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH) test_e3a = $test_expand3 test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH) #if __GLASGOW_HASKELL__ >= 707 test_e5a = $test_expand5 test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6 test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH) test_e7a = $test_expand7 test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH) #if __GLASGOW_HASKELL__ < 801 test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH) -- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for -- closed type families. #endif test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) #endif #if __GLASGOW_HASKELL__ >= 709 test_e9a = $test_expand9 -- requires GHC #9262 test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH) #endif hasSameType :: a -> a -> Bool hasSameType _ _ = True test_expand :: Bool test_expand = and [ hasSameType test35a test35b , hasSameType test36a test36b , hasSameType test_e3a test_e3b , hasSameType test_e4a test_e4b #if __GLASGOW_HASKELL__ >= 707 , hasSameType test_e5a test_e5b , hasSameType test_e6a test_e6b , hasSameType test_e7a test_e7b , hasSameType test_e7a test_e7c #if __GLASGOW_HASKELL__ < 801 , hasSameType test_e8a test_e8a #endif , hasSameType test_e8b test_e8b #endif #if __GLASGOW_HASKELL__ >= 709 , hasSameType test_e9a test_e9b #endif ] test_dec :: [Bool] test_dec = $(do bools <- mapM testDecSplice dec_test_nums return $ ListE bools) $( do fuzzType <- mkTypeName "Fuzz" fuzzData <- mkDataName "Fuzz" let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType) dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData) fuzzDecs <- [d| data Fuzz = Fuzz |] return $ tySynDecs : dataSynDecs : fuzzDecs ) test_mkName :: Bool test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz) , hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ] test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) <- dsInfo info let isTypeKind (DConT n) = isTypeKindName n isTypeKind _ = False case (isTypeKind resK, lhs) of #if __GLASGOW_HASKELL__ < 709 (True, [DVarT _]) -> [| True |] #else (True, [DSigT (DVarT _) (DVarT _)]) -> [| True |] #endif _ -> do runIO $ do putStrLn "Failed bug8884 test:" putStrLn $ show dinfo [| False |] ) flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test) s2 = $(do exp <- flatten_dvald_test DLetE ddecs dexp <- dsExp exp flattened <- fmap concat $ mapM flattenDValD ddecs return $ expToTH $ DLetE flattened dexp ) in s1 == s2 test_rec_sels :: Bool test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels] return $ ListE bools) test_standalone_deriving :: Bool #if __GLASGOW_HASKELL__ >= 709 test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x') #else test_standalone_deriving = True #endif test_deriving_strategies :: Bool #if __GLASGOW_HASKELL__ >= 801 test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ #else test_deriving_strategies = True #endif test_local_tyfam_expansion :: Bool test_local_tyfam_expansion = $(do fam_name <- newName "Fam" let orig_ty = DConT fam_name exp_ty <- withLocalDeclarations (decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing) , DTySynInstD fam_name (DTySynEqn [] (DConT ''Int)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) test_stuck_tyfam_expansion :: Bool test_stuck_tyfam_expansion = $(do fam_name <- newName "F" x <- newName "x" k <- newName "k" let orig_ty = DConT fam_name `DAppT` DConT '() -- F '() exp_ty <- withLocalDeclarations (decsToTH [ -- type family F (x :: k) :: k DOpenTypeFamilyD (DTypeFamilyHead fam_name [DKindedTV x (DVarT k)] (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x , DTySynInstD fam_name (DTySynEqn [DSigT (DVarT x) (DConT ''())] (DVarT x)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) test_t85 :: Bool test_t85 = $(do let orig_ty = (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True) `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool) expected_ty = DConT 'True `DSigT` DConT ''Bool expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) test_getDataD_kind_sig :: Bool test_getDataD_kind_sig = #if __GLASGOW_HASKELL__ >= 800 3 == $(do data_name <- newName "TestData" a <- newName "a" let type_kind = DConT typeKindName data_kind_sig = DArrowT `DAppT` type_kind `DAppT` (DArrowT `DAppT` type_kind `DAppT` type_kind) (tvbs, _) <- withLocalDeclarations (decToTH (DDataD Data [] data_name [DPlainTV a] (Just data_kind_sig) [] [])) (getDataD "th-desugar: Impossible" data_name) [| $(Syn.lift (length tvbs)) |]) #else True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0 #endif test_kind_substitution :: [Bool] test_kind_substitution = $(do a <- newName "a" b <- newName "b" c <- newName "c" k <- newName "k" let subst = M.singleton a (DVarT b) -- (Nothing :: Maybe a) ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a) -- forall (c :: a). c ty2 = DForallT [DKindedTV c (DVarT a)] [] (DVarT c) -- forall a (c :: a). c ty3 = DForallT [DPlainTV a, DKindedTV c (DVarT a)] [] (DVarT c) -- forall (a :: k) k (b :: k). Proxy b -> Proxy a ty4 = DForallT [ DKindedTV a (DVarT k) , DPlainTV k , DKindedTV b (DVarT k) ] [] (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b) `DAppT` (DConT ''Proxy `DAppT` DVarT a)) substTy1 <- substTy subst ty1 substTy2 <- substTy subst ty2 substTy3 <- substTy subst ty3 substTy4 <- substTy subst ty4 let freeVars1 = fvDType substTy1 freeVars2 = fvDType substTy2 freeVars3 = fvDType substTy3 freeVars4 = fvDType substTy4 b1 = freeVars1 `eqTH` S.singleton b b2 = freeVars2 `eqTH` S.singleton b b3 = freeVars3 `eqTH` S.empty b4 = freeVars4 `eqTH` S.singleton k [| [b1, b2, b3, b4] |]) test_lookup_value_type_names :: [Bool] test_lookup_value_type_names = $(do let nameStr = "***" valName <- newName nameStr typeName <- newName nameStr let tyDec = DTySynD typeName [] (DConT ''Bool) decs = decsToTH [ DLetDec (DSigD valName (DConT ''Bool)) , DLetDec (DValD (DVarPa valName) (DConE 'False)) , tyDec ] lookupReify lookup_fun = withLocalDeclarations decs $ do Just n <- lookup_fun nameStr Just i <- dsReify n return i reifiedVal <- lookupReify lookupValueNameWithLocals reifiedType <- lookupReify lookupTypeNameWithLocals let b1 = reifiedVal `eqTH` DVarI valName (DConT ''Bool) Nothing let b2 = reifiedType `eqTH` DTyConI tyDec Nothing [| [b1, b2] |]) local_reifications :: [String] local_reifications = $(do decs <- reifyDecs m_infos <- withLocalDeclarations decs $ mapM reifyWithLocals_maybe reifyDecsNames let m_infos' = assumeStarT m_infos ListE <$> mapM (Syn.lift . show) (unqualify m_infos')) $reifyDecs $(return []) -- somehow, this is necessary to get the staging correct for the -- reifications below. Weird. normal_reifications :: [String] normal_reifications = $(do infos <- mapM reify reifyDecsNames ListE <$> mapM (Syn.lift . show . Just) (dropTrailing0s $ unqualify infos)) zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs) zipWith3M _ _ _ _ = return [] simplCase :: [Bool] simplCase = $( do exps <- sequence simplCaseTests dexps <- mapM dsExp exps sexps <- mapM scExp dexps bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |]) exps (map sweeten sexps) return $ ListE bools ) test_roundtrip :: [Bool] test_roundtrip = $( do exprs <- sequence test_exprs ds_exprs1 <- mapM dsExp exprs let th_exprs1 = map expToTH ds_exprs1 ds_exprs2 <- mapM dsExp th_exprs1 let th_exprs2 = map expToTH ds_exprs2 ds_exprs3 <- mapM dsExp th_exprs2 let bools = zipWith eqTH ds_exprs2 ds_exprs3 Syn.lift bools ) test_matchTy :: [Bool] test_matchTy = [ matchTy NoIgnore (DVarT a) (DConT ''Bool) `eq` Just (M.singleton a (DConT ''Bool)) , matchTy NoIgnore (DVarT a) (DVarT a) `eq` Just (M.singleton a (DVarT a)) , matchTy NoIgnore (DVarT a) (DVarT b) `eq` Just (M.singleton a (DVarT b)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) `eq` Just (M.fromList [(a, DConT ''Int), (b, DConT ''Bool)]) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Int) `eq` Just (M.singleton a (DConT ''Int)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) `eq` Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) `eq` Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Int) `eq` Just M.empty , matchTy NoIgnore (DConT ''Int) (DVarT a) `eq` Nothing , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) `eq` Nothing , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) `eq` Just (M.singleton a (DConT ''Int)) ] where a = mkName "a" b = mkName "b" -- GHC 7.6 uses containers-0.5.0.0 which doesn't have a good Data instance -- for Map. So we have to convert to lists before comparing. eq = geq `on` fmap M.toList main :: IO () main = hspec $ do describe "th-desugar library" $ do it "compiles" $ True it "expands" $ test_expand zipWithM (\num success -> it ("passes dec test " ++ show num) success) dec_test_nums test_dec -- instance test 1 is part of dectest 6. it "passes instance test" $ $(do ty <- [t| Int -> Bool |] [inst1, inst2] <- reifyInstances ''Show [ty] inst1 `eqTHSplice` inst2) #if __GLASGOW_HASKELL__ < 707 it "passes roles test" $ (decsToTH [ds_role_test]) `eqTH` role_test #endif it "makes type names" $ test_mkName it "fixes bug 8884" $ test_bug8884 it "flattens DValDs" $ flatten_dvald it "extracts record selectors" $ test_rec_sels it "works with standalone deriving" $ test_standalone_deriving it "works with deriving strategies" $ test_deriving_strategies it "doesn't expand local type families" $ test_local_tyfam_expansion it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion it "expands type synonyms in kinds" $ test_t85 it "reifies data type return kinds accurately" $ test_getDataD_kind_sig -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') $(sequence round_trip_types >>= Syn.lift . map pprint) $(sequence round_trip_types >>= mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>= Syn.lift . map pprint) zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b) local_reifications normal_reifications [1..] zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..] zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..] zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b) test_lookup_value_type_names [1..] zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b) test_kind_substitution [1..] zipWithM (\b n -> it ("matches types " ++ show n) b) test_matchTy [1..] fromHUnitTest tests th-desugar-1.9/Test/Dec.hs0000644000000000000000000000216713350246155013574 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif module Dec where import qualified Splices as S import Splices ( unqualify ) $(S.dectest1) $(S.dectest2) $(S.dectest3) $(S.dectest4) $(S.dectest5) $(S.dectest6) $(S.dectest7) $(S.dectest8) $(S.dectest9) $(S.dectest10) #if __GLASGOW_HASKELL__ >= 709 $(S.dectest11) #endif $(S.dectest12) $(S.dectest13) $(S.dectest14) #if __GLASGOW_HASKELL__ >= 710 $(S.dectest15) #endif $(fmap unqualify S.instance_test) $(fmap unqualify S.imp_inst_test1) $(fmap unqualify S.imp_inst_test2) $(fmap unqualify S.imp_inst_test3) $(fmap unqualify S.imp_inst_test4) $(S.rec_sel_test) th-desugar-1.9/Test/Splices.hs0000644000000000000000000005057313350246155014507 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples, MultiWayIf, ParallelListComp, CPP, BangPatterns, ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes, DataKinds, PolyKinds, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, StandaloneDeriving, DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE TypeApplications #-} #endif #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedSums #-} #endif #if __GLASGOW_HASKELL__ >= 803 {-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -Wno-orphans #-} -- IsLabel is an orphan #endif #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} module Splices where import Data.List import Data.Char import GHC.Exts import GHC.TypeLits import Language.Haskell.TH import Language.Haskell.TH.Desugar import Data.Generics #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( IsLabel(..) ) #endif #if __GLASGOW_HASKELL__ < 707 data Proxy a = Proxy #endif dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) dsDecSplice :: Q [Dec] -> Q [Dec] dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH) testDecSplice :: Int -> Q Exp testDecSplice n = do let dsName = mkName $ "DsDec.Dec" ++ show n regName = mkName $ "Dec.Dec" ++ show n infoDs <- reify dsName infoReg <- reify regName #if __GLASGOW_HASKELL__ < 707 eqTHSplice infoDs infoReg #else rolesDs <- reifyRoles dsName rolesReg <- reifyRoles regName #if __GLASGOW_HASKELL__ < 711 eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg) #else fixityDs <- reifyFixity dsName fixityReg <- reifyFixity regName eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) #endif #endif unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a #if __GLASGOW_HASKELL__ < 709 assumeStarT = id #else assumeStarT = everywhere (mkT go) where go :: TyVarBndr -> TyVarBndr go (PlainTV n) = KindedTV n StarT go (KindedTV n k) = KindedTV n (assumeStarT k) #endif dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where frob str | head str == 'r' = str | head str == 'R' = str | otherwise = dropWhileEnd isDigit str eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) eqTHSplice :: (Data a, Show a) => a -> a -> Q Exp eqTHSplice a b = if a `eqTH` b then [| True |] else [| False |] test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |] test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |] test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |] test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |] test9_do = [| show $ do { foo <- Just "foo" ; let fool = foo ++ "l" ; elemIndex 'o' fool ; x <- elemIndex 'l' fool ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |] #if __GLASGOW_HASKELL__ >= 707 test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |] test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |] #endif test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |] data Record = MkRecord1 { field1 :: Bool, field2 :: Int } | MkRecord2 { field2 :: Int, field3 :: Char } test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }] r2 = map (\r -> r { field2 = 18 }) r1 r3 = (head r2) { field1 = True } in map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |] test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |] test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |] data InfixType = Int :+: Bool deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |] test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |] #if __GLASGOW_HASKELL__ >= 801 test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] #endif test24_fun = [| let f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in (f 5, f 3.0) |] test27_kisig = [| let f :: Proxy (a :: Bool) -> () f _ = () in (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |] test28_tupt = [| let f :: (a,b) -> a f (a,_) = a in map f [(1,'a'),(2,'b')] |] test29_listt = [| let f :: [[a]] -> a f = head . head in map f [ [[1]], [[2]] ] |] test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> () f _ _ = () in f Proxy Proxy |] test31_constraint = [| let f :: Proxy (c :: * -> Constraint) -> () f _ = () in [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> () f _ _ = () in f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |] test33_tvbs = [| let f :: forall a (b :: * -> *). Monad b => a -> b a f = return in [f 1, f 2] :: [Maybe Int] |] test34_let_as = [| let a@(Just x) = Just 5 in show x ++ show a |] type Pair a = (a, a) test35_expand = [| let f :: Pair a -> a f = fst in f |] type Constant a b = b test36_expand = [| let f :: Constant Int (,) Bool Char -> Char f = snd in f |] #if __GLASGOW_HASKELL__ >= 711 test40_wildcards = [| let f :: (Show a, _) => a -> a -> _ f x y = if x == y then show x else "bad" in f True False :: String |] #endif #if __GLASGOW_HASKELL__ >= 801 test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool f g = g (undefined @_ @a) in f (const True) |] test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String f (_ :: b) (x :: String) = show (read x :: b) in f True "True" |] test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool f (# b | #) = not b f (# | c #) = c == "c" in f (# | "a" #) |] #endif test44_let_pragma = [| let x :: Int x = 1 {-# INLINE x #-} in x |] test45_empty_record_con = [| let j :: Maybe Int j = Just{} in case j of Nothing -> j Just{} -> j |] #if __GLASGOW_HASKELL__ >= 803 data Label (l :: Symbol) = Get class Has a l b | a l -> b where from :: a -> Label l -> b data Point = Point Int Int deriving Show instance Has Point "x" Int where from (Point x _) _ = x instance Has Point "y" Int where from (Point _ y) _ = y instance Has a l b => IsLabel l (a -> b) where fromLabel x = from x (Get :: Label l) test46_overloaded_label = [| let p = Point 3 4 in #x p - #y p |] #endif test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |] #if __GLASGOW_HASKELL__ >= 805 test48_quantified_constraints = [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool f = (==) in f (Proxy @Int) (Proxy @Int) |] #endif type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] test_expand3 = [| let f :: TFExpand Int -> () f True = () in f |] test_expand4 = [| let f :: TFExpand (Maybe Bool) -> () f [True, False] = () in f |] #if __GLASGOW_HASKELL__ >= 707 type family ClosedTF a where ClosedTF Int = Bool ClosedTF x = Char test_expand5 = [| let f :: ClosedTF Int -> () f True = () in f |] test_expand6 = [| let f :: ClosedTF Double -> () f 'x' = () in f |] type family PolyTF (x :: k) :: * where PolyTF (x :: *) = Bool test_expand7 = [| let f :: PolyTF Int -> () f True = () in f |] test_expand8 = [| let f :: PolyTF IO -> () f True = () in f |] #endif #if __GLASGOW_HASKELL__ >= 709 test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO () f actions = sequence_ actions in f |] #endif #if __GLASGOW_HASKELL__ >= 709 test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a f x = read (show x) + x in (f 3, f 4.5) |] test38_pred2 = [| let f :: a b => Proxy a -> b -> b f _ x = x in (f (Proxy :: Proxy Show) False, f (Proxy :: Proxy Num) (3 :: Int)) |] test39_eq = [| let f :: (a ~ b) => a -> b f x = x in (f ()) |] #endif #if __GLASGOW_HASKELL__ < 707 dec_test_nums = [1..9] :: [Int] #elif __GLASGOW_HASKELL__ < 709 dec_test_nums = [1..10] :: [Int] #else dec_test_nums = [1..11] :: [Int] #endif dectest1 = [d| data Dec1 where Foo :: Dec1 Bar :: Int -> Dec1 |] dectest2 = [d| data Dec2 a where MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |] dectest3 = [d| data Dec3 a where MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a #if __GLASGOW_HASKELL__ >= 707 type role Dec3 nominal #endif |] dectest4 = [d| newtype Dec4 a where MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |] dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a type M2 m1 :: * -> * |] dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] #if __GLASGOW_HASKELL__ < 707 ds_dectest10 = DClosedTypeFamilyD (DTypeFamilyHead (mkName "Dec10") [DPlainTV (mkName "a")] (DKindSig (DAppT (DAppT DArrowT (DConT typeKindName)) (DConT typeKindName))) Nothing) [ DTySynEqn [DConT ''Int] (DConT ''Maybe) , DTySynEqn [DConT ''Bool] (DConT ''[]) ] dectest10 = [d| type family Dec10 a :: * -> * type instance Dec10 Int = Maybe type instance Dec10 Bool = [] |] ds_role_test = DRoleAnnotD (mkName "Dec3") [NominalR] role_test = [] #else dectest10 = [d| type family Dec10 a :: * -> * where Dec10 Int = Maybe Dec10 Bool = [] |] #endif data Blarggie a = MkBlarggie Int a #if __GLASGOW_HASKELL__ >= 709 dectest11 = [d| class Dec11 a where meth13 :: a -> a -> Bool default meth13 :: Eq a => a -> a -> Bool meth13 = (==) |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |] #endif #if __GLASGOW_HASKELL__ >= 801 deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |] #endif dectest12 = [d| data Dec12 a where MkGInt :: Dec12 Int MkGOther :: Dec12 b |] dectest13 = [d| data Dec13 :: (* -> Constraint) -> * where MkDec13 :: c a => a -> Dec13 c |] dectest14 = [d| data InfixADT = Int `InfixADT` Int |] dectest15 = [d| infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` data InfixGADT a where (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] ActuallyPrefix :: Char -> Bool -> InfixGADT Double (:^^:) :: Int -> Int -> Int -> InfixGADT Int (:!!:) :: Char -> Char -> InfixGADT Char |] instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] class Dec6 a b where { lift :: a x -> b x; type M2 a } imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where lift Nothing = Left () lift (Just x) = Right x type M2 Maybe = Either () |] data family Dec9 a (b :: * -> *) :: * -> * #if __GLASGOW_HASKELL__ >= 800 imp_inst_test2 = [d| data instance Dec9 Int Maybe a where MkIMB :: [a] -> Dec9 Int Maybe a MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x where MkBMX :: m x -> Dec9 Bool m x |] #else -- TH-quoted data family instances with GADT syntax are horribly broken on GHC 7.10 -- and older, so we opt to use non-GADT syntax on older GHCs so we can at least -- test *something*. imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |] #endif type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |] -- used for bug8884 test type family Poly (a :: k) :: * type instance Poly x = Int flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in show a ++ show b ++ show c |] rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) => MkRecord { recsel1 :: (Int, a) , recsel_naughty :: (a, b) , recsel2 :: (forall b. b -> a) , recsel3 :: Bool } | MkRecord2 { recsel4 :: (a, a) } |] rec_sel_test_num_sels = 4 :: Int -- exclude naughty one testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do #if __GLASGOW_HASKELL__ > 710 VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ <- reify (mkName ("Dec.recsel" ++ show n)) #else VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel" ++ show n)) #endif let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1' x = undefined y :: $ty2' y = undefined in $(return $ VarE $ mkName "hasSameType") x y |] -- used for expand reifyDecs :: Q [Dec] reifyDecs = [d| -- NB: Use a forall here! If you don't, when you splice r1 in and then reify -- it, GHC will add an explicit forall behind the scenes, which will cause an -- incongruity with the locally reified declaration (which would lack an -- explicit forall). r1 :: forall a. a -> a r1 x = x class R2 a b where r3 :: a -> b -> c -> a type R4 b a :: * data R5 a :: * data R6 a = R7 { r8 :: a -> a, r9 :: Bool } instance R2 (R6 a) a where r3 = undefined type R4 a (R6 a) = a data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b } type family R12 a b :: * data family R13 a :: * data instance R13 Int = R14 { r15 :: Bool } r16, r17 :: Int (r16, r17) = (5, 6) newtype R18 = R19 Bool type R20 = Bool #if __GLASGOW_HASKELL__ >= 707 type family R21 (a :: k) (b :: k) :: k where #if __GLASGOW_HASKELL__ >= 801 R21 (a :: k) (b :: k) = b #else -- Due to GHC Trac #12646, R21 will get reified without kind signatures on -- a and b on older GHCs, so we must reflect that here. R21 a b = b #endif #endif class XXX a where r22 :: a -> a r22 = id -- test #32 data R23 a = MkR23 { getR23 :: a } r23Test :: R23 a -> a r23Test (MkR23 { getR23 = x }) = x #if __GLASGOW_HASKELL__ >= 801 pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y) data T a where MkT :: Eq b => a -> b -> T a foo :: Show a => a -> Bool foo x = show x == "foo" pattern P :: Show a => Eq b => b -> T a pattern P x <- MkT (foo -> True) x pattern HeadC :: a -> [a] pattern HeadC x <- x:_ where HeadC x = [x] class LL f where llMeth :: f a -> () instance LL [] where llMeth _ = () pattern LLMeth :: LL f => f a pattern LLMeth <- (llMeth -> ()) {-# COMPLETE LLMeth :: [] #-} llEx :: [a] -> Int llEx LLMeth = 5 #endif #if __GLASGOW_HASKELL__ >= 805 newtype Id a = MkId a deriving stock Eq newtype R24 a = MkR24 [a] deriving Eq via (Id [a]) #endif |] reifyDecsNames :: [Name] reifyDecsNames = map mkName [ "r1" #if __GLASGOW_HASKELL__ < 711 , "R2", "r3" -- these fail due to GHC#11797 #endif , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" #if __GLASGOW_HASKELL__ >= 707 , "R21" #endif , "r22" ] simplCaseTests :: [Q Exp] simplCaseTests = [ [| map (\a -> case a :: [Int] of (_:_:_:_) -> (5 :: Int) _ -> 6) [[], [1], [1,2,3]] |] , [| let foo [] = True foo _ = False in (foo [], foo "hi") |] #if __GLASGOW_HASKELL__ >= 801 , [| let foo ([] :: String) = True foo (_ :: String) = False in foo "hello" |] #endif ] -- These foralls are needed because of bug trac9262, fixed in ghc-7.10. round_trip_types :: [TypeQ] round_trip_types = [ [t|forall a. a ~ Int => a|] , [t|forall a. [a]|] , [t|forall a b. (a,b)|] ] test_exprs :: [Q Exp] test_exprs = [ test1_sections , test2_lampats , test3_lamcase -- see above , test4_tuples , test5_ifs , test6_ifs2 , test7_let , test8_case , test9_do , test10_comp #if __GLASGOW_HASKELL__ >= 707 , test11_parcomp , test12_parcomp2 #endif , test13_sig , test14_record , test15_litp , test16_tupp , test17_infixp , test18_tildep , test19_bangp , test20_asp , test21_wildp , test22_listp #if __GLASGOW_HASKELL__ >= 801 , test23_sigp #endif , test24_fun , test25_fun2 , test26_forall , test27_kisig , test28_tupt , test29_listt , test30_promoted , test31_constraint , test32_tylit , test33_tvbs , test34_let_as #if __GLASGOW_HASKELL__ >= 709 , test37_pred , test38_pred2 , test39_eq #endif #if __GLASGOW_HASKELL__ >= 801 , test41_typeapps , test42_scoped_tvs , test43_ubx_sums #endif , test44_let_pragma , test45_empty_record_con #if __GLASGOW_HASKELL__ >= 803 , test46_overloaded_label #endif ] th-desugar-1.9/Test/DsDec.hs0000644000000000000000000000532713350246155014064 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-} #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif module DsDec where import qualified Splices as S import Splices ( dsDecSplice, unqualify ) import Language.Haskell.TH ( reportError ) import Language.Haskell.TH.Desugar import Control.Monad import Data.Maybe( mapMaybe ) $(dsDecSplice S.dectest1) $(dsDecSplice S.dectest2) $(dsDecSplice S.dectest3) $(dsDecSplice S.dectest4) $(dsDecSplice S.dectest5) $(dsDecSplice S.dectest6) $(dsDecSplice S.dectest7) $(dsDecSplice S.dectest8) $(dsDecSplice S.dectest9) $(dsDecSplice (fmap unqualify S.instance_test)) $(dsDecSplice (fmap unqualify S.imp_inst_test1)) $(dsDecSplice (fmap unqualify S.imp_inst_test2)) $(dsDecSplice (fmap unqualify S.imp_inst_test3)) $(dsDecSplice (fmap unqualify S.imp_inst_test4)) #if __GLASGOW_HASKELL__ < 707 $(return $ decsToTH [S.ds_dectest10]) #else $(dsDecSplice S.dectest10) #endif #if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test) #endif #if __GLASGOW_HASKELL__ >= 801 $(dsDecSplice S.deriv_strat_test) #endif $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13) $(dsDecSplice S.dectest14) #if __GLASGOW_HASKELL__ >= 710 $(dsDecSplice S.dectest15) #endif $(do decs <- S.rec_sel_test [DDataD nd [] name [DPlainTV tvbName] k cons []] <- dsDecs decs let arg_ty = (DConT name) `DAppT` (DVarT tvbName) recsels <- getRecordSelectors arg_ty cons let num_sels = length recsels `div` 2 -- ignore type sigs when (num_sels /= S.rec_sel_test_num_sels) $ reportError $ "Wrong number of record selectors extracted.\n" ++ "Wanted " ++ show S.rec_sel_test_num_sels ++ ", Got " ++ show num_sels let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = let (_names, stricts, types) = unzip3 fields fields' = zip stricts types in DCon tvbs cxt con_name (DNormalC False fields') rty plaindata = [DDataD nd [] name [DPlainTV tvbName] k (map unrecord cons) []] return (decsToTH plaindata ++ mapMaybe letDecToTH recsels)) th-desugar-1.9/Language/0000755000000000000000000000000013350246155013343 5ustar0000000000000000th-desugar-1.9/Language/Haskell/0000755000000000000000000000000013350246155014726 5ustar0000000000000000th-desugar-1.9/Language/Haskell/TH/0000755000000000000000000000000013350246155015241 5ustar0000000000000000th-desugar-1.9/Language/Haskell/TH/Desugar.hs0000644000000000000000000003574213350246155017202 0ustar0000000000000000{- Language/Haskell/TH/Desugar.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further -- processing. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar ( -- * Desugared data types DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..), DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..), DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class Desugar(..), -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, dsLetDecs, dsTvb, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions PatM, dsPred, dsPat, dsDec, dsDerivClause, dsLetDec, dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, #if __GLASGOW_HASKELL__ > 710 dsTypeFamilyHead, dsFamilyResultSig, #endif #if __GLASGOW_HASKELL__ >= 801 dsPatSynDir, #endif -- * Converting desugared AST back to TH AST module Language.Haskell.TH.Desugar.Sweeten, -- * Expanding type synonyms expand, expandType, -- * Reification reifyWithWarning, -- | The following definitions allow you to register a list of -- @Dec@s to be used in reification queries. withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals, lookupValueNameWithLocals, lookupTypeNameWithLocals, mkDataNameWithLocals, mkTypeNameWithLocals, reifyNameSpace, DsMonad(..), DsM, -- * Nested pattern flattening scExp, scLetDec, -- * Capture-avoiding substitution and utilities module Language.Haskell.TH.Desugar.Subst, -- * Utility functions applyDExp, applyDType, dPatToDExp, removeWilds, getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, fvDType, tupleDegree_maybe, tupleNameDegree_maybe, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, strictToBang, isTypeKindName, typeKindName, unravel, conExistentialTvbs, mkExtraDKindBinders, dTyVarBndrToDType, toposortTyVarsOf, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Expand import Language.Haskell.TH.Desugar.Match import Language.Haskell.TH.Desugar.Subst import Control.Monad import qualified Data.Map as M import qualified Data.Set as S import Prelude hiding ( exp ) -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one -- way because `Type` and `Kind` are type synonyms, but they desugar -- to different types. class Desugar th ds | ds -> th where desugar :: DsMonad q => th -> q ds sweeten :: ds -> th instance Desugar Exp DExp where desugar = dsExp sweeten = expToTH instance Desugar Type DType where desugar = dsType sweeten = typeToTH instance Desugar Cxt DCxt where desugar = dsCxt sweeten = cxtToTH instance Desugar TyVarBndr DTyVarBndr where desugar = dsTvb sweeten = tvbToTH instance Desugar [Dec] [DDec] where desugar = dsDecs sweeten = decsToTH -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain -- 'DVarPa'. Other declarations are passed through unchanged. -- Note that the declarations that come out of this function are rather -- less efficient than those that come in: they have many more pattern -- matches. flattenDValD :: Quasi q => DLetDec -> q [DLetDec] flattenDValD dec@(DValD (DVarPa _) _) = return [dec] flattenDValD (DValD pat exp) = do x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level let top_val_d = DValD (DVarPa x) exp bound_names = S.elems $ extractBoundNamesDPat pat other_val_ds <- mapM (mk_val_d x) bound_names return $ top_val_d : other_val_ds where mk_val_d x name = do y <- newUniqueName "y" let pat' = wildify name y pat match = DMatch pat' (DVarE y) cas = DCaseE (DVarE x) [match] return $ DValD (DVarPa name) cas wildify name y p = case p of DLitPa lit -> DLitPa lit DVarPa n | n == name -> DVarPa y | otherwise -> DWildPa DConPa con ps -> DConPa con (map (wildify name y) ps) DTildePa pa -> DTildePa (wildify name y pa) DBangPa pa -> DBangPa (wildify name y pa) DSigPa pa ty -> DSigPa (wildify name y pa) ty DWildPa -> DWildPa flattenDValD other_dec = return [other_dec] -- | Produces 'DLetDec's representing the record selector functions from -- the provided 'DCon's. -- -- Note that if the same record selector appears in multiple constructors, -- 'getRecordSelectors' will return only one binding for that selector. -- For example, if you had: -- -- @ -- data X = X1 {y :: Symbol} | X2 {y :: Symbol} -- @ -- -- Then calling 'getRecordSelectors' on @[X1, X2]@ will return: -- -- @ -- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol)) -- , DFunD y [ DClause [DConPa X1 [DVarPa field]] (DVarE field) -- , DClause [DConPa X2 [DVarPa field]] (DVarE field) ] ] -- @ -- -- instead of returning one binding for @X1@ and another binding for @X2@. -- -- 'getRecordSelectors' attempts to filter out \"naughty\" record selectors -- whose types mention existentially quantified type variables. But see the -- documentation for 'conExistentialTvbs' for limitations to this approach. -- See https://github.com/goldfirere/singletons/issues/180 for an example where -- the latter behavior can bite you. getRecordSelectors :: Quasi q => DType -- ^ the type of the argument -> [DCon] -> q [DLetDec] getRecordSelectors arg_ty cons = merge_let_decs `fmap` concatMapM get_record_sels cons where get_record_sels (DCon _ _ con_name con _) = case con of DRecC fields -> go fields _ -> return [] where go fields = do varName <- qNewName "field" let tvbs = fvDType arg_ty forall' = DForallT (map DPlainTV $ S.toList tvbs) [] num_pats = length fields return $ concat [ [ DSigD name (forall' $ DArrowT `DAppT` arg_ty `DAppT` res_ty) , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)] (DVarE varName)] ] | ((name, _strict, res_ty), n) <- zip fields [0..] , fvDType res_ty `S.isSubsetOf` tvbs -- exclude "naughty" selectors ] mk_field_pats :: Int -> Int -> Name -> [DPat] mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa) mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name merge_let_decs :: [DLetDec] -> [DLetDec] merge_let_decs decs = let (name_clause_map, decs') = gather_decs M.empty S.empty decs in augment_clauses name_clause_map decs' -- First, for each record selector-related declarations, do the following: -- -- 1. If it's a DFunD... -- a. If we haven't encountered it before, add a mapping from its Name -- to its associated DClauses, and continue. -- b. If we have encountered it before, augment the existing Name's -- mapping with the new clauses. Then remove the DFunD from the list -- and continue. -- 2. If it's a DSigD... -- a. If we haven't encountered it before, remember its Name and continue. -- b. If we have encountered it before, remove the DSigD from the list -- and continue. -- 3. Otherwise, continue. -- -- After this, scan over the resulting list once more with the mapping -- that we accumulated. For every DFunD, replace its DClauses with the -- ones corresponding to its Name in the mapping. -- -- Note that this algorithm combines all of the DClauses for each unique -- Name, while preserving the order in which the DFunDs were originally -- found. Moreover, it removes duplicate DSigD entries. Using Maps and -- Sets avoid quadratic blowup for data types with many record selectors. where gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec] -> (M.Map Name [DClause], [DLetDec]) gather_decs name_clause_map _ [] = (name_clause_map, []) gather_decs name_clause_map type_sig_names (x:xs) -- 1. | DFunD n clauses <- x = let name_clause_map' = M.insertWith (\new old -> old ++ new) n clauses name_clause_map in if n `M.member` name_clause_map then gather_decs name_clause_map' type_sig_names xs else let (map', decs') = gather_decs name_clause_map' type_sig_names xs in (map', x:decs') -- 2. | DSigD n _ <- x = if n `S.member` type_sig_names then gather_decs name_clause_map type_sig_names xs else let (map', decs') = gather_decs name_clause_map (n `S.insert` type_sig_names) xs in (map', x:decs') -- 3. | otherwise = let (map', decs') = gather_decs name_clause_map type_sig_names xs in (map', x:decs') augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec] augment_clauses _ [] = [] augment_clauses name_clause_map (x:xs) | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map = DFunD n merged_clauses:augment_clauses name_clause_map xs | otherwise = x:augment_clauses name_clause_map xs -- | Create new kind variable binder names corresponding to the return kind of -- a data type. This is useful when you have a data type like: -- -- @ -- data Foo :: forall k. k -> Type -> Type where ... -- @ -- -- But you want to be able to refer to the type @Foo a b@. -- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@, -- discover that is has two visible argument kinds, and return as a result -- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary. mkExtraDKindBinders :: DsMonad q => DKind -> q [DTyVarBndr] mkExtraDKindBinders = expandType >=> mkExtraDKindBinders' -- | Returns all of a constructor's existentially quantified type variable -- binders. -- -- Detecting the presence of existentially quantified type variables in the -- context of Template Haskell is quite involved. Here is an example that -- we will use to explain how this works: -- -- @ -- data family Foo a b -- data instance Foo (Maybe a) b where -- MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z] -- @ -- -- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are -- existentially quantified. Note that @MkFoo@ desugars (in Core) to -- something like this: -- -- @ -- data instance Foo (Maybe a) b where -- MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b -- @ -- -- Here, we can see that @a@ appears in the desugared return type (it is a -- simple alpha-renaming of @x@), so it is universally quantified. On the other -- hand, neither @y@ nor @z@ appear in the desugared return type, so they are -- existentially quantified. -- -- This analysis would not have been possible without knowing what the original -- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why -- we require it as an argument. Our algorithm for detecting existentially -- quantified variables is not too different from what was described above: -- we match the constructor's return type with the original data type, forming -- a substitution, and check which quantified variables are not part of the -- domain of the substitution. -- -- Be warned: this may overestimate which variables are existentially -- quantified when kind variables are involved. For instance, consider this -- example: -- -- @ -- data S k (a :: k) -- data T a where -- MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a -- @ -- -- Here, the kind variable @k@ does not appear syntactically in the return type -- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential. -- -- There are various tricks we could employ to improve this, but ultimately, -- making this behave correctly with respect to @PolyKinds@ 100% of the time -- would amount to performing kind inference in Template Haskell, which is -- quite difficult. For the sake of simplicity, we have decided to stick with -- a dumb-but-predictable syntactic check. conExistentialTvbs :: DsMonad q => DType -- ^ The type of the original data declaration -> DCon -> q [DTyVarBndr] conExistentialTvbs data_ty (DCon tvbs _ _ _ ret_ty) = -- Due to GHC Trac #13885, it's possible that the type variables bound by -- a GADT constructor will shadow those that are bound by the data type. -- This function assumes this isn't the case in certain parts (e.g., when -- unifying types), so we do an alpha-renaming of the -- constructor-bound variables before proceeding. substTyVarBndrs M.empty tvbs $ \subst tvbs' -> do renamed_ret_ty <- substTy subst ret_ty data_ty' <- expandType data_ty ret_ty' <- expandType renamed_ret_ty case matchTy YesIgnore ret_ty' data_ty' of Nothing -> fail $ showString "Unable to match type " . showsPrec 11 ret_ty' . showString " with " . showsPrec 11 data_ty' $ "" Just gadtSubt -> return [ tvb | tvb <- tvbs' , M.notMember (dtvbName tvb) gadtSubt ] th-desugar-1.9/Language/Haskell/TH/Desugar/0000755000000000000000000000000013350246155016633 5ustar0000000000000000th-desugar-1.9/Language/Haskell/TH/Desugar/Expand.hs0000644000000000000000000002254713350246155020420 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Expand.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, NoMonomorphismRestriction, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Expand -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Expands type synonyms and type families in desugared types. -- See also the package th-expand-syns for doing this to -- non-desugared types. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Expand ( -- * Expand synonyms soundly expand, expandType, -- * Expand synonyms potentially unsoundly expandUnsoundly ) where import qualified Data.Map as M import Control.Monad #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics import qualified Data.Traversable as T import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Subst -- | Expands all type synonyms in a desugared type. Also expands open type family -- applications. (In GHCs before 7.10, this part does not work if there are any -- variables.) Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where go :: [DType] -> DType -> q DType go [] (DForallT tvbs cxt ty) = DForallT tvbs <$> mapM (expand_pred ign) cxt <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go args (DAppT t1 t2) = do t2' <- expand_type ign t2 go (t2' : args) t1 go args (DSigT ty ki) = do ty' <- go [] ty ki' <- go [] ki finish (DSigT ty' ki') args go args (DConT n) = expand_con ign n args go args ty@(DVarT _) = finish ty args go args ty@DArrowT = finish ty args go args ty@(DLitT _) = finish ty args go args ty@DWildCardT = finish ty args finish :: DType -> [DType] -> q DType finish ty args = return $ applyDType ty args -- | Expands all type synonyms in a desugared predicate. expand_pred :: forall q. DsMonad q => IgnoreKinds -> DPred -> q DPred expand_pred ign = go [] where go :: [DType] -> DPred -> q DPred go [] (DForallPr tvbs cxt p) = DForallPr tvbs <$> mapM (go []) cxt <*> expand_pred ign p go _ (DForallPr {}) = impossible "A quantified constraint is applied to another constraint." go args (DAppPr p t) = do t' <- expand_type ign t go (t' : args) p go args (DSigPr p k) = do p' <- go [] p k' <- expand_type ign k finish (DSigPr p' k') args go args (DConPr n) = do ty <- expand_con ign n args dTypeToDPred ty go args p@(DVarPr _) = finish p args go args p@DWildCardPr = finish p args finish :: DPred -> [DType] -> q DPred finish p args = return $ foldl DAppPr p args -- | Expand a constructor with given arguments expand_con :: forall q. DsMonad q => IgnoreKinds -> Name -- ^ Tycon name -> [DType] -- ^ Arguments -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n case info of TyConI (TySynD _ _ StarT) -- See Note [Don't expand synonyms for *] -> return $ applyDType (DConT typeKindName) args _ -> go info where go :: Info -> q DType go info = do dinfo <- dsInfo info args_ok <- allM no_tyvars_tyfams args case dinfo of DTyConI (DTySynD _n tvbs rhs) _ | length args >= length tvbs -- this should always be true! -> do let (syn_args, rest_args) = splitAtList tvbs args ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs ty' <- expand_type ign ty return $ applyDType ty' rest_args DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ | length args >= length tvbs -- this should always be true! #if __GLASGOW_HASKELL__ < 709 , args_ok #endif -> do let (syn_args, rest_args) = splitAtList tvbs args -- We need to get the correct instance. If we fail to reify anything -- (e.g., if a type family is quasiquoted), then fall back by -- pretending that there are no instances in scope. insts <- qRecover (return []) $ qReifyInstances n (map typeToTH syn_args) dinsts <- dsDecs insts case dinsts of [DTySynInstD _n (DTySynEqn lhs rhs)] | Just subst <- unionMaybeSubsts $ zipWith (matchTy ign) lhs syn_args -> do ty <- substTy subst rhs ty' <- expand_type ign ty return $ applyDType ty' rest_args _ -> give_up DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ | length args >= length tvbs , args_ok -> do let (syn_args, rest_args) = splitAtList tvbs args rhss <- mapMaybeM (check_eqn syn_args) eqns case rhss of (rhs : _) -> do rhs' <- expand_type ign rhs return $ applyDType rhs' rest_args [] -> give_up where -- returns the substed rhs check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType) check_eqn arg_tys (DTySynEqn lhs rhs) = do let m_subst = unionMaybeSubsts $ zipWith (matchTy ign) lhs arg_tys T.mapM (flip substTy rhs) m_subst _ -> give_up -- Used when we can't proceed with type family instance expansion any more, -- and must conservatively return the orignal type family applied to its -- arguments. give_up :: q DType give_up = return $ applyDType (DConT n) args no_tyvars_tyfams :: Data a => a -> q Bool no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam) no_tyvar_tyfam :: DType -> q Bool no_tyvar_tyfam (DVarT _) = return False no_tyvar_tyfam (DConT con_name) = do m_info <- dsReify con_name return $ case m_info of Nothing -> False -- we don't know anything. False is safe. Just (DTyConI (DOpenTypeFamilyD {}) _) -> False Just (DTyConI (DDataFamilyD {}) _) -> False Just (DTyConI (DClosedTypeFamilyD {}) _) -> False _ -> True no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True {- Note [Don't expand synonyms for *] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We deliberately avoid expanding type synonyms for * such as Type and ★. Why? If you reify any such type synonym using Template Haskell, this is what you'll get: TyConI (TySynD [] StarT) If you blindly charge ahead and recursively inspect the right-hand side of this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type, and get back another type synonym with StarT as its right-hand side. Then you'll recursively inspect StarT and find yourself knee-deep in an infinite loop. To prevent these sorts of shenanigans, we simply stop whenever we see a type synonym with StarT as its right-hand side and return Type. -} -- | Extract the name from a @TyVarBndr@ extractDTvbName :: DTyVarBndr -> Name extractDTvbName (DPlainTV n) = n extractDTvbName (DKindedTV n _) = n -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "best effort" -- basis. Normally, the first parameter should have a type like -- 'DExp' or 'DLetDec'. expand :: (DsMonad q, Data a) => a -> q a expand = expand_ NoIgnore -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "better -- than best effort" basis. This means that it will try so hard that it will -- sometimes do the wrong thing. Specifically, any kind parameters to type -- families are ignored. So, if we have -- -- > type family F (x :: k) where -- > F (a :: *) = Int -- -- 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the -- expansion should only work for type of kind @*@. -- -- This function is useful because plain old 'expand' will simply fail -- to expand type families that make use of kinds. Sometimes, the kinds -- are benign and we want to expand anyway. Use this function in that case. expandUnsoundly :: (DsMonad q, Data a) => a -> q a expandUnsoundly = expand_ YesIgnore -- | Generalization of 'expand' that either can or won't ignore kind annotations.sx expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a expand_ ign = everywhereM (mkM (expand_type ign) >=> mkM (expand_pred ign)) th-desugar-1.9/Language/Haskell/TH/Desugar/Reify.hs0000644000000000000000000006046513350246155020260 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Reify.hs (c) Richard Eisenberg 2014 rae@cs.brynmawr.edu Allows for reification from a list of declarations, without looking a name up in the environment. -} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Language.Haskell.TH.Desugar.Reify ( -- * Reification reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, -- ** Fixity reification qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs, -- * Datatype lookup getDataD, dataConNameToCon, dataConNameToDataName, -- * Value and type lookup lookupValueNameWithLocals, lookupTypeNameWithLocals, mkDataNameWithLocals, mkTypeNameWithLocals, reifyNameSpace, -- * Monad support DsMonad(..), DsM, withLocalDeclarations ) where import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Monad.RWS import Data.List import Data.Maybe #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import qualified Data.Set as S #if __GLASGOW_HASKELL__ >= 800 import qualified Control.Monad.Fail as Fail #else import qualified Control.Monad as Fail #endif import Language.Haskell.TH.ExpandSyns ( expandSyns ) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) import Language.Haskell.TH.Desugar.Util -- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked -- declarations. To establish this list of not-yet-typechecked declarations, -- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. -- Note that no inferred type information is available from local declarations; -- bottoms may be used if necessary. reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info) reifyWithLocals_maybe name = qRecover (return . reifyInDecs name =<< localDeclarations) (Just `fmap` qReify name) -- | Like 'reifyWithLocals_maybe', but throws an exception upon failure, -- warning the user about separating splices. reifyWithLocals :: DsMonad q => Name -> q Info reifyWithLocals name = do m_info <- reifyWithLocals_maybe name case m_info of Nothing -> reifyFail name Just i -> return i -- | Reify a declaration, warning the user about splices if the reify fails. -- The warning says that reification can fail if you try to reify a type in -- the same splice as it is declared. reifyWithWarning :: Quasi q => Name -> q Info reifyWithWarning name = qRecover (reifyFail name) (qReify name) -- | Print out a warning about separating splices and fail. #if __GLASGOW_HASKELL__ >= 800 reifyFail :: Fail.MonadFail m => Name -> m a #else reifyFail :: Monad m => Name -> m a #endif reifyFail name = Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ "declarations failed.\nThis lookup fails if the declaration " ++ "referenced was made in the same Template\nHaskell splice as the use " ++ "of the declaration. If this is the case, put\nthe reference to " ++ "the declaration in a new splice." --------------------------------- -- Utilities --------------------------------- -- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest -> q ([TyVarBndr], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of #if __GLASGOW_HASKELL__ > 710 DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con] #else DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con] #endif _ -> badDeclaration where go tvbs mk cons = do k <- maybe (pure (ConT typeKindName)) (runQ . expandSyns) mk extra_tvbs <- mkExtraKindBindersGeneric unravelType KindedTV k let all_tvbs = tvbs ++ extra_tvbs return (all_tvbs, cons) badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err -- | From the name of a data constructor, retrive the datatype definition it -- is a part of. dataConNameToDataName :: DsMonad q => Name -> q Name dataConNameToDataName con_name = do info <- reifyWithLocals con_name case info of #if __GLASGOW_HASKELL__ > 710 DataConI _name _type parent_name -> return parent_name #else DataConI _name _type parent_name _fixity -> return parent_name #endif _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ "a data constructor." -- | From the name of a data constructor, retrieve its definition as a @Con@ dataConNameToCon :: DsMonad q => Name -> q Con dataConNameToCon con_name = do -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s type_name <- dataConNameToDataName con_name (_, cons) <- getDataD "This seems to be an error in GHC." type_name let m_con = find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con Nothing -> impossible "Datatype does not contain one of its own constructors." where get_con_name (NormalC name _) = [name] get_con_name (RecC name _) = [name] get_con_name (InfixC _ name _) = [name] get_con_name (ForallC _ _ con) = get_con_name con #if __GLASGOW_HASKELL__ > 710 get_con_name (GadtC names _ _) = names get_con_name (RecGadtC names _ _) = names #endif -------------------------------------------------- -- DsMonad -------------------------------------------------- -- | A 'DsMonad' stores some list of declarations that should be considered -- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. class Quasi m => DsMonad m where -- | Produce a list of local declarations. localDeclarations :: m [Dec] instance DsMonad Q where localDeclarations = return [] instance DsMonad IO where localDeclarations = return [] -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a) deriving ( Functor, Applicative, Monad, MonadTrans, Quasi #if __GLASGOW_HASKELL__ >= 800 , Fail.MonadFail #endif #if __GLASGOW_HASKELL__ >= 803 , MonadIO #endif ) instance Quasi q => DsMonad (DsM q) where localDeclarations = DsM ask instance DsMonad m => DsMonad (ReaderT r m) where localDeclarations = lift localDeclarations instance DsMonad m => DsMonad (StateT s m) where localDeclarations = lift localDeclarations instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where localDeclarations = lift localDeclarations instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where localDeclarations = lift localDeclarations -- | Add a list of declarations to be considered when reifying local -- declarations. withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a withLocalDeclarations new_decs (DsM x) = do orig_decs <- localDeclarations runReaderT x (orig_decs ++ new_decs) --------------------------- -- Reifying local declarations --------------------------- -- | Look through a list of declarations and possibly return a relevant 'Info' reifyInDecs :: Name -> [Dec] -> Maybe Info reifyInDecs n decs = snd `fmap` firstMatch (reifyInDec n decs) decs -- | Look through a list of declarations and possibly return a fixity. reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity reifyFixityInDecs n = firstMatch match_fixity where match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity match_fixity _ = Nothing -- | A reified thing along with the name of that thing. type Named a = (Name, a) reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info) reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs) reifyInDec n decs (ValD pat _ _) | Just n' <- find (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just (n', mkVarI n decs) #if __GLASGOW_HASKELL__ > 710 reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) #else reifyInDec n _ dec@(DataD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) #endif reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' = Just (n', ClassI (stripClassDec dec) (findInstances n decs)) reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n' = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n' = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n' = Just (n', FamilyI dec []) #else reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n' = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) #if __GLASGOW_HASKELL__ >= 707 reifyInDec n _ dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n' = Just (n', FamilyI dec []) #endif #endif #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) #endif #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] = Just info #else reifyInDec n decs (DataD _ ty_name tvbs cons _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs con _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] = Just info #endif #if __GLASGOW_HASKELL__ > 710 reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs = Just (n', ClassOpI n (addClassCxt ty_name tvbs ty) ty_name) #else reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs = Just (n', ClassOpI n (addClassCxt ty_name tvbs ty) ty_name (fromMaybe defaultFixity $ reifyFixityInDecs n $ sub_decs ++ decs)) #endif reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs = Just info #if __GLASGOW_HASKELL__ >= 711 reifyInDec n decs (InstanceD _ _ _ sub_decs) #else reifyInDec n decs (InstanceD _ _ sub_decs) #endif | Just info <- firstMatch reify_in_instance sub_decs = Just info where reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataInstD _ ty_name tys _ cons _) | Just info <- maybeReifyCon n decs ty_name tys cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) | Just info <- maybeReifyCon n decs ty_name tys [con] = Just info #else reifyInDec n decs (DataInstD _ ty_name tys cons _) | Just info <- maybeReifyCon n decs ty_name tys cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys con _) | Just info <- maybeReifyCon n decs ty_name tys [con] = Just info #endif reifyInDec _ _ _ = Nothing maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe (Named Info) #if __GLASGOW_HASKELL__ > 710 maybeReifyCon n _decs ty_name ty_args cons | Just (n', con) <- findCon n cons = Just (n', DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name) #else maybeReifyCon n decs ty_name ty_args cons | Just (n', con) <- findCon n cons = Just (n', DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name fixity) #endif | Just (n', ty) <- findRecSelector n cons -- we don't try to ferret out naughty record selectors. #if __GLASGOW_HASKELL__ > 710 = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing) #else = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity) #endif where result_ty = foldl AppT (ConT ty_name) ty_args con_to_type (NormalC _ stys) = mkArrows (map snd stys) result_ty con_to_type (RecC _ vstys) = mkArrows (map thdOf3 vstys) result_ty con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c) #if __GLASGOW_HASKELL__ > 710 con_to_type (GadtC _ stys rty) = mkArrows (map snd stys) rty con_to_type (RecGadtC _ vstys rty) = mkArrows (map thdOf3 vstys) rty #endif #if __GLASGOW_HASKELL__ < 711 fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs #endif tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args maybeReifyCon _ _ _ _ _ = Nothing mkVarI :: Name -> [Dec] -> Info mkVarI n decs = mkVarITy n decs (maybe (no_type n) snd $ findType n decs) mkVarITy :: Name -> [Dec] -> Type -> Info #if __GLASGOW_HASKELL__ > 710 mkVarITy n _decs ty = VarI n ty Nothing #else mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $ reifyFixityInDecs n decs) #endif findType :: Name -> [Dec] -> Maybe (Named Type) findType n = firstMatch match_type where match_type (SigD n' ty) | n `nameMatches` n' = Just (n', ty) match_type _ = Nothing #if __GLASGOW_HASKELL__ >= 801 mkPatSynI :: Name -> [Dec] -> Info mkPatSynI n decs = PatSynI n (fromMaybe (no_type n) $ findPatSynType n decs) findPatSynType :: Name -> [Dec] -> Maybe PatSynType findPatSynType n = firstMatch match_pat_syn_type where match_pat_syn_type (PatSynSigD n' psty) | n `nameMatches` n' = Just psty match_pat_syn_type _ = Nothing #endif no_type :: Name -> Type no_type n = error $ "No type information found in local declaration for " ++ show n findInstances :: Name -> [Dec] -> [Dec] findInstances n = map stripInstanceDec . concatMap match_instance where #if __GLASGOW_HASKELL__ >= 711 match_instance d@(InstanceD _ _ ty _) #else match_instance d@(InstanceD _ ty _) #endif | ConT n' <- ty_head ty , n `nameMatches` n' = [d] #if __GLASGOW_HASKELL__ > 710 match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] #else match_instance d@(DataInstD _ n' _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d] #endif #if __GLASGOW_HASKELL__ >= 707 match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] #else match_instance d@(TySynInstD n' _ _) | n `nameMatches` n' = [d] #endif #if __GLASGOW_HASKELL__ >= 711 match_instance (InstanceD _ _ _ decs) #else match_instance (InstanceD _ _ decs) #endif = concatMap match_instance decs match_instance _ = [] ty_head (ForallT _ _ ty) = ty_head ty ty_head (AppT ty _) = ty_head ty ty_head (SigT ty _) = ty_head ty ty_head ty = ty stripClassDec :: Dec -> Dec stripClassDec (ClassD cxt name tvbs fds sub_decs) = ClassD cxt name tvbs fds sub_decs' where sub_decs' = mapMaybe go sub_decs go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty #if __GLASGOW_HASKELL__ > 710 go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d #endif go _ = Nothing stripClassDec dec = dec addClassCxt :: Name -> [TyVarBndr] -> Type -> Type addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty where #if __GLASGOW_HASKELL__ < 709 class_cxt = [ClassP class_name (map tvbToType tvbs)] #else class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)] #endif stripInstanceDec :: Dec -> Dec #if __GLASGOW_HASKELL__ >= 711 stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] #else stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty [] #endif stripInstanceDec dec = dec mkArrows :: [Type] -> Type -> Type mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type maybeForallT tvbs cxt ty | null tvbs && null cxt = ty | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 | otherwise = ForallT tvbs cxt ty findCon :: Name -> [Con] -> Maybe (Named Con) findCon n = firstMatch match_con where match_con :: Con -> Maybe (Named Con) match_con con = case con of NormalC n' _ | n `nameMatches` n' -> Just (n', con) RecC n' _ | n `nameMatches` n' -> Just (n', con) InfixC _ n' _ | n `nameMatches` n' -> Just (n', con) ForallC _ _ c -> case match_con c of Just (n', _) -> Just (n', con) Nothing -> Nothing #if __GLASGOW_HASKELL__ > 710 GadtC nms _ _ -> gadt_case con nms RecGadtC nms _ _ -> gadt_case con nms #endif _ -> Nothing #if __GLASGOW_HASKELL__ > 710 gadt_case :: Con -> [Name] -> Maybe (Named Con) gadt_case con nms = case find (n `nameMatches`) nms of Just n' -> Just (n', con) Nothing -> Nothing #endif findRecSelector :: Name -> [Con] -> Maybe (Named Type) findRecSelector n = firstMatch match_con where match_con (RecC _ vstys) = firstMatch match_rec_sel vstys #if __GLASGOW_HASKELL__ >= 800 match_con (RecGadtC _ vstys _) = firstMatch match_rec_sel vstys #endif match_con (ForallC _ _ c) = match_con c match_con _ = Nothing match_rec_sel (n', _, ty) | n `nameMatches` n' = Just (n', ty) match_rec_sel _ = Nothing handleBug8884 :: Dec -> Dec #if __GLASGOW_HASKELL__ >= 707 handleBug8884 = id #else handleBug8884 (FamilyD flav name tvbs m_kind) = FamilyD flav name tvbs (Just stupid_kind) where kind_from_maybe = fromMaybe StarT tvb_kind (PlainTV _) = Nothing tvb_kind (KindedTV _ k) = Just k result_kind = kind_from_maybe m_kind args_kinds = map (kind_from_maybe . tvb_kind) tvbs stupid_kind = mkArrows args_kinds result_kind handleBug8884 dec = dec #endif --------------------------------- -- Reifying fixities --------------------------------- -- -- This section allows GHC 7.x to call reifyFixity #if __GLASGOW_HASKELL__ < 711 qReifyFixity :: Quasi m => Name -> m (Maybe Fixity) qReifyFixity name = do info <- qReify name return $ case info of ClassOpI _ _ _ fixity -> Just fixity DataConI _ _ _ fixity -> Just fixity VarI _ _ _ fixity -> Just fixity _ -> Nothing {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function @bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) reifyFixity = qReifyFixity #endif -- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return of -- @Nothing@ might mean that the name is not in scope, or it might mean -- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if -- you really need to tell the difference.) reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity) reifyFixityWithLocals name = qRecover (return . reifyFixityInDecs name =<< localDeclarations) (qReifyFixity name) -------------------------------------- -- Lookuping name value and type names -------------------------------------- -- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value -- with the same name can be found. lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupValueNameWithLocals = lookupNameWithLocals False -- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type -- with the same name can be found. lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupTypeNameWithLocals = lookupNameWithLocals True lookupNameWithLocals :: DsMonad q => Bool -> String -> q (Maybe Name) lookupNameWithLocals ns s = do mb_name <- qLookupName ns s case mb_name of j_name@(Just{}) -> return j_name Nothing -> consult_locals where built_name = mkName s consult_locals = do decs <- localDeclarations let mb_infos = map (reifyInDec built_name decs) decs infos = catMaybes mb_infos return $ firstMatch (if ns then find_type_name else find_value_name) infos -- These functions work over Named Infos so we can avoid performing -- tiresome pattern-matching to retrieve the name associated with each Info. find_type_name, find_value_name :: Named Info -> Maybe Name find_type_name (n, info) = case infoNameSpace info of TcClsName -> Just n VarName -> Nothing DataName -> Nothing find_value_name (n, info) = case infoNameSpace info of VarName -> Just n DataName -> Just n TcClsName -> Nothing -- | Like TH's @lookupValueName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkDataName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkDataNameWithLocals :: DsMonad q => String -> q Name mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkTypeName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkTypeNameWithLocals :: DsMonad q => String -> q Name mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc -- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to -- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is -- immediately returned. Otherwise, reification is used to lookup up the -- 'NameSpace' (consulting local declarations if necessary). -- -- Note that if a 'Name' lives in two different 'NameSpaces' (which can -- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both -- a function and a type family), then this function will simply return -- whichever 'NameSpace' is discovered first via reification. If you wish -- to find a 'Name' in a particular 'NameSpace', use the -- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions. reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace) reifyNameSpace n@(Name _ nf) = case nf of -- NameGs are simple, as they have a NameSpace attached. NameG ns _ _ -> pure $ Just ns -- For other names, we must use reification to determine what NameSpace -- it lives in (if any). _ -> do mb_info <- reifyWithLocals_maybe n pure $ fmap infoNameSpace mb_info -- | Determine a name's 'NameSpace' from its 'Info'. infoNameSpace :: Info -> NameSpace infoNameSpace info = case info of ClassI{} -> TcClsName TyConI{} -> TcClsName FamilyI{} -> TcClsName PrimTyConI{} -> TcClsName TyVarI{} -> TcClsName ClassOpI{} -> VarName VarI{} -> VarName DataConI{} -> DataName #if __GLASGOW_HASKELL__ >= 801 PatSynI{} -> DataName #endif th-desugar-1.9/Language/Haskell/TH/Desugar/Util.hs0000644000000000000000000003305313350246155020110 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Util.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Utility functions for th-desugar package. -} {-# LANGUAGE CPP, TupleSections #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #endif module Language.Haskell.TH.Desugar.Util ( newUniqueName, impossible, nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName, stripVarP_maybe, extractBoundNamesStmt, concatMapM, mapAccumLM, mapMaybeM, expectJustM, stripPlainTV_maybe, thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat, tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, mkExtraKindBindersGeneric, unravelType ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Syntax import Control.Monad ( replicateM ) import qualified Data.Set as S import Data.Foldable import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe #if __GLASGOW_HASKELL__ >= 800 import qualified Data.Kind as Kind #endif #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif ---------------------------------------- -- TH manipulations ---------------------------------------- -- | Like newName, but even more unique (unique across different splices), -- and with unique @nameBase@s. Precondition: the string is a valid Haskell -- alphanumeric identifier (could be upper- or lower-case). newUniqueName :: Quasi q => String -> q Name newUniqueName str = do n <- qNewName str qNewName $ show n -- | @mkNameWith lookup_fun mkName_fun str@ looks up the exact 'Name' of @str@ -- using the function @lookup_fun@. If it finds 'Just' the 'Name', meaning -- that it is bound in the current scope, then it is returned. If it finds -- 'Nothing', it assumes that @str@ is declared in the current module, and -- uses @mkName_fun@ to construct the appropriate 'Name' to return. mkNameWith :: Quasi q => (String -> q (Maybe Name)) -> (String -> String -> String -> Name) -> String -> q Name mkNameWith lookup_fun mkName_fun str = do m_name <- lookup_fun str case m_name of Just name -> return name Nothing -> do Loc { loc_package = pkg, loc_module = modu } <- qLocation return $ mkName_fun pkg modu str -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. mkTypeName :: Quasi q => String -> q Name mkTypeName = mkNameWith (qLookupName True) mkNameG_tc -- | Like TH's @lookupDataName@, but if this name is not bound, then we assume -- it is declared in the current module. mkDataName :: Quasi q => String -> q Name mkDataName = mkNameWith (qLookupName False) mkNameG_d -- | Is this name a data constructor name? A 'False' answer means "unsure". isDataName :: Name -> Bool isDataName (Name _ (NameG DataName _ _)) = True isDataName _ = False -- | Extracts the name out of a variable pattern, or returns @Nothing@ stripVarP_maybe :: Pat -> Maybe Name stripVarP_maybe (VarP name) = Just name stripVarP_maybe _ = Nothing -- | Extracts the name out of a @PlainTV@, or returns @Nothing@ stripPlainTV_maybe :: TyVarBndr -> Maybe Name stripPlainTV_maybe (PlainTV n) = Just n stripPlainTV_maybe _ = Nothing -- | Report that a certain TH construct is impossible impossible :: Monad q => String -> q a impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") -- | Extract a 'Name' from a 'TyVarBndr' tvbName :: TyVarBndr -> Name tvbName (PlainTV n) = n tvbName (KindedTV n _) = n -- | Convert a 'TyVarBndr' into a 'Type' tvbToType :: TyVarBndr -> Type tvbToType = VarT . tvbName -- | Do two names name the same thing? nameMatches :: Name -> Name -> Bool nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) | NameS <- flav1 = occ1 == occ2 | NameS <- flav2 = occ1 == occ2 | NameQ mod1 <- flav1 , NameQ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | NameQ mod1 <- flav1 , NameG _ _ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | NameG _ _ mod1 <- flav1 , NameQ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | otherwise = n1 == n2 -- | Extract the degree of a tuple tupleDegree_maybe :: String -> Maybe Int tupleDegree_maybe s = do '(' : s1 <- return s (commas, ")") <- return $ span (== ',') s1 let degree | "" <- commas = 0 | otherwise = length commas + 1 return degree -- | Extract the degree of a tuple name tupleNameDegree_maybe :: Name -> Maybe Int tupleNameDegree_maybe = tupleDegree_maybe . nameBase -- | Extract the degree of an unboxed sum unboxedSumDegree_maybe :: String -> Maybe Int unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|' -- | Extract the degree of an unboxed sum name unboxedSumNameDegree_maybe :: Name -> Maybe Int unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int unboxedTupleDegree_maybe = unboxedSumTupleDegree_maybe ',' -- | Extract the degree of an unboxed sum or tuple unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int unboxedSumTupleDegree_maybe sep s = do '(' : '#' : s1 <- return s (seps, "#)") <- return $ span (== sep) s1 let degree | "" <- seps = 0 | otherwise = length seps + 1 return degree -- | Extract the degree of an unboxed tuple name unboxedTupleNameDegree_maybe :: Name -> Maybe Int unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase -- | If the argument is a tuple type, return the components splitTuple_maybe :: Type -> Maybe [Type] splitTuple_maybe t = go [] t where go args (t1 `AppT` t2) = go (t2:args) t1 go args (t1 `SigT` _k) = go args t1 go args (ConT con_name) | Just degree <- tupleNameDegree_maybe con_name , length args == degree = Just args go args (TupleT degree) | length args == degree = Just args go _ _ = Nothing -- | Like 'mkExtraDKindBinders', but parameterized to allow working over both -- 'Kind'/'TyVarBndr' and 'DKind'/'DTyVarBndr'. mkExtraKindBindersGeneric :: Quasi q => (kind -> ([tyVarBndr], [pred], [kind], kind)) -> (Name -> kind -> tyVarBndr) -> kind -> q [tyVarBndr] mkExtraKindBindersGeneric unravel mkKindedTV k = do let (_, _, args, _) = unravel k names <- replicateM (length args) (qNewName "a") return (zipWith mkKindedTV names args) -- | Decompose a function 'Type' into its type variables, its context, its -- argument types, and its result type. unravelType :: Type -> ([TyVarBndr], [Pred], [Type], Type) unravelType (ForallT tvbs cxt ty) = let (tvbs', cxt', tys, res) = unravelType ty in (tvbs ++ tvbs', cxt ++ cxt', tys, res) unravelType (AppT (AppT ArrowT t1) t2) = let (tvbs, cxt, tys, res) = unravelType t2 in (tvbs, cxt, t1 : tys, res) unravelType t = ([], [], [], t) ---------------------------------------- -- Free names, etc. ---------------------------------------- -- | Check if a name occurs anywhere within a TH tree. nameOccursIn :: Data a => Name -> a -> Bool nameOccursIn n = everything (||) $ mkQ False (== n) -- | Extract all Names mentioned in a TH tree. allNamesIn :: Data a => a -> [Name] allNamesIn = everything (++) $ mkQ [] (:[]) -- | Extract the names bound in a @Stmt@ extractBoundNamesStmt :: Stmt -> S.Set Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs extractBoundNamesStmt (NoBindS _) = S.empty extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. extractBoundNamesDec :: Dec -> S.Set Name extractBoundNamesDec (FunD name _) = S.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat extractBoundNamesDec _ = S.empty -- | Extract the names bound in a @Pat@ extractBoundNamesPat :: Pat -> S.Set Name extractBoundNamesPat (LitP _) = S.empty extractBoundNamesPat (VarP name) = S.singleton name extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` extractBoundNamesPat p2 extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` extractBoundNamesPat p2 extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat extractBoundNamesPat (AsP name pat) = S.singleton name `S.union` extractBoundNamesPat pat extractBoundNamesPat WildP = S.empty extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in foldMap extractBoundNamesPat pats extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat #if __GLASGOW_HASKELL__ >= 801 extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat #endif freeNamesOfTypes :: [Type] -> S.Set Name freeNamesOfTypes = foldMap go where go (ForallT tvbs cxt ty) = (foldMap go_tvb tvbs <> go ty <> foldMap go_pred cxt) S.\\ S.fromList (map tvbName tvbs) go (AppT t1 t2) = go t1 <> go t2 go (SigT ty ki) = go ty <> go ki go (VarT n) = S.singleton n go _ = S.empty #if __GLASGOW_HASKELL__ >= 709 go_pred = go #else go_pred (ClassP _ tys) = freeNamesOfTypes tys go_pred (EqualP t1 t2) = go t1 <> go t2 #endif go_tvb (PlainTV{}) = S.empty go_tvb (KindedTV _ k) = go k ---------------------------------------- -- General utility ---------------------------------------- -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x) splitAtList (_ : t) (x : xs) = let (as, bs) = splitAtList t xs in (x : as, bs) splitAtList (_ : _) [] = ([], []) thdOf3 :: (a,b,c) -> c thdOf3 (_,_,c) = c thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) thirdOf3 f (c, d, a) = (c, d, f a) -- lift concatMap into a monad -- could this be more efficient? -- | Concatenate the result of a @mapM@ concatMapM :: (Monad monad, Monoid monoid, Traversable t) => (a -> monad monoid) -> t a -> monad monoid concatMapM fn list = do bss <- mapM fn list return $ fold bss -- like GHC's -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs mapAccumLM _ s [] = return (s, []) mapAccumLM f s (x:xs) = do (s1, x') <- f s x (s2, xs') <- mapAccumLM f s1 xs return (s2, x' : xs') -- like GHC's mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM _ [] = return [] mapMaybeM f (x:xs) = do y <- f x ys <- mapMaybeM f xs return $ case y of Nothing -> ys Just z -> z : ys expectJustM :: Monad m => String -> Maybe a -> m a expectJustM _ (Just x) = return x expectJustM err Nothing = fail err firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs -- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). -- -- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,20,30],"foo") -- -- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,200,3000],"foo") topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b topEverywhereM handler = gmapM (topEverywhereM handler) `extM` handler -- Checks if a String names a valid Haskell infix data constructor -- (i.e., does it begin with a colon?). isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False -- | Returns 'True' if the argument 'Name' is that of 'Kind.Type' -- (or @*@ or 'Kind.★', to support older GHCs). isTypeKindName :: Name -> Bool isTypeKindName n = n == typeKindName #if __GLASGOW_HASKELL__ < 805 || n == starKindName || n == uniStarKindName #endif -- | The 'Name' of: -- -- 1. The kind 'Kind.Type', on GHC 8.0 or later. -- 2. The kind @*@ on older GHCs. typeKindName :: Name #if __GLASGOW_HASKELL__ >= 800 typeKindName = ''Kind.Type #else typeKindName = starKindName #endif #if __GLASGOW_HASKELL__ < 805 -- | The 'Name' of the kind @*@. starKindName :: Name #if __GLASGOW_HASKELL__ >= 800 starKindName = ''(Kind.*) #else starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" #endif -- | The 'Name' of: -- -- 1. The kind 'Kind.★', on GHC 8.0 or later. -- 2. The kind @*@ on older GHCs. uniStarKindName :: Name #if __GLASGOW_HASKELL__ >= 800 uniStarKindName = ''(Kind.★) #else uniStarKindName = starKindName #endif #endif th-desugar-1.9/Language/Haskell/TH/Desugar/Subst.hs0000644000000000000000000001275413350246155020300 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Subst -- Copyright : (C) 2018 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Capture-avoiding substitutions on 'DType's -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Subst ( DSubst, -- * Capture-avoiding substitution substTy, substTyVarBndrs, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy ) where import qualified Data.Map as M import qualified Data.Set as S import Data.Generics import Data.List import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -- | A substitution is just a map from names to types type DSubst = M.Map Name DType -- | Capture-avoiding substitution on types substTy :: Quasi q => DSubst -> DType -> q DType substTy vars (DForallT tvbs cxt ty) = substTyVarBndrs vars tvbs $ \vars' tvbs' -> do cxt' <- mapM (substPred vars') cxt ty' <- substTy vars' ty return $ DForallT tvbs' cxt' ty' substTy vars (DAppT t1 t2) = DAppT <$> substTy vars t1 <*> substTy vars t2 substTy vars (DSigT ty ki) = DSigT <$> substTy vars ty <*> substTy vars ki substTy vars (DVarT n) | Just ty <- M.lookup n vars = return ty | otherwise = return $ DVarT n substTy _ ty@(DConT _) = return ty substTy _ ty@DArrowT = return ty substTy _ ty@(DLitT _) = return ty substTy _ ty@DWildCardT = return ty substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr] -> (DSubst -> [DTyVarBndr] -> q a) -> q a substTyVarBndrs vars tvbs thing = do (vars', tvbs') <- mapAccumLM substTvb vars tvbs thing vars' tvbs' substTvb :: Quasi q => DSubst -> DTyVarBndr -> q (DSubst, DTyVarBndr) substTvb vars (DPlainTV n) = do new_n <- qNewName (nameBase n) return (M.insert n (DVarT new_n) vars, DPlainTV new_n) substTvb vars (DKindedTV n k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k return (M.insert n (DVarT new_n) vars, DKindedTV new_n k') substPred :: Quasi q => DSubst -> DPred -> q DPred substPred vars (DForallPr tvbs cxt p) = substTyVarBndrs vars tvbs $ \vars' tvbs' -> do cxt' <- mapM (substPred vars') cxt p' <- substPred vars' p return $ DForallPr tvbs' cxt' p' substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> substTy vars k substPred vars (DVarPr n) | Just ty <- M.lookup n vars = dTypeToDPred ty | otherwise = return $ DVarPr n substPred _ p@(DConPr {}) = return p substPred _ p@DWildCardPr = return p -- | Computes the union of two substitutions. Fails if both subsitutions map -- the same variable to different types. unionSubsts :: DSubst -> DSubst -> Maybe DSubst unionSubsts a b = let shared_key_set = M.keysSet a `S.intersection` M.keysSet b matches_up = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&)) True shared_key_set in if matches_up then return (a `M.union` b) else Nothing --------------------------- -- Matching -- | Ignore kind annotations in @matchTy@? data IgnoreKinds = YesIgnore | NoIgnore -- | @matchTy ign tmpl targ@ matches a type template @tmpl@ against a type -- target @targ@. This returns a Map from names of type variables in the -- type template to types if the types indeed match up, or @Nothing@ otherwise. -- In the @Just@ case, it is guaranteed that every type variable mentioned -- in the template is mapped by the returned substitution. -- -- The first argument @ign@ tells @matchTy@ whether to ignore kind signatures -- in the template. A kind signature in the template might mean that a type -- variable has a more restrictive kind than otherwise possible, and that -- mapping that type variable to a type of a different kind could be disastrous. -- So, if we don't ignore kind signatures, this function returns @Nothing@ if -- the template has a signature anywhere. If we do ignore kind signatures, it's -- possible the returned map will be ill-kinded. Use at your own risk. matchTy :: IgnoreKinds -> DType -> DType -> Maybe DSubst matchTy _ (DVarT var_name) arg = Just $ M.singleton var_name arg -- if a pattern has a kind signature, it's really easy to get -- this wrong. matchTy ign (DSigT ty _ki) arg = case ign of YesIgnore -> matchTy ign ty arg NoIgnore -> Nothing -- but we can safely ignore kind signatures on the target matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty matchTy _ (DForallT {}) _ = error "Cannot match a forall in a pattern" matchTy _ _ (DForallT {}) = error "Cannot match a forall in a target" matchTy ign (DAppT pat1 pat2) (DAppT arg1 arg2) = unionMaybeSubsts [matchTy ign pat1 arg1, matchTy ign pat2 arg2] matchTy _ (DConT pat_con) (DConT arg_con) | pat_con == arg_con = Just M.empty matchTy _ DArrowT DArrowT = Just M.empty matchTy _ (DLitT pat_lit) (DLitT arg_lit) | pat_lit == arg_lit = Just M.empty matchTy _ _ _ = Nothing unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst unionMaybeSubsts = foldl' union_subst1 (Just M.empty) where union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst union_subst1 ma mb = do a <- ma b <- mb unionSubsts a b th-desugar-1.9/Language/Haskell/TH/Desugar/Match.hs0000644000000000000000000003723313350246155020233 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Match.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Simplifies case statements in desugared TH. After this pass, there are no more nested patterns. This code is directly based on the analogous operation as written in GHC. -} {-# LANGUAGE CPP, TemplateHaskell #-} #if __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- we need Ord Lit. argh. #endif module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where import Prelude hiding ( fail, exp ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding ( fail ) import qualified Control.Monad as Monad import Data.Data import Data.Generics import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify -- | Remove all nested pattern-matches within this expression. This also -- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern -- is guaranteed to be either a 'DConPa' with bare variables as arguments, -- a 'DLitPa', or a 'DWildPa'. scExp :: DsMonad q => DExp -> q DExp scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2 scExp (DLamE names exp) = DLamE names <$> scExp exp scExp (DCaseE scrut matches) | DVarE name <- scrut = simplCaseExp [name] clauses | otherwise = do scrut_name <- newUniqueName "scrut" case_exp <- simplCaseExp [scrut_name] clauses return $ DLetE [DValD (DVarPa scrut_name) scrut] case_exp where clauses = map match_to_clause matches match_to_clause (DMatch pat exp) = DClause [pat] exp scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty scExp e@(DVarE {}) = return e scExp e@(DConE {}) = return e scExp e@(DLitE {}) = return e scExp e@(DStaticE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do arg_names <- mapM (const (newUniqueName "_arg")) pats1 clauses' <- mapM sc_clause_rhs clauses case_exp <- simplCaseExp arg_names clauses' return $ DFunD name [DClause (map DVarPa arg_names) case_exp] where sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp scLetDec (DValD pat exp) = DValD pat <$> scExp exp scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag scLetDec dec@(DSigD {}) = return dec scLetDec dec@(DInfixD {}) = return dec scLetDec dec@(DFunD _ []) = return dec scLetPragma :: DsMonad q => DPragma -> q DPragma scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own type MatchResult = DExp -> DExp matchResultToDExp :: MatchResult -> DExp matchResultToDExp mr = mr failed_pattern_match where failed_pattern_match = DAppE (DVarE 'error) (DLitE $ StringL "Pattern-match failure") simplCaseExp :: DsMonad q => [Name] -> [DClause] -> q DExp simplCaseExp vars clauses = do let eis = [ EquationInfo pats (\_ -> rhs) | DClause pats rhs <- clauses ] matchResultToDExp `liftM` simplCase vars eis data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q => [Name] -- the names of the scrutinees -> [EquationInfo] -- the matches (where the # of pats == length (1st arg)) -> q MatchResult simplCase [] clauses = return (foldr1 (.) match_results) where match_results = [ mr | EquationInfo _ mr <- clauses ] simplCase vars@(v:_) clauses = do (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses let grouped = groupClauses tidy_clauses match_results <- match_groups grouped return (adjustMatchResult (foldr (.) id aux_binds) $ foldr1 (.) match_results) where match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult] match_groups [] = matchEmpty v match_groups gs = mapM match_group gs match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult match_group [] = error "Internal error in th-desugar (match_group)" match_group eqns@((group,_) : _) = case group of PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns]) PgLit _ -> matchLiterals vars (subGroup [(l,e) | (PgLit l, e) <- eqns]) PgBang -> matchBangs vars (drop_group eqns) PgAny -> matchVariables vars (drop_group eqns) drop_group = map snd -- analogous to GHC's tidyEqnInfo tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo) tidyClause _ (EquationInfo [] _) = error "Internal error in th-desugar: no patterns in tidyClause." tidyClause v (EquationInfo (pat : pats) body) = do (wrap, pat') <- tidy1 v pat return (wrap, EquationInfo (pat' : pats) body) tidy1 :: DsMonad q => Name -- the name of the variable that ... -> DPat -- ... this pattern is matching against -> q (DExp -> DExp, DPat) -- a wrapper and tidied pattern tidy1 _ p@(DLitPa {}) = return (id, p) tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa) tidy1 _ p@(DConPa {}) = return (id, p) tidy1 v (DTildePa pat) = do sel_decs <- mkSelectorDecs pat v return (maybeDLetE sel_decs, DWildPa) tidy1 v (DBangPa pat) = case pat of DLitPa _ -> tidy1 v pat -- already strict DVarPa _ -> return (id, DBangPa pat) -- no change DConPa _ _ -> tidy1 v pat -- already strict DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under ! DBangPa p -> tidy1 v (DBangPa p) -- discard ! under ! DSigPa p _ -> tidy1 v (DBangPa p) -- discard sig under ! DWildPa -> return (id, DBangPa pat) -- no change tidy1 v (DSigPa pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention -- type variables properly, so we give up if we encounter one. -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976 -- for further discussion. | otherwise = Monad.fail "Match-flattening patterns that mention type variables is not supported." where no_tyvars_ty :: Data a => a -> Bool no_tyvars_ty = everything (&&) (mkQ True no_tyvar_ty) no_tyvar_ty :: DType -> Bool no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildPa = return (id, DWildPa) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id | otherwise = DLetE [DValD (DVarPa new) (DVarE old)] -- like GHC's mkSelectorBinds mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against -> q [DLetDec] mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)] mkSelectorDecs pat name | S.null binders = return [] | S.size binders == 1 = do val_var <- newUniqueName "var" err_var <- newUniqueName "err" bind <- mk_bind val_var err_var (head $ S.elems binders) return [DValD (DVarPa val_var) (DVarE name), DValD (DVarPa err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")), bind] | otherwise = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple] tuple_var <- newUniqueName "tuple" projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1] return (DValD (DVarPa tuple_var) tuple_expr : zipWith DValD (map DVarPa binders_list) projections) where binders = extractBoundNamesDPat pat binders_list = S.toAscList binders tuple_size = length binders_list local_tuple = mkTupleDExp (map DVarE binders_list) mk_projection :: DsMonad q => Name -- of the tuple -> Int -- which element to get (0-indexed) -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj" return $ DCaseE (DVarE tup_name) [DMatch (DConPa (tupleDataName tuple_size) (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element -> Int -- which element to get (0-indexed) -> [DPat] mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa mk_bind scrut_var err_var bndr_var = do rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)] return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var))) data PatGroup = PgAny -- immediate match (wilds, vars, lazies) | PgCon Name | PgLit Lit | PgBang -- like GHC's groupEquations groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] groupClauses clauses = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] where same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 patGroup :: DPat -> PatGroup patGroup (DLitPa l) = PgLit l patGroup (DVarPa {}) = error "Internal error in th-desugar (patGroup DVarPa)" patGroup (DConPa con _) = PgCon con patGroup (DTildePa {}) = error "Internal error in th-desugar (patGroup DTildePa)" patGroup (DBangPa {}) = PgBang patGroup (DSigPa{}) = error "Internal error in th-desugar (patGroup DSigPa)" patGroup DWildPa = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True sameGroup (PgCon _) (PgCon _) = True sameGroup (PgLit _) (PgLit _) = True sameGroup _ _ = False subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] subGroup group = map reverse $ Map.elems $ foldl accumulate Map.empty group where accumulate pg_map (pg, eqn) = case Map.lookup pg pg_map of Just eqns -> Map.insert pg (eqn:eqns) pg_map Nothing -> Map.insert pg [eqn] pg_map firstPat :: EquationInfo -> DPat firstPat (EquationInfo (pat : _) _) = pat firstPat _ = error "Clause encountered with no patterns -- should never happen" data CaseAlt = CaseAlt { alt_con :: Name -- con name , _alt_args :: [Name] -- bound var names , _alt_rhs :: MatchResult -- RHS } -- from GHC's MatchCon.lhs matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult matchConFamily (var:vars) groups = do alts <- mapM (matchOneCon vars) groups mkDataConCase var alts matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)" -- like matchOneConLike from MatchCon matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt matchOneCon vars eqns@(eqn1 : _) = do arg_vars <- selectMatchVars (pat_args pat1) match_result <- match_group arg_vars return $ CaseAlt (pat_con pat1) arg_vars match_result where pat1 = firstPat eqn1 pat_args (DConPa _ pats) = pats pat_args _ = error "Internal error in th-desugar (pat_args)" pat_con (DConPa con _) = con pat_con _ = error "Internal error in th-desugar (pat_con)" match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars = simplCase (arg_vars ++ vars) (map shift eqns) shift (EquationInfo (DConPa _ args : pats) exp) = EquationInfo (args ++ pats) exp shift _ = error "Internal error in th-desugar (shift)" matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult mkDataConCase var case_alts = do all_ctors <- get_all_ctors (alt_con $ head case_alts) return $ \fail -> let matches = map (mk_alt fail) case_alts in DCaseE (DVarE var) (matches ++ mk_default all_ctors fail) where mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in DMatch (DConPa con (map DVarPa args)) body mk_default all_ctors fail | exhaustive_case all_ctors = [] | otherwise = [DMatch DWildPa fail] mentioned_ctors = S.fromList $ map alt_con case_alts exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors get_all_ctors :: DsMonad q => Name -> q (S.Set Name) get_all_ctors con_name = do ty_name <- dataConNameToDataName con_name Just (DTyConI tycon_dec _) <- dsReify ty_name return $ S.fromList $ map get_con_name $ get_cons tycon_dec get_cons (DDataD _ _ _ _ _ cons _) = cons get_cons (DDataInstD _ _ _ _ _ cons _) = cons get_cons _ = [] get_con_name (DCon _ _ n _ _) = n matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa fail] matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult matchLiterals (var:vars) sub_groups = do alts <- mapM match_group sub_groups return (mkCoPrimCaseMatchResult var alts) where match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult) match_group eqns = do let DLitPa lit = firstPat (head eqns) match_result <- simplCase vars (shiftEqns eqns) return (lit, match_result) matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" mkCoPrimCaseMatchResult :: Name -- Scrutinee -> [(Lit, MatchResult)] -> MatchResult mkCoPrimCaseMatchResult var match_alts = mk_case where mk_case fail = let alts = map (mk_alt fail) match_alts in DCaseE (DVarE var) (alts ++ [DMatch DWildPa fail]) mk_alt fail (lit, body_fn) = DMatch (DLitPa lit) (body_fn fail) matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult matchBangs (var:vars) eqns = do match_result <- simplCase (var:vars) $ map (decomposeFirstPat getBangPat) eqns return (mkEvalMatchResult var match_result) matchBangs [] _ = error "Internal error in th-desugar (matchBangs)" decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (EquationInfo (pat:pats) body) = EquationInfo (extractpat pat : pats) body decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)" getBangPat :: DPat -> DPat getBangPat (DBangPa p) = p getBangPat _ = error "Internal error in th-desugar (getBangPat)" mkEvalMatchResult :: Name -> MatchResult -> MatchResult mkEvalMatchResult var body_fn fail = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail] matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns) matchVariables _ _ = error "Internal error in th-desugar (matchVariables)" shiftEqns :: [EquationInfo] -> [EquationInfo] shiftEqns = map shift where shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult adjustMatchResult wrap mr fail = wrap $ mr fail -- from DsUtils selectMatchVars :: DsMonad q => [DPat] -> q [Name] selectMatchVars = mapM selectMatchVar -- from DsUtils selectMatchVar :: DsMonad q => DPat -> q Name selectMatchVar (DBangPa pat) = selectMatchVar pat selectMatchVar (DTildePa pat) = selectMatchVar pat selectMatchVar (DVarPa var) = newUniqueName ('_' : nameBase var) selectMatchVar _ = newUniqueName "_pat" -- like GHC's runs runs :: (a -> a -> Bool) -> [a] -> [[a]] runs _ [] = [] runs p (x:xs) = case span (p x) xs of (first, rest) -> (x:first) : (runs p rest) th-desugar-1.9/Language/Haskell/TH/Desugar/Lift.hs0000644000000000000000000000277313350246155020076 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Lift -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- 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 CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.TH.Desugar.Lift () where import Language.Haskell.TH.Desugar import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift $(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn , ''DPatSynDir , ''NewOrData, ''DDerivStrategy #if __GLASGOW_HASKELL__ < 707 , ''AnnTarget, ''Role #endif , ''DTypeFamilyHead, ''DFamilyResultSig #if __GLASGOW_HASKELL__ <= 710 , ''InjectivityAnn, ''Bang, ''SourceUnpackedness , ''SourceStrictness, ''Overlap #endif #if __GLASGOW_HASKELL__ < 801 , ''PatSynArgs #endif ]) th-desugar-1.9/Language/Haskell/TH/Desugar/AST.hs0000644000000000000000000002612013350246155017617 0ustar0000000000000000{- Language/Haskell/TH/Desugar/AST.hs (c) Ryan Scott 2018 Defines the desugared Template Haskell AST. The desugared types and constructors are prefixed with a D. -} {-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. data DExp = DVarE Name | DConE Name | DLitE Lit | DAppE DExp DExp | DAppTypeE DExp DType | DLamE [Name] DExp | DCaseE DExp [DMatch] | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Pat@ type. data DPat = DLitPa Lit | DVarPa Name | DConPa Name [DPat] | DTildePa DPat | DBangPa DPat | DSigPa DPat DType | DWildPa deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds. data DType = DForallT [DTyVarBndr] DCxt DType | DAppT DType DType | DSigT DType DKind | DVarT Name | DConT Name | DArrowT | DLitT TyLit | DWildCardT deriving (Show, Typeable, Data, Generic) -- | Kinds are types. type DKind = DType -- | Corresponds to TH's @Cxt@ type DCxt = [DPred] -- | Corresponds to TH's @Pred@ data DPred = DForallPr [DTyVarBndr] DCxt DPred | DAppPr DPred DType | DSigPr DPred DKind | DVarPr Name | DConPr Name | DWildCardPr deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @TyVarBndr@ data DTyVarBndr = DPlainTV Name | DKindedTV Name DKind deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp deriving (Show, Typeable, Data, Generic) -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType | DInfixD Fixity Name | DPragmaD DPragma deriving (Show, Typeable, Data, Generic) -- | Is it a @newtype@ or a @data@ type? data NewOrData = Newtype | Data deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec | DDataD NewOrData DCxt Name [DTyVarBndr] (Maybe DKind) [DCon] [DDerivClause] | DTySynD Name [DTyVarBndr] DType | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec] | DInstanceD (Maybe Overlap) DCxt DType [DDec] | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] | DDataFamilyD Name [DTyVarBndr] (Maybe DKind) | DDataInstD NewOrData DCxt Name [DType] (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD Name DTySynEqn | DRoleAnnotD Name [Role] | DStandaloneDerivD (Maybe DDerivStrategy) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat | DPatSynSigD Name DPatSynType deriving (Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ < 711 data Overlap = Overlappable | Overlapping | Overlaps | Incoherent deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'PatSynDir' type data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ | DImplBidir -- ^ @pattern P x {=} p@ | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType #if __GLASGOW_HASKELL__ < 801 -- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. data PatSynArgs = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving (Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig (Maybe InjectivityAnn) deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndr deriving (Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ <= 710 data InjectivityAnn = InjectivityAnn Name [Name] deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT -- syntax. This is beneficial for @th-desugar@'s since it means -- that all data type declarations can support explicit return kinds, so -- one does not need to represent them with something like @'Maybe' 'DKind'@, -- since Haskell98-style data declaration syntax isn't used. Accordingly, -- there are some differences between 'DCon' and 'Con' to keep in mind: -- -- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending -- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the -- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of -- universally /and/ existentially quantified type variables. Note that it is -- not guaranteed that one set of type variables will appear before the -- other. -- -- * A 'DCon' always has an explicit return type. data DCon = DCon [DTyVarBndr] DCxt Name DConFields DType -- ^ The GADT result type deriving (Show, Typeable, Data, Generic) -- | A list of fields either for a standard data constructor or a record -- data constructor. data DConFields = DNormalC DDeclaredInfix [DBangType] | DRecC [DVarBangType] deriving (Show, Typeable, Data, Generic) -- | 'True' if a constructor is declared infix. For normal ADTs, this means -- that is was written in infix style. For example, both of the constructors -- below are declared infix. -- -- @ -- data Infix = Int `Infix` Int | Int :*: Int -- @ -- -- Whereas neither of these constructors are declared infix: -- -- @ -- data Prefix = Prefix Int Int | (:+:) Int Int -- @ -- -- For GADTs, detecting whether a constructor is declared infix is a bit -- trickier, as one cannot write a GADT constructor "infix-style" like one -- can for normal ADT constructors. GHC considers a GADT constructor to be -- declared infix if it meets the following three criteria: -- -- 1. Its name uses operator syntax (e.g., @(:*:)@). -- 2. It has exactly two fields (without record syntax). -- 3. It has a programmer-specified fixity declaration. -- -- For example, in the following GADT: -- -- @ -- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` -- data InfixGADT a where -- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix -- ActuallyPrefix :: Char -> Bool -> InfixGADT Double -- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] -- (:^^:) :: Int -> Int -> Int -> InfixGADT Int -- (:!!:) :: Char -> Char -> InfixGADT Char -- @ -- -- Only the @(:**:)@ constructor is declared infix. The other constructors -- are not declared infix, because: -- -- * @ActuallyPrefix@ does not use operator syntax (criterion 1). -- * @(:&&:)@ uses record syntax (criterion 2). -- * @(:^^:)@ does not have exactly two fields (criterion 2). -- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). type DDeclaredInfix = Bool -- | Corresponds to TH's @BangType@ type. type DBangType = (Bang, DType) -- | Corresponds to TH's @VarBangType@ type. type DVarBangType = (Name, Bang, DType) #if __GLASGOW_HASKELL__ <= 710 -- | Corresponds to TH's definition data SourceUnpackedness = NoSourceUnpackedness | SourceNoUnpack | SourceUnpack deriving (Eq, Ord, Show, Typeable, Data, Generic) -- | Corresponds to TH's definition data SourceStrictness = NoSourceStrictness | SourceLazy | SourceStrict deriving (Eq, Ord, Show, Typeable, Data, Generic) -- | Corresponds to TH's definition data Bang = Bang SourceUnpackedness SourceStrictness deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases | DSpecialiseP Name DType (Maybe Inline) Phases | DSpecialiseInstP DType | DRuleP String [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn [DType] DType deriving (Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ < 707 -- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility. data Role = NominalR | RepresentationalR | PhantomR | InferR deriving (Show, Typeable, Data, Generic) -- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility. data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name deriving (Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec]) | DVarI Name DType (Maybe Name) -- ^ The @Maybe Name@ stores the name of the enclosing definition -- (datatype, for a data constructor; class, for a method), -- if any | DTyVarI Name DKind | DPrimTyConI Name Int Bool -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType deriving (Show, Typeable, Data, Generic) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | DViaStrategy DType -- ^ @-XDerivingVia@ deriving (Show, Typeable, Data, Generic) th-desugar-1.9/Language/Haskell/TH/Desugar/Core.hs0000644000000000000000000016350413350246155020070 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Core.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Desugars full Template Haskell syntax into a smaller core syntax for further processing. The desugared types and constructors are prefixed with a D. -} {-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, TupleSections #-} module Language.Haskell.TH.Desugar.Core where import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.ExpandSyns ( expandSyns ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding (forM_, mapM) import Control.Monad.Zip import Control.Monad.Writer hiding (forM_, mapM) import Data.Foldable hiding (notElem) import Data.Graph import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.Traversable #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) #endif #if __GLASGOW_HASKELL__ >= 800 import qualified Control.Monad.Fail as MonadFail #endif #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif import qualified Data.Set as S import GHC.Exts import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify -- | Desugar an expression dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n dsExp (ConE n) = return $ DConE n dsExp (LitE lit) = return $ DLitE lit dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 dsExp (InfixE Nothing op Nothing) = dsExp op dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) dsExp (InfixE Nothing op (Just rhs)) = do lhsName <- newUniqueName "lhs" op' <- dsExp op rhs' <- dsExp rhs return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) dsExp (InfixE (Just lhs) op (Just rhs)) = DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs dsExp (UInfixE _ _ _) = fail "Cannot desugar unresolved infix operators." dsExp (ParensE exp) = dsExp exp dsExp (LamE pats exp) = dsLam pats =<< dsExp exp dsExp (LamCaseE matches) = do x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = do exps' <- mapM dsExp exps return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps' dsExp (UnboxedTupE exps) = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps dsExp (CondE e1 e2 e3) = dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) [] , Match (ConP 'False []) (NormalB e3) [] ]) dsExp (MultiIfE guarded_exps) = let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in dsGuards guarded_exps failure dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp -- the following special case avoids creating a new "let" when it's not -- necessary. See #34. dsExp (CaseE (VarE scrutinee) matches) = do matches' <- dsMatches scrutinee matches return $ DCaseE (DVarE scrutinee) matches' dsExp (CaseE exp matches) = do scrutinee <- newUniqueName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarPa scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches' dsExp (DoE stmts) = dsDoStmts stmts dsExp (CompE stmts) = dsComp stmts dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp dsExp (ArithSeqE (FromThenR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromToR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> dsExp e2) <*> dsExp e3 dsExp (ListE exps) = go exps where go [] = return $ DConE '[] go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty dsExp (RecConE con_name field_exps) = do con <- dataConNameToCon con_name reordered <- reorder con return $ foldl DAppE (DConE con_name) reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields fields ForallC _ _ c -> reorder c #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields fields #endif reorder_fields fields = reorderFields con_name fields field_exps (repeat $ DVarE 'undefined) non_record fields | null field_exps -- Special case: record construction is allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that no -- records are given in the expression itself. (See #59). -- -- Con{} desugars down to Con undefined ... undefined. = return $ replicate (length fields) $ DVarE 'undefined | otherwise = impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsExp (RecUpdE exp field_exps) = do -- here, we need to use one of the field names to find the tycon, somewhat dodgily first_name <- case field_exps of ((name, _) : _) -> return name _ -> impossible "Record update with no fields listed." info <- reifyWithLocals first_name applied_type <- case info of #if __GLASGOW_HASKELL__ > 710 VarI _name ty _m_dec -> extract_first_arg ty #else VarI _name ty _m_dec _fixity -> extract_first_arg ty #endif _ -> impossible "Record update with an invalid field name." type_name <- extract_type_name applied_type (_, cons) <- getDataD "This seems to be an error in GHC." type_name let filtered_cons = filter_cons_with_names cons (map fst field_exps) exp' <- dsExp exp matches <- mapM con_to_dmatch filtered_cons let all_matches | length filtered_cons == length cons = matches | otherwise = matches ++ [error_match] return $ DCaseE exp' all_matches where extract_first_arg :: DsMonad q => Type -> q Type extract_first_arg (AppT (AppT ArrowT arg) _) = return arg extract_first_arg (ForallT _ _ t) = extract_first_arg t extract_first_arg (SigT t _) = extract_first_arg t extract_first_arg _ = impossible "Record selector not a function." extract_type_name :: DsMonad q => Type -> q Name extract_type_name (AppT t1 _) = extract_type_name t1 extract_type_name (SigT t _) = extract_type_name t extract_type_name (ConT n) = return n extract_type_name _ = impossible "Record selector domain not a datatype." filter_cons_with_names cons field_names = filter has_names cons where args_contain_names args = let con_field_names = map fst_of_3 args in all (`elem` con_field_names) field_names has_names (RecC _con_name args) = args_contain_names args #if __GLASGOW_HASKELL__ >= 800 has_names (RecGadtC _con_name args _ret_ty) = args_contain_names args #endif has_names (ForallC _ _ c) = has_names c has_names _ = False rec_con_to_dmatch con_name args = do let con_field_names = map fst_of_3 args field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConPa con_name (map DVarPa field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields con_name args field_exps (map DVarE field_var_names))) con_to_dmatch :: DsMonad q => Con -> q DMatch con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args #if __GLASGOW_HASKELL__ >= 800 -- We're assuming the GADT constructor has only one Name here, but since -- this constructor was reified, this assumption should always hold true. con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args #endif con_to_dmatch (ForallC _ _ c) = con_to_dmatch c con_to_dmatch _ = impossible "Internal error within th-desugar." error_match = DMatch DWildPa (DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive patterns in record update"))) fst_of_3 (x, _, _) = x #if __GLASGOW_HASKELL__ >= 709 dsExp (StaticE exp) = DStaticE <$> dsExp exp #endif #if __GLASGOW_HASKELL__ > 710 dsExp (UnboundVarE n) = return (DVarE n) #endif #if __GLASGOW_HASKELL__ >= 801 dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty dsExp (UnboxedSumE exp alt arity) = DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp #endif #if __GLASGOW_HASKELL__ >= 803 dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) #endif -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp dsLam = mkLam stripVarP_maybe dsPatsOverExp -- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This -- is needed since 'DLamE' takes a list of 'Name's for its bound variables -- instead of 'DPat's, so some reorganization is needed. mkDLamEFromDPats :: DsMonad q => [DPat] -> DExp -> q DExp mkDLamEFromDPats = mkLam stripDVarPa_maybe (\pats exp -> return (pats, exp)) where stripDVarPa_maybe :: DPat -> Maybe Name stripDVarPa_maybe (DVarPa n) = Just n stripDVarPa_maybe _ = Nothing -- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary -- pattern type. mkLam :: DsMonad q => (pat -> Maybe Name) -- ^ Should return @'Just' n@ if the argument is a -- variable pattern, and 'Nothing' otherwise. -> ([pat] -> DExp -> q ([DPat], DExp)) -- ^ Should process a list of @pat@ arguments and -- a 'DExp' body. (This might do some internal -- reorganization if there are as-patterns, as -- in the case of 'dsPatsOverExp'.) -> [pat] -> DExp -> q DExp mkLam mb_strip_var_pat process_pats_over_exp pats exp | Just names <- mapM mb_strip_var_pat pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) (pats', exp') <- process_pats_over_exp pats exp let match = DMatch (mkTupleDPat pats') exp' return $ DLamE arg_names (DCaseE scrutinee [match]) -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q => Name -- ^ Name of the scrutinee, which must be a bare var -> [Match] -- ^ Matches of the @case@ statement -> q [DMatch] dsMatches scr = go where go :: DsMonad q => [Match] -> q [DMatch] go [] = return [] go (Match pat body where_decs : rest) = do rest' <- go rest let failure = DCaseE (DVarE scr) rest' -- this might be an empty case. exp' <- dsBody body where_decs failure (pat', exp'') <- dsPatOverExp pat exp' uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 if uni_pattern then return [DMatch pat' exp''] else return (DMatch pat' exp'' : rest') -- | Desugar a @Body@ dsBody :: DsMonad q => Body -- ^ body to desugar -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match -> q DExp dsBody (NormalB exp) decs _ = maybeDLetE <$> dsLetDecs decs <*> dsExp exp dsBody (GuardedB guarded_exps) decs failure = maybeDLetE <$> dsLetDecs decs <*> dsGuards guarded_exps failure -- | If decs is non-empty, delcare them in a let: maybeDLetE :: [DLetDec] -> DExp -> DExp maybeDLetE [] exp = exp maybeDLetE decs exp = DLetE decs exp -- | If matches is non-empty, make a case statement; otherwise make an error statement maybeDCaseE :: String -> DExp -> [DMatch] -> DExp maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err)) maybeDCaseE _ scrut matches = DCaseE scrut matches -- | Desugar guarded expressions dsGuards :: DsMonad q => [(Guard, Exp)] -- ^ Guarded expressions -> DExp -- ^ What to do if none of the guards match -> q DExp dsGuards [] thing_inside = return thing_inside dsGuards ((NormalG gd, exp) : rest) thing_inside = dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside dsGuards ((PatG stmts, exp) : rest) thing_inside = do success <- dsExp exp failure <- dsGuards rest thing_inside dsGuardStmts stmts success failure -- | Desugar the @Stmt@s in a guard dsGuardStmts :: DsMonad q => [Stmt] -- ^ The @Stmt@s to desugar -> DExp -- ^ What to do if the @Stmt@s yield success -> DExp -- ^ What to do if the @Stmt@s yield failure -> q DExp dsGuardStmts [] success _failure = return success dsGuardStmts (BindS pat exp : rest) success failure = do success' <- dsGuardStmts rest success failure (pat', success'') <- dsPatOverExp pat success' exp' <- dsExp exp return $ DCaseE exp' [DMatch pat' success'', DMatch DWildPa failure] dsGuardStmts (LetS decs : rest) success failure = do decs' <- dsLetDecs decs success' <- dsGuardStmts rest success failure return $ DLetE decs' success' -- special-case a final pattern containing "otherwise" or "True" -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr dsGuardStmts [NoBindS exp] success _failure | VarE name <- exp , name == 'otherwise = return success | ConE name <- exp , name == 'True = return success dsGuardStmts (NoBindS exp : rest) success failure = do exp' <- dsExp exp success' <- dsGuardStmts rest success failure return $ DCaseE exp' [ DMatch (DConPa 'True []) success' , DMatch (DConPa 'False []) failure ] dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." -- | Desugar the @Stmt@s in a @do@ expression dsDoStmts :: DsMonad q => [Stmt] -> q DExp dsDoStmts [] = impossible "do-expression ended with something other than bare statement." dsDoStmts [NoBindS exp] = dsExp exp dsDoStmts (BindS pat exp : rest) = do rest' <- dsDoStmts rest dsBindS exp pat rest' "do expression" dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest dsDoStmts (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsDoStmts rest return $ DAppE (DAppE (DVarE '(>>)) exp') rest' dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement." -- | Desugar the @Stmt@s in a list or monad comprehension dsComp :: DsMonad q => [Stmt] -> q DExp dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do rest' <- dsComp rest dsBindS exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest dsComp (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsComp rest return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' dsComp (ParS stmtss : rest) = do (pat, exp) <- dsParComp stmtss rest' <- dsComp rest DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest' -- Desugar a binding statement in a do- or list comprehension. -- -- In the event that the pattern in the statement is partial, the desugared -- case expression will contain a catch-all case that calls 'fail' from either -- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ -- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from -- 'Monad' is always used.) dsBindS :: forall q. DsMonad q => Exp -> Pat -> DExp -> String -> q DExp dsBindS bind_arg_exp success_pat success_exp ctxt = do bind_arg_exp' <- dsExp bind_arg_exp (success_pat', success_exp') <- dsPatOverExp success_pat success_exp is_univ_pat <- isUniversalPattern success_pat' let bind_into = DAppE (DAppE (DVarE '(>>=)) bind_arg_exp') if is_univ_pat then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' else do arg_name <- newUniqueName "arg" fail_name <- mk_fail_name return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) [ DMatch success_pat' success_exp' , DMatch DWildPa $ DVarE fail_name `DAppE` DLitE (StringL $ "Pattern match failure in " ++ ctxt) ] where mk_fail_name :: q Name #if __GLASGOW_HASKELL__ >= 800 mk_fail_name = do mfd <- qIsExtEnabled MonadFailDesugaring return $ if mfd then 'MonadFail.fail else 'Prelude.fail #else mk_fail_name = return 'Prelude.fail #endif -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do let rv = foldMap extractBoundNamesStmt r dsR <- dsComp (r ++ [mk_tuple_stmt rv]) return (mk_tuple_pat rv, dsR) dsParComp (q : rest) = do let qv = foldMap extractBoundNamesStmt q (rest_pat, rest_exp) <- dsParComp rest dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: S.Set Name -> Stmt mk_tuple_stmt name_set = NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set)) -- helper function for dsParComp mk_tuple_pat :: S.Set Name -> Pat mk_tuple_pat name_set = mkTuplePat (S.foldr ((:) . VarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra -- variables that must be bound within the scope of the pattern dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) dsPatX = runWriterT . dsPat -- | Desugaring a pattern also returns the list of variables bound in as-patterns -- and the values they should be bound to. This variables must be brought into -- scope in the "body" of the pattern. type PatM q = WriterT [(Name, DExp)] q -- | Desugar a pattern. dsPat :: DsMonad q => Pat -> PatM q DPat dsPat (LitP lit) = return $ DLitPa lit dsPat (VarP n) = return $ DVarPa n dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats dsPat (UnboxedTupP pats) = DConPa (unboxedTupleDataName (length pats)) <$> mapM dsPat pats dsPat (ConP name pats) = DConPa name <$> mapM dsPat pats dsPat (InfixP p1 name p2) = DConPa name <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) = fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat dsPat (TildeP pat) = DTildePa <$> dsPat pat dsPat (BangP pat) = DBangPa <$> dsPat pat dsPat (AsP name pat) = do pat' <- dsPat pat pat'' <- lift $ removeWilds pat' tell [(name, dPatToDExp pat'')] return pat'' dsPat WildP = return DWildPa dsPat (RecP con_name field_pats) = do con <- lift $ dataConNameToCon con_name reordered <- reorder con return $ DConPa con_name reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields_pat fields ForallC _ _ c -> reorder c #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields_pat fields #endif reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats non_record fields | null field_pats -- Special case: record patterns are allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that -- no records are given in the pattern itself. (See #59). -- -- Con{} desugars down to Con _ ... _. = return $ replicate (length fields) DWildPa | otherwise = lift $ impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsPat (ListP pats) = go pats where go [] = return $ DConPa '[] [] go (h : t) = do h' <- dsPat h t' <- go t return $ DConPa '(:) [h', t'] dsPat (SigP pat ty) = DSigPa <$> dsPat pat <*> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsPat (UnboxedSumP pat alt arity) = DConPa (unboxedSumDataName alt arity) <$> ((:[]) <$> dsPat pat) #endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead." -- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. dPatToDExp :: DPat -> DExp dPatToDExp (DLitPa lit) = DLitE lit dPatToDExp (DVarPa name) = DVarE name dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats) dPatToDExp (DTildePa pat) = dPatToDExp pat dPatToDExp (DBangPa pat) = dPatToDExp pat dPatToDExp (DSigPa pat ty) = DSigE (dPatToDExp pat) ty dPatToDExp DWildPa = error "Internal error in th-desugar: wildcard in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable removeWilds :: DsMonad q => DPat -> q DPat removeWilds p@(DLitPa _) = return p removeWilds p@(DVarPa _) = return p removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat removeWilds (DSigPa pat ty) = DSigPa <$> removeWilds pat <*> pure ty removeWilds DWildPa = DVarPa <$> newUniqueName "wild" extractBoundNamesDPat :: DPat -> S.Set Name extractBoundNamesDPat (DLitPa _) = S.empty extractBoundNamesDPat (DVarPa n) = S.singleton n extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats) extractBoundNamesDPat (DTildePa p) = extractBoundNamesDPat p extractBoundNamesDPat (DBangPa p) = extractBoundNamesDPat p extractBoundNamesDPat (DSigPa p _) = extractBoundNamesDPat p extractBoundNamesDPat DWildPa = S.empty -- | Desugar @Info@ dsInfo :: DsMonad q => Info -> q DInfo dsInfo (ClassI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) #if __GLASGOW_HASKELL__ > 710 dsInfo (ClassOpI name ty parent) = #else dsInfo (ClassOpI name ty parent _fixity) = #endif DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do [ddec] <- dsDec dec return $ DTyConI ddec Nothing dsInfo (FamilyI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances (ddec', num_args) <- fixBug8884ForFamilies ddec let dinstances' = map (fixBug8884ForInstances num_args) dinstances return $ DTyConI ddec' (Just dinstances') dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted #if __GLASGOW_HASKELL__ > 710 dsInfo (DataConI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _)) = impossible $ "Declaration supplied with variable: " ++ show name #else dsInfo (DataConI name ty parent _fixity) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing _fixity) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _) _) = impossible $ "Declaration supplied with variable: " ++ show name #endif dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty #endif fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) #if __GLASGOW_HASKELL__ < 708 fixBug8884ForFamilies (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs ann)) = do let num_args = length tvbs frs' <- remove_arrows num_args frs return (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs' ann),num_args) fixBug8884ForFamilies (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs ann) eqns) = do let num_args = length tvbs eqns' = map (fixBug8884ForEqn num_args) eqns frs' <- remove_arrows num_args frs return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args) fixBug8884ForFamilies dec@(DDataFamilyD _ _ _) = return (dec, 0) -- the num_args is ignored for data families fixBug8884ForFamilies dec = impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec remove_arrows :: DsMonad q => Int -> DFamilyResultSig -> q DFamilyResultSig remove_arrows n (DKindSig k) = DKindSig <$> remove_arrows_kind n k remove_arrows n (DTyVarSig (DKindedTV nm k)) = DTyVarSig <$> (DKindedTV nm <$> remove_arrows_kind n k) remove_arrows _ frs = return frs remove_arrows_kind :: DsMonad q => Int -> DKind -> q DKind remove_arrows_kind 0 k = return k remove_arrows_kind n (DAppT (DAppT DArrowT _) k) = remove_arrows_kind (n-1) k remove_arrows_kind _ _ = impossible "Internal error: Fix for bug 8884 ran out of arrows." #else fixBug8884ForFamilies dec = return (dec, 0) -- return value ignored #endif fixBug8884ForInstances :: Int -> DDec -> DDec fixBug8884ForInstances num_args (DTySynInstD name eqn) = DTySynInstD name (fixBug8884ForEqn num_args eqn) fixBug8884ForInstances _ dec = dec fixBug8884ForEqn :: Int -> DTySynEqn -> DTySynEqn #if __GLASGOW_HASKELL__ < 708 fixBug8884ForEqn num_args (DTySynEqn lhs rhs) = let lhs' = drop (length lhs - num_args) lhs in DTySynEqn lhs' rhs #else fixBug8884ForEqn _ = id #endif -- | Desugar arbitrary @Dec@s dsDecs :: DsMonad q => [Dec] -> q [DDec] dsDecs = concatMapM dsDec -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (DataD cxt n tvbs mk cons derivings) = do tvbs' <- mapM dsTvb tvbs all_tvbs <- nonFamilyDataTvbs tvbs' mk let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> mapM dsType mk <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs mk con derivings) = do tvbs' <- mapM dsTvb tvbs all_tvbs <- nonFamilyDataTvbs tvbs' mk let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> mapM dsType mk <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #else dsDec (DataD cxt n tvbs cons derivings) = do tvbs' <- mapM dsTvb tvbs let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> pure Nothing <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs con derivings) = do tvbs' <- mapM dsTvb tvbs let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> pure Nothing <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #endif dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) = (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs <*> pure fds <*> dsDecs decs) #if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) = (:[]) <$> (DInstanceD <$> pure over <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) #else dsDec (InstanceD cxt ty decs) = (:[]) <$> (DInstanceD <$> pure Nothing <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) #endif dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec d@(PragmaD {}) = (fmap . map) DLetDec $ dsLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #else dsDec (FamilyD TypeFam n tvbs m_k) = do (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k) dsDec (FamilyD DataFam n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #endif #if __GLASGOW_HASKELL__ > 710 dsDec (DataInstD cxt n tys mk cons derivings) = do tys' <- mapM dsType tys all_tys <- dataFamInstTypes tys' mk let tvbs = dataFamInstTvbs all_tys fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> pure tys' <*> mapM dsType mk <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys mk con derivings) = do tys' <- mapM dsType tys all_tys <- dataFamInstTypes tys' mk let tvbs = dataFamInstTvbs all_tys fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> pure tys' <*> mapM dsType mk <*> dsCon tvbs fam_inst_type con <*> mapM dsDerivClause derivings) #else dsDec (DataInstD cxt n tys cons derivings) = do tys' <- mapM dsType tys let tvbs = dataFamInstTvbs tys' fam_inst_type = dataFamInstReturnType n tys' (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> pure tys' <*> pure Nothing <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys con derivings) = do tys' <- mapM dsType tys let tvbs = dataFamInstTvbs tys' fam_inst_type = dataFamInstReturnType n tys' (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> pure tys' <*> pure Nothing <*> dsCon tvbs fam_inst_type con <*> mapM dsDerivClause derivings) #endif #if __GLASGOW_HASKELL__ < 707 dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> (DTySynEqn <$> mapM dsType lhs <*> dsType rhs)) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD n <$> dsTySynEqn eqn) #if __GLASGOW_HASKELL__ > 710 dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead <*> mapM dsTySynEqn eqns) #else dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k <*> mapM dsTySynEqn eqns) #endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #endif #if __GLASGOW_HASKELL__ >= 709 #if __GLASGOW_HASKELL__ >= 801 dsDec (PatSynD n args dir pat) = do dir' <- dsPatSynDir n dir (pat', vars) <- dsPatX pat unless (null vars) $ fail $ "Pattern synonym definition cannot contain as-patterns (@)." return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) = (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD Nothing <$> dsCxt cxt <*> dsType ty) #endif dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif -- Like mkExtraDKindBinders, but accepts a Maybe Kind -- argument instead of DKind. mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr] mkExtraKindBinders = maybe (pure (DConT typeKindName)) (runQ . expandSyns >=> dsType) >=> mkExtraDKindBinders' -- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded. mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr] mkExtraDKindBinders' = mkExtraKindBindersGeneric unravel DKindedTV #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig = return DNoSig dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb -- | Desugar a @TypeFamilyHead@ dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) = DTypeFamilyHead n <$> mapM dsTvb tvbs <*> dsFamilyResultSig result <*> pure inj #else -- | Desugar bits and pieces into a 'DTypeFamilyHead' dsTypeFamilyHead :: DsMonad q => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead dsTypeFamilyHead n tvbs m_kind = do result_sig <- case m_kind of Nothing -> return DNoSig Just k -> DKindSig <$> dsType k DTypeFamilyHead n <$> mapM dsTvb tvbs <*> pure result_sig <*> pure Nothing #endif -- | Desugar @Dec@s that can appear in a let expression dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec] dsLetDecs = concatMapM dsLetDec -- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's dsLetDec :: DsMonad q => Dec -> q [DLetDec] dsLetDec (FunD name clauses) = do clauses' <- dsClauses name clauses return [DFunD name clauses'] dsLetDec (ValD pat body where_decs) = do (pat', vars) <- dsPatX pat body' <- dsBody body where_decs error_exp let extras = uncurry (zipWith (DValD . DVarPa)) $ unzip vars return $ DValD pat' body' : extras where error_exp = DAppE (DVarE 'error) (DLitE (StringL $ "Non-exhaustive patterns for " ++ pprint pat)) dsLetDec (SigD name ty) = do ty' <- dsType ty return [DSigD name ty'] dsLetDec (InfixD fixity name) = return [DInfixD fixity name] dsLetDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag) dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single @Con@. -- -- Because we always desugar @Con@s to GADT syntax (see the documentation for -- 'DCon'), it is not always possible to desugar with just a 'Con' alone. -- For instance, we must desugar: -- -- @ -- data Foo a = forall b. MkFoo b -- @ -- -- To this: -- -- @ -- data Foo a :: Type where -- MkFoo :: forall a b. b -> Foo a -- @ -- -- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward -- to figure out (1) what the set of universally quantified type variables -- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, -- we require passing these as arguments. (If we desugar an actual GADT -- constructor, these arguments are ignored.) dsCon :: DsMonad q => [DTyVarBndr] -- ^ The universally quantified type variables -- (used if desugaring a non-GADT constructor). -> DType -- ^ The original data declaration's type -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] dsCon univ_dtvbs data_type con = do dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> case m_gadt_type of Nothing -> let ex_dtvbs = dtvbs in DCon (univ_dtvbs ++ ex_dtvbs) dcxt n fields data_type Just gadt_type -> let univ_ex_dtvbs = dtvbs in DCon univ_ex_dtvbs dcxt n fields gadt_type -- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes -- depending on what the returned Maybe DType value is: -- -- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, -- so the returned DTyVarBndrs are both the universally and existentially -- quantified tyvars. -- * If returning Nothing, we're dealing with a non-GADT constructor, so -- the returned DTyVarBndrs are the existentials only. dsCon' :: DsMonad q => Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] dsCon' (NormalC n stys) = do dtys <- mapM dsBangType stys return [(n, [], [], DNormalC False dtys, Nothing)] dsCon' (RecC n vstys) = do vdtys <- mapM dsVarBangType vstys return [(n, [], [], DRecC vdtys, Nothing)] dsCon' (InfixC sty1 n sty2) = do dty1 <- dsBangType sty1 dty2 <- dsBangType sty2 return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] dsCon' (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvb tvbs dcxt <- dsCxt cxt dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) #if __GLASGOW_HASKELL__ > 710 dsCon' (GadtC nms btys rty) = do dbtys <- mapM dsBangType btys drty <- dsType rty sequence $ flip map nms $ \nm -> do mbFi <- reifyFixityWithLocals nm -- A GADT data constructor is declared infix when these three -- properties hold: let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax -- (e.g., (:*:)) || length dbtys == 2 -- 2. It has exactly two fields || isJust mbFi -- 3. It has a programmer-specified -- fixity declaration return (nm, [], [], DNormalC decInfix dbtys, Just drty) dsCon' (RecGadtC nms vbtys rty) = do dvbtys <- mapM dsVarBangType vbtys drty <- dsType rty return $ flip map nms $ \nm -> (nm, [], [], DRecC dvbtys, Just drty) #endif #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty #else -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => StrictType -> q DBangType dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty #endif -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty -- | Desugar a @Pragma@. dsPragma :: DsMonad q => Pragma -> q DPragma dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty <*> pure m_inl <*> pure phases dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str <$> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases #if __GLASGOW_HASKELL__ >= 707 dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp #endif #if __GLASGOW_HASKELL__ >= 709 dsPragma (LineP n str) = return $ DLineP n str #endif #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty #endif -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr dsRuleBndr (RuleVar n) = return $ DRuleVar n dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty #if __GLASGOW_HASKELL__ >= 707 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs #endif -- | Desugar clauses to a function definition dsClauses :: DsMonad q => Name -- ^ Name of the function -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses n rest exp' <- dsExp exp where_decs' <- dsLetDecs where_decs let exp_with_wheres = maybeDLetE where_decs' exp' (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' dsClauses n clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) clause <- DClause (map DVarPa arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n)) scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' let match = DMatch (mkTupleDPat pats') exp' if uni_pats then return [match] else return (match : failure_matches) -- | Desugar a type dsType :: DsMonad q => Type -> q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name -- the only difference between ConT and PromotedT is the name lookup. Here, we assume -- that the TH quote mechanism figured out the right name. Note that lookupDataName name -- does not necessarily work, because `name` has its original module attached, which -- may not be in scope. dsType (PromotedT name) = return $ DConT name dsType (TupleT n) = return $ DConT (tupleTypeName n) dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) dsType ArrowT = return DArrowT dsType ListT = return $ DConT ''[] dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:) dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit #if __GLASGOW_HASKELL__ >= 709 dsType EqualityT = return $ DConT ''(~) #endif #if __GLASGOW_HASKELL__ > 710 dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #endif #if __GLASGOW_HASKELL__ >= 801 dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) #endif -- | Desugar a @TyVarBndr@ dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsType k -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivClause@. dsDerivClause :: DsMonad q => DerivClause -> q DDerivClause dsDerivClause (DerivClause mds cxt) = DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #elif __GLASGOW_HASKELL__ >= 711 dsDerivClause :: DsMonad q => Pred -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #else dsDerivClause :: DsMonad q => Name -> q DDerivClause dsDerivClause n = pure $ DDerivClause Nothing [DConPr n] #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivStrategy@. dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy dsDerivStrategy StockStrategy = pure DStockStrategy dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy #if __GLASGOW_HASKELL__ >= 805 dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty #endif #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir dsPatSynDir _ ImplBidir = pure DImplBidir dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses n clauses #endif -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709 dsPred (ClassP n tys) = do ts' <- mapM dsType tys return [foldl DAppPr (DConPr n) ts'] dsPred (EqualP t1 t2) = do ts' <- mapM dsType [t1, t2] return [foldl DAppPr (DConPr ''(~)) ts'] #else dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts dsPred (ForallT tvbs cxt p) = do ps' <- dsPred p case ps' of [p'] -> (:[]) <$> (DForallPr <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p') _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" -- See Trac #15334. dsPred (AppT t1 t2) = do [p1] <- dsPred t1 -- tuples can't be applied! (:[]) <$> DAppPr p1 <$> dsType t2 dsPred (SigT ty ki) = do preds <- dsPred ty case preds of [p] -> (:[]) <$> DSigPr p <$> dsType ki other -> return other -- just drop the kind signature on a tuple. dsPred (VarT n) = return [DVarPr n] dsPred (ConT n) = return [DConPr n] dsPred t@(PromotedT _) = impossible $ "Promoted type seen as head of constraint: " ++ show t dsPred (TupleT 0) = return [DConPr (tupleTypeName 0)] dsPred (TupleT _) = impossible "Internal error in th-desugar in detecting tuple constraints." dsPred t@(UnboxedTupleT _) = impossible $ "Unboxed tuple seen as head of constraint: " ++ show t dsPred ArrowT = impossible "Arrow seen as head of constraint." dsPred ListT = impossible "List seen as head of constraint." dsPred (PromotedTupleT _) = impossible "Promoted tuple seen as head of constraint." dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." dsPred StarT = impossible "* seen as head of constraint." dsPred ConstraintT = impossible "The kind `Constraint' seen as head of constraint." dsPred t@(LitT _) = impossible $ "Type literal seen as head of constraint: " ++ show t dsPred EqualityT = return [DConPr ''(~)] #if __GLASGOW_HASKELL__ > 710 dsPred (InfixT t1 n t2) = (:[]) <$> (DAppPr <$> (DAppPr (DConPr n) <$> dsType t1) <*> dsType t2) dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardPr] #endif #if __GLASGOW_HASKELL__ >= 801 dsPred t@(UnboxedSumT {}) = impossible $ "Unboxed sum seen as head of constraint: " ++ show t #endif #endif -- | Like 'reify', but safer and desugared. Uses local declarations where -- available. dsReify :: DsMonad q => Name -> q (Maybe DInfo) dsReify = traverse dsInfo <=< reifyWithLocals_maybe -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat con_name field_decs field_pats = reorderFields' dsPat con_name field_decs field_pats (repeat DWildPa) reorderFields' :: (Applicative m, Monad m) => (a -> m da) -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] -> [da] -> m [da] reorderFields' ds_thing con_name field_names_types field_things deflts = check_valid_fields >> reorder field_names deflts where field_names = map (\(a, _, _) -> a) field_names_types check_valid_fields = forM_ field_things $ \(thing_name, _) -> unless (thing_name `elem` field_names) $ fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" ++ nameBase thing_name ++ "‘" reorder [] _ = return [] reorder (field_name : rest) (deflt : rest_deflt) = do rest' <- reorder rest rest_deflt case find (\(thing_name, _) -> thing_name == field_name) field_things of Just (_, thing) -> (: rest') <$> ds_thing thing Nothing -> return $ deflt : rest' reorder (_ : _) [] = error "Internal error in th-desugar." -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps -- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkTupleExp :: [Exp] -> Exp mkTupleExp [exp] = exp mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat mkTupleDPat pats = DConPa (tupleDataName (length pats)) pats -- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple. mkTuplePat :: [Pat] -> Pat mkTuplePat [pat] = pat mkTuplePat pats = ConP (tupleDataName (length pats)) pats -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitPa {}) = return False isUniversalPattern (DVarPa {}) = return True isUniversalPattern (DConPa con_name pats) = do data_name <- dataConNameToDataName con_name (_tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1 then fmap and $ mapM isUniversalPattern pats else return False isUniversalPattern (DTildePa {}) = return True isUniversalPattern (DBangPa pat) = isUniversalPattern pat isUniversalPattern (DSigPa 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 -- | Convert a 'DTyVarBndr' into a 'DType' dTyVarBndrToDType :: DTyVarBndr -> DType dTyVarBndrToDType (DPlainTV a) = DVarT a dTyVarBndrToDType (DKindedTV a k) = DVarT a `DSigT` k -- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just -- the identity operation in GHC 8.x, which has no 'Strict'. -- (This is included in GHC 8.x only for good Haddocking.) #if __GLASGOW_HASKELL__ <= 710 strictToBang :: Strict -> Bang strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness strictToBang Unpacked = Bang SourceUnpack SourceStrict #else strictToBang :: Bang -> Bang strictToBang = id #endif -- | Convert a 'DType' to a 'DPred'. dTypeToDPred :: Monad q => DType -> q DPred dTypeToDPred (DForallT tvbs cxt ty) = DForallPr tvbs cxt `liftM` dTypeToDPred ty dTypeToDPred (DAppT t1 t2) = liftM2 DAppPr (dTypeToDPred t1) (return t2) dTypeToDPred (DSigT ty ki) = liftM2 DSigPr (dTypeToDPred ty) (return ki) dTypeToDPred (DVarT n) = return $ DVarPr n dTypeToDPred (DConT n) = return $ DConPr n dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" dTypeToDPred DWildCardT = return DWildCardPr -- | Convert a 'DPred' to 'DType'. dPredToDType :: DPred -> DType dPredToDType (DForallPr tvbs cxt p) = DForallT tvbs cxt (dPredToDType p) dPredToDType (DAppPr p t) = DAppT (dPredToDType p) t dPredToDType (DSigPr p k) = DSigT (dPredToDType p) k dPredToDType (DVarPr n) = DVarT n dPredToDType (DConPr n) = DConT n dPredToDType DWildCardPr = DWildCardT -- Take a data type name (which does not belong to a data family) and -- apply it to its type variable binders to form a DType. nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map dTyVarBndrToDType -- Take a data family name and apply it to its argument types to form a -- data family instance DType. dataFamInstReturnType :: Name -> [DType] -> DType dataFamInstReturnType fam_name = applyDType (DConT fam_name) -- Take a data type (which does not belong to a data family) of the form -- @Foo a :: k -> Type -> Type@ and return @Foo a (b :: k) (c :: Type)@, where -- @b@ and @c@ are fresh type variable names. nonFamilyDataTvbs :: DsMonad q => [DTyVarBndr] -> Maybe Kind -> q [DTyVarBndr] nonFamilyDataTvbs tvbs mk = do extra_tvbs <- mkExtraKindBinders mk pure $ tvbs ++ extra_tvbs -- Take a data family instance of the form @Foo a :: k -> Type -> Type@ and -- return @Foo a (b :: k) (c :: Type)@, where @b@ and @c@ are fresh type -- variable names. dataFamInstTypes :: DsMonad q => [DType] -> Maybe Kind -> q [DType] dataFamInstTypes tys mk = do extra_tvbs <- mkExtraKindBinders mk pure $ tys ++ map dTyVarBndrToDType extra_tvbs -- Unlike vanilla data types and data family declarations, data family -- instance declarations do not come equipped with a list of bound type -- variables (at least not yet—see Trac #14268). This means that we have -- to reverse engineer this information ourselves from the list of type -- patterns. We accomplish this by taking the free variables of the types -- and performing a reverse topological sort on them to ensure that the -- returned list is well scoped. dataFamInstTvbs :: [DType] -> [DTyVarBndr] dataFamInstTvbs = toposortTyVarsOf -- | Take a list of 'DType's, find their free variables, and sort them in -- reverse topological order to ensure that they are well scoped. -- -- On older GHCs, this takes measures to avoid returning explicitly bound -- kind variables, which was not possible before @TypeInType@. toposortTyVarsOf :: [DType] -> [DTyVarBndr] toposortTyVarsOf tys = let fvs :: [Name] fvs = Set.toList $ foldMap fvDType tys varKindSigs :: Map Name DKind varKindSigs = foldMap go tys where go :: DType -> Map Name DKind go (DForallT {}) = error "`forall` type used in type family pattern" go (DAppT t1 t2) = go t1 `mappend` go t2 go (DSigT t k) = let kSigs = go k in case t of DVarT n -> Map.insert n k kSigs _ -> go t `mappend` kSigs go (DVarT {}) = mempty go (DConT {}) = mempty go DArrowT = mempty go (DLitT {}) = mempty go DWildCardT = mempty (g, gLookup, _) = graphFromEdges [ (fv, fv, kindVars) | fv <- fvs , let kindVars = case Map.lookup fv varKindSigs of Nothing -> [] Just ks -> Set.toList (fvDType ks) ] tg = reverse $ topSort g lookupVertex x = case gLookup x of (n, _, _) -> n ascribeWithKind n | Just k <- Map.lookup n varKindSigs = DKindedTV n k | otherwise = DPlainTV n -- An annoying wrinkle: GHCs before 8.0 don't support explicitly -- quantifying kinds, so something like @forall k (a :: k)@ would be -- rejected. To work around this, we filter out any binders whose names -- also appear in a kind on old GHCs. isKindBinderOnOldGHCs #if __GLASGOW_HASKELL__ >= 800 = const False #else = (`elem` kindVars) where kindVars = foldMap fvDType $ Map.elems varKindSigs #endif in map ascribeWithKind $ filter (not . isKindBinderOnOldGHCs) $ map lookupVertex tg fvDType :: DType -> S.Set Name fvDType = go_ty where go_ty :: DType -> S.Set Name go_ty (DForallT tvbs cxt ty) = foldr go_tvb (foldMap go_pred cxt <> go_ty ty) tvbs go_ty (DAppT t1 t2) = go_ty t1 <> go_ty t2 go_ty (DSigT ty ki) = go_ty ty <> go_ty ki go_ty (DVarT n) = S.singleton n go_ty (DConT {}) = S.empty go_ty DArrowT = S.empty go_ty (DLitT {}) = S.empty go_ty DWildCardT = S.empty go_pred :: DPred -> S.Set Name go_pred (DAppPr pr ty) = go_pred pr <> go_ty ty go_pred (DSigPr pr ki) = go_pred pr <> go_ty ki go_pred (DVarPr n) = S.singleton n go_pred _ = S.empty go_tvb :: DTyVarBndr -> S.Set Name -> S.Set Name go_tvb (DPlainTV n) fvs = S.delete n fvs go_tvb (DKindedTV n k) fvs = S.delete n fvs <> go_ty k dtvbName :: DTyVarBndr -> Name dtvbName (DPlainTV n) = n dtvbName (DKindedTV n _) = n -- | Decompose a function type into its type variables, its context, its -- argument types, and its result type. unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType) unravel (DForallT tvbs cxt ty) = let (tvbs', cxt', tys, res) = unravel ty in (tvbs ++ tvbs', cxt ++ cxt', tys, res) unravel (DAppT (DAppT DArrowT t1) t2) = let (tvbs, cxt, tys, res) = unravel t2 in (tvbs, cxt, t1 : tys, res) unravel t = ([], [], [], t) th-desugar-1.9/Language/Haskell/TH/Desugar/Sweeten.hs0000644000000000000000000004024213350246155020603 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Sweeten.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Converts desugared TH back into real TH. -} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- 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 ( expToTH, matchToTH, patToTH, decsToTH, decToTH, letDecToTH, typeToTH, conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH, #if __GLASGOW_HASKELL__ >= 801 patSynDirToTH #endif ) where import Prelude hiding (exp) import Control.Arrow import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Data.Maybe ( maybeToList, mapMaybe ) expToTH :: DExp -> Exp expToTH (DVarE n) = VarE n expToTH (DConE n) = ConE n expToTH (DLitE l) = LitE l expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2) expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp) expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp) = LetE (mapMaybe letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) #if __GLASGOW_HASKELL__ < 709 expToTH (DStaticE _) = error "Static expressions supported only in GHC 7.10+" #else expToTH (DStaticE exp) = StaticE (expToTH exp) #endif #if __GLASGOW_HASKELL__ >= 801 expToTH (DAppTypeE exp ty) = AppTypeE (expToTH exp) (typeToTH ty) #else -- In the event that we're on a version of Template Haskell without support for -- type applications, we will simply drop the applied type. expToTH (DAppTypeE exp _) = expToTH exp #endif matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] patToTH :: DPat -> Pat patToTH (DLitPa lit) = LitP lit patToTH (DVarPa n) = VarP n patToTH (DConPa n pats) = ConP n (map patToTH pats) patToTH (DTildePa pat) = TildeP (patToTH pat) patToTH (DBangPa pat) = BangP (patToTH pat) patToTH (DSigPa pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildPa = WildP decsToTH :: [DDec] -> [Dec] decsToTH = concatMap decToTH -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@. decToTH :: DDec -> [Dec] decToTH (DLetDec d) = maybeToList (letDecToTH d) decToTH (DDataD Data cxt n tvbs _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710 [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) (map derivingToTH derivings)] #endif decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) (map derivingToTH derivings)] #endif decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)] decToTH (DClassD cxt n tvbs fds decs) = [ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)] #if __GLASGOW_HASKELL__ >= 711 decToTH (DInstanceD over cxt ty decs) = [InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] #else decToTH (DInstanceD _ cxt ty decs) = [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] #endif decToTH (DForeignD f) = [ForeignD (foreignToTH f)] #if __GLASGOW_HASKELL__ > 710 decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) = [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)] #else decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) = [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)] #endif decToTH (DDataFamilyD n tvbs mk) = #if __GLASGOW_HASKELL__ > 710 [DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk)] #else [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)] #endif decToTH (DDataInstD Data cxt n tys _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710 [DataInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) (map derivingToTH derivings)] #endif decToTH (DDataInstD Newtype cxt n tys _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con) (map derivingToTH derivings)] #endif #if __GLASGOW_HASKELL__ < 707 decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn] decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = (FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)) : (map (tySynEqnToTHDec n) eqns) decToTH (DRoleAnnotD {}) = [] #else decToTH (DTySynInstD n eqn) = [TySynInstD n (tySynEqnToTH eqn)] #if __GLASGOW_HASKELL__ > 710 decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) (map tySynEqnToTH eqns) ] #else decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map tySynEqnToTH eqns)] #endif decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] #endif #if __GLASGOW_HASKELL__ < 709 decToTH (DStandaloneDerivD {}) = error "Standalone deriving supported only in GHC 7.10+" decToTH (DDefaultSigD {}) = error "Default method signatures supported only in GHC 7.10+" #else decToTH (DStandaloneDerivD _mds cxt ty) = [StandaloneDerivD #if __GLASGOW_HASKELL__ >= 801 (fmap derivStrategyToTH _mds) #endif (cxtToTH cxt) (typeToTH ty)] decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)] #endif #if __GLASGOW_HASKELL__ >= 801 decToTH (DPatSynD n args dir pat) = [PatSynD n args (patSynDirToTH dir) (patToTH pat)] decToTH (DPatSynSigD n ty) = [PatSynSigD n (typeToTH ty)] #else decToTH dec | DPatSynD{} <- dec = patSynErr | DPatSynSigD{} <- dec = patSynErr where patSynErr = error "Pattern synonyms supported only in GHC 8.2+" #endif decToTH _ = error "Newtype declaration without exactly 1 constructor." #if __GLASGOW_HASKELL__ > 710 frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig = NoSig frsToTH (DKindSig k) = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb) #else frsToTH :: DFamilyResultSig -> Maybe Kind frsToTH DNoSig = Nothing frsToTH (DKindSig k) = Just (typeToTH k) frsToTH (DTyVarSig (DPlainTV _)) = Nothing frsToTH (DTyVarSig (DKindedTV _ k)) = Just (typeToTH k) #endif #if __GLASGOW_HASKELL__ <= 710 derivingToTH :: DDerivClause -> Name derivingToTH (DDerivClause _ [DConPr nm]) = nm derivingToTH p = error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p) #endif -- | Note: This can currently only return a 'Nothing' if the 'DLetDec' is a pragma which -- is not supported by the GHC version being used. letDecToTH :: DLetDec -> Maybe Dec letDecToTH (DFunD name clauses) = Just $ FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = Just $ ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = Just $ SigD name (typeToTH ty) letDecToTH (DInfixD f name) = Just $ InfixD f name letDecToTH (DPragmaD prag) = fmap PragmaD (pragmaToTH prag) conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710 conToTH (DCon [] [] n (DNormalC _ stys) rty) = GadtC [n] (map (second typeToTH) stys) (typeToTH rty) conToTH (DCon [] [] n (DRecC vstys) rty) = RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty) #else conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) = InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2) -- Note: it's possible that someone could pass in a DNormalC value that -- erroneously claims that it's declared infix (e.g., if has more than two -- fields), but we will fall back on NormalC in such a scenario. conToTH (DCon [] [] n (DNormalC _ stys) _) = NormalC n (map (bangToStrict *** typeToTH) stys) conToTH (DCon [] [] n (DRecC vstys) _) = RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys) #endif #if __GLASGOW_HASKELL__ > 710 -- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is -- perfectly OK to put all of the quantified type variables -- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) = ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) #else -- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is -- used is when there are either: -- -- 1. Any existentially quantified type variables -- 2. A constructor context -- -- If neither of these conditions hold, then we needn't put a ForallC at the -- front, since it would be completely pointless (you'd end up with things like -- @data Foo = forall. MkFoo@!). conToTH (DCon tvbs cxt n fields rty) | null ex_tvbs && null cxt = con' | otherwise = ForallC ex_tvbs (cxtToTH cxt) con' where -- Fortunately, on old GHCs, it's especially easy to distinguish between -- universally and existentially quantified type variables. When desugaring -- a ForallC, we just stick all of the universals (from the datatype -- definition) at the front of the @forall@. Therefore, it suffices to -- count the number of type variables in the return type and drop that many -- variables from the @forall@ in the ForallC, leaving only the -- existentials. ex_tvbs :: [TyVarBndr] ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs num_univ_tvs :: Int num_univ_tvs = go rty where go :: DType -> Int go (DForallT {}) = error "`forall` type used in GADT return type" go (DAppT t1 t2) = go t1 + go t2 go (DSigT t _) = go t go (DVarT {}) = 1 go (DConT {}) = 0 go DArrowT = 0 go (DLitT {}) = 0 go DWildCardT = 0 con' :: Con con' = conToTH $ DCon [] [] n fields rty #endif foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) pragmaToTH :: DPragma -> Maybe Pragma pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) = Just $ SpecialiseP n (typeToTH ty) m_inl phases pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty) pragmaToTH (DRuleP str rbs lhs rhs phases) = Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #if __GLASGOW_HASKELL__ < 707 pragmaToTH (DAnnP {}) = Nothing #else pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) #endif #if __GLASGOW_HASKELL__ < 709 pragmaToTH (DLineP {}) = Nothing #else pragmaToTH (DLineP n str) = Just $ LineP n str #endif #if __GLASGOW_HASKELL__ < 801 pragmaToTH (DCompleteP {}) = Nothing #else pragmaToTH (DCompleteP cls mty) = Just $ CompleteP cls mty #endif ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty) #if __GLASGOW_HASKELL__ < 707 -- | GHC 7.6.3 doesn't have TySynEqn, so we sweeten to a Dec in GHC 7.6.3; -- GHC 7.8+ does not use this function tySynEqnToTHDec :: Name -> DTySynEqn -> Dec tySynEqnToTHDec n (DTySynEqn lhs rhs) = TySynInstD n (map typeToTH lhs) (typeToTH rhs) #else tySynEqnToTH :: DTySynEqn -> TySynEqn tySynEqnToTH (DTySynEqn lhs rhs) = TySynEqn (map typeToTH lhs) (typeToTH rhs) #endif clauseToTH :: DClause -> Clause clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) [] typeToTH :: DType -> Type typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2) typeToTH (DSigT ty ki) = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n) = VarT n typeToTH (DConT n) = tyconToTH n typeToTH DArrowT = ArrowT typeToTH (DLitT lit) = LitT lit #if __GLASGOW_HASKELL__ > 710 typeToTH DWildCardT = WildCardT #else typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n tvbToTH (DKindedTV n k) = KindedTV n (typeToTH k) cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH #if __GLASGOW_HASKELL__ >= 801 derivClauseToTH :: DDerivClause -> [DerivClause] derivClauseToTH (DDerivClause mds cxt) = [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else derivClauseToTH :: DDerivClause -> Cxt derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt #endif #if __GLASGOW_HASKELL__ >= 801 derivStrategyToTH :: DDerivStrategy -> DerivStrategy derivStrategyToTH DStockStrategy = StockStrategy derivStrategyToTH DAnyclassStrategy = AnyclassStrategy derivStrategyToTH DNewtypeStrategy = NewtypeStrategy #if __GLASGOW_HASKELL__ >= 805 derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty) #else derivStrategyToTH (DViaStrategy _) = error "DerivingVia supported only in GHC 8.6+" #endif #endif #if __GLASGOW_HASKELL__ >= 801 patSynDirToTH :: DPatSynDir -> PatSynDir patSynDirToTH DUnidir = Unidir patSynDirToTH DImplBidir = ImplBidir patSynDirToTH (DExplBidir clauses) = ExplBidir (map clauseToTH clauses) #endif predToTH :: DPred -> Pred #if __GLASGOW_HASKELL__ < 709 predToTH = go [] where go acc (DAppPr p t) = go (typeToTH t : acc) p go acc (DSigPr p _) = go acc p -- this shouldn't happen. go _ (DVarPr _) = error "Template Haskell in GHC <= 7.8 does not support variable constraints." go acc (DConPr n) | nameBase n == "~" , [t1, t2] <- acc = EqualP t1 t2 | otherwise = ClassP n acc go _ DWildCardPr = error "Wildcards supported only in GHC 8.0+" go _ (DForallPr {}) = error "Quantified constraints supported only in GHC 8.6+" #else predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t) predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k) predToTH (DVarPr n) = VarT n predToTH (DConPr n) = typeToTH (DConT n) #if __GLASGOW_HASKELL__ > 710 predToTH DWildCardPr = WildCardT #else predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" #endif #if __GLASGOW_HASKELL__ >= 805 predToTH (DForallPr tvbs cxt p) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (predToTH p) #else predToTH (DForallPr {}) = error "Quantified constraints supported only in GHC 8.6+" #endif #endif tyconToTH :: Name -> Type tyconToTH n | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT #if __GLASGOW_HASKELL__ >= 709 | n == ''(~) = EqualityT #endif | n == '[] = PromotedNilT | n == '(:) = PromotedConsT | Just deg <- tupleNameDegree_maybe n = if isDataName n #if __GLASGOW_HASKELL__ >= 805 then PromotedTupleT deg #else then PromotedT n -- Work around Trac #14843 #endif else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg #if __GLASGOW_HASKELL__ == 706 -- Work around Trac #7667 | isTypeKindName n = StarT #endif #if __GLASGOW_HASKELL__ >= 801 | Just deg <- unboxedSumNameDegree_maybe n = UnboxedSumT deg #endif | otherwise = ConT n #if __GLASGOW_HASKELL__ <= 710 -- | Convert a 'Bang' to a 'Strict' bangToStrict :: Bang -> Strict bangToStrict (Bang SourceUnpack _) = Unpacked bangToStrict (Bang _ SourceStrict) = IsStrict bangToStrict (Bang _ _) = NotStrict #endif