template-haskell 2.15.0.0 → 2.24.0.0
raw patch · 16 files changed
Files
- Language/Haskell/TH.hs +16/−4
- Language/Haskell/TH/CodeDo.hs +22/−0
- Language/Haskell/TH/LanguageExtensions.hs +1/−0
- Language/Haskell/TH/Lib.hs +210/−57
- Language/Haskell/TH/Lib/Internal.hs +0/−938
- Language/Haskell/TH/Lib/Map.hs +0/−110
- Language/Haskell/TH/Ppr.hs +89/−897
- Language/Haskell/TH/PprLib.hs +51/−221
- Language/Haskell/TH/Quote.hs +12/−28
- Language/Haskell/TH/Syntax.hs +399/−2161
- Setup.hs +2/−0
- changelog.md +165/−2
- template-haskell.cabal +20/−18
- vendored-filepath/System/FilePath.hs +147/−0
- vendored-filepath/System/FilePath/Posix.hs +1047/−0
- vendored-filepath/System/FilePath/Windows.hs +1047/−0
Language/Haskell/TH.hs view
@@ -1,13 +1,15 @@ {- | The public face of Template Haskell For other documentation, refer to:-<http://www.haskell.org/haskellwiki/Template_Haskell>+<https://wiki.haskell.org/Template_Haskell> -}+{-# LANGUAGE Safe #-} module Language.Haskell.TH( -- * The monad and its operations Q, runQ,+ Quote(..), -- ** Administration: errors, locations and IO reportError, -- :: String -> Q () reportWarning, -- :: String -> Q ()@@ -20,6 +22,7 @@ -- *** Reify reify, -- :: Name -> Q Info reifyModule,+ newDeclarationGroup, Info(..), ModuleInfo(..), InstanceDec, ParentName,@@ -34,6 +37,8 @@ lookupValueName, -- :: String -> Q (Maybe Name) -- *** Fixity lookup reifyFixity,+ -- *** Type lookup+ reifyType, -- *** Instance lookup reifyInstances, isInstance,@@ -46,12 +51,13 @@ -- * Typed expressions TExp, unType,+ Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode,+ bindCode_, joinCode, liftCode, -- * Names Name, NameSpace, -- Abstract -- ** Constructing names mkName, -- :: String -> Name- newName, -- :: String -> Q Name -- ** Deconstructing names nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String@@ -74,7 +80,8 @@ Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), FunDep(..), TySynEqn(..), TypeFamilyHead(..),- Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,+ Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity,+ maxPrecedence, PatSynDir(..), PatSynArgs(..), -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),@@ -82,7 +89,12 @@ Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),- FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType,+ Syntax.Specificity(..),+ Syntax.BndrVis(..),+ FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType,++ -- ** Documentation+ putDoc, getDoc, DocLoc(..), -- * Library functions module Language.Haskell.TH.Lib,
+ Language/Haskell/TH/CodeDo.hs view
@@ -0,0 +1,22 @@+-- | This module exists to work nicely with the QualifiedDo+-- extension.+--+-- @+-- import qualified Language.Haskell.TH.CodeDo as Code+--+-- myExample :: Monad m => Code m a -> Code m a -> Code m a+-- myExample opt1 opt2 =+-- Code.do+-- x <- someSideEffect -- This one is of type `M Bool`+-- if x then opt1 else opt2+-- @+module Language.Haskell.TH.CodeDo((>>=), (>>)) where++import Language.Haskell.TH.Syntax+import Prelude(Monad)++-- | Module over monad operator for 'Code'+(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b+(>>=) = bindCode+(>>) :: Monad m => m a -> Code m b -> Code m b+(>>) = bindCode_
Language/Haskell/TH/LanguageExtensions.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.LanguageExtensions
Language/Haskell/TH/Lib.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE Safe #-}+ -- | -- Language.Haskell.TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms@@ -16,21 +18,22 @@ -- * Library functions -- ** Abbreviations- InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ,+ InfoQ, ExpQ, TExpQ, CodeQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, FamilyResultSigQ, DerivStrategyQ,+ TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis, -- ** Constructors lifted to 'Q' -- *** Literals intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,- charL, stringL, stringPrimL, charPrimL,+ charL, stringL, stringPrimL, charPrimL, bytesPrimL, mkBytes, -- *** Patterns litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP, infixP, tildeP, bangP, asP, wildP, recP,- listP, sigP, viewP,+ listP, sigP, viewP, typeP, invisP, fieldPat, -- *** Pattern Guards@@ -39,8 +42,11 @@ -- *** Expressions dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE, appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,- lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,- letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,+ lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,+ multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,+ fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE, typeE,+ forallE, forallVisE, constrainedE,+ -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, @@ -52,12 +58,13 @@ bindS, letS, noBindS, parS, recS, -- *** Types- forallT, varT, conT, appT, appKindT, arrowT, infixT, uInfixT, parensT,- equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT,- wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT,- implicitParamT,+ forallT, forallVisT, varT, conT, appT, appKindT, arrowT, mulArrowT,+ infixT, uInfixT, promotedInfixT, promotedUInfixT,+ parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,+ sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,+ promotedConsT, implicitParamT, -- **** Type literals- numTyLit, strTyLit,+ numTyLit, strTyLit, charTyLit, -- **** Strictness noSourceUnpackedness, sourceNoUnpack, sourceUnpack, noSourceStrictness, sourceLazy, sourceStrict,@@ -72,20 +79,25 @@ varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, -- *** Type variable binders+ DefaultBndrFlag(defaultBndrFlag), plainTV, kindedTV,+ plainInvisTV, kindedInvisTV,+ plainBndrTV, kindedBndrTV,+ specifiedSpec, inferredSpec,+ bndrReq, bndrInvis, -- *** Roles nominalR, representationalR, phantomR, inferR, -- *** Top Level Declarations -- **** Data- valD, funD, tySynD, dataD, newtypeD,+ valD, funD, tySynD, dataD, newtypeD, typeDataD, derivClause, DerivClause(..), stockStrategy, anyclassStrategy, newtypeStrategy, viaStrategy, DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..),- sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD,+ sigD, kiSigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, -- **** Role annotations roleAnnotD,@@ -97,6 +109,9 @@ -- **** Fixity infixLD, infixRD, infixND, + -- **** Default declaration+ defaultD,+ -- **** Foreign Function Interface (FFI) cCall, stdCall, cApi, prim, javaScript, unsafe, safe, interruptible, forImpD,@@ -107,7 +122,9 @@ -- **** Pragmas ruleVar, typedRuleVar, valueAnnotation, typeAnnotation, moduleAnnotation,- pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,+ pragInlD, pragSpecD, pragSpecInlD,+ pragSpecED, pragSpecInlED,+ pragSpecInstD, pragRuleD, pragAnnD, pragLineD, pragCompleteD, -- **** Pattern Synonyms@@ -118,14 +135,19 @@ implicitParamBindD, -- ** Reify- thisModule+ thisModule, + -- ** Documentation+ withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc,+ typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc+ ) where -import Language.Haskell.TH.Lib.Internal hiding+import GHC.Boot.TH.Lib hiding ( tySynD , dataD , newtypeD+ , typeDataD , classD , pragRuleD , dataInstD@@ -151,13 +173,23 @@ , derivClause , standaloneDerivWithStrategyD + , doE+ , mdoE+ , tupE+ , unboxedTupE++ , conP+ , Role , InjectivityAnn )+import qualified GHC.Boot.TH.Lib as Internal import Language.Haskell.TH.Syntax -import Control.Monad (liftM2)-import Prelude+import Control.Applicative (Applicative(..))+import Foreign.ForeignPtr+import Data.Word+import Prelude hiding (Applicative(..)) -- All definitions below represent the "old" API, since their definitions are -- different in Language.Haskell.TH.Lib.Internal. Please think carefully before@@ -167,111 +199,133 @@ ------------------------------------------------------------------------------- -- * Dec -tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ+tySynD :: Quote m => Name -> [TyVarBndr BndrVis] -> m Type -> m Dec tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]- -> DecQ+dataD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con] -> [m DerivClause]+ -> m Dec dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt- cons1 <- sequence cons- derivs1 <- sequence derivs+ cons1 <- sequenceA cons+ derivs1 <- sequenceA derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ]- -> DecQ+newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Con -> [m DerivClause]+ -> m Dec newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con- derivs1 <- sequence derivs+ derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) -classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ+typeDataD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con]+ -> m Dec+typeDataD tc tvs ksig cons =+ do+ cons1 <- sequenceA cons+ return (TypeDataD tc tvs ksig cons1)++classD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do- decs1 <- sequence decs+ decs1 <- sequenceA decs ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 -pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ+pragRuleD :: Quote m => String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec pragRuleD n bndrs lhs rhs phases = do- bndrs1 <- sequence bndrs+ bndrs1 <- sequenceA bndrs lhs1 <- lhs rhs1 <- rhs return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]- -> DecQ+dataInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> [m Con] -> [m DerivClause]+ -> m Dec dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys- cons1 <- sequence cons- derivs1 <- sequence derivs+ cons1 <- sequenceA cons+ derivs1 <- sequenceA derivs return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]- -> DecQ+newtypeInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> m Con -> [m DerivClause]+ -> m Dec newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys con1 <- con- derivs1 <- sequence derivs+ derivs1 <- sequenceA derivs return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ+dataFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Dec dataFamilyD tc tvs kind- = return $ DataFamilyD tc tvs kind+ = pure $ DataFamilyD tc tvs kind -openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig- -> Maybe InjectivityAnn -> DecQ+openTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig+ -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj- = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)+ = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig- -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ+closedTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig+ -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns =- do eqns1 <- sequence eqns+ do eqns1 <- sequenceA eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) -tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ+tySynEqn :: Quote m => (Maybe [TyVarBndr ()]) -> m Type -> m Type -> m TySynEqn tySynEqn tvs lhs rhs = do lhs1 <- lhs rhs1 <- rhs return (TySynEqn tvs lhs1 rhs1) -forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ-forallC ns ctxt con = liftM2 (ForallC ns) ctxt con+forallC :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Con -> m Con+forallC ns ctxt con = liftA2 (ForallC ns) ctxt con ------------------------------------------------------------------------------- -- * Type -forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ+forallT :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT tvars ctxt ty = do ctxt1 <- ctxt ty1 <- ty return $ ForallT tvars ctxt1 ty1 -sigT :: TypeQ -> Kind -> TypeQ+sigT :: Quote m => m Type -> Kind -> m Type sigT t k = do t' <- t return $ SigT t' k ---------------------------------------------------------------------------------- * Kind+-- * Type variable binders -plainTV :: Name -> TyVarBndr-plainTV = PlainTV+class DefaultBndrFlag flag where+ defaultBndrFlag :: flag -kindedTV :: Name -> Kind -> TyVarBndr-kindedTV = KindedTV+instance DefaultBndrFlag () where+ defaultBndrFlag = () +instance DefaultBndrFlag Specificity where+ defaultBndrFlag = SpecifiedSpec++instance DefaultBndrFlag BndrVis where+ defaultBndrFlag = BndrReq++plainTV :: DefaultBndrFlag flag => Name -> TyVarBndr flag+plainTV n = PlainTV n defaultBndrFlag++kindedTV :: DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag+kindedTV n k = KindedTV n defaultBndrFlag k++-------------------------------------------------------------------------------+-- * Kind+ starK :: Kind starK = StarT @@ -287,19 +341,118 @@ kindSig :: Kind -> FamilyResultSig kindSig = KindSig -tyVarSig :: TyVarBndr -> FamilyResultSig+tyVarSig :: TyVarBndr () -> FamilyResultSig tyVarSig = TyVarSig ------------------------------------------------------------------------------- -- * Top Level Declarations -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ+derivClause :: Quote m => Maybe DerivStrategy -> [m Pred] -> m DerivClause derivClause mds p = do p' <- cxt p return $ DerivClause mds p' -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ+standaloneDerivWithStrategyD :: Quote m => Maybe DerivStrategy -> m Cxt -> m Type -> m Dec standaloneDerivWithStrategyD mds ctxt ty = do ctxt' <- ctxt ty' <- ty return $ StandaloneDerivD mds ctxt' ty'++-------------------------------------------------------------------------------+-- * Bytes literals++-- | Create a Bytes datatype representing raw bytes to be embedded into the+-- program/library binary.+--+-- @since 2.16.0.0+mkBytes+ :: ForeignPtr Word8 -- ^ Pointer to the data+ -> Word -- ^ Offset from the pointer+ -> Word -- ^ Number of bytes+ -> Bytes+mkBytes = Bytes++-------------------------------------------------------------------------------+-- * Tuple expressions++tupE :: Quote m => [m Exp] -> m Exp+tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)}++unboxedTupE :: Quote m => [m Exp] -> m Exp+unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)}++-------------------------------------------------------------------------------+-- * Do expressions++doE :: Quote m => [m Stmt] -> m Exp+doE = Internal.doE Nothing++mdoE :: Quote m => [m Stmt] -> m Exp+mdoE = Internal.mdoE Nothing++-------------------------------------------------------------------------------+-- * Patterns++conP :: Quote m => Name -> [m Pat] -> m Pat+conP n xs = Internal.conP n [] xs+++--------------------------------------------------------------------------------+-- * Constraint predicates (deprecated)++{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}+classP :: Quote m => Name -> [m Type] -> m Pred+classP cla tys+ = do+ tysl <- sequenceA tys+ pure (foldl AppT (ConT cla) tysl)++{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}+equalP :: Quote m => m Type -> m Type -> m Pred+equalP tleft tright+ = do+ tleft1 <- tleft+ tright1 <- tright+ eqT <- equalityT+ pure (foldl AppT eqT [tleft1, tright1])++--------------------------------------------------------------------------------+-- * Strictness queries (deprecated)+{-# DEPRECATED isStrict+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}+{-# DEPRECATED notStrict+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}+{-# DEPRECATED unpacked+ ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",+ "Example usage: 'bang sourceUnpack sourceStrict'"] #-}+isStrict, notStrict, unpacked :: Quote m => m Strict+isStrict = bang noSourceUnpackedness sourceStrict+notStrict = bang noSourceUnpackedness noSourceStrictness+unpacked = bang sourceUnpack sourceStrict++{-# DEPRECATED strictType+ "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}+strictType :: Quote m => m Strict -> m Type -> m StrictType+strictType = bangType++{-# DEPRECATED varStrictType+ "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}+varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType+varStrictType = varBangType++--------------------------------------------------------------------------------+-- * Specialisation pragmas (backwards compatibility)++pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec+pragSpecD n ty phases+ = do+ ty1 <- ty+ pure $ PragmaD $ SpecialiseP n ty1 Nothing phases++pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec+pragSpecInlD n ty inline phases+ = do+ ty1 <- ty+ pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
− Language/Haskell/TH/Lib/Internal.hs
@@ -1,938 +0,0 @@--- |--- Language.Haskell.TH.Lib.Internal exposes some additional functionality that--- is used internally in GHC's integration with Template Haskell. This is not a--- part of the public API, and as such, there are no API guarantees for this--- module from version to version.---- Why do we have both Language.Haskell.TH.Lib.Internal and--- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the--- former (which are tailored for GHC's use) need different type signatures--- than the ones in the latter. Syncing up the Internal type signatures would--- involve a massive amount of breaking changes, so for the time being, we--- relegate as many changes as we can to just the Internal module, where it--- is safe to break things.--module Language.Haskell.TH.Lib.Internal where--import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)-import qualified Language.Haskell.TH.Syntax as TH-import Control.Monad( liftM, liftM2 )-import Data.Word( Word8 )-import Prelude--------------------------------------------------------------- * Type synonyms-------------------------------------------------------------type InfoQ = Q Info-type PatQ = Q Pat-type FieldPatQ = Q FieldPat-type ExpQ = Q Exp-type TExpQ a = Q (TExp a)-type DecQ = Q Dec-type DecsQ = Q [Dec]-type ConQ = Q Con-type TypeQ = Q Type-type KindQ = Q Kind-type TyVarBndrQ = Q TyVarBndr-type TyLitQ = Q TyLit-type CxtQ = Q Cxt-type PredQ = Q Pred-type DerivClauseQ = Q DerivClause-type MatchQ = Q Match-type ClauseQ = Q Clause-type BodyQ = Q Body-type GuardQ = Q Guard-type StmtQ = Q Stmt-type RangeQ = Q Range-type SourceStrictnessQ = Q SourceStrictness-type SourceUnpackednessQ = Q SourceUnpackedness-type BangQ = Q Bang-type BangTypeQ = Q BangType-type VarBangTypeQ = Q VarBangType-type StrictTypeQ = Q StrictType-type VarStrictTypeQ = Q VarStrictType-type FieldExpQ = Q FieldExp-type RuleBndrQ = Q RuleBndr-type TySynEqnQ = Q TySynEqn-type PatSynDirQ = Q PatSynDir-type PatSynArgsQ = Q PatSynArgs-type FamilyResultSigQ = Q FamilyResultSig-type DerivStrategyQ = Q DerivStrategy---- must be defined here for DsMeta to find it-type Role = TH.Role-type InjectivityAnn = TH.InjectivityAnn--------------------------------------------------------------- * Lowercase pattern syntax functions-------------------------------------------------------------intPrimL :: Integer -> Lit-intPrimL = IntPrimL-wordPrimL :: Integer -> Lit-wordPrimL = WordPrimL-floatPrimL :: Rational -> Lit-floatPrimL = FloatPrimL-doublePrimL :: Rational -> Lit-doublePrimL = DoublePrimL-integerL :: Integer -> Lit-integerL = IntegerL-charL :: Char -> Lit-charL = CharL-charPrimL :: Char -> Lit-charPrimL = CharPrimL-stringL :: String -> Lit-stringL = StringL-stringPrimL :: [Word8] -> Lit-stringPrimL = StringPrimL-rationalL :: Rational -> Lit-rationalL = RationalL--litP :: Lit -> PatQ-litP l = return (LitP l)--varP :: Name -> PatQ-varP v = return (VarP v)--tupP :: [PatQ] -> PatQ-tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}--unboxedTupP :: [PatQ] -> PatQ-unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}--unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ-unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }--conP :: Name -> [PatQ] -> PatQ-conP n ps = do ps' <- sequence ps- return (ConP n ps')-infixP :: PatQ -> Name -> PatQ -> PatQ-infixP p1 n p2 = do p1' <- p1- p2' <- p2- return (InfixP p1' n p2')-uInfixP :: PatQ -> Name -> PatQ -> PatQ-uInfixP p1 n p2 = do p1' <- p1- p2' <- p2- return (UInfixP p1' n p2')-parensP :: PatQ -> PatQ-parensP p = do p' <- p- return (ParensP p')--tildeP :: PatQ -> PatQ-tildeP p = do p' <- p- return (TildeP p')-bangP :: PatQ -> PatQ-bangP p = do p' <- p- return (BangP p')-asP :: Name -> PatQ -> PatQ-asP n p = do p' <- p- return (AsP n p')-wildP :: PatQ-wildP = return WildP-recP :: Name -> [FieldPatQ] -> PatQ-recP n fps = do fps' <- sequence fps- return (RecP n fps')-listP :: [PatQ] -> PatQ-listP ps = do ps' <- sequence ps- return (ListP ps')-sigP :: PatQ -> TypeQ -> PatQ-sigP p t = do p' <- p- t' <- t- return (SigP p' t')-viewP :: ExpQ -> PatQ -> PatQ-viewP e p = do e' <- e- p' <- p- return (ViewP e' p')--fieldPat :: Name -> PatQ -> FieldPatQ-fieldPat n p = do p' <- p- return (n, p')------------------------------------------------------------------------------------- * Stmt--bindS :: PatQ -> ExpQ -> StmtQ-bindS p e = liftM2 BindS p e--letS :: [DecQ] -> StmtQ-letS ds = do { ds1 <- sequence ds; return (LetS ds1) }--noBindS :: ExpQ -> StmtQ-noBindS e = do { e1 <- e; return (NoBindS e1) }--parS :: [[StmtQ]] -> StmtQ-parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }--recS :: [StmtQ] -> StmtQ-recS ss = do { ss1 <- sequence ss; return (RecS ss1) }------------------------------------------------------------------------------------ * Range--fromR :: ExpQ -> RangeQ-fromR x = do { a <- x; return (FromR a) }--fromThenR :: ExpQ -> ExpQ -> RangeQ-fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }--fromToR :: ExpQ -> ExpQ -> RangeQ-fromToR x y = do { a <- x; b <- y; return (FromToR a b) }--fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ-fromThenToR x y z = do { a <- x; b <- y; c <- z;- return (FromThenToR a b c) }----------------------------------------------------------------------------------- * Body--normalB :: ExpQ -> BodyQ-normalB e = do { e1 <- e; return (NormalB e1) }--guardedB :: [Q (Guard,Exp)] -> BodyQ-guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }------------------------------------------------------------------------------------ * Guard--normalG :: ExpQ -> GuardQ-normalG e = do { e1 <- e; return (NormalG e1) }--normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)-normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }--patG :: [StmtQ] -> GuardQ-patG ss = do { ss' <- sequence ss; return (PatG ss') }--patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)-patGE ss e = do { ss' <- sequence ss;- e' <- e;- return (PatG ss', e') }------------------------------------------------------------------------------------ * Match and Clause---- | Use with 'caseE'-match :: PatQ -> BodyQ -> [DecQ] -> MatchQ-match p rhs ds = do { p' <- p;- r' <- rhs;- ds' <- sequence ds;- return (Match p' r' ds') }---- | Use with 'funD'-clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ-clause ps r ds = do { ps' <- sequence ps;- r' <- r;- ds' <- sequence ds;- return (Clause ps' r' ds') }--------------------------------------------------------------------------------- * Exp---- | Dynamically binding a variable (unhygenic)-dyn :: String -> ExpQ-dyn s = return (VarE (mkName s))--varE :: Name -> ExpQ-varE s = return (VarE s)--conE :: Name -> ExpQ-conE s = return (ConE s)--litE :: Lit -> ExpQ-litE c = return (LitE c)--appE :: ExpQ -> ExpQ -> ExpQ-appE x y = do { a <- x; b <- y; return (AppE a b)}--appTypeE :: ExpQ -> TypeQ -> ExpQ-appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }--parensE :: ExpQ -> ExpQ-parensE x = do { x' <- x; return (ParensE x') }--uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ-uInfixE x s y = do { x' <- x; s' <- s; y' <- y;- return (UInfixE x' s' y') }--infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ-infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;- return (InfixE (Just a) s' (Just b))}-infixE Nothing s (Just y) = do { s' <- s; b <- y;- return (InfixE Nothing s' (Just b))}-infixE (Just x) s Nothing = do { a <- x; s' <- s;- return (InfixE (Just a) s' Nothing)}-infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }--infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ-infixApp x y z = infixE (Just x) y (Just z)-sectionL :: ExpQ -> ExpQ -> ExpQ-sectionL x y = infixE (Just x) y Nothing-sectionR :: ExpQ -> ExpQ -> ExpQ-sectionR x y = infixE Nothing x (Just y)--lamE :: [PatQ] -> ExpQ -> ExpQ-lamE ps e = do ps' <- sequence ps- e' <- e- return (LamE ps' e')---- | Single-arg lambda-lam1E :: PatQ -> ExpQ -> ExpQ-lam1E p e = lamE [p] e--lamCaseE :: [MatchQ] -> ExpQ-lamCaseE ms = sequence ms >>= return . LamCaseE--tupE :: [ExpQ] -> ExpQ-tupE es = do { es1 <- sequence es; return (TupE es1)}--unboxedTupE :: [ExpQ] -> ExpQ-unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}--unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ-unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }--condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ-condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}--multiIfE :: [Q (Guard, Exp)] -> ExpQ-multiIfE alts = sequence alts >>= return . MultiIfE--letE :: [DecQ] -> ExpQ -> ExpQ-letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }--caseE :: ExpQ -> [MatchQ] -> ExpQ-caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }--doE :: [StmtQ] -> ExpQ-doE ss = do { ss1 <- sequence ss; return (DoE ss1) }--mdoE :: [StmtQ] -> ExpQ-mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) }--compE :: [StmtQ] -> ExpQ-compE ss = do { ss1 <- sequence ss; return (CompE ss1) }--arithSeqE :: RangeQ -> ExpQ-arithSeqE r = do { r' <- r; return (ArithSeqE r') }--listE :: [ExpQ] -> ExpQ-listE es = do { es1 <- sequence es; return (ListE es1) }--sigE :: ExpQ -> TypeQ -> ExpQ-sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }--recConE :: Name -> [Q (Name,Exp)] -> ExpQ-recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }--recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ-recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }--stringE :: String -> ExpQ-stringE = litE . stringL--fieldExp :: Name -> ExpQ -> Q (Name, Exp)-fieldExp s e = do { e' <- e; return (s,e') }---- | @staticE x = [| static x |]@-staticE :: ExpQ -> ExpQ-staticE = fmap StaticE--unboundVarE :: Name -> ExpQ-unboundVarE s = return (UnboundVarE s)--labelE :: String -> ExpQ-labelE s = return (LabelE s)--implicitParamVarE :: String -> ExpQ-implicitParamVarE n = return (ImplicitParamVarE n)---- ** 'arithSeqE' Shortcuts-fromE :: ExpQ -> ExpQ-fromE x = do { a <- x; return (ArithSeqE (FromR a)) }--fromThenE :: ExpQ -> ExpQ -> ExpQ-fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }--fromToE :: ExpQ -> ExpQ -> ExpQ-fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }--fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ-fromThenToE x y z = do { a <- x; b <- y; c <- z;- return (ArithSeqE (FromThenToR a b c)) }------------------------------------------------------------------------------------- * Dec--valD :: PatQ -> BodyQ -> [DecQ] -> DecQ-valD p b ds =- do { p' <- p- ; ds' <- sequence ds- ; b' <- b- ; return (ValD p' b' ds')- }--funD :: Name -> [ClauseQ] -> DecQ-funD nm cs =- do { cs1 <- sequence cs- ; return (FunD nm cs1)- }--tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ-tySynD tc tvs rhs =- do { tvs1 <- sequenceA tvs- ; rhs1 <- rhs- ; return (TySynD tc tvs1 rhs1)- }--dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ]- -> [DerivClauseQ] -> DecQ-dataD ctxt tc tvs ksig cons derivs =- do- ctxt1 <- ctxt- tvs1 <- sequenceA tvs- ksig1 <- sequenceA ksig- cons1 <- sequence cons- derivs1 <- sequence derivs- return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)--newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ- -> [DerivClauseQ] -> DecQ-newtypeD ctxt tc tvs ksig con derivs =- do- ctxt1 <- ctxt- tvs1 <- sequenceA tvs- ksig1 <- sequenceA ksig- con1 <- con- derivs1 <- sequence derivs- return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)--classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ-classD ctxt cls tvs fds decs =- do- tvs1 <- sequenceA tvs- decs1 <- sequenceA decs- ctxt1 <- ctxt- return $ ClassD ctxt1 cls tvs1 fds decs1--instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ-instanceD = instanceWithOverlapD Nothing--instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ-instanceWithOverlapD o ctxt ty decs =- do- ctxt1 <- ctxt- decs1 <- sequence decs- ty1 <- ty- return $ InstanceD o ctxt1 ty1 decs1----sigD :: Name -> TypeQ -> DecQ-sigD fun ty = liftM (SigD fun) $ ty--forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ-forImpD cc s str n ty- = do ty' <- ty- return $ ForeignD (ImportF cc s str n ty')--infixLD :: Int -> Name -> DecQ-infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)--infixRD :: Int -> Name -> DecQ-infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)--infixND :: Int -> Name -> DecQ-infixND prec nm = return (InfixD (Fixity prec InfixN) nm)--pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ-pragInlD name inline rm phases- = return $ PragmaD $ InlineP name inline rm phases--pragSpecD :: Name -> TypeQ -> Phases -> DecQ-pragSpecD n ty phases- = do- ty1 <- ty- return $ PragmaD $ SpecialiseP n ty1 Nothing phases--pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ-pragSpecInlD n ty inline phases- = do- ty1 <- ty- return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases--pragSpecInstD :: TypeQ -> DecQ-pragSpecInstD ty- = do- ty1 <- ty- return $ PragmaD $ SpecialiseInstP ty1--pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ- -> Phases -> DecQ-pragRuleD n ty_bndrs tm_bndrs lhs rhs phases- = do- ty_bndrs1 <- traverse sequence ty_bndrs- tm_bndrs1 <- sequence tm_bndrs- lhs1 <- lhs- rhs1 <- rhs- return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases--pragAnnD :: AnnTarget -> ExpQ -> DecQ-pragAnnD target expr- = do- exp1 <- expr- return $ PragmaD $ AnnP target exp1--pragLineD :: Int -> String -> DecQ-pragLineD line file = return $ PragmaD $ LineP line file--pragCompleteD :: [Name] -> Maybe Name -> DecQ-pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty--dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ]- -> [DerivClauseQ] -> DecQ-dataInstD ctxt mb_bndrs ty ksig cons derivs =- do- ctxt1 <- ctxt- mb_bndrs1 <- traverse sequence mb_bndrs- ty1 <- ty- ksig1 <- sequenceA ksig- cons1 <- sequenceA cons- derivs1 <- sequenceA derivs- return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)--newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ- -> [DerivClauseQ] -> DecQ-newtypeInstD ctxt mb_bndrs ty ksig con derivs =- do- ctxt1 <- ctxt- mb_bndrs1 <- traverse sequence mb_bndrs- ty1 <- ty- ksig1 <- sequenceA ksig- con1 <- con- derivs1 <- sequence derivs- return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)--tySynInstD :: TySynEqnQ -> DecQ-tySynInstD eqn =- do- eqn1 <- eqn- return (TySynInstD eqn1)--dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ-dataFamilyD tc tvs kind =- do tvs' <- sequenceA tvs- kind' <- sequenceA kind- return $ DataFamilyD tc tvs' kind'--openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ- -> Maybe InjectivityAnn -> DecQ-openTypeFamilyD tc tvs res inj =- do tvs' <- sequenceA tvs- res' <- res- return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)--closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ- -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ-closedTypeFamilyD tc tvs result injectivity eqns =- do tvs1 <- sequenceA tvs- result1 <- result- eqns1 <- sequenceA eqns- return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)--roleAnnotD :: Name -> [Role] -> DecQ-roleAnnotD name roles = return $ RoleAnnotD name roles--standaloneDerivD :: CxtQ -> TypeQ -> DecQ-standaloneDerivD = standaloneDerivWithStrategyD Nothing--standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ-standaloneDerivWithStrategyD mdsq ctxtq tyq =- do- mds <- sequenceA mdsq- ctxt <- ctxtq- ty <- tyq- return $ StandaloneDerivD mds ctxt ty--defaultSigD :: Name -> TypeQ -> DecQ-defaultSigD n tyq =- do- ty <- tyq- return $ DefaultSigD n ty---- | Pattern synonym declaration-patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ-patSynD name args dir pat = do- args' <- args- dir' <- dir- pat' <- pat- return (PatSynD name args' dir' pat')---- | Pattern synonym type signature-patSynSigD :: Name -> TypeQ -> DecQ-patSynSigD nm ty =- do ty' <- ty- return $ PatSynSigD nm ty'---- | Implicit parameter binding declaration. Can only be used in let--- and where clauses which consist entirely of implicit bindings.-implicitParamBindD :: String -> ExpQ -> DecQ-implicitParamBindD n e =- do- e' <- e- return $ ImplicitParamBindD n e'--tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ-tySynEqn mb_bndrs lhs rhs =- do- mb_bndrs1 <- traverse sequence mb_bndrs- lhs1 <- lhs- rhs1 <- rhs- return (TySynEqn mb_bndrs1 lhs1 rhs1)--cxt :: [PredQ] -> CxtQ-cxt = sequence--derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ-derivClause mds p = do mds' <- sequenceA mds- p' <- cxt p- return $ DerivClause mds' p'--stockStrategy :: DerivStrategyQ-stockStrategy = pure StockStrategy--anyclassStrategy :: DerivStrategyQ-anyclassStrategy = pure AnyclassStrategy--newtypeStrategy :: DerivStrategyQ-newtypeStrategy = pure NewtypeStrategy--viaStrategy :: TypeQ -> DerivStrategyQ-viaStrategy = fmap ViaStrategy--normalC :: Name -> [BangTypeQ] -> ConQ-normalC con strtys = liftM (NormalC con) $ sequence strtys--recC :: Name -> [VarBangTypeQ] -> ConQ-recC con varstrtys = liftM (RecC con) $ sequence varstrtys--infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ-infixC st1 con st2 = do st1' <- st1- st2' <- st2- return $ InfixC st1' con st2'--forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ-forallC ns ctxt con = do- ns' <- sequenceA ns- ctxt' <- ctxt- con' <- con- pure $ ForallC ns' ctxt' con'--gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ-gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty--recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ-recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty------------------------------------------------------------------------------------ * Type--forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ-forallT tvars ctxt ty = do- tvars1 <- sequenceA tvars- ctxt1 <- ctxt- ty1 <- ty- return $ ForallT tvars1 ctxt1 ty1--varT :: Name -> TypeQ-varT = return . VarT--conT :: Name -> TypeQ-conT = return . ConT--infixT :: TypeQ -> Name -> TypeQ -> TypeQ-infixT t1 n t2 = do t1' <- t1- t2' <- t2- return (InfixT t1' n t2')--uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ-uInfixT t1 n t2 = do t1' <- t1- t2' <- t2- return (UInfixT t1' n t2')--parensT :: TypeQ -> TypeQ-parensT t = do t' <- t- return (ParensT t')--appT :: TypeQ -> TypeQ -> TypeQ-appT t1 t2 = do- t1' <- t1- t2' <- t2- return $ AppT t1' t2'--appKindT :: TypeQ -> KindQ -> TypeQ-appKindT ty ki = do- ty' <- ty- ki' <- ki- return $ AppKindT ty' ki'--arrowT :: TypeQ-arrowT = return ArrowT--listT :: TypeQ-listT = return ListT--litT :: TyLitQ -> TypeQ-litT l = fmap LitT l--tupleT :: Int -> TypeQ-tupleT i = return (TupleT i)--unboxedTupleT :: Int -> TypeQ-unboxedTupleT i = return (UnboxedTupleT i)--unboxedSumT :: SumArity -> TypeQ-unboxedSumT arity = return (UnboxedSumT arity)--sigT :: TypeQ -> KindQ -> TypeQ-sigT t k- = do- t' <- t- k' <- k- return $ SigT t' k'--equalityT :: TypeQ-equalityT = return EqualityT--wildCardT :: TypeQ-wildCardT = return WildCardT--implicitParamT :: String -> TypeQ -> TypeQ-implicitParamT n t- = do- t' <- t- return $ ImplicitParamT n t'--{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}-classP :: Name -> [Q Type] -> Q Pred-classP cla tys- = do- tysl <- sequence tys- return (foldl AppT (ConT cla) tysl)--{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}-equalP :: TypeQ -> TypeQ -> PredQ-equalP tleft tright- = do- tleft1 <- tleft- tright1 <- tright- eqT <- equalityT- return (foldl AppT eqT [tleft1, tright1])--promotedT :: Name -> TypeQ-promotedT = return . PromotedT--promotedTupleT :: Int -> TypeQ-promotedTupleT i = return (PromotedTupleT i)--promotedNilT :: TypeQ-promotedNilT = return PromotedNilT--promotedConsT :: TypeQ-promotedConsT = return PromotedConsT--noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ-noSourceUnpackedness = return NoSourceUnpackedness-sourceNoUnpack = return SourceNoUnpack-sourceUnpack = return SourceUnpack--noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ-noSourceStrictness = return NoSourceStrictness-sourceLazy = return SourceLazy-sourceStrict = return SourceStrict--{-# DEPRECATED isStrict- ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",- "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}-{-# DEPRECATED notStrict- ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",- "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}-{-# DEPRECATED unpacked- ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",- "Example usage: 'bang sourceUnpack sourceStrict'"] #-}-isStrict, notStrict, unpacked :: Q Strict-isStrict = bang noSourceUnpackedness sourceStrict-notStrict = bang noSourceUnpackedness noSourceStrictness-unpacked = bang sourceUnpack sourceStrict--bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ-bang u s = do u' <- u- s' <- s- return (Bang u' s')--bangType :: BangQ -> TypeQ -> BangTypeQ-bangType = liftM2 (,)--varBangType :: Name -> BangTypeQ -> VarBangTypeQ-varBangType v bt = do (b, t) <- bt- return (v, b, t)--{-# DEPRECATED strictType- "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}-strictType :: Q Strict -> TypeQ -> StrictTypeQ-strictType = bangType--{-# DEPRECATED varStrictType- "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}-varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ-varStrictType = varBangType---- * Type Literals--numTyLit :: Integer -> TyLitQ-numTyLit n = if n >= 0 then return (NumTyLit n)- else fail ("Negative type-level number: " ++ show n)--strTyLit :: String -> TyLitQ-strTyLit s = return (StrTyLit s)------------------------------------------------------------------------------------ * Kind--plainTV :: Name -> TyVarBndrQ-plainTV = pure . PlainTV--kindedTV :: Name -> KindQ -> TyVarBndrQ-kindedTV n = fmap (KindedTV n)--varK :: Name -> Kind-varK = VarT--conK :: Name -> Kind-conK = ConT--tupleK :: Int -> Kind-tupleK = TupleT--arrowK :: Kind-arrowK = ArrowT--listK :: Kind-listK = ListT--appK :: Kind -> Kind -> Kind-appK = AppT--starK :: KindQ-starK = pure StarT--constraintK :: KindQ-constraintK = pure ConstraintT------------------------------------------------------------------------------------ * Type family result--noSig :: FamilyResultSigQ-noSig = pure NoSig--kindSig :: KindQ -> FamilyResultSigQ-kindSig = fmap KindSig--tyVarSig :: TyVarBndrQ -> FamilyResultSigQ-tyVarSig = fmap TyVarSig------------------------------------------------------------------------------------ * Injectivity annotation--injectivityAnn :: Name -> [Name] -> InjectivityAnn-injectivityAnn = TH.InjectivityAnn------------------------------------------------------------------------------------ * Role--nominalR, representationalR, phantomR, inferR :: Role-nominalR = NominalR-representationalR = RepresentationalR-phantomR = PhantomR-inferR = InferR------------------------------------------------------------------------------------ * Callconv--cCall, stdCall, cApi, prim, javaScript :: Callconv-cCall = CCall-stdCall = StdCall-cApi = CApi-prim = Prim-javaScript = JavaScript------------------------------------------------------------------------------------ * Safety--unsafe, safe, interruptible :: Safety-unsafe = Unsafe-safe = Safe-interruptible = Interruptible------------------------------------------------------------------------------------ * FunDep--funDep :: [Name] -> [Name] -> FunDep-funDep = FunDep------------------------------------------------------------------------------------ * RuleBndr-ruleVar :: Name -> RuleBndrQ-ruleVar = return . RuleVar--typedRuleVar :: Name -> TypeQ -> RuleBndrQ-typedRuleVar n ty = ty >>= return . TypedRuleVar n------------------------------------------------------------------------------------ * AnnTarget-valueAnnotation :: Name -> AnnTarget-valueAnnotation = ValueAnnotation--typeAnnotation :: Name -> AnnTarget-typeAnnotation = TypeAnnotation--moduleAnnotation :: AnnTarget-moduleAnnotation = ModuleAnnotation------------------------------------------------------------------------------------ * Pattern Synonyms (sub constructs)--unidir, implBidir :: PatSynDirQ-unidir = return Unidir-implBidir = return ImplBidir--explBidir :: [ClauseQ] -> PatSynDirQ-explBidir cls = do- cls' <- sequence cls- return (ExplBidir cls')--prefixPatSyn :: [Name] -> PatSynArgsQ-prefixPatSyn args = return $ PrefixPatSyn args--recordPatSyn :: [Name] -> PatSynArgsQ-recordPatSyn sels = return $ RecordPatSyn sels--infixPatSyn :: Name -> Name -> PatSynArgsQ-infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2------------------------------------------------------------------- * Useful helper function--appsE :: [ExpQ] -> ExpQ-appsE [] = error "appsE []"-appsE [x] = x-appsE (x:y:zs) = appsE ( (appE x y) : zs )---- | Return the Module at the place of splicing. Can be used as an--- input for 'reifyModule'.-thisModule :: Q Module-thisModule = do- loc <- location- return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
− Language/Haskell/TH/Lib/Map.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- This is a non-exposed internal module------ The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost--- verbatimely to avoid a dependency of 'template-haskell' on the containers package.------ [1] see https://hackage.haskell.org/package/containers-0.5.5.1------ The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.--module Language.Haskell.TH.Lib.Map- ( Map- , empty- , insert- , Language.Haskell.TH.Lib.Map.lookup- ) where--import Prelude--data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)- | Tip--type Size = Int--empty :: Map k a-empty = Tip-{-# INLINE empty #-}--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip-{-# INLINE singleton #-}--size :: Map k a -> Int-size Tip = 0-size (Bin sz _ _ _ _) = sz-{-# INLINE size #-}--lookup :: Ord k => k -> Map k a -> Maybe a-lookup = go- where- go _ Tip = Nothing- go !k (Bin _ kx x l r) = case compare k kx of- LT -> go k l- GT -> go k r- EQ -> Just x-{-# INLINABLE lookup #-}---insert :: Ord k => k -> a -> Map k a -> Map k a-insert = go- where- go :: Ord k => k -> a -> Map k a -> Map k a- go !kx x Tip = singleton kx x- go !kx x (Bin sz ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go kx x l) r- GT -> balanceR ky y l (go kx x r)- EQ -> Bin sz kx x l r-{-# INLINABLE insert #-}--balanceL :: k -> a -> Map k a -> Map k a -> Map k a-balanceL k x l r = case r of- Tip -> case l of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip- (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)- (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)- (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))- | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)- | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)-- (Bin rs _ _ _ _) -> case l of- Tip -> Bin (1+rs) k x Tip r-- (Bin ls lk lx ll lr)- | ls > delta*rs -> case (ll, lr) of- (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)- | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)- | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)- (_, _) -> error "Failure in Data.Map.balanceL"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}--balanceR :: k -> a -> Map k a -> Map k a -> Map k a-balanceR k x l r = case l of- Tip -> case r of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r- (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr- (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)- (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))- | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr- | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-- (Bin ls _ _ _ _) -> case r of- Tip -> Bin (1+ls) k x l Tip-- (Bin rs rk rx rl rr)- | rs > delta*ls -> case (rl, rr) of- (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)- | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr- | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)- (_, _) -> error "Failure in Data.Map.balanceR"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}--delta,ratio :: Int-delta = 3-ratio = 2
Language/Haskell/TH/Ppr.hs view
@@ -1,899 +1,91 @@--- | contains a prettyprinter for the--- Template Haskell datatypes--module Language.Haskell.TH.Ppr where- -- All of the exports from this module should- -- be "public" functions. The main module TH- -- re-exports them all.--import Text.PrettyPrint (render)-import Language.Haskell.TH.PprLib-import Language.Haskell.TH.Syntax-import Data.Word ( Word8 )-import Data.Char ( toLower, chr)-import GHC.Show ( showMultiLineString )-import GHC.Lexeme( startsVarSym )-import Data.Ratio ( numerator, denominator )-import Prelude hiding ((<>))--nestDepth :: Int-nestDepth = 4--type Precedence = Int-appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence-appPrec = 4 -- Argument of a function application-opPrec = 3 -- Argument of an infix operator-unopPrec = 2 -- Argument of an unresolved infix operator-sigPrec = 1 -- Argument of an explicit type signature-noPrec = 0 -- Others--parensIf :: Bool -> Doc -> Doc-parensIf True d = parens d-parensIf False d = d----------------------------------pprint :: Ppr a => a -> String-pprint x = render $ to_HPJ_Doc $ ppr x--class Ppr a where- ppr :: a -> Doc- ppr_list :: [a] -> Doc- ppr_list = vcat . map ppr--instance Ppr a => Ppr [a] where- ppr x = ppr_list x---------------------------------instance Ppr Name where- ppr v = pprName v---------------------------------instance Ppr Info where- ppr (TyConI d) = ppr d- ppr (ClassI d is) = ppr d $$ vcat (map ppr is)- ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)- ppr (PrimTyConI name arity is_unlifted)- = text "Primitive"- <+> (if is_unlifted then text "unlifted" else empty)- <+> text "type constructor" <+> quotes (ppr name)- <+> parens (text "arity" <+> int arity)- ppr (ClassOpI v ty cls)- = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty- ppr (DataConI v ty tc)- = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty- ppr (PatSynI nm ty) = pprPatSynSig nm ty- ppr (TyVarI v ty)- = text "Type variable" <+> ppr v <+> equals <+> ppr ty- ppr (VarI v ty mb_d)- = vcat [ppr_sig v ty,- case mb_d of { Nothing -> empty; Just d -> ppr d }]--ppr_sig :: Name -> Type -> Doc-ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty--pprFixity :: Name -> Fixity -> Doc-pprFixity _ f | f == defaultFixity = empty-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v- where ppr_fix InfixR = text "infixr"- ppr_fix InfixL = text "infixl"- ppr_fix InfixN = text "infix"---- | Pretty prints a pattern synonym type signature-pprPatSynSig :: Name -> PatSynType -> Doc-pprPatSynSig nm ty- = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty---- | Pretty prints a pattern synonym's type; follows the usual--- conventions to print a pattern synonym type compactly, yet--- unambiguously. See the note on 'PatSynType' and the section on--- pattern synonyms in the GHC user's guide for more information.-pprPatSynType :: PatSynType -> Doc-pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))- | null exTys, null provs = ppr (ForallT uniTys reqs ty'')- | null uniTys, null reqs = noreqs <+> ppr ty'- | null reqs = forall uniTys <+> noreqs <+> ppr ty'- | otherwise = ppr ty- where noreqs = text "() =>"- forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."-pprPatSynType ty = ppr ty---------------------------------instance Ppr Module where- ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)--instance Ppr ModuleInfo where- ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)---------------------------------instance Ppr Exp where- ppr = pprExp noPrec--pprPrefixOcc :: Name -> Doc--- Print operators with parens around them-pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)--isSymOcc :: Name -> Bool-isSymOcc n- = case nameBase n of- [] -> True -- Empty name; weird- (c:_) -> startsVarSym c- -- c.f. OccName.startsVarSym in GHC itself--pprInfixExp :: Exp -> Doc-pprInfixExp (VarE v) = pprName' Infix v-pprInfixExp (ConE v) = pprName' Infix v-pprInfixExp _ = text "<<Non-variable/constructor in infix context>>"--pprExp :: Precedence -> Exp -> Doc-pprExp _ (VarE v) = pprName' Applied v-pprExp _ (ConE c) = pprName' Applied c-pprExp i (LitE l) = pprLit i l-pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1- <+> pprExp appPrec e2-pprExp i (AppTypeE e t)- = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t-pprExp _ (ParensE e) = parens (pprExp noPrec e)-pprExp i (UInfixE e1 op e2)- = parensIf (i > unopPrec) $ pprExp unopPrec e1- <+> pprInfixExp op- <+> pprExp unopPrec e2-pprExp i (InfixE (Just e1) op (Just e2))- = parensIf (i >= opPrec) $ pprExp opPrec e1- <+> pprInfixExp op- <+> pprExp opPrec e2-pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1- <+> pprInfixExp op- <+> pprMaybeExp noPrec me2-pprExp i (LamE [] e) = pprExp i e -- #13856-pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)- <+> text "->" <+> ppr e-pprExp i (LamCaseE ms) = parensIf (i > noPrec)- $ text "\\case" $$ nest nestDepth (ppr ms)-pprExp _ (TupE es) = parens (commaSep es)-pprExp _ (UnboxedTupE es) = hashParens (commaSep es)-pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity--- Nesting in Cond is to avoid potential problems in do statements-pprExp i (CondE guard true false)- = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,- nest 1 $ text "then" <+> ppr true,- nest 1 $ text "else" <+> ppr false]-pprExp i (MultiIfE alts)- = parensIf (i > noPrec) $ vcat $- case alts of- [] -> [text "if {}"]- (alt : alts') -> text "if" <+> pprGuarded arrow alt- : map (nest 3 . pprGuarded arrow) alts'-pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_- $$ text " in" <+> ppr e- where- pprDecs [] = empty- pprDecs [d] = ppr d- pprDecs ds = braces (semiSep ds)--pprExp i (CaseE e ms)- = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"- $$ nest nestDepth (ppr ms)-pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_- where- pprStms [] = empty- pprStms [s] = ppr s- pprStms ss = braces (semiSep ss)-pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_- where- pprStms [] = empty- pprStms [s] = ppr s- pprStms ss = braces (semiSep ss)--pprExp _ (CompE []) = text "<<Empty CompExp>>"--- This will probably break with fixity declarations - would need a ';'-pprExp _ (CompE ss) =- if null ss'- -- If there are no statements in a list comprehension besides the last- -- one, we simply treat it like a normal list.- then text "[" <> ppr s <> text "]"- else text "[" <> ppr s- <+> bar- <+> commaSep ss'- <> text "]"- where s = last ss- ss' = init ss-pprExp _ (ArithSeqE d) = ppr d-pprExp _ (ListE es) = brackets (commaSep es)-pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e- <+> dcolon <+> ppr t-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)-pprExp i (StaticE e) = parensIf (i >= appPrec) $- text "static"<+> pprExp appPrec e-pprExp _ (UnboundVarE v) = pprName' Applied v-pprExp _ (LabelE s) = text "#" <> text s-pprExp _ (ImplicitParamVarE n) = text ('?' : n)--pprFields :: [(Name,Exp)] -> Doc-pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)--pprMaybeExp :: Precedence -> Maybe Exp -> Doc-pprMaybeExp _ Nothing = empty-pprMaybeExp i (Just e) = pprExp i e---------------------------------instance Ppr Stmt where- ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e- ppr (LetS ds) = text "let" <+> (braces (semiSep ds))- ppr (NoBindS e) = ppr e- ppr (ParS sss) = sep $ punctuate bar- $ map commaSep sss- ppr (RecS ss) = text "rec" <+> (braces (semiSep ss))---------------------------------instance Ppr Match where- ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs- $$ where_clause ds--pprMatchPat :: Pat -> Doc--- Everything except pattern signatures bind more tightly than (->)-pprMatchPat p@(SigP {}) = parens (ppr p)-pprMatchPat p = ppr p---------------------------------pprGuarded :: Doc -> (Guard, Exp) -> Doc-pprGuarded eqDoc (guard, expr) = case guard of- NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr- PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$- nest nestDepth (eqDoc <+> ppr expr)---------------------------------pprBody :: Bool -> Body -> Doc-pprBody eq body = case body of- GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs- NormalB e -> eqDoc <+> ppr e- where eqDoc | eq = equals- | otherwise = arrow---------------------------------instance Ppr Lit where- ppr = pprLit noPrec--pprLit :: Precedence -> Lit -> Doc-pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)- (integer x <> char '#')-pprLit _ (WordPrimL x) = integer x <> text "##"-pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)- (float (fromRational x) <> char '#')-pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)- (double (fromRational x) <> text "##")-pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)-pprLit _ (CharL c) = text (show c)-pprLit _ (CharPrimL c) = text (show c) <> char '#'-pprLit _ (StringL s) = pprString s-pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'-pprLit i (RationalL rat) = parensIf (i > noPrec) $- integer (numerator rat) <+> char '/'- <+> integer (denominator rat)--bytesToString :: [Word8] -> String-bytesToString = map (chr . fromIntegral)--pprString :: String -> Doc--- Print newlines as newlines with Haskell string escape notation,--- not as '\n'. For other non-printables use regular escape notation.-pprString s = vcat (map text (showMultiLineString s))---------------------------------instance Ppr Pat where- ppr = pprPat noPrec--pprPat :: Precedence -> Pat -> Doc-pprPat i (LitP l) = pprLit i l-pprPat _ (VarP v) = pprName' Applied v-pprPat _ (TupP ps) = parens (commaSep ps)-pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)-pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity-pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s- <+> sep (map (pprPat appPrec) ps)-pprPat _ (ParensP p) = parens $ pprPat noPrec p-pprPat i (UInfixP p1 n p2)- = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>- pprName' Infix n <+>- pprPat unopPrec p2)-pprPat i (InfixP p1 n p2)- = parensIf (i >= opPrec) (pprPat opPrec p1 <+>- pprName' Infix n <+>- pprPat opPrec p2)-pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p-pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p-pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"- <> pprPat appPrec p-pprPat _ WildP = text "_"-pprPat _ (RecP nm fs)- = parens $ ppr nm- <+> braces (sep $ punctuate comma $- map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)-pprPat _ (ListP ps) = brackets (commaSep ps)-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t-pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p---------------------------------instance Ppr Dec where- ppr = ppr_dec True--ppr_dec :: Bool -- declaration on the toplevel?- -> Dec- -> Doc-ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs-ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r- $$ where_clause ds-ppr_dec _ (TySynD t xs rhs)- = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs-ppr_dec _ (DataD ctxt t xs ksig cs decs)- = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs-ppr_dec _ (NewtypeD ctxt t xs ksig c decs)- = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs-ppr_dec _ (ClassD ctxt c xs fds ds)- = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds- $$ where_clause ds-ppr_dec _ (InstanceD o ctxt i ds) =- text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i- $$ where_clause ds-ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t-ppr_dec _ (ForeignD f) = ppr f-ppr_dec _ (InfixD fx n) = pprFixity n fx-ppr_dec _ (PragmaD p) = ppr p-ppr_dec isTop (DataFamilyD tc tvs kind)- = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind- where- maybeFamily | isTop = text "family"- | otherwise = empty- maybeKind | (Just k') <- kind = dcolon <+> ppr k'- | otherwise = empty-ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)- = ppr_data (maybeInst <+> ppr_bndrs bndrs)- ctxt Nothing (ppr ty) ksig cs decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)- = ppr_newtype (maybeInst <+> ppr_bndrs bndrs)- ctxt Nothing (ppr ty) ksig c decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs))- = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs)- Nothing (ppr ty) rhs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (OpenTypeFamilyD tfhead)- = text "type" <+> maybeFamily <+> ppr_tf_head tfhead- where- maybeFamily | isTop = text "family"- | otherwise = empty-ppr_dec _ (ClosedTypeFamilyD tfhead eqns)- = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")- nestDepth (vcat (map ppr_eqn eqns))- where- ppr_eqn (TySynEqn mb_bndrs lhs rhs)- = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs-ppr_dec _ (RoleAnnotD name roles)- = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)-ppr_dec _ (StandaloneDerivD ds cxt ty)- = hsep [ text "deriving"- , maybe empty ppr_deriv_strategy ds- , text "instance"- , pprCxt cxt- , ppr ty ]-ppr_dec _ (DefaultSigD n ty)- = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]-ppr_dec _ (PatSynD name args dir pat)- = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS- where- pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2- | otherwise = ppr name <+> ppr args- pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")- nestDepth (ppr name <+> ppr cls)- | otherwise = ppr pat-ppr_dec _ (PatSynSigD name ty)- = pprPatSynSig name ty-ppr_dec _ (ImplicitParamBindD n e)- = hsep [text ('?' : n), text "=", ppr e]--ppr_deriv_strategy :: DerivStrategy -> Doc-ppr_deriv_strategy ds =- case ds of- StockStrategy -> text "stock"- AnyclassStrategy -> text "anyclass"- NewtypeStrategy -> text "newtype"- ViaStrategy ty -> text "via" <+> pprParendType ty--ppr_overlap :: Overlap -> Doc-ppr_overlap o = text $- case o of- Overlaps -> "{-# OVERLAPS #-}"- Overlappable -> "{-# OVERLAPPABLE #-}"- Overlapping -> "{-# OVERLAPPING #-}"- Incoherent -> "{-# INCOHERENT #-}"--ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]- -> Doc-ppr_data maybeInst ctxt t argsDoc ksig cs decs- = sep [text "data" <+> maybeInst- <+> pprCxt ctxt- <+> case t of- Just n -> pprName' Applied n <+> argsDoc- Nothing -> argsDoc- <+> ksigDoc <+> maybeWhere,- nest nestDepth (sep (pref $ map ppr cs)),- if null decs- then empty- else nest nestDepth- $ vcat $ map ppr_deriv_clause decs]- where- pref :: [Doc] -> [Doc]- pref xs | isGadtDecl = xs- pref [] = [] -- No constructors; can't happen in H98- pref (d:ds) = (char '=' <+> d):map (bar <+>) ds-- maybeWhere :: Doc- maybeWhere | isGadtDecl = text "where"- | otherwise = empty-- isGadtDecl :: Bool- isGadtDecl = not (null cs) && all isGadtCon cs- where isGadtCon (GadtC _ _ _ ) = True- isGadtCon (RecGadtC _ _ _) = True- isGadtCon (ForallC _ _ x ) = isGadtCon x- isGadtCon _ = False-- ksigDoc = case ksig of- Nothing -> empty- Just k -> dcolon <+> ppr k--ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]- -> Doc-ppr_newtype maybeInst ctxt t argsDoc ksig c decs- = sep [text "newtype" <+> maybeInst- <+> pprCxt ctxt- <+> case t of- Just n -> ppr n <+> argsDoc- Nothing -> argsDoc- <+> ksigDoc,- nest 2 (char '=' <+> ppr c),- if null decs- then empty- else nest nestDepth- $ vcat $ map ppr_deriv_clause decs]- where- ksigDoc = case ksig of- Nothing -> empty- Just k -> dcolon <+> ppr k--ppr_deriv_clause :: DerivClause -> Doc-ppr_deriv_clause (DerivClause ds ctxt)- = text "deriving" <+> pp_strat_before- <+> ppr_cxt_preds ctxt- <+> pp_strat_after- where- -- @via@ is unique in that in comes /after/ the class being derived,- -- so we must special-case it.- (pp_strat_before, pp_strat_after) =- case ds of- Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via)- _ -> (maybe empty ppr_deriv_strategy ds, empty)--ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc-ppr_tySyn maybeInst t argsDoc rhs- = text "type" <+> maybeInst- <+> case t of- Just n -> ppr n <+> argsDoc- Nothing -> argsDoc- <+> text "=" <+> ppr rhs--ppr_tf_head :: TypeFamilyHead -> Doc-ppr_tf_head (TypeFamilyHead tc tvs res inj)- = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj- where- maybeInj | (Just inj') <- inj = ppr inj'- | otherwise = empty--ppr_bndrs :: Maybe [TyVarBndr] -> Doc-ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."-ppr_bndrs Nothing = empty---------------------------------instance Ppr FunDep where- ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)- ppr_list [] = empty- ppr_list xs = bar <+> commaSep xs---------------------------------instance Ppr FamilyResultSig where- ppr NoSig = empty- ppr (KindSig k) = dcolon <+> ppr k- ppr (TyVarSig bndr) = text "=" <+> ppr bndr---------------------------------instance Ppr InjectivityAnn where- ppr (InjectivityAnn lhs rhs) =- bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)---------------------------------instance Ppr Foreign where- ppr (ImportF callconv safety impent as typ)- = text "foreign import"- <+> showtextl callconv- <+> showtextl safety- <+> text (show impent)- <+> ppr as- <+> dcolon <+> ppr typ- ppr (ExportF callconv expent as typ)- = text "foreign export"- <+> showtextl callconv- <+> text (show expent)- <+> ppr as- <+> dcolon <+> ppr typ---------------------------------instance Ppr Pragma where- ppr (InlineP n inline rm phases)- = text "{-#"- <+> ppr inline- <+> ppr rm- <+> ppr phases- <+> ppr n- <+> text "#-}"- ppr (SpecialiseP n ty inline phases)- = text "{-# SPECIALISE"- <+> maybe empty ppr inline- <+> ppr phases- <+> sep [ ppr n <+> dcolon- , nest 2 $ ppr ty ]- <+> text "#-}"- ppr (SpecialiseInstP inst)- = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"- ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)- = sep [ text "{-# RULES" <+> pprString n <+> ppr phases- , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs- <+> ppr lhs- , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]- where ppr_ty_forall Nothing = empty- ppr_ty_forall (Just bndrs) = text "forall"- <+> fsep (map ppr bndrs)- <+> char '.'- ppr_tm_forall Nothing | null tm_bndrs = empty- ppr_tm_forall _ = text "forall"- <+> fsep (map ppr tm_bndrs)- <+> char '.'- ppr (AnnP tgt expr)- = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"- where target1 ModuleAnnotation = text "module"- target1 (TypeAnnotation t) = text "type" <+> ppr t- target1 (ValueAnnotation v) = ppr v- ppr (LineP line file)- = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"- ppr (CompleteP cls mty)- = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)- <+> maybe empty (\ty -> dcolon <+> ppr ty) mty---------------------------------instance Ppr Inline where- ppr NoInline = text "NOINLINE"- ppr Inline = text "INLINE"- ppr Inlinable = text "INLINABLE"---------------------------------instance Ppr RuleMatch where- ppr ConLike = text "CONLIKE"- ppr FunLike = empty---------------------------------instance Ppr Phases where- ppr AllPhases = empty- ppr (FromPhase i) = brackets $ int i- ppr (BeforePhase i) = brackets $ char '~' <> int i---------------------------------instance Ppr RuleBndr where- ppr (RuleVar n) = ppr n- ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty---------------------------------instance Ppr Clause where- ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs- $$ where_clause ds---------------------------------instance Ppr Con where- ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)-- ppr (RecC c vsts)- = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))-- ppr (InfixC st1 c st2) = pprBangType st1- <+> pprName' Infix c- <+> pprBangType st2-- ppr (ForallC ns ctxt (GadtC c sts ty))- = commaSepApplied c <+> dcolon <+> pprForall ns ctxt- <+> pprGadtRHS sts ty-- ppr (ForallC ns ctxt (RecGadtC c vsts ty))- = commaSepApplied c <+> dcolon <+> pprForall ns ctxt- <+> pprRecFields vsts ty-- ppr (ForallC ns ctxt con)- = pprForall ns ctxt <+> ppr con-- ppr (GadtC c sts ty)- = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty-- ppr (RecGadtC c vsts ty)- = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty--instance Ppr PatSynDir where- ppr Unidir = text "<-"- ppr ImplBidir = text "="- ppr (ExplBidir _) = text "<-"- -- the ExplBidir's clauses are pretty printed together with the- -- entire pattern synonym; so only print the direction here.--instance Ppr PatSynArgs where- ppr (PrefixPatSyn args) = sep $ map ppr args- ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2- ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))--commaSepApplied :: [Name] -> Doc-commaSepApplied = commaSepWith (pprName' Applied)--pprForall :: [TyVarBndr] -> Cxt -> Doc-pprForall tvs cxt- -- even in the case without any tvs, there could be a non-empty- -- context cxt (e.g., in the case of pattern synonyms, where there- -- are multiple forall binders and contexts).- | [] <- tvs = pprCxt cxt- | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt--pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc-pprRecFields vsts ty- = braces (sep (punctuate comma $ map pprVarBangType vsts))- <+> arrow <+> ppr ty--pprGadtRHS :: [(Strict, Type)] -> Type -> Doc-pprGadtRHS [] ty- = ppr ty-pprGadtRHS sts ty- = sep (punctuate (space <> arrow) (map pprBangType sts))- <+> arrow <+> ppr ty---------------------------------pprVarBangType :: VarBangType -> Doc--- Slight infelicity: with print non-atomic type with parens-pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)---------------------------------pprBangType :: BangType -> Doc--- Make sure we print------ Con {-# UNPACK #-} a------ rather than------ Con {-# UNPACK #-}a------ when there's no strictness annotation. If there is a strictness annotation,--- it's okay to not put a space between it and the type.-pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t-pprBangType (bt, t) = ppr bt <> pprParendType t---------------------------------instance Ppr Bang where- ppr (Bang su ss) = ppr su <+> ppr ss---------------------------------instance Ppr SourceUnpackedness where- ppr NoSourceUnpackedness = empty- ppr SourceNoUnpack = text "{-# NOUNPACK #-}"- ppr SourceUnpack = text "{-# UNPACK #-}"---------------------------------instance Ppr SourceStrictness where- ppr NoSourceStrictness = empty- ppr SourceLazy = char '~'- ppr SourceStrict = char '!'---------------------------------instance Ppr DecidedStrictness where- ppr DecidedLazy = empty- ppr DecidedStrict = char '!'- ppr DecidedUnpack = text "{-# UNPACK #-} !"---------------------------------{-# DEPRECATED pprVarStrictType- "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}-pprVarStrictType :: (Name, Strict, Type) -> Doc-pprVarStrictType = pprVarBangType---------------------------------{-# DEPRECATED pprStrictType- "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}-pprStrictType :: (Strict, Type) -> Doc-pprStrictType = pprBangType---------------------------------pprParendType :: Type -> Doc-pprParendType (VarT v) = pprName' Applied v--- `Applied` is used here instead of `ppr` because of infix names (#13887)-pprParendType (ConT c) = pprName' Applied c-pprParendType (TupleT 0) = text "()"-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))-pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma-pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar-pprParendType ArrowT = parens (text "->")-pprParendType ListT = text "[]"-pprParendType (LitT l) = pprTyLit l-pprParendType (PromotedT c) = text "'" <> pprName' Applied c-pprParendType (PromotedTupleT 0) = text "'()"-pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))-pprParendType PromotedNilT = text "'[]"-pprParendType PromotedConsT = text "'(:)"-pprParendType StarT = char '*'-pprParendType ConstraintT = text "Constraint"-pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)-pprParendType WildCardT = char '_'-pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y)-pprParendType t@(UInfixT {}) = parens (pprUInfixT t)-pprParendType (ParensT t) = ppr t-pprParendType tuple | (TupleT n, args) <- split tuple- , length args == n- = parens (commaSep args)-pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t-pprParendType EqualityT = text "(~)"-pprParendType t@(ForallT {}) = parens (ppr t)-pprParendType t@(AppT {}) = parens (ppr t)-pprParendType t@(AppKindT {}) = parens (ppr t)--pprUInfixT :: Type -> Doc-pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y-pprUInfixT t = ppr t--instance Ppr Type where- ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]- ppr ty = pprTyApp (split ty)- -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)- -- See Note [Pretty-printing kind signatures]-instance Ppr TypeArg where- ppr (TANormal ty) = ppr ty- ppr (TyArg ki) = char '@' <> ppr ki--pprParendTypeArg :: TypeArg -> Doc-pprParendTypeArg (TANormal ty) = pprParendType ty-pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki-{- Note [Pretty-printing kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC's parser only recognises a kind signature in a type when there are-parens around it. E.g. the parens are required here:- f :: (Int :: *)- type instance F Int = (Bool :: *)-So we always print a SigT with parens (see Trac #10050). -}--pprTyApp :: (Type, [TypeArg]) -> Doc-pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]-pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =- sep [pprFunArgType arg1 <+> text "~", ppr arg2]-pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg)-pprTyApp (TupleT n, args)- | length args == n = parens (commaSep args)-pprTyApp (PromotedTupleT n, args)- | length args == n = quoteParens (commaSep args)-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)--pprFunArgType :: Type -> Doc -- Should really use a precedence argument--- Everything except forall and (->) binds more tightly than (->)-pprFunArgType ty@(ForallT {}) = parens (ppr ty)-pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)-pprFunArgType ty@(SigT _ _) = parens (ppr ty)-pprFunArgType ty = ppr ty--data TypeArg = TANormal Type- | TyArg Kind--split :: Type -> (Type, [TypeArg]) -- Split into function and args-split t = go t []- where go (AppT t1 t2) args = go t1 (TANormal t2:args)- go (AppKindT ty ki) args = go ty (TyArg ki:args)- go ty args = (ty, args)--pprTyLit :: TyLit -> Doc-pprTyLit (NumTyLit n) = integer n-pprTyLit (StrTyLit s) = text (show s)--instance Ppr TyLit where- ppr = pprTyLit---------------------------------instance Ppr TyVarBndr where- ppr (PlainTV nm) = ppr nm- ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k)--instance Ppr Role where- ppr NominalR = text "nominal"- ppr RepresentationalR = text "representational"- ppr PhantomR = text "phantom"- ppr InferR = text "_"---------------------------------pprCxt :: Cxt -> Doc-pprCxt [] = empty-pprCxt ts = ppr_cxt_preds ts <+> text "=>"--ppr_cxt_preds :: Cxt -> Doc-ppr_cxt_preds [] = empty-ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t)-ppr_cxt_preds [t@ForallT{}] = parens (ppr t)-ppr_cxt_preds [t] = ppr t-ppr_cxt_preds ts = parens (commaSep ts)---------------------------------instance Ppr Range where- ppr = brackets . pprRange- where pprRange :: Range -> Doc- pprRange (FromR e) = ppr e <> text ".."- pprRange (FromThenR e1 e2) = ppr e1 <> text ","- <> ppr e2 <> text ".."- pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2- pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","- <> ppr e2 <> text ".."- <> ppr e3---------------------------------where_clause :: [Dec] -> Doc-where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)--showtextl :: Show a => a -> Doc-showtextl = text . map toLower . show--hashParens :: Doc -> Doc-hashParens d = text "(# " <> d <> text " #)"--quoteParens :: Doc -> Doc-quoteParens d = text "'(" <> d <> text ")"--------------------------------instance Ppr Loc where- ppr (Loc { loc_module = md- , loc_package = pkg- , loc_start = (start_ln, start_col)- , loc_end = (end_ln, end_col) })- = hcat [ text pkg, colon, text md, colon- , parens $ int start_ln <> comma <> int start_col- , text "-"- , parens $ int end_ln <> comma <> int end_col ]---- Takes a list of printable things and prints them separated by commas followed--- by space.-commaSep :: Ppr a => [a] -> Doc-commaSep = commaSepWith ppr---- Takes a list of things and prints them with the given pretty-printing--- function, separated by commas followed by space.-commaSepWith :: (a -> Doc) -> [a] -> Doc-commaSepWith pprFun = sep . punctuate comma . map pprFun---- Takes a list of printable things and prints them separated by semicolons--- followed by space.-semiSep :: Ppr a => [a] -> Doc-semiSep = sep . punctuate semi . map ppr+{-# LANGUAGE Safe #-} --- Prints out the series of vertical bars that wraps an expression or pattern--- used in an unboxed sum.-unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc-unboxedSumBars d alt arity = hashParens $- bars (alt-1) <> d <> bars (arity - alt)- where- bars i = hsep (replicate i bar)+{- | contains a prettyprinter for the+Template Haskell datatypes+-}+module Language.Haskell.TH.Ppr (+ appPrec,+ bar,+ bytesToString,+ commaSep,+ commaSepApplied,+ commaSepWith,+ fromTANormal,+ funPrec,+ hashParens,+ isStarT,+ isSymOcc,+ nestDepth,+ noPrec,+ opPrec,+ parensIf,+ pprBangType,+ pprBndrVis,+ pprBody,+ pprClause,+ pprCtxWith,+ pprCxt,+ pprExp,+ pprFields,+ pprFixity,+ pprForall,+ pprForall',+ pprForallVis,+ pprFunArgType,+ pprGadtRHS,+ pprGuarded,+ pprInfixExp,+ pprInfixT,+ pprLit,+ pprMatchPat,+ pprMaybeExp,+ pprNamespaceSpecifier,+ pprParendType,+ pprParendTypeArg,+ pprPat,+ pprPatSynSig,+ pprPatSynType,+ pprPrefixOcc,+ pprRecFields,+ pprStrictType,+ pprString,+ pprTyApp,+ pprTyLit,+ pprType,+ pprVarBangType,+ pprVarStrictType,+ ppr_bndrs,+ ppr_ctx_preds_with,+ ppr_cxt_preds,+ ppr_data,+ ppr_dec,+ ppr_deriv_clause,+ ppr_deriv_strategy,+ ppr_newtype,+ ppr_overlap,+ ppr_sig,+ ppr_tf_head,+ ppr_tySyn,+ ppr_type_data,+ ppr_typedef,+ pprint,+ qualPrec,+ quoteParens,+ semiSep,+ semiSepWith,+ sepWith,+ showtextl,+ sigPrec,+ split,+ unboxedSumBars,+ unopPrec,+ where_clause,+ ForallVisFlag (..),+ Ppr (..),+ PprFlag (..),+ Precedence,+ TypeArg (..),+)+where --- Text containing the vertical bar character.-bar :: Doc-bar = char '|'+import GHC.Boot.TH.Ppr
Language/Haskell/TH/PprLib.hs view
@@ -1,226 +1,56 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Safe #-} -- | Monadic front-end to Text.PrettyPrint- module Language.Haskell.TH.PprLib (-- -- * The document type- Doc, -- Abstract, instance of Show- PprM,-- -- * Primitive Documents- empty,- semi, comma, colon, dcolon, space, equals, arrow,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- -- * Converting values into documents- text, char, ptext,- int, integer, float, double, rational,-- -- * Wrapping documents in delimiters- parens, brackets, braces, quotes, doubleQuotes,-- -- * Combining documents- (<>), (<+>), hcat, hsep,- ($$), ($+$), vcat,- sep, cat,- fsep, fcat,- nest,- hang, punctuate,-- -- * Predicates on documents- isEmpty,-- to_HPJ_Doc, pprName, pprName'- ) where-+ ($$),+ ($+$),+ (<+>),+ (<>),+ arrow,+ braces,+ brackets,+ cat,+ char,+ colon,+ comma,+ dcolon,+ double,+ doubleQuotes,+ empty,+ equals,+ fcat,+ float,+ fsep,+ hang,+ hcat,+ hsep,+ int,+ integer,+ isEmpty,+ lbrace,+ lbrack,+ lparen,+ nest,+ parens,+ pprName,+ pprName',+ ptext,+ punctuate,+ quotes,+ rational,+ rbrace,+ rbrack,+ rparen,+ semi,+ sep,+ space,+ text,+ to_HPJ_Doc,+ vcat,+ Doc,+ PprM,+)+where -import Language.Haskell.TH.Syntax- (Name(..), showName', NameFlavour(..), NameIs(..))-import qualified Text.PrettyPrint as HPJ-import Control.Monad (liftM, liftM2, ap)-import Language.Haskell.TH.Lib.Map ( Map )-import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import Prelude hiding ((<>))--infixl 6 <> -infixl 6 <+>-infixl 5 $$, $+$---- ------------------------------------------------------------------------------ The interface---- The primitive Doc values--instance Show Doc where- show d = HPJ.render (to_HPJ_Doc d)--isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty--empty :: Doc; -- ^ An empty document-semi :: Doc; -- ^ A ';' character-comma :: Doc; -- ^ A ',' character-colon :: Doc; -- ^ A ':' character-dcolon :: Doc; -- ^ A "::" string-space :: Doc; -- ^ A space character-equals :: Doc; -- ^ A '=' character-arrow :: Doc; -- ^ A "->" string-lparen :: Doc; -- ^ A '(' character-rparen :: Doc; -- ^ A ')' character-lbrack :: Doc; -- ^ A '[' character-rbrack :: Doc; -- ^ A ']' character-lbrace :: Doc; -- ^ A '{' character-rbrace :: Doc; -- ^ A '}' character--text :: String -> Doc-ptext :: String -> Doc-char :: Char -> Doc-int :: Int -> Doc-integer :: Integer -> Doc-float :: Float -> Doc-double :: Double -> Doc-rational :: Rational -> Doc---parens :: Doc -> Doc; -- ^ Wrap document in @(...)@-brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@-braces :: Doc -> Doc; -- ^ Wrap document in @{...}@-quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@-doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@---- Combining @Doc@ values--(<>) :: Doc -> Doc -> Doc; -- ^Beside-hcat :: [Doc] -> Doc; -- ^List version of '<>'-(<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space-hsep :: [Doc] -> Doc; -- ^List version of '<+>'--($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no- -- overlap it \"dovetails\" the two-($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.-vcat :: [Doc] -> Doc; -- ^List version of '$$'--cat :: [Doc] -> Doc; -- ^ Either hcat or vcat-sep :: [Doc] -> Doc; -- ^ Either hsep or vcat-fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat-fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep--nest :: Int -> Doc -> Doc; -- ^ Nested----- GHC-specific ones.--hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@-punctuate :: Doc -> [Doc] -> [Doc]- -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@---- ------------------------------------------------------------------------------ The "implementation"--type State = (Map Name Name, Int)-data PprM a = PprM { runPprM :: State -> (a, State) }--pprName :: Name -> Doc-pprName = pprName' Alone--pprName' :: NameIs -> Name -> Doc-pprName' ni n@(Name o (NameU _))- = PprM $ \s@(fm, i)- -> let (n', s') = case Map.lookup n fm of- Just d -> (d, s)- Nothing -> let n'' = Name o (NameU i)- in (n'', (Map.insert n n'' fm, i + 1))- in (HPJ.text $ showName' ni n', s')-pprName' ni n = text $ showName' ni n--{--instance Show Name where- show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u)- show (Name occ NameS) = occString occ- show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ--data Name = Name OccName NameFlavour--data NameFlavour- | NameU Int# -- A unique local name--}--to_HPJ_Doc :: Doc -> HPJ.Doc-to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0)--instance Functor PprM where- fmap = liftM--instance Applicative PprM where- pure x = PprM $ \s -> (x, s)- (<*>) = ap--instance Monad PprM where- m >>= k = PprM $ \s -> let (x, s') = runPprM m s- in runPprM (k x) s'--type Doc = PprM HPJ.Doc---- The primitive Doc values--isEmpty = liftM HPJ.isEmpty--empty = return HPJ.empty-semi = return HPJ.semi-comma = return HPJ.comma-colon = return HPJ.colon-dcolon = return $ HPJ.text "::"-space = return HPJ.space-equals = return HPJ.equals-arrow = return $ HPJ.text "->"-lparen = return HPJ.lparen-rparen = return HPJ.rparen-lbrack = return HPJ.lbrack-rbrack = return HPJ.rbrack-lbrace = return HPJ.lbrace-rbrace = return HPJ.rbrace--text = return . HPJ.text-ptext = return . HPJ.ptext-char = return . HPJ.char-int = return . HPJ.int-integer = return . HPJ.integer-float = return . HPJ.float-double = return . HPJ.double-rational = return . HPJ.rational---parens = liftM HPJ.parens-brackets = liftM HPJ.brackets-braces = liftM HPJ.braces-quotes = liftM HPJ.quotes-doubleQuotes = liftM HPJ.doubleQuotes---- Combining @Doc@ values--(<>) = liftM2 (HPJ.<>)-hcat = liftM HPJ.hcat . sequence-(<+>) = liftM2 (HPJ.<+>)-hsep = liftM HPJ.hsep . sequence--($$) = liftM2 (HPJ.$$)-($+$) = liftM2 (HPJ.$+$)-vcat = liftM HPJ.vcat . sequence--cat = liftM HPJ.cat . sequence-sep = liftM HPJ.sep . sequence-fcat = liftM HPJ.fcat . sequence-fsep = liftM HPJ.fsep . sequence--nest n = liftM (HPJ.nest n)--hang d1 n d2 = do d1' <- d1- d2' <- d2- return (HPJ.hang d1' n d2')---- punctuate uses the same definition as Text.PrettyPrint-punctuate _ [] = []-punctuate p (d:ds) = go d ds- where- go d' [] = [d']- go d' (e:es) = (d' <> p) : go e es+import GHC.Boot.TH.PprLib
Language/Haskell/TH/Quote.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE Safe #-} {- | Module : Language.Haskell.TH.Quote Description : Quasi-quoting support for Template Haskell@@ -13,33 +13,17 @@ quasiquoters. Nota bene: this package does not define any parsers, that is up to you. -}-module Language.Haskell.TH.Quote(- QuasiQuoter(..),- quoteFile,- -- * For backwards compatibility- dataToQa, dataToExpQ, dataToPatQ- ) where+module Language.Haskell.TH.Quote+ ( QuasiQuoter(..)+ , quoteFile+ -- * For backwards compatibility+ , dataToQa, dataToExpQ, dataToPatQ+ ) where -import Language.Haskell.TH.Syntax-import Prelude+import GHC.Boot.TH.Syntax+import GHC.Boot.TH.Quote+import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) --- | The 'QuasiQuoter' type, a value @q@ of this type can be used--- in the syntax @[q| ... string to parse ...|]@. In fact, for--- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters--- to be used in different splice contexts; if you are only interested--- in defining a quasiquoter to be used for expressions, you would--- define a 'QuasiQuoter' with only 'quoteExp', and leave the other--- fields stubbed out with errors.-data QuasiQuoter = QuasiQuoter {- -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@- quoteExp :: String -> Q Exp,- -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@- quotePat :: String -> Q Pat,- -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@- quoteType :: String -> Q Type,- -- | Quasi-quoter for declarations, invoked by top-level quotes- quoteDec :: String -> Q [Dec]- } -- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read -- the data out of a file. For example, suppose @asmq@ is an@@ -48,10 +32,10 @@ -- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead -- of the inline text quoteFile :: QuasiQuoter -> QuasiQuoter-quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) +quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd } where get :: (String -> Q a) -> String -> Q a- get old_quoter file_name = do { file_cts <- runIO (readFile file_name) + get old_quoter file_name = do { file_cts <- runIO (readFile file_name) ; addDependentFile file_name ; old_quoter file_cts }
Language/Haskell/TH/Syntax.hs view
@@ -1,2161 +1,399 @@-{-# LANGUAGE CPP, DeriveDataTypeable,- DeriveGeneric, FlexibleInstances, DefaultSignatures,- RankNTypes, RoleAnnotations, ScopedTypeVariables,- Trustworthy #-}--{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}---------------------------------------------------------------------------------- |--- Module : Language.Haskell.Syntax--- Copyright : (c) The University of Glasgow 2003--- License : BSD-style (see the file libraries/base/LICENSE)------ Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ Abstract syntax definitions for Template Haskell.-----------------------------------------------------------------------------------module Language.Haskell.TH.Syntax- ( module Language.Haskell.TH.Syntax- -- * Language extensions- , module Language.Haskell.TH.LanguageExtensions- , ForeignSrcLang(..)- ) where--import Data.Data hiding (Fixity(..))-import Data.IORef-import System.IO.Unsafe ( unsafePerformIO )-import Control.Monad (liftM)-import Control.Monad.IO.Class (MonadIO (..))-import System.IO ( hPutStrLn, stderr )-import Data.Char ( isAlpha, isAlphaNum, isUpper )-import Data.Int-import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Void ( Void, absurd )-import Data.Word-import Data.Ratio-import GHC.Generics ( Generic )-import GHC.Lexeme ( startsVarSym, startsVarId )-import GHC.ForeignSrcLang.Type-import Language.Haskell.TH.LanguageExtensions-import Numeric.Natural-import Prelude--import qualified Control.Monad.Fail as Fail------------------------------------------------------------- The Quasi class-----------------------------------------------------------class (MonadIO m, Fail.MonadFail m) => Quasi m where- qNewName :: String -> m Name- -- ^ Fresh names-- -- Error reporting and recovery- qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False)- -- ...but carry on; use 'fail' to stop- qRecover :: m a -- ^ the error handler- -> m a -- ^ action which may fail- -> m a -- ^ Recover from the monadic 'fail'-- -- Inspect the type-checker's environment- qLookupName :: Bool -> String -> m (Maybe Name)- -- True <=> type namespace, False <=> value namespace- qReify :: Name -> m Info- qReifyFixity :: Name -> m (Maybe Fixity)- qReifyInstances :: Name -> [Type] -> m [Dec]- -- Is (n tys) an instance?- -- Returns list of matching instance Decs- -- (with empty sub-Decs)- -- Works for classes and type functions- qReifyRoles :: Name -> m [Role]- qReifyAnnotations :: Data a => AnnLookup -> m [a]- qReifyModule :: Module -> m ModuleInfo- qReifyConStrictness :: Name -> m [DecidedStrictness]-- qLocation :: m Loc-- qRunIO :: IO a -> m a- qRunIO = liftIO- -- ^ Input/output (dangerous)-- qAddDependentFile :: FilePath -> m ()-- qAddTempFile :: String -> m FilePath-- qAddTopDecls :: [Dec] -> m ()-- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()-- qAddModFinalizer :: Q () -> m ()-- qAddCorePlugin :: String -> m ()-- qGetQ :: Typeable a => m (Maybe a)-- qPutQ :: Typeable a => a -> m ()-- qIsExtEnabled :: Extension -> m Bool- qExtsEnabled :: m [Extension]---------------------------------------------------------- The IO instance of Quasi------ This instance is used only when running a Q--- computation in the IO monad, usually just to--- print the result. There is no interesting--- type environment, so reification isn't going to--- work.-----------------------------------------------------------instance Quasi IO where- qNewName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))- ; pure (mkNameU s n) }-- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)-- qLookupName _ _ = badIO "lookupName"- qReify _ = badIO "reify"- qReifyFixity _ = badIO "reifyFixity"- qReifyInstances _ _ = badIO "reifyInstances"- qReifyRoles _ = badIO "reifyRoles"- qReifyAnnotations _ = badIO "reifyAnnotations"- qReifyModule _ = badIO "reifyModule"- qReifyConStrictness _ = badIO "reifyConStrictness"- qLocation = badIO "currentLocation"- qRecover _ _ = badIO "recover" -- Maybe we could fix this?- qAddDependentFile _ = badIO "addDependentFile"- qAddTempFile _ = badIO "addTempFile"- qAddTopDecls _ = badIO "addTopDecls"- qAddForeignFilePath _ _ = badIO "addForeignFilePath"- qAddModFinalizer _ = badIO "addModFinalizer"- qAddCorePlugin _ = badIO "addCorePlugin"- qGetQ = badIO "getQ"- qPutQ _ = badIO "putQ"- qIsExtEnabled _ = badIO "isExtEnabled"- qExtsEnabled = badIO "extsEnabled"--badIO :: String -> IO a-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")- ; fail "Template Haskell failure" }---- Global variable to generate unique symbols-counter :: IORef Int-{-# NOINLINE counter #-}-counter = unsafePerformIO (newIORef 0)-------------------------------------------------------------- The Q monad-----------------------------------------------------------newtype Q a = Q { unQ :: forall m. Quasi m => m a }---- \"Runs\" the 'Q' monad. Normal users of Template Haskell--- should not need this function, as the splice brackets @$( ... )@--- are the usual way of running a 'Q' computation.------ This function is primarily used in GHC internals, and for debugging--- splices by running them in 'IO'.------ Note that many functions in 'Q', such as 'reify' and other compiler--- queries, are not supported when running 'Q' in 'IO'; these operations--- simply fail at runtime. Indeed, the only operations guaranteed to succeed--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.-runQ :: Quasi m => Q a -> m a-runQ (Q m) = m--instance Monad Q where- Q m >>= k = Q (m >>= \x -> unQ (k x))- (>>) = (*>)-#if !MIN_VERSION_base(4,13,0)- fail = Fail.fail-#endif--instance Fail.MonadFail Q where- fail s = report True s >> Q (Fail.fail "Q monad failure")--instance Functor Q where- fmap f (Q x) = Q (fmap f x)--instance Applicative Q where- pure x = Q (pure x)- Q f <*> Q x = Q (f <*> x)- Q m *> Q n = Q (m *> n)------------------------------------------------------------- The TExp type-----------------------------------------------------------type role TExp nominal -- See Note [Role of TExp]-newtype TExp a = TExp { unType :: Exp }--unTypeQ :: Q (TExp a) -> Q Exp-unTypeQ m = do { TExp e <- m- ; return e }--unsafeTExpCoerce :: Q Exp -> Q (TExp a)-unsafeTExpCoerce m = do { e <- m- ; return (TExp e) }--{- Note [Role of TExp]-~~~~~~~~~~~~~~~~~~~~~~-TExp's argument must have a nominal role, not phantom as would-be inferred (Trac #8459). Consider-- e :: TExp Age- e = MkAge 3-- foo = $(coerce e) + 4::Int--The splice will evaluate to (MkAge 3) and you can't add that to-4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}--------------------------------------------------------- Packaged versions for the programmer, hiding the Quasi-ness--{- |-Generate a fresh name, which cannot be captured.--For example, this:--@f = $(do- nm1 <- newName \"x\"- let nm2 = 'mkName' \"x\"- return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))- )@--will produce the splice-->f = \x0 -> \x -> x0--In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,-and is not captured by the binding @VarP nm2@.--Although names generated by @newName@ cannot /be captured/, they can-/capture/ other names. For example, this:-->g = $(do-> nm1 <- newName "x"-> let nm2 = mkName "x"-> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))-> )--will produce the splice-->g = \x -> \x0 -> x0--since the occurrence @VarE nm2@ is captured by the innermost binding-of @x@, namely @VarP nm1@.--}-newName :: String -> Q Name-newName s = Q (qNewName s)---- | Report an error (True) or warning (False),--- but carry on; use 'fail' to stop.-report :: Bool -> String -> Q ()-report b s = Q (qReport b s)-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6---- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.-reportError :: String -> Q ()-reportError = report True---- | Report a warning to the user, and carry on.-reportWarning :: String -> Q ()-reportWarning = report False---- | Recover from errors raised by 'reportError' or 'fail'.-recover :: Q a -- ^ handler to invoke on failure- -> Q a -- ^ computation to run- -> Q a-recover (Q r) (Q m) = Q (qRecover r m)---- We don't export lookupName; the Bool isn't a great API--- Instead we export lookupTypeName, lookupValueName-lookupName :: Bool -> String -> Q (Maybe Name)-lookupName ns s = Q (qLookupName ns s)---- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.-lookupTypeName :: String -> Q (Maybe Name)-lookupTypeName s = Q (qLookupName True s)---- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.-lookupValueName :: String -> Q (Maybe Name)-lookupValueName s = Q (qLookupName False s)--{--Note [Name lookup]-~~~~~~~~~~~~~~~~~~--}-{- $namelookup #namelookup#-The functions 'lookupTypeName' and 'lookupValueName' provide-a way to query the current splice's context for what names-are in scope. The function 'lookupTypeName' queries the type-namespace, whereas 'lookupValueName' queries the value namespace,-but the functions are otherwise identical.--A call @lookupValueName s@ will check if there is a value-with name @s@ in scope at the current splice's location. If-there is, the @Name@ of this value is returned;-if not, then @Nothing@ is returned.--The returned name cannot be \"captured\".-For example:--> f = "global"-> g = $( do-> Just nm <- lookupValueName "f"-> [| let f = "local" in $( varE nm ) |]--In this case, @g = \"global\"@; the call to @lookupValueName@-returned the global @f@, and this name was /not/ captured by-the local definition of @f@.--The lookup is performed in the context of the /top-level/ splice-being run. For example:--> f = "global"-> g = $( [| let f = "local" in-> $(do-> Just nm <- lookupValueName "f"-> varE nm-> ) |] )--Again in this example, @g = \"global\"@, because the call to-@lookupValueName@ queries the context of the outer-most @$(...)@.--Operators should be queried without any surrounding parentheses, like so:--> lookupValueName "+"--Qualified names are also supported, like so:--> lookupValueName "Prelude.+"-> lookupValueName "Prelude.map"---}---{- | 'reify' looks up information about the 'Name'.--It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'-to ensure that we are reifying from the right namespace. For instance, in this context:--> data D = D--which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)-To ensure we get information about @D@-the-value, use 'lookupValueName':--> do-> Just nm <- lookupValueName "D"-> reify nm--and to get information about @D@-the-type, use 'lookupTypeName'.--}-reify :: Name -> Q Info-reify v = Q (qReify v)--{- | @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 nm = Q (qReifyFixity nm)--{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,-if @nm@ is the name of a type class, then all instances of this class at the types @tys@-are returned. Alternatively, if @nm@ is the name of a data family or type family,-all instances of this family at the types @tys@ are returned.--Note that this is a \"shallow\" test; the declarations returned merely have-instance heads which unify with @nm tys@, they need not actually be satisfiable.-- - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains- the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and- @B@ themselves implement 'Eq'-- - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available- instance of 'Eq'--There is one edge case: @reifyInstances ''Typeable tys@ currently always-produces an empty list (no matter what @tys@ are given).--}-reifyInstances :: Name -> [Type] -> Q [InstanceDec]-reifyInstances cls tys = Q (qReifyInstances cls tys)--{- | @reifyRoles nm@ returns the list of roles associated with the parameters of-the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.-The returned list should never contain 'InferR'.--}-reifyRoles :: Name -> Q [Role]-reifyRoles nm = Q (qReifyRoles nm)---- | @reifyAnnotations target@ returns the list of annotations--- associated with @target@. Only the annotations that are--- appropriately typed is returned. So if you have @Int@ and @String@--- annotations for the same target, you have to call this function twice.-reifyAnnotations :: Data a => AnnLookup -> Q [a]-reifyAnnotations an = Q (qReifyAnnotations an)---- | @reifyModule mod@ looks up information about module @mod@. To--- look up the current module, call this function with the return--- value of 'Language.Haskell.TH.Lib.thisModule'.-reifyModule :: Module -> Q ModuleInfo-reifyModule m = Q (qReifyModule m)---- | @reifyConStrictness nm@ looks up the strictness information for the fields--- of the constructor with the name @nm@. Note that the strictness information--- that 'reifyConStrictness' returns may not correspond to what is written in--- the source code. For example, in the following data declaration:------ @--- data Pair a = Pair a a--- @------ 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most--- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the--- @-XStrictData@ language extension was enabled.-reifyConStrictness :: Name -> Q [DecidedStrictness]-reifyConStrictness n = Q (qReifyConStrictness n)---- | Is the list of instances returned by 'reifyInstances' nonempty?-isInstance :: Name -> [Type] -> Q Bool-isInstance nm tys = do { decs <- reifyInstances nm tys- ; return (not (null decs)) }---- | The location at which this computation is spliced.-location :: Q Loc-location = Q qLocation---- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.--- Take care: you are guaranteed the ordering of calls to 'runIO' within--- a single 'Q' computation, but not about the order in which splices are run.------ Note: for various murky reasons, stdout and stderr handles are not--- necessarily flushed when the compiler finishes running, so you should--- flush them yourself.-runIO :: IO a -> Q a-runIO m = Q (qRunIO m)---- | Record external files that runIO is using (dependent upon).--- The compiler can then recognize that it should re-compile the Haskell file--- when an external file changes.------ Expects an absolute file path.------ Notes:------ * ghc -M does not know about these dependencies - it does not execute TH.------ * The dependency is based on file content, not a modification time-addDependentFile :: FilePath -> Q ()-addDependentFile fp = Q (qAddDependentFile fp)---- | Obtain a temporary file path with the given suffix. The compiler will--- delete this file after compilation.-addTempFile :: String -> Q FilePath-addTempFile suffix = Q (qAddTempFile suffix)---- | Add additional top-level declarations. The added declarations will be type--- checked along with the current declaration group.-addTopDecls :: [Dec] -> Q ()-addTopDecls ds = Q (qAddTopDecls ds)---- |-addForeignFile :: ForeignSrcLang -> String -> Q ()-addForeignFile = addForeignSource-{-# DEPRECATED addForeignFile- "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"- #-} -- deprecated in 8.6---- | Emit a foreign file which will be compiled and linked to the object for--- the current module. Currently only languages that can be compiled with--- the C compiler are supported, and the flags passed as part of -optc will--- be also applied to the C compiler invocation that will compile them.------ Note that for non-C languages (for example C++) @extern "C"@ directives--- must be used to get symbols that we can access from Haskell.------ To get better errors, it is recommended to use #line pragmas when--- emitting C files, e.g.------ > {-# LANGUAGE CPP #-}--- > ...--- > addForeignSource LangC $ unlines--- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__--- > , ...--- > ]-addForeignSource :: ForeignSrcLang -> String -> Q ()-addForeignSource lang src = do- let suffix = case lang of- LangC -> "c"- LangCxx -> "cpp"- LangObjc -> "m"- LangObjcxx -> "mm"- LangAsm -> "s"- RawObject -> "a"- path <- addTempFile suffix- runIO $ writeFile path src- addForeignFilePath lang path---- | Same as 'addForeignSource', but expects to receive a path pointing to the--- foreign file instead of a 'String' of its contents. Consider using this in--- conjunction with 'addTempFile'.------ This is a good alternative to 'addForeignSource' when you are trying to--- directly link in an object file.-addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)---- | Add a finalizer that will run in the Q monad after the current module has--- been type checked. This only makes sense when run within a top-level splice.------ The finalizer is given the local type environment at the splice point. Thus--- 'reify' is able to find the local definitions when executed inside the--- finalizer.-addModFinalizer :: Q () -> Q ()-addModFinalizer act = Q (qAddModFinalizer (unQ act))---- | Adds a core plugin to the compilation pipeline.------ @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc--- in the command line. The major difference is that the plugin module @m@--- must not belong to the current package. When TH executes, it is too late--- to tell the compiler that we needed to compile first a plugin module in the--- current package.-addCorePlugin :: String -> Q ()-addCorePlugin plugin = Q (qAddCorePlugin plugin)---- | Get state from the 'Q' monad. Note that the state is local to the--- Haskell module in which the Template Haskell expression is executed.-getQ :: Typeable a => Q (Maybe a)-getQ = Q qGetQ---- | Replace the state in the 'Q' monad. Note that the state is local to the--- Haskell module in which the Template Haskell expression is executed.-putQ :: Typeable a => a -> Q ()-putQ x = Q (qPutQ x)---- | Determine whether the given language extension is enabled in the 'Q' monad.-isExtEnabled :: Extension -> Q Bool-isExtEnabled ext = Q (qIsExtEnabled ext)---- | List all enabled language extensions.-extsEnabled :: Q [Extension]-extsEnabled = Q qExtsEnabled--instance MonadIO Q where- liftIO = runIO--instance Quasi Q where- qNewName = newName- qReport = report- qRecover = recover- qReify = reify- qReifyFixity = reifyFixity- qReifyInstances = reifyInstances- qReifyRoles = reifyRoles- qReifyAnnotations = reifyAnnotations- qReifyModule = reifyModule- qReifyConStrictness = reifyConStrictness- qLookupName = lookupName- qLocation = location- qAddDependentFile = addDependentFile- qAddTempFile = addTempFile- qAddTopDecls = addTopDecls- qAddForeignFilePath = addForeignFilePath- qAddModFinalizer = addModFinalizer- qAddCorePlugin = addCorePlugin- qGetQ = getQ- qPutQ = putQ- qIsExtEnabled = isExtEnabled- qExtsEnabled = extsEnabled---------------------------------------------------------- The following operations are used solely in DsMeta when desugaring brackets--- They are not necessary for the user, who can use ordinary return and (>>=) etc--returnQ :: a -> Q a-returnQ = return--bindQ :: Q a -> (a -> Q b) -> Q b-bindQ = (>>=)--sequenceQ :: [Q a] -> Q [a]-sequenceQ = sequence-------------------------------------------------------------- The Lift class------------------------------------------------------------- | A 'Lift' instance can have any of its values turned into a Template--- Haskell expression. This is needed when a value used within a Template--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not--- at the top level. As an example:------ > add1 :: Int -> Q Exp--- > add1 x = [| x + 1 |]------ Template Haskell has no way of knowing what value @x@ will take on at--- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.------ A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@--- is a Template Haskell splice.------ 'Lift' instances can be derived automatically by use of the @-XDeriveLift@--- GHC language extension:------ > {-# LANGUAGE DeriveLift #-}--- > module Foo where--- >--- > import Language.Haskell.TH.Syntax--- >--- > data Bar a = Bar1 a (Bar a) | Bar2 String--- > deriving Lift-class Lift t where- -- | Turn a value into a Template Haskell expression, suitable for use in- -- a splice.- lift :: t -> Q Exp- default lift :: Data t => t -> Q Exp- lift = liftData---- If you add any instances here, consider updating test th/TH_Lift-instance Lift Integer where- lift x = return (LitE (IntegerL x))--instance Lift Int where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int8 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int16 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int32 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Int64 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word8 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word16 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word32 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Word64 where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Lift Natural where- lift x = return (LitE (IntegerL (fromIntegral x)))--instance Integral a => Lift (Ratio a) where- lift x = return (LitE (RationalL (toRational x)))--instance Lift Float where- lift x = return (LitE (RationalL (toRational x)))--instance Lift Double where- lift x = return (LitE (RationalL (toRational x)))--instance Lift Char where- lift x = return (LitE (CharL x))--instance Lift Bool where- lift True = return (ConE trueName)- lift False = return (ConE falseName)--instance Lift a => Lift (Maybe a) where- lift Nothing = return (ConE nothingName)- lift (Just x) = liftM (ConE justName `AppE`) (lift x)--instance (Lift a, Lift b) => Lift (Either a b) where- lift (Left x) = liftM (ConE leftName `AppE`) (lift x)- lift (Right y) = liftM (ConE rightName `AppE`) (lift y)--instance Lift a => Lift [a] where- lift xs = do { xs' <- mapM lift xs; return (ListE xs') }--liftString :: String -> Q Exp--- Used in TcExpr to short-circuit the lifting for strings-liftString s = return (LitE (StringL s))---- | @since 2.15.0.0-instance Lift a => Lift (NonEmpty a) where- lift (x :| xs) = do- x' <- lift x- xs' <- lift xs- return (InfixE (Just x') (ConE nonemptyName) (Just xs'))---- | @since 2.15.0.0-instance Lift Void where- lift = pure . absurd--instance Lift () where- lift () = return (ConE (tupleDataName 0))--instance (Lift a, Lift b) => Lift (a, b) where- lift (a, b)- = liftM TupE $ sequence [lift a, lift b]--instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where- lift (a, b, c)- = liftM TupE $ sequence [lift a, lift b, lift c]--instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where- lift (a, b, c, d)- = liftM TupE $ sequence [lift a, lift b, lift c, lift d]--instance (Lift a, Lift b, Lift c, Lift d, Lift e)- => Lift (a, b, c, d, e) where- lift (a, b, c, d, e)- = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]--instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)- => Lift (a, b, c, d, e, f) where- lift (a, b, c, d, e, f)- = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]--instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)- => Lift (a, b, c, d, e, f, g) where- lift (a, b, c, d, e, f, g)- = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]---- TH has a special form for literal strings,--- which we should take advantage of.--- NB: the lhs of the rule has no args, so that--- the rule will apply to a 'lift' all on its own--- which happens to be the way the type checker--- creates it.-{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}---trueName, falseName :: Name-trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True"-falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False"--nothingName, justName :: Name-nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing"-justName = mkNameG DataName "base" "GHC.Maybe" "Just"--leftName, rightName :: Name-leftName = mkNameG DataName "base" "Data.Either" "Left"-rightName = mkNameG DataName "base" "Data.Either" "Right"--nonemptyName :: Name-nonemptyName = mkNameG DataName "base" "GHC.Base" ":|"------------------------------------------------------------- Generic Lift implementations------------------------------------------------------------- | 'dataToQa' is an internal utility function for constructing generic--- conversion functions from types with 'Data' instances to various--- quasi-quoting representations. See the source of 'dataToExpQ' and--- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@--- and @appQ@ are overloadable to account for different syntax for--- expressions and patterns; @antiQ@ allows you to override type-specific--- cases, a common usage is just @const Nothing@, which results in--- no overloading.-dataToQa :: forall a k q. Data a- => (Name -> k)- -> (Lit -> Q q)- -> (k -> [Q q] -> Q q)- -> (forall b . Data b => b -> Maybe (Q q))- -> a- -> Q q-dataToQa mkCon mkLit appCon antiQ t =- case antiQ t of- Nothing ->- case constrRep constr of- AlgConstr _ ->- appCon (mkCon funOrConName) conArgs- where- funOrConName :: Name- funOrConName =- case showConstr constr of- "(:)" -> Name (mkOccName ":")- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Types"))- con@"[]" -> Name (mkOccName con)- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Types"))- con@('(':_) -> Name (mkOccName con)- (NameG DataName- (mkPkgName "ghc-prim")- (mkModName "GHC.Tuple"))-- -- Tricky case: see Note [Data for non-algebraic types]- fun@(x:_) | startsVarSym x || startsVarId x- -> mkNameG_v tyconPkg tyconMod fun- con -> mkNameG_d tyconPkg tyconMod con-- where- tycon :: TyCon- tycon = (typeRepTyCon . typeOf) t-- tyconPkg, tyconMod :: String- tyconPkg = tyConPackage tycon- tyconMod = tyConModule tycon-- conArgs :: [Q q]- conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t- IntConstr n ->- mkLit $ IntegerL n- FloatConstr n ->- mkLit $ RationalL n- CharConstr c ->- mkLit $ CharL c- where- constr :: Constr- constr = toConstr t-- Just y -> y---{- Note [Data for non-algebraic types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Class Data was originally intended for algebraic data types. But-it is possible to use it for abstract types too. For example, in-package `text` we find-- instance Data Text where- ...- toConstr _ = packConstr-- packConstr :: Constr- packConstr = mkConstr textDataType "pack" [] Prefix--Here `packConstr` isn't a real data constructor, it's an ordinary-function. Two complications--* In such a case, we must take care to build the Name using- mkNameG_v (for values), not mkNameG_d (for data constructors).- See Trac #10796.--* The pseudo-constructor is named only by its string, here "pack".- But 'dataToQa' needs the TyCon of its defining module, and has- to assume it's defined in the same module as the TyCon itself.- But nothing enforces that; Trac #12596 shows what goes wrong if- "pack" is defined in a different module than the data type "Text".- -}---- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the--- same value, in the SYB style. It is generalized to take a function--- override type-specific cases; see 'liftData' for a more commonly--- used variant.-dataToExpQ :: Data a- => (forall b . Data b => b -> Maybe (Q Exp))- -> a- -> Q Exp-dataToExpQ = dataToQa varOrConE litE (foldl appE)- where- -- Make sure that VarE is used if the Constr value relies on a- -- function underneath the surface (instead of a constructor).- -- See Trac #10796.- varOrConE s =- case nameSpace s of- Just VarName -> return (VarE s)- Just DataName -> return (ConE s)- _ -> fail $ "Can't construct an expression from name "- ++ showName s- appE x y = do { a <- x; b <- y; return (AppE a b)}- litE c = return (LitE c)---- | 'liftData' is a variant of 'lift' in the 'Lift' type class which--- works for any type with a 'Data' instance.-liftData :: Data a => a -> Q Exp-liftData = dataToExpQ (const Nothing)---- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same--- value, in the SYB style. It takes a function to handle type-specific cases,--- alternatively, pass @const Nothing@ to get default behavior.-dataToPatQ :: Data a- => (forall b . Data b => b -> Maybe (Q Pat))- -> a- -> Q Pat-dataToPatQ = dataToQa id litP conP- where litP l = return (LitP l)- conP n ps =- case nameSpace n of- Just DataName -> do- ps' <- sequence ps- return (ConP n ps')- _ -> fail $ "Can't construct a pattern from name "- ++ showName n---------------------------------------------------------- Names and uniques--------------------------------------------------------newtype ModName = ModName String -- Module name- deriving (Show,Eq,Ord,Data,Generic)--newtype PkgName = PkgName String -- package name- deriving (Show,Eq,Ord,Data,Generic)---- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'.-data Module = Module PkgName ModName -- package qualified module name- deriving (Show,Eq,Ord,Data,Generic)--newtype OccName = OccName String- deriving (Show,Eq,Ord,Data,Generic)--mkModName :: String -> ModName-mkModName s = ModName s--modString :: ModName -> String-modString (ModName m) = m---mkPkgName :: String -> PkgName-mkPkgName s = PkgName s--pkgString :: PkgName -> String-pkgString (PkgName m) = m----------------------------------------------------------- OccName--------------------------------------------------------mkOccName :: String -> OccName-mkOccName s = OccName s--occString :: OccName -> String-occString (OccName occ) = occ----------------------------------------------------------- Names------------------------------------------------------------ For "global" names ('NameG') we need a totally unique name,--- so we must include the name-space of the thing------ For unique-numbered things ('NameU'), we've got a unique reference--- anyway, so no need for name space------ For dynamically bound thing ('NameS') we probably want them to--- in a context-dependent way, so again we don't want the name--- space. For example:------ > let v = mkName "T" in [| data $v = $v |]------ Here we use the same Name for both type constructor and data constructor--------- NameL and NameG are bound *outside* the TH syntax tree--- either globally (NameG) or locally (NameL). Ex:------ > f x = $(h [| (map, x) |])------ The 'map' will be a NameG, and 'x' wil be a NameL------ These Names should never appear in a binding position in a TH syntax tree--{- $namecapture #namecapture#-Much of 'Name' API is concerned with the problem of /name capture/, which-can be seen in the following example.--> f expr = [| let x = 0 in $expr |]-> ...-> g x = $( f [| x |] )-> h y = $( f [| y |] )--A naive desugaring of this would yield:--> g x = let x = 0 in x-> h y = let x = 0 in y--All of a sudden, @g@ and @h@ have different meanings! In this case,-we say that the @x@ in the RHS of @g@ has been /captured/-by the binding of @x@ in @f@.--What we actually want is for the @x@ in @f@ to be distinct from the-@x@ in @g@, so we get the following desugaring:--> g x = let x' = 0 in x-> h y = let x' = 0 in y--which avoids name capture as desired.--In the general case, we say that a @Name@ can be captured if-the thing it refers to can be changed by adding new declarations.--}--{- |-An abstract type representing names in the syntax tree.--'Name's can be constructed in several ways, which come with different-name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for-an explanation of name capture):-- * the built-in syntax @'f@ and @''T@ can be used to construct names,- The expression @'f@ gives a @Name@ which refers to the value @f@- currently in scope, and @''T@ gives a @Name@ which refers to the- type @T@ currently in scope. These names can never be captured.-- * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and- @''T@ respectively, but the @Name@s are looked up at the point- where the current splice is being run. These names can never be- captured.-- * 'newName' monadically generates a new name, which can never- be captured.-- * 'mkName' generates a capturable name.--Names constructed using @newName@ and @mkName@ may be used in bindings-(such as @let x = ...@ or @\x -> ...@), but names constructed using-@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.--}-data Name = Name OccName NameFlavour deriving (Data, Eq, Generic)--instance Ord Name where- -- check if unique is different before looking at strings- (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`- (o1 `compare` o2)--data NameFlavour- = NameS -- ^ An unqualified name; dynamically bound- | NameQ ModName -- ^ A qualified name; dynamically bound- | NameU !Int -- ^ A unique local name- | NameL !Int -- ^ Local name bound outside of the TH AST- | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:- -- An original name (occurrences only, not binders)- -- Need the namespace too to be sure which- -- thing we are naming- deriving ( Data, Eq, Ord, Show, Generic )--data NameSpace = VarName -- ^ Variables- | DataName -- ^ Data constructors- | TcClsName -- ^ Type constructors and classes; Haskell has them- -- in the same name space for now.- deriving( Eq, Ord, Show, Data, Generic )--type Uniq = Int---- | The name without its module prefix.------ ==== __Examples__------ >>> nameBase ''Data.Either.Either--- "Either"--- >>> nameBase (mkName "foo")--- "foo"--- >>> nameBase (mkName "Module.foo")--- "foo"-nameBase :: Name -> String-nameBase (Name occ _) = occString occ---- | Module prefix of a name, if it exists.------ ==== __Examples__------ >>> nameModule ''Data.Either.Either--- Just "Data.Either"--- >>> nameModule (mkName "foo")--- Nothing--- >>> nameModule (mkName "Module.foo")--- Just "Module"-nameModule :: Name -> Maybe String-nameModule (Name _ (NameQ m)) = Just (modString m)-nameModule (Name _ (NameG _ _ m)) = Just (modString m)-nameModule _ = Nothing---- | A name's package, if it exists.------ ==== __Examples__------ >>> namePackage ''Data.Either.Either--- Just "base"--- >>> namePackage (mkName "foo")--- Nothing--- >>> namePackage (mkName "Module.foo")--- Nothing-namePackage :: Name -> Maybe String-namePackage (Name _ (NameG _ p _)) = Just (pkgString p)-namePackage _ = Nothing---- | Returns whether a name represents an occurrence of a top-level variable--- ('VarName'), data constructor ('DataName'), type constructor, or type class--- ('TcClsName'). If we can't be sure, it returns 'Nothing'.------ ==== __Examples__------ >>> nameSpace 'Prelude.id--- Just VarName--- >>> nameSpace (mkName "id")--- Nothing -- only works for top-level variable names--- >>> nameSpace 'Data.Maybe.Just--- Just DataName--- >>> nameSpace ''Data.Maybe.Maybe--- Just TcClsName--- >>> nameSpace ''Data.Ord.Ord--- Just TcClsName-nameSpace :: Name -> Maybe NameSpace-nameSpace (Name _ (NameG ns _ _)) = Just ns-nameSpace _ = Nothing--{- |-Generate a capturable name. Occurrences of such names will be-resolved according to the Haskell scoping rules at the occurrence-site.--For example:--> f = [| pi + $(varE (mkName "pi")) |]-> ...-> g = let pi = 3 in $f--In this case, @g@ is desugared to--> g = Prelude.pi + 3--Note that @mkName@ may be used with qualified names:--> mkName "Prelude.pi"--See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could-be rewritten using 'Language.Haskell.TH.Lib.dyn' as--> f = [| pi + $(dyn "pi") |]--}-mkName :: String -> Name--- The string can have a '.', thus "Foo.baz",--- giving a dynamically-bound qualified name,--- in which case we want to generate a NameQ------ Parse the string to see if it has a "." in it--- so we know whether to generate a qualified or unqualified name--- It's a bit tricky because we need to parse------ > Foo.Baz.x as Qual Foo.Baz x------ So we parse it from back to front-mkName str- = split [] (reverse str)- where- split occ [] = Name (mkOccName occ) NameS- split occ ('.':rev) | not (null occ)- , is_rev_mod_name rev- = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))- -- The 'not (null occ)' guard ensures that- -- mkName "&." = Name "&." NameS- -- The 'is_rev_mod' guards ensure that- -- mkName ".&" = Name ".&" NameS- -- mkName "^.." = Name "^.." NameS -- Trac #8633- -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")- -- This rather bizarre case actually happened; (.&.) is in Data.Bits- split occ (c:rev) = split (c:occ) rev-- -- Recognises a reversed module name xA.yB.C,- -- with at least one component,- -- and each component looks like a module name- -- (i.e. non-empty, starts with capital, all alpha)- is_rev_mod_name rev_mod_str- | (compt, rest) <- break (== '.') rev_mod_str- , not (null compt), isUpper (last compt), all is_mod_char compt- = case rest of- [] -> True- (_dot : rest') -> is_rev_mod_name rest'- | otherwise- = False-- is_mod_char c = isAlphaNum c || c == '_' || c == '\''---- | Only used internally-mkNameU :: String -> Uniq -> Name-mkNameU s u = Name (mkOccName s) (NameU u)---- | Only used internally-mkNameL :: String -> Uniq -> Name-mkNameL s u = Name (mkOccName s) (NameL u)---- | Used for 'x etc, but not available to the programmer-mkNameG :: NameSpace -> String -> String -> String -> Name-mkNameG ns pkg modu occ- = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))--mkNameS :: String -> Name-mkNameS n = Name (mkOccName n) NameS--mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name-mkNameG_v = mkNameG VarName-mkNameG_tc = mkNameG TcClsName-mkNameG_d = mkNameG DataName--data NameIs = Alone | Applied | Infix--showName :: Name -> String-showName = showName' Alone--showName' :: NameIs -> Name -> String-showName' ni nm- = case ni of- Alone -> nms- Applied- | pnam -> nms- | otherwise -> "(" ++ nms ++ ")"- Infix- | pnam -> "`" ++ nms ++ "`"- | otherwise -> nms- where- -- For now, we make the NameQ and NameG print the same, even though- -- NameQ is a qualified name (so what it means depends on what the- -- current scope is), and NameG is an original name (so its meaning- -- should be independent of what's in scope.- -- We may well want to distinguish them in the end.- -- Ditto NameU and NameL- nms = case nm of- Name occ NameS -> occString occ- Name occ (NameQ m) -> modString m ++ "." ++ occString occ- Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ- Name occ (NameU u) -> occString occ ++ "_" ++ show u- Name occ (NameL u) -> occString occ ++ "_" ++ show u-- pnam = classify nms-- -- True if we are function style, e.g. f, [], (,)- -- False if we are operator style, e.g. +, :+- classify "" = False -- shouldn't happen; . operator is handled below- classify (x:xs) | isAlpha x || (x `elem` "_[]()") =- case dropWhile (/='.') xs of- (_:xs') -> classify xs'- [] -> True- | otherwise = False--instance Show Name where- show = showName---- Tuple data and type constructors--- | Tuple data constructor-tupleDataName :: Int -> Name--- | Tuple type constructor-tupleTypeName :: Int -> Name--tupleDataName 0 = mk_tup_name 0 DataName-tupleDataName 1 = error "tupleDataName 1"-tupleDataName n = mk_tup_name (n-1) DataName--tupleTypeName 0 = mk_tup_name 0 TcClsName-tupleTypeName 1 = error "tupleTypeName 1"-tupleTypeName n = mk_tup_name (n-1) TcClsName--mk_tup_name :: Int -> NameSpace -> Name-mk_tup_name n_commas space- = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)- where- occ = mkOccName ('(' : replicate n_commas ',' ++ ")")- tup_mod = mkModName "GHC.Tuple"---- Unboxed tuple data and type constructors--- | Unboxed tuple data constructor-unboxedTupleDataName :: Int -> Name--- | Unboxed tuple type constructor-unboxedTupleTypeName :: Int -> Name--unboxedTupleDataName n = mk_unboxed_tup_name n DataName-unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName--mk_unboxed_tup_name :: Int -> NameSpace -> Name-mk_unboxed_tup_name n space- = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)- where- tup_occ | n == 1 = "Unit#" -- See Note [One-tuples] in TysWiredIn- | otherwise = "(#" ++ replicate n_commas ',' ++ "#)"- n_commas = n - 1- tup_mod = mkModName "GHC.Tuple"---- Unboxed sum data and type constructors--- | Unboxed sum data constructor-unboxedSumDataName :: SumAlt -> SumArity -> Name--- | Unboxed sum type constructor-unboxedSumTypeName :: SumArity -> Name--unboxedSumDataName alt arity- | alt > arity- = error $ prefix ++ "Index out of bounds." ++ debug_info-- | alt <= 0- = error $ prefix ++ "Alt must be > 0." ++ debug_info-- | arity < 2- = error $ prefix ++ "Arity must be >= 2." ++ debug_info-- | otherwise- = Name (mkOccName sum_occ)- (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))-- where- prefix = "unboxedSumDataName: "- debug_info = " (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")"-- -- Synced with the definition of mkSumDataConOcc in TysWiredIn- sum_occ = '(' : '#' : bars nbars_before ++ '_' : bars nbars_after ++ "#)"- bars i = replicate i '|'- nbars_before = alt - 1- nbars_after = arity - alt--unboxedSumTypeName arity- | arity < 2- = error $ "unboxedSumTypeName: Arity must be >= 2."- ++ " (arity: " ++ show arity ++ ")"-- | otherwise- = Name (mkOccName sum_occ)- (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))-- where- -- Synced with the definition of mkSumTyConOcc in TysWiredIn- sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)"---------------------------------------------------------- Locations--------------------------------------------------------data Loc- = Loc { loc_filename :: String- , loc_package :: String- , loc_module :: String- , loc_start :: CharPos- , loc_end :: CharPos }- deriving( Show, Eq, Ord, Data, Generic )--type CharPos = (Int, Int) -- ^ Line and character position-------------------------------------------------------------- The Info returned by reification------------------------------------------------------------- | Obtained from 'reify' in the 'Q' Monad.-data Info- =- -- | A class, with a list of its visible instances- ClassI- Dec- [InstanceDec]-- -- | A class method- | ClassOpI- Name- Type- ParentName-- -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned- -- using 'PrimTyConI' or 'FamilyI' as appropriate. At present, this reified- -- declaration will never have derived instances attached to it (if you wish- -- to check for an instance, see 'reifyInstances').- | TyConI- Dec-- -- | A type or data family, with a list of its visible instances. A closed- -- type family is returned with 0 instances.- | FamilyI- Dec- [InstanceDec]-- -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'.- -- Examples: @(->)@, @Int#@.- | PrimTyConI- Name- Arity- Unlifted-- -- | A data constructor- | DataConI- Name- Type- ParentName-- -- | A pattern synonym- | PatSynI- Name- PatSynType-- {- |- A \"value\" variable (as opposed to a type variable, see 'TyVarI').-- The @Maybe Dec@ field contains @Just@ the declaration which- defined the variable - including the RHS of the declaration -- or else @Nothing@, in the case where the RHS is unavailable to- the compiler. At present, this value is /always/ @Nothing@:- returning the RHS has not yet been implemented because of- lack of interest.- -}- | VarI- Name- Type- (Maybe Dec)-- {- |- A type variable.-- The @Type@ field contains the type which underlies the variable.- At present, this is always @'VarT' theName@, but future changes- may permit refinement of this.- -}- | TyVarI -- Scoped type variable- Name- Type -- What it is bound to- deriving( Show, Eq, Ord, Data, Generic )---- | Obtained from 'reifyModule' in the 'Q' Monad.-data ModuleInfo =- -- | Contains the import list of the module.- ModuleInfo [Module]- deriving( Show, Eq, Ord, Data, Generic )--{- |-In 'ClassOpI' and 'DataConI', name of the parent class or type--}-type ParentName = Name---- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a--- particular data constructor. 'SumAlt's are one-indexed and should never--- exceed the value of its corresponding 'SumArity'. For example:------ * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2)------ * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2)-type SumAlt = Int---- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of--- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2.-type SumArity = Int---- | In 'PrimTyConI', arity of the type constructor-type Arity = Int---- | In 'PrimTyConI', is the type constructor unlifted?-type Unlifted = Bool---- | 'InstanceDec' desribes a single instance of a class or type function.--- It is just a 'Dec', but guaranteed to be one of the following:------ * 'InstanceD' (with empty @['Dec']@)------ * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@)------ * 'TySynInstD'-type InstanceDec = Dec--data Fixity = Fixity Int FixityDirection- deriving( Eq, Ord, Show, Data, Generic )-data FixityDirection = InfixL | InfixR | InfixN- deriving( Eq, Ord, Show, Data, Generic )---- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)-maxPrecedence :: Int-maxPrecedence = (9::Int)---- | Default fixity: @infixl 9@-defaultFixity :: Fixity-defaultFixity = Fixity maxPrecedence InfixL---{--Note [Unresolved infix]-~~~~~~~~~~~~~~~~~~~~~~~--}-{- $infix #infix#-When implementing antiquotation for quasiquoters, one often wants-to parse strings into expressions:--> parse :: String -> Maybe Exp--But how should we parse @a + b * c@? If we don't know the fixities of-@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a-+ b) * c@.--In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for-\"unresolved infix expression/pattern/type\", respectively. When the compiler-is given a splice containing a tree of @UInfixE@ applications such as--> UInfixE-> (UInfixE e1 op1 e2)-> op2-> (UInfixE e3 op3 e4)--it will look up and the fixities of the relevant operators and-reassociate the tree as necessary.-- * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT',- which are of use for parsing expressions like-- > (a + b * c) + d * e-- * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated.-- * The 'UInfixE' constructor doesn't support sections. Sections- such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer- sections such as @(a + b * c -)@, use an 'InfixE' constructor for the- outer-most section, and use 'UInfixE' constructors for all- other operators:-- > InfixE- > Just (UInfixE ...a + b * c...)- > op- > Nothing-- Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered- into 'Exp's differently:-- > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b)- > -- will result in a fixity error if (+) is left-infix- > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b)- > -- no fixity errors-- * Quoted expressions such as-- > [| a * b + c |] :: Q Exp- > [p| a : b : c |] :: Q Pat- > [t| T + T |] :: Q Type-- will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE',- 'ParensP', or 'ParensT' constructors.---}------------------------------------------------------------- The main syntax data types-----------------------------------------------------------data Lit = CharL Char- | StringL String- | IntegerL Integer -- ^ Used for overloaded and non-overloaded- -- literals. We don't have a good way to- -- represent non-overloaded literals at- -- the moment. Maybe that doesn't matter?- | RationalL Rational -- Ditto- | IntPrimL Integer- | WordPrimL Integer- | FloatPrimL Rational- | DoublePrimL Rational- | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#- | CharPrimL Char- deriving( Show, Eq, Ord, Data, Generic )-- -- We could add Int, Float, Double etc, as we do in HsLit,- -- but that could complicate the- -- supposedly-simple TH.Syntax literal type---- | Pattern in Haskell given in @{}@-data Pat- = LitP Lit -- ^ @{ 5 or \'c\' }@- | VarP Name -- ^ @{ x }@- | TupP [Pat] -- ^ @{ (p1,p2) }@- | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@- | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@- | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@- | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@- | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensP Pat -- ^ @{(p)}@- --- -- See "Language.Haskell.TH.Syntax#infix"- | TildeP Pat -- ^ @{ ~p }@- | BangP Pat -- ^ @{ !p }@- | AsP Name Pat -- ^ @{ x \@ p }@- | WildP -- ^ @{ _ }@- | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@- | ListP [ Pat ] -- ^ @{ [1,2,3] }@- | SigP Pat Type -- ^ @{ p :: t }@- | ViewP Exp Pat -- ^ @{ e -> p }@- deriving( Show, Eq, Ord, Data, Generic )--type FieldPat = (Name,Pat)--data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@- deriving( Show, Eq, Ord, Data, Generic )-data Clause = Clause [Pat] Body [Dec]- -- ^ @f { p1 p2 = body where decs }@- deriving( Show, Eq, Ord, Data, Generic )--data Exp- = VarE Name -- ^ @{ x }@- | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @- | LitE Lit -- ^ @{ 5 or \'c\'}@- | AppE Exp Exp -- ^ @{ f x }@- | AppTypeE Exp Type -- ^ @{ f \@Int }@-- | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@-- -- It's a bit gruesome to use an Exp as the- -- operator, but how else can we distinguish- -- constructors from non-constructors?- -- Maybe there should be a var-or-con type?- -- Or maybe we should leave it to the String itself?-- | UInfixE Exp Exp Exp -- ^ @{x + y}@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensE Exp -- ^ @{ (e) }@- --- -- See "Language.Haskell.TH.Syntax#infix"- | LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@- | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@- | TupE [Exp] -- ^ @{ (e1,e2) } @- | UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @- | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@- | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@- | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@- | LetE [Dec] Exp -- ^ @{ let { x=e1; y=e2 } in e3 }@- | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@- | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@- | MDoE [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@- | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@- --- -- The result expression of the comprehension is- -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'.- --- -- E.g. translation:- --- -- > [ f x | x <- xs ]- --- -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]-- | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@- | ListE [ Exp ] -- ^ @{ [1,2,3] }@- | SigE Exp Type -- ^ @{ e :: t }@- | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@- | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@- | StaticE Exp -- ^ @{ static e }@- | UnboundVarE Name -- ^ @{ _x }@- --- -- This is used for holes or unresolved- -- identifiers in AST quotes. Note that- -- it could either have a variable name- -- or constructor name.- | LabelE String -- ^ @{ #x }@ ( Overloaded label )- | ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter )- deriving( Show, Eq, Ord, Data, Generic )--type FieldExp = (Name,Exp)---- Omitted: implicit parameters--data Body- = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2- -- | e3 = e4 }- -- where ds@- | NormalB Exp -- ^ @f p { = e } where ds@- deriving( Show, Eq, Ord, Data, Generic )--data Guard- = NormalG Exp -- ^ @f x { | odd x } = x@- | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@- deriving( Show, Eq, Ord, Data, Generic )--data Stmt- = BindS Pat Exp -- ^ @p <- e@- | LetS [ Dec ] -- ^ @{ let { x=e1; y=e2 } }@- | NoBindS Exp -- ^ @e@- | ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')- | RecS [Stmt] -- ^ @rec { s1; s2 }@- deriving( Show, Eq, Ord, Data, Generic )--data Range = FromR Exp | FromThenR Exp Exp- | FromToR Exp Exp | FromThenToR Exp Exp Exp- deriving( Show, Eq, Ord, Data, Generic )--data Dec- = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@- | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@- | DataD Cxt Name [TyVarBndr]- (Maybe Kind) -- Kind signature (allowed only for GADTs)- [Con] [DerivClause]- -- ^ @{ data Cxt x => T x = A x | B (T x)- -- deriving (Z,W)- -- deriving stock Eq }@- | NewtypeD Cxt Name [TyVarBndr]- (Maybe Kind) -- Kind signature- Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x)- -- deriving (Z,W Q)- -- deriving stock Eq }@- | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@- | ClassD Cxt Name [TyVarBndr]- [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@- | InstanceD (Maybe Overlap) Cxt Type [Dec]- -- ^ @{ instance {\-\# OVERLAPS \#-\}- -- Show w => Show [w] where ds }@- | SigD Name Type -- ^ @{ length :: [a] -> Int }@- | ForeignD Foreign -- ^ @{ foreign import ... }- --{ foreign export ... }@-- | InfixD Fixity Name -- ^ @{ infix 3 foo }@-- -- | pragmas- | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@-- -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')- | DataFamilyD Name [TyVarBndr]- (Maybe Kind)- -- ^ @{ data family T a b c :: * }@-- | DataInstD Cxt (Maybe [TyVarBndr]) Type- (Maybe Kind) -- Kind signature- [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x]- -- = A x | B (T x)- -- deriving (Z,W)- -- deriving stock Eq }@-- | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars- (Maybe Kind) -- Kind signature- Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]- -- = A (B x)- -- deriving (Z,W)- -- deriving stock Eq }@- | TySynInstD TySynEqn -- ^ @{ type instance ... }@-- -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')- | OpenTypeFamilyD TypeFamilyHead- -- ^ @{ type family T a b c = (r :: *) | r -> a b }@-- | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]- -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@-- | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@- | StandaloneDerivD (Maybe DerivStrategy) Cxt Type- -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@- | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@-- -- | Pattern Synonyms- | PatSynD Name PatSynArgs PatSynDir Pat- -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or- -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or- -- @{ pattern P v1 v2 .. vn <- p- -- where P v1 v2 .. vn = e }@ explicit bidirectional- --- -- also, besides prefix pattern synonyms, both infix and record- -- pattern synonyms are supported. See 'PatSynArgs' for details-- | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature.-- | ImplicitParamBindD String Exp- -- ^ @{ ?x = expr }@- --- -- Implicit parameter binding declaration. Can only be used in let- -- and where clauses which consist entirely of implicit bindings.- deriving( Show, Eq, Ord, Data, Generic )---- | Varieties of allowed instance overlap.-data Overlap = Overlappable -- ^ May be overlapped by more specific instances- | Overlapping -- ^ May overlap a more general instance- | Overlaps -- ^ Both 'Overlapping' and 'Overlappable'- | Incoherent -- ^ Both 'Overlappable' and 'Overlappable', and- -- pick an arbitrary one if multiple choices are- -- available.- deriving( Show, Eq, Ord, Data, Generic )---- | A single @deriving@ clause at the end of a datatype.-data DerivClause = DerivClause (Maybe DerivStrategy) Cxt- -- ^ @{ deriving stock (Eq, Ord) }@- deriving( Show, Eq, Ord, Data, Generic )---- | What the user explicitly requests when deriving an instance.-data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance- | AnyclassStrategy -- ^ @-XDeriveAnyClass@- | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@- | ViaStrategy Type -- ^ @-XDerivingVia@- deriving( Show, Eq, Ord, Data, Generic )---- | A pattern synonym's type. Note that a pattern synonym's /fully/--- specified type has a peculiar shape coming with two forall--- quantifiers and two constraint contexts. For example, consider the--- pattern synonym------ > pattern P x1 x2 ... xn = <some-pattern>------ P's complete type is of the following form------ > pattern P :: forall universals. required constraints--- > => forall existentials. provided constraints--- > => t1 -> t2 -> ... -> tn -> t------ consisting of four parts:------ 1. the (possibly empty lists of) universally quantified type--- variables and required constraints on them.--- 2. the (possibly empty lists of) existentially quantified--- type variables and the provided constraints on them.--- 3. the types @t1@, @t2@, .., @tn@ of @x1@, @x2@, .., @xn@, respectively--- 4. the type @t@ of @\<some-pattern\>@, mentioning only universals.------ Pattern synonym types interact with TH when (a) reifying a pattern--- synonym, (b) pretty printing, or (c) specifying a pattern synonym's--- type signature explicitly:------ * Reification always returns a pattern synonym's /fully/ specified--- type in abstract syntax.------ * Pretty printing via 'Language.Haskell.TH.Ppr.pprPatSynType' abbreviates--- a pattern synonym's type unambiguously in concrete syntax: The rule of--- thumb is to print initial empty universals and the required--- context as @() =>@, if existentials and a provided context--- follow. If only universals and their required context, but no--- existentials are specified, only the universals and their--- required context are printed. If both or none are specified, so--- both (or none) are printed.------ * When specifying a pattern synonym's type explicitly with--- 'PatSynSigD' either one of the universals, the existentials, or--- their contexts may be left empty.------ See the GHC user's guide for more information on pattern synonyms--- and their types:--- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#pattern-synonyms>.-type PatSynType = Type---- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By--- analogy with "head" for type classes and type class instances as--- defined in /Type classes: an exploration of the design space/, the--- @TypeFamilyHead@ is defined to be the elements of the declaration--- between @type family@ and @where@.-data TypeFamilyHead =- TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn)- deriving( Show, Eq, Ord, Data, Generic )---- | One equation of a type family instance or closed type family. The--- arguments are the left-hand-side type and the right-hand-side result.------ For instance, if you had the following type family:------ @--- type family Foo (a :: k) :: k where--- forall k (a :: k). Foo \@k a = a--- @------ The @Foo \@k a = a@ equation would be represented as follows:------ @--- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)])--- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a))--- ('VarT' a)--- @-data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type- deriving( Show, Eq, Ord, Data, Generic )--data FunDep = FunDep [Name] [Name]- deriving( Show, Eq, Ord, Data, Generic )--data Foreign = ImportF Callconv Safety String Name Type- | ExportF Callconv String Name Type- deriving( Show, Eq, Ord, Data, Generic )---- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs-data Callconv = CCall | StdCall | CApi | Prim | JavaScript- deriving( Show, Eq, Ord, Data, Generic )--data Safety = Unsafe | Safe | Interruptible- deriving( Show, Eq, Ord, Data, Generic )--data Pragma = InlineP Name Inline RuleMatch Phases- | SpecialiseP Name Type (Maybe Inline) Phases- | SpecialiseInstP Type- | RuleP String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases- | AnnP AnnTarget Exp- | LineP Int String- | CompleteP [Name] (Maybe Name)- -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@- deriving( Show, Eq, Ord, Data, Generic )--data Inline = NoInline- | Inline- | Inlinable- deriving (Show, Eq, Ord, Data, Generic)--data RuleMatch = ConLike- | FunLike- deriving (Show, Eq, Ord, Data, Generic)--data Phases = AllPhases- | FromPhase Int- | BeforePhase Int- deriving (Show, Eq, Ord, Data, Generic)--data RuleBndr = RuleVar Name- | TypedRuleVar Name Type- deriving (Show, Eq, Ord, Data, Generic)--data AnnTarget = ModuleAnnotation- | TypeAnnotation Name- | ValueAnnotation Name- deriving (Show, Eq, Ord, Data, Generic)--type Cxt = [Pred] -- ^ @(Eq a, Ord b)@---- | Since the advent of @ConstraintKinds@, constraints are really just types.--- Equality constraints use the 'EqualityT' constructor. Constraints may also--- be tuples of other constraints.-type Pred = Type--data SourceUnpackedness- = NoSourceUnpackedness -- ^ @C a@- | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@- | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@- deriving (Show, Eq, Ord, Data, Generic)--data SourceStrictness = NoSourceStrictness -- ^ @C a@- | SourceLazy -- ^ @C {~}a@- | SourceStrict -- ^ @C {!}a@- deriving (Show, Eq, Ord, Data, Generic)---- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'--- refers to the strictness that the compiler chooses for a data constructor--- field, which may be different from what is written in source code. See--- 'reifyConStrictness' for more information.-data DecidedStrictness = DecidedLazy- | DecidedStrict- | DecidedUnpack- deriving (Show, Eq, Ord, Data, Generic)---- | A single data constructor.------ The constructors for 'Con' can roughly be divided up into two categories:--- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and--- 'InfixC'), and those for constructors with GADT syntax ('GadtC' and--- 'RecGadtC'). The 'ForallC' constructor, which quantifies additional type--- variables and class contexts, can surround either variety of constructor.--- However, the type variables that it quantifies are different depending--- on what constructor syntax is used:------ * If a 'ForallC' surrounds a constructor with vanilla syntax, then the--- 'ForallC' will only quantify /existential/ type variables. For example:------ @--- data Foo a = forall b. MkFoo a b--- @------ In @MkFoo@, 'ForallC' will quantify @b@, but not @a@.------ * If a 'ForallC' surrounds a constructor with GADT syntax, then the--- 'ForallC' will quantify /all/ type variables used in the constructor.--- For example:------ @--- data Bar a b where--- MkBar :: (a ~ b) => c -> MkBar a b--- @------ In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@.-data Con = NormalC Name [BangType] -- ^ @C Int a@- | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@- | InfixC BangType Name BangType -- ^ @Int :+ a@- | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@- | GadtC [Name] [BangType]- Type -- See Note [GADT return type]- -- ^ @C :: a -> b -> T b Int@- | RecGadtC [Name] [VarBangType]- Type -- See Note [GADT return type]- -- ^ @C :: { v :: Int } -> T b Int@- deriving (Show, Eq, Ord, Data, Generic)---- Note [GADT return type]--- ~~~~~~~~~~~~~~~~~~~~~~~------ The return type of a GADT constructor does not necessarily match the name of--- the data type:------ type S = T------ data T a where--- MkT :: S Int--------- type S a = T------ data T a where--- MkT :: S Char Int--------- type Id a = a--- type S a = T------ data T a where--- MkT :: Id (S Char Int)--------- That is why we allow the return type stored by a constructor to be an--- arbitrary type. See also #11341--data Bang = Bang SourceUnpackedness SourceStrictness- -- ^ @C { {\-\# UNPACK \#-\} !}a@- deriving (Show, Eq, Ord, Data, Generic)--type BangType = (Bang, Type)-type VarBangType = (Name, Bang, Type)---- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'.-type Strict = Bang---- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by--- 'BangType'.-type StrictType = BangType---- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by--- 'VarBangType'.-type VarStrictType = VarBangType---- | A pattern synonym's directionality.-data PatSynDir- = Unidir -- ^ @pattern P x {<-} p@- | ImplBidir -- ^ @pattern P x {=} p@- | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@- deriving( Show, Eq, Ord, Data, Generic )---- | A pattern synonym's argument type.-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, Eq, Ord, Data, Generic )--data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@- | AppT Type Type -- ^ @T a b@- | AppKindT Type Kind -- ^ @T \@k t@- | SigT Type Kind -- ^ @t :: k@- | VarT Name -- ^ @a@- | ConT Name -- ^ @T@- | PromotedT Name -- ^ @'T@- | InfixT Type Name Type -- ^ @T + T@- | UInfixT Type Name Type -- ^ @T + T@- --- -- See "Language.Haskell.TH.Syntax#infix"- | ParensT Type -- ^ @(T)@-- -- See Note [Representing concrete syntax in types]- | TupleT Int -- ^ @(,), (,,), etc.@- | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@- | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@- | ArrowT -- ^ @->@- | EqualityT -- ^ @~@- | ListT -- ^ @[]@- | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@- | PromotedNilT -- ^ @'[]@- | PromotedConsT -- ^ @(':)@- | StarT -- ^ @*@- | ConstraintT -- ^ @Constraint@- | LitT TyLit -- ^ @0,1,2, etc.@- | WildCardT -- ^ @_@- | ImplicitParamT String Type -- ^ @?x :: t@- deriving( Show, Eq, Ord, Data, Generic )--data TyVarBndr = PlainTV Name -- ^ @a@- | KindedTV Name Kind -- ^ @(a :: k)@- deriving( Show, Eq, Ord, Data, Generic )---- | Type family result signature-data FamilyResultSig = NoSig -- ^ no signature- | KindSig Kind -- ^ @k@- | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@- deriving( Show, Eq, Ord, Data, Generic )---- | Injectivity annotation-data InjectivityAnn = InjectivityAnn Name [Name]- deriving ( Show, Eq, Ord, Data, Generic )--data TyLit = NumTyLit Integer -- ^ @2@- | StrTyLit String -- ^ @\"Hello\"@- deriving ( Show, Eq, Ord, Data, Generic )---- | Role annotations-data Role = NominalR -- ^ @nominal@- | RepresentationalR -- ^ @representational@- | PhantomR -- ^ @phantom@- | InferR -- ^ @_@- deriving( Show, Eq, Ord, Data, Generic )---- | Annotation target for reifyAnnotations-data AnnLookup = AnnLookupModule Module- | AnnLookupName Name- deriving( Show, Eq, Ord, Data, Generic )---- | To avoid duplication between kinds and types, they--- are defined to be the same. Naturally, you would never--- have a type be 'StarT' and you would never have a kind--- be 'SigT', but many of the other constructors are shared.--- Note that the kind @Bool@ is denoted with 'ConT', not--- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT',--- not 'PromotedTupleT'.--type Kind = Type--{- Note [Representing concrete syntax in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Haskell has a rich concrete syntax for types, including- t1 -> t2, (t1,t2), [t], and so on-In TH we represent all of this using AppT, with a distinguished-type constructor at the head. So,- Type TH representation- ------------------------------------------------ t1 -> t2 ArrowT `AppT` t2 `AppT` t2- [t] ListT `AppT` t- (t1,t2) TupleT 2 `AppT` t1 `AppT` t2- '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2--But if the original HsSyn used prefix application, we won't use-these special TH constructors. For example- [] t ConT "[]" `AppT` t- (->) t ConT "->" `AppT` t-In this way we can faithfully represent in TH whether the original-HsType used concrete syntax or not.--The one case that doesn't fit this pattern is that of promoted lists- '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2-but it's very smelly because there really is no type constructor-corresponding to PromotedListT. So we encode HsExplicitListTy with-PromotedConsT and PromotedNilT (which *do* have underlying type-constructors):- '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT`- (PromotedConsT `AppT` IO `AppT` PromotedNilT)--}---------------------------------------------------------- Internal helper functions--------------------------------------------------------cmpEq :: Ordering -> Bool-cmpEq EQ = True-cmpEq _ = False--thenCmp :: Ordering -> Ordering -> Ordering-thenCmp EQ o2 = o2-thenCmp o1 _ = o1+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnboxedTuples #-}++module Language.Haskell.TH.Syntax (+ Quote (..),+ Exp (..),+ Match (..),+ Clause (..),+ Q (..),+ Pat (..),+ Stmt (..),+ Con (..),+ Type (..),+ Dec (..),+ BangType,+ VarBangType,+ FieldExp,+ FieldPat,+ Name (..),+ FunDep (..),+ Pred,+ RuleBndr (..),+ TySynEqn (..),+ InjectivityAnn (..),+ Kind,+ Overlap (..),+ DerivClause (..),+ DerivStrategy (..),+ Code (..),+ ModName (..),+ addCorePlugin,+ addDependentFile,+ addForeignFile,+ addForeignFilePath,+ addForeignSource,+ addModFinalizer,+ addTempFile,+ addTopDecls,+ badIO,+ bindCode,+ bindCode_,+ cmpEq,+ compareBytes,+ counter,+ defaultFixity,+ eqBytes,+ extsEnabled,+ getDoc,+ getPackageRoot,+ getQ,+ get_cons_names,+ hoistCode,+ isExtEnabled,+ isInstance,+ joinCode,+ liftCode,+ location,+ lookupName,+ lookupTypeName,+ lookupValueName,+ manyName,+ maxPrecedence,+ memcmp,+ mkNameG,+ mkNameU,+ mkOccName,+ mkPkgName,+ mk_tup_name,+ mkName,+ mkNameG_v,+ mkNameG_d,+ mkNameG_tc,+ mkNameL,+ mkNameS,+ unTypeCode,+ mkModName,+ unsafeCodeCoerce,+ mkNameQ,+ mkNameG_fld,+ modString,+ nameBase,+ nameModule,+ namePackage,+ nameSpace,+ newDeclarationGroup,+ newNameIO,+ occString,+ oneName,+ pkgString,+ putDoc,+ putQ,+ recover,+ reify,+ reifyAnnotations,+ reifyConStrictness,+ reifyFixity,+ reifyInstances,+ reifyModule,+ reifyRoles,+ reifyType,+ report,+ reportError,+ reportWarning,+ runIO,+ sequenceQ,+ runQ,+ showName,+ showName',+ thenCmp,+ tupleDataName,+ tupleTypeName,+ unTypeQ,+ unboxedSumDataName,+ unboxedSumTypeName,+ unboxedTupleDataName,+ unboxedTupleTypeName,+ unsafeTExpCoerce,+ ForeignSrcLang (..),+ Extension (..),+ AnnLookup (..),+ AnnTarget (..),+ Arity,+ Bang (..),+ BndrVis (..),+ Body (..),+ Bytes (..),+ Callconv (..),+ CharPos,+ Cxt,+ DecidedStrictness (..),+ DocLoc (..),+ FamilyResultSig (..),+ Fixity (..),+ FixityDirection (..),+ Foreign (..),+ Guard (..),+ Info (..),+ Inline (..),+ InstanceDec,+ Lit (..),+ Loc (..),+ Module (..),+ ModuleInfo (..),+ NameFlavour (..),+ NameIs (..),+ NameSpace (..),+ NamespaceSpecifier (..),+ OccName (..),+ ParentName,+ PatSynArgs (..),+ PatSynDir (..),+ PatSynType,+ Phases (..),+ PkgName (..),+ Pragma (SpecialiseP, ..),+ Quasi (..),+ Range (..),+ Role (..),+ RuleMatch (..),+ Safety (..),+ SourceStrictness (..),+ SourceUnpackedness (..),+ Specificity (..),+ Strict,+ StrictType,+ SumAlt,+ SumArity,+ TExp (..),+ TyLit (..),+ TyVarBndr (..),+ TypeFamilyHead (..),+ Uniq,+ Unlifted,+ VarStrictType,+ makeRelativeToProject,+ liftString,+ Lift (..),+ dataToCodeQ,+ dataToExpQ,+ dataToPatQ,+ dataToQa,+ falseName,+ justName,+ leftName,+ liftData,+ liftDataTyped,+ nonemptyName,+ nothingName,+ rightName,+ trueName,+)+where++import GHC.Boot.TH.Lift+import GHC.Boot.TH.Syntax+import System.FilePath+import Data.Data hiding (Fixity(..))+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Lexeme ( startsVarSym, startsVarId )++-- This module completely re-exports 'GHC.Boot.TH.Syntax',+-- and exports additionally functions that depend on filepath.++-- |+addForeignFile :: ForeignSrcLang -> String -> Q ()+addForeignFile = addForeignSource+{-# DEPRECATED addForeignFile+ "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"+ #-} -- deprecated in 8.6++-- | The input is a filepath, which if relative is offset by the package root.+makeRelativeToProject :: FilePath -> Q FilePath+makeRelativeToProject fp | isRelative fp = do+ root <- getPackageRoot+ return (root </> fp)+makeRelativeToProject fp = return fp++trueName, falseName :: Name+trueName = 'True+falseName = 'False++nothingName, justName :: Name+nothingName = 'Nothing+justName = 'Just++leftName, rightName :: Name+leftName = 'Left+rightName = 'Right++nonemptyName :: Name+nonemptyName = '(:|)++-----------------------------------------------------+--+-- Generic Lift implementations+--+-----------------------------------------------------++-- | 'dataToQa' is an internal utility function for constructing generic+-- conversion functions from types with 'Data' instances to various+-- quasi-quoting representations. See the source of 'dataToExpQ' and+-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@+-- and @appQ@ are overloadable to account for different syntax for+-- expressions and patterns; @antiQ@ allows you to override type-specific+-- cases, a common usage is just @const Nothing@, which results in+-- no overloading.+dataToQa :: forall m a k q. (Quote m, Data a)+ => (Name -> k)+ -> (Lit -> m q)+ -> (k -> [m q] -> m q)+ -> (forall b . Data b => b -> Maybe (m q))+ -> a+ -> m q+dataToQa mkCon mkLit appCon antiQ t =+ case antiQ t of+ Nothing ->+ case constrRep constr of+ AlgConstr _ ->+ appCon (mkCon funOrConName) conArgs+ where+ funOrConName :: Name+ funOrConName =+ case showConstr constr of+ "(:)" -> Name (mkOccName ":")+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Types"))+ con@"[]" -> Name (mkOccName con)+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Types"))+ con@('(':_) -> Name (mkOccName con)+ (NameG DataName+ (mkPkgName "ghc-internal")+ (mkModName "GHC.Internal.Tuple"))++ -- Tricky case: see Note [Data for non-algebraic types]+ fun@(x:_) | startsVarSym x || startsVarId x+ -> mkNameG_v tyconPkg tyconMod fun+ con -> mkNameG_d tyconPkg tyconMod con++ where+ tycon :: TyCon+ tycon = (typeRepTyCon . typeOf) t++ tyconPkg, tyconMod :: String+ tyconPkg = tyConPackage tycon+ tyconMod = tyConModule tycon++ conArgs :: [m q]+ conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t+ IntConstr n ->+ mkLit $ IntegerL n+ FloatConstr n ->+ mkLit $ RationalL n+ CharConstr c ->+ mkLit $ CharL c+ where+ constr :: Constr+ constr = toConstr t++ Just y -> y+++{- Note [Data for non-algebraic types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Class Data was originally intended for algebraic data types. But+it is possible to use it for abstract types too. For example, in+package `text` we find++ instance Data Text where+ ...+ toConstr _ = packConstr++ packConstr :: Constr+ packConstr = mkConstr textDataType "pack" [] Prefix++Here `packConstr` isn't a real data constructor, it's an ordinary+function. Two complications++* In such a case, we must take care to build the Name using+ mkNameG_v (for values), not mkNameG_d (for data constructors).+ See #10796.++* The pseudo-constructor is named only by its string, here "pack".+ But 'dataToQa' needs the TyCon of its defining module, and has+ to assume it's defined in the same module as the TyCon itself.+ But nothing enforces that; #12596 shows what goes wrong if+ "pack" is defined in a different module than the data type "Text".+ -}++-- | A typed variant of 'dataToExpQ'.+dataToCodeQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (Code m b))+ -> a -> Code m a+dataToCodeQ f = unsafeCodeCoerce . dataToExpQ (fmap unTypeCode . f)++-- | 'dataToExpQ' converts a value to a 'Exp' representation of the+-- same value, in the SYB style. It is generalized to take a function+-- override type-specific cases; see 'liftData' for a more commonly+-- used variant.+dataToExpQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (m Exp))+ -> a+ -> m Exp+dataToExpQ = dataToQa varOrConE litE (foldl appE)+ where+ -- Make sure that VarE is used if the Constr value relies on a+ -- function underneath the surface (instead of a constructor).+ -- See #10796.+ varOrConE s =+ case nameSpace s of+ Just VarName -> return (VarE s)+ Just (FldName {}) -> return (VarE s)+ Just DataName -> return (ConE s)+ _ -> error $ "Can't construct an expression from name "+ ++ showName s+ appE x y = do { a <- x; b <- y; return (AppE a b)}+ litE c = return (LitE c)++-- | A typed variant of 'liftData'.+liftDataTyped :: (Quote m, Data a) => a -> Code m a+liftDataTyped = dataToCodeQ (const Nothing)++-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which+-- works for any type with a 'Data' instance.+liftData :: (Quote m, Data a) => a -> m Exp+liftData = dataToExpQ (const Nothing)++-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same+-- value, in the SYB style. It takes a function to handle type-specific cases,+-- alternatively, pass @const Nothing@ to get default behavior.+dataToPatQ :: (Quote m, Data a)+ => (forall b . Data b => b -> Maybe (m Pat))+ -> a+ -> m Pat+dataToPatQ = dataToQa id litP conP+ where litP l = return (LitP l)+ conP n ps =+ case nameSpace n of+ Just DataName -> do+ ps' <- sequence ps+ return (ConP n [] ps')+ _ -> error $ "Can't construct a pattern from name "+ ++ showName n++--------------------------------------------------------------------------------+-- Back-compat for Specialise pragmas++-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@.+--+-- Subsumed by the more general 'SpecialiseEP' constructor.+pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma+pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
Setup.hs view
@@ -1,4 +1,6 @@ module Main (main) where+ import Distribution.Simple+ main :: IO () main = defaultMain
changelog.md view
@@ -1,7 +1,168 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) -## 2.15.0.0 *May 2019+## 2.24.0.0 + * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.++ * Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals.+ Users should use `Language.Haskell.TH.Lib` instead, which exposes a more stable version of this API.++ * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were accidentally exported because this module lacked an explicit export list. They have no usages on Hackage.++## 2.23.0.0++ * Extend `Exp` with `ForallE`, `ForallVisE`, `ConstraintedE`,+ introduce functions `forallE`, `forallVisE`, `constraintedE` (GHC Proposal #281).+ * `template-haskell` is no longer wired-in. All wired-in identifiers have been moved to `ghc-internal`.+ * `Lift` instances were added for the `template-haskell` AST.++## 2.22.0.0++ * The kind of `Code` was changed from `forall r. (Type -> Type) -> TYPE r -> Type`+ to `(Type -> Type) -> forall r. TYPE r -> Type`. This enables higher-kinded usage.++ * Extend `Pat` with `TypeP` and `Exp` with `TypeE`,+ introduce functions `typeP` and `typeE` (GHC Proposal #281).++ * Extend `Pragma` with `SCCP`.++ * Extend `Pat` with `InvisP`, introduce function `invisP`. (Ghc Proposal #448).++ * Add a new data type `NamespaceSpecifier` to represent `type`/`data` namespace specifiers,+ which can be used in conjunction with the `ExplicitNamespaces` extension:++ * The `InfixD` constructor of the `Dec` data type now stores a `NamespaceSpecifier`.++ * Add `infixLWithSpecD`, `infixRWithSpecD` and `infixNWithSpecD` functions, which+ accept a `NamespaceSpecifier` as an argument.++## 2.21.0.0++ * Record fields now belong to separate `NameSpace`s, keyed by the parent of+ the record field. This is the name of the first constructor of the parent type,+ even if this constructor does not have the field in question.++ This change enables TemplateHaskell support for `DuplicateRecordFields`.++ * Add support for generating typed splices and brackets in untyped Template Haskell+ Introduces `typedSpliceE :: Quote m => m Exp -> m Exp` and+ `typedBracketE :: Quote m => m Exp -> m Exp`++ * Add `BndrVis` to support invisible binders+ in type declarations (GHC Proposal #425).++ * The binder flag type in `plainTV` and `kindedTV` is generalized from `()`+ to any data type with a `DefaultBndrFlag` instance, including `()`,+ `Specificity`, and `BndrVis`.++## 2.20.0.0++ * The `Ppr.pprInfixT` function has gained a `Precedence` argument.+ * The values of named precedence levels like `Ppr.appPrec` have changed.++ * Add `TypeDataD` constructor to the `Dec` type for `type data`+ declarations (GHC proposal #106).+ * Add `instance Lift (Fixed a)`++## 2.19.0.0++ * Add `DefaultD` constructor to support Haskell `default` declarations.++ * Add support for Overloaded Record Dot.+ Introduces `getFieldE :: Quote m => m Exp -> String -> m Exp` and+ `projectionE :: Quote m => [String] -> m Exp`.+ * Add `instance Lift ByteArray`.++ * Add `PromotedInfixT` and `PromotedUInfixT`, which are analogs to `InfixT`+ and `UInfixT` that ensure that if a dynamically bound name (i.e. a name+ with `NameFlavour` `NameS` or `NameQ`; the flavours produced by `mkName`)+ is used as operator, it will be bound to a promoted data constructor rather+ than a type constructor, if both are in scope.++ * Add a `vendor-filepath` Cabal flag to the `template-haskell` package. If+ this flag is set then `template-haskell` will not depend on the `filepath`+ package and will instead use some modules from `filepath` that have been+ copied into the `template-haskell` source tree.++## 2.18.0.0+ * The types of `ConP` and `conP` have been changed to allow for an additional list+ of type applications preceding the argument patterns.++ * Add support for the `Char` kind (#11342): we extend the `TyLit` data type with+ the constructor `CharTyLit` that reflects type-level characters.++ * Add `putDoc` and `getDoc` which allow Haddock documentation to be attached+ to module headers, declarations, function arguments and instances, as well+ as queried. These are quite low level operations, so for convenience there+ are several combinators that can be used with `Dec`s directly, including+ `withDecDoc`/`withDecsDoc` as well as `_doc` counterparts to many of the+ `Dec` helper functions.++ * Add `newDeclarationGroup` to document the effect of visibility while+ reifying types and instances.++## 2.17.0.0+ * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195).+ The main motiviation is to make writing instances easier and make it easier to+ store `Code` values in type-indexed maps.++ * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a+ few fundamental things in the API. All the library combinators are generalised+ to be in terms of a new minimal class `Quote`. The types of `lift`, `liftTyped`,+ and `liftData` are modified to return `m Exp` rather than `Q Exp`. Instances+ written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce`+ and `unTypeQ` are also generalised in terms of `Quote` rather than specific+ to `Q`.++ * Implement Explicit specificity in type variable binders (GHC Proposal #99).+ In `Language.Haskell.TH.Syntax`, `TyVarBndr` is now annotated with a `flag`,+ denoting the additional argument to its constructors `PlainTV` and `KindedTV`.+ `flag` is either the `Specificity` of the type variable (`SpecifiedSpec` or+ `InferredSpec`) or `()`.++ * Fix Eq/Ord instances for `Bytes`: we were comparing pointers while we should+ compare the actual bytes (#16457).++ * Fix Show instance for `Bytes`: we were showing the pointer value while we+ want to show the contents (#16457).++ * Add `Semigroup` and `Monoid` instances for `Q` (#18123).++ * Add `MonadFix` instance for `Q` (#12073).++ * Add support for QualifiedDo. The data constructors `DoE` and `MDoE` got a new+ `Maybe ModName` argument to describe the qualifier of do blocks.++ * The argument to `TExpQ` can now be levity polymorphic.++## 2.16.0.0 *Jan 2020*++ * Bundled with GHC 8.10.1++ * Add support for tuple sections. (#15843) The type signatures of `TupE` and+ `UnboxedTupE` have changed from `[Exp] -> Exp` to `[Maybe Exp] -> Exp`.+ The type signatures of `tupE` and `unboxedTupE` remain the same for+ backwards compatibility.++ * Introduce a `liftTyped` method to the `Lift` class and set the default+ implementations of `lift` in terms of `liftTyped`.++ * Add a `ForallVisT` constructor to `Type` to represent visible, dependent+ quantification.++ * Introduce support for `Bytes` literals (raw bytes embedded into the output+ binary)++ * Make the `Lift` typeclass levity-polymorphic and add instances for unboxed+ tuples, unboxed sums, `Int#`, `Word#`, `Addr#`, `Float#`, and `Double#`.++ * Introduce `reifyType` to reify the type or kind of a thing referenced by+ `Name`.++## 2.15.0.0 *May 2019*++ * Bundled with GHC 8.8.1+ * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`, and `RuleP` now all have a `Maybe [TyVarBndr]` argument, which contains a list of quantified type variables if an explicit `forall` is present, and@@ -22,7 +183,9 @@ * `addForeignFilePath` now support assembler sources (#16180). -## 2.14.0.0 *September 2018+## 2.14.0.0 *September 2018*++ * Bundled with GHC 8.6.1 * Introduce an `addForeignFilePath` function, as well as a corresponding `qAddForeignFile` class method to `Quasi`. Unlike `addForeignFile`, which
template-haskell.cabal view
@@ -1,11 +1,15 @@+-- WARNING: template-haskell.cabal is automatically generated from template-haskell.cabal.in by+-- ../../configure. Make sure you are editing template-haskell.cabal.in, not+-- template-haskell.cabal.+ name: template-haskell-version: 2.15.0.0+version: 2.24.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE category: Template Haskell maintainer: libraries@haskell.org-bug-reports: https://gitlab.haskell.org/ghc/ghc/issues+bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new synopsis: Support library for Template Haskell build-type: Simple Cabal-Version: >= 1.10@@ -44,24 +48,22 @@ Language.Haskell.TH.Quote Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions+ Language.Haskell.TH.CodeDo - Language.Haskell.TH.Lib.Internal+ build-depends:+ base >= 4.11 && < 4.23,+ -- We don't directly depend on any of the modules from `ghc-internal`+ -- But we need to depend on it to work around a hadrian bug.+ -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705+ ghc-internal == 9.1401.*,+ ghc-boot-th == 9.14.1 other-modules:- Language.Haskell.TH.Lib.Map-- build-depends:- base >= 4.11 && < 4.14,- ghc-boot-th == 8.8.*,- pretty == 1.1.*+ System.FilePath+ System.FilePath.Posix+ System.FilePath.Windows+ hs-source-dirs: ./vendored-filepath .+ default-extensions:+ ImplicitPrelude ghc-options: -Wall-- -- We need to set the unit ID to template-haskell (without a- -- version number) as it's magic.- ghc-options: -this-unit-id template-haskell-- -- This should match the default-extensions used in 'ghc.cabal'. This way,- -- GHCi can be used to load it along with the compiler.- Default-Extensions:- NoImplicitPrelude
+ vendored-filepath/System/FilePath.hs view
@@ -0,0 +1,147 @@+-- Vendored from filepath v1.4.2.2++{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{- |+Module : System.FilePath+Copyright : (c) Neil Mitchell 2005-2014+License : BSD3++Maintainer : ndmitchell@gmail.com+Stability : stable+Portability : portable++A library for 'FilePath' manipulations, using Posix or Windows filepaths+depending on the platform.++Both "System.FilePath.Posix" and "System.FilePath.Windows" provide the+same interface.++Given the example 'FilePath': @\/directory\/file.ext@++We can use the following functions to extract pieces.++* 'takeFileName' gives @\"file.ext\"@++* 'takeDirectory' gives @\"\/directory\"@++* 'takeExtension' gives @\".ext\"@++* 'dropExtension' gives @\"\/directory\/file\"@++* 'takeBaseName' gives @\"file\"@++And we could have built an equivalent path with the following expressions:++* @\"\/directory\" '</>' \"file.ext\"@.++* @\"\/directory\/file" '<.>' \"ext\"@.++* @\"\/directory\/file.txt" '-<.>' \"ext\"@.++Each function in this module is documented with several examples,+which are also used as tests.++Here are a few examples of using the @filepath@ functions together:++/Example 1:/ Find the possible locations of a Haskell module @Test@ imported from module @Main@:++@['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@++/Example 2:/ Download a file from @url@ and save it to disk:++@do let file = 'makeValid' url+ System.Directory.createDirectoryIfMissing True ('takeDirectory' file)@++/Example 3:/ Compile a Haskell file, putting the @.hi@ file under @interface@:++@'takeDirectory' file '</>' \"interface\" '</>' ('takeFileName' file '-<.>' \"hi\")@++References:+[1] <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx Naming Files, Paths and Namespaces> (Microsoft MSDN)+-}+++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+module System.FilePath(+ -- * Separator predicates+ FilePath,+ pathSeparator, pathSeparators, isPathSeparator,+ searchPathSeparator, isSearchPathSeparator,+ extSeparator, isExtSeparator,++ -- * @$PATH@ methods+ splitSearchPath, getSearchPath,++ -- * Extension functions+ splitExtension,+ takeExtension, replaceExtension, (-<.>), dropExtension, addExtension, hasExtension, (<.>),+ splitExtensions, dropExtensions, takeExtensions, replaceExtensions, isExtensionOf,+ stripExtension,++ -- * Filename\/directory functions+ splitFileName,+ takeFileName, replaceFileName, dropFileName,+ takeBaseName, replaceBaseName,+ takeDirectory, replaceDirectory,+ combine, (</>),+ splitPath, joinPath, splitDirectories,++ -- * Drive functions+ splitDrive, joinDrive,+ takeDrive, hasDrive, dropDrive, isDrive,++ -- * Trailing slash functions+ hasTrailingPathSeparator,+ addTrailingPathSeparator,+ dropTrailingPathSeparator,++ -- * File name manipulations+ normalise, equalFilePath,+ makeRelative,+ isRelative, isAbsolute,+ isValid, makeValid+) where+import System.FilePath.Windows+#else+module System.FilePath(+ -- * Separator predicates+ FilePath,+ pathSeparator, pathSeparators, isPathSeparator,+ searchPathSeparator, isSearchPathSeparator,+ extSeparator, isExtSeparator,++ -- * @$PATH@ methods+ splitSearchPath, getSearchPath,++ -- * Extension functions+ splitExtension,+ takeExtension, replaceExtension, (-<.>), dropExtension, addExtension, hasExtension, (<.>),+ splitExtensions, dropExtensions, takeExtensions, replaceExtensions, isExtensionOf,+ stripExtension,++ -- * Filename\/directory functions+ splitFileName,+ takeFileName, replaceFileName, dropFileName,+ takeBaseName, replaceBaseName,+ takeDirectory, replaceDirectory,+ combine, (</>),+ splitPath, joinPath, splitDirectories,++ -- * Drive functions+ splitDrive, joinDrive,+ takeDrive, hasDrive, dropDrive, isDrive,++ -- * Trailing slash functions+ hasTrailingPathSeparator,+ addTrailingPathSeparator,+ dropTrailingPathSeparator,++ -- * File name manipulations+ normalise, equalFilePath,+ makeRelative,+ isRelative, isAbsolute,+ isValid, makeValid+) where+import System.FilePath.Posix+#endif
+ vendored-filepath/System/FilePath/Posix.hs view
@@ -0,0 +1,1047 @@+-- Vendored from filepath v1.4.2.2++{-# LANGUAGE PatternGuards #-}++-- This template expects CPP definitions for:+-- MODULE_NAME = Posix | Windows+-- IS_WINDOWS = False | True++-- |+-- Module : System.FilePath.MODULE_NAME+-- Copyright : (c) Neil Mitchell 2005-2014+-- License : BSD3+--+-- Maintainer : ndmitchell@gmail.com+-- Stability : stable+-- Portability : portable+--+-- A library for 'FilePath' manipulations, using MODULE_NAME style paths on+-- all platforms. Importing "System.FilePath" is usually better.+--+-- Given the example 'FilePath': @\/directory\/file.ext@+--+-- We can use the following functions to extract pieces.+--+-- * 'takeFileName' gives @\"file.ext\"@+--+-- * 'takeDirectory' gives @\"\/directory\"@+--+-- * 'takeExtension' gives @\".ext\"@+--+-- * 'dropExtension' gives @\"\/directory\/file\"@+--+-- * 'takeBaseName' gives @\"file\"@+--+-- And we could have built an equivalent path with the following expressions:+--+-- * @\"\/directory\" '</>' \"file.ext\"@.+--+-- * @\"\/directory\/file" '<.>' \"ext\"@.+--+-- * @\"\/directory\/file.txt" '-<.>' \"ext\"@.+--+-- Each function in this module is documented with several examples,+-- which are also used as tests.+--+-- Here are a few examples of using the @filepath@ functions together:+--+-- /Example 1:/ Find the possible locations of a Haskell module @Test@ imported from module @Main@:+--+-- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@+--+-- /Example 2:/ Download a file from @url@ and save it to disk:+--+-- @do let file = 'makeValid' url+-- System.Directory.createDirectoryIfMissing True ('takeDirectory' file)@+--+-- /Example 3:/ Compile a Haskell file, putting the @.hi@ file under @interface@:+--+-- @'takeDirectory' file '</>' \"interface\" '</>' ('takeFileName' file '-<.>' \"hi\")@+--+-- References:+-- [1] <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx Naming Files, Paths and Namespaces> (Microsoft MSDN)+module System.FilePath.Posix+ (+ -- * Separator predicates+ FilePath,+ pathSeparator, pathSeparators, isPathSeparator,+ searchPathSeparator, isSearchPathSeparator,+ extSeparator, isExtSeparator,++ -- * @$PATH@ methods+ splitSearchPath, getSearchPath,++ -- * Extension functions+ splitExtension,+ takeExtension, replaceExtension, (-<.>), dropExtension, addExtension, hasExtension, (<.>),+ splitExtensions, dropExtensions, takeExtensions, replaceExtensions, isExtensionOf,+ stripExtension,++ -- * Filename\/directory functions+ splitFileName,+ takeFileName, replaceFileName, dropFileName,+ takeBaseName, replaceBaseName,+ takeDirectory, replaceDirectory,+ combine, (</>),+ splitPath, joinPath, splitDirectories,++ -- * Drive functions+ splitDrive, joinDrive,+ takeDrive, hasDrive, dropDrive, isDrive,++ -- * Trailing slash functions+ hasTrailingPathSeparator,+ addTrailingPathSeparator,+ dropTrailingPathSeparator,++ -- * File name manipulations+ normalise, equalFilePath,+ makeRelative,+ isRelative, isAbsolute,+ isValid, makeValid+ )+ where++import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)+import Data.Maybe(isJust)+import Data.List(stripPrefix, isSuffixOf)++import System.Environment(getEnv)+++infixr 7 <.>, -<.>+infixr 5 </>++++++---------------------------------------------------------------------+-- Platform Abstraction Methods (private)++-- | Is the operating system Unix or Linux like+isPosix :: Bool+isPosix = not isWindows++-- | Is the operating system Windows like+isWindows :: Bool+isWindows = False+++---------------------------------------------------------------------+-- The basic functions++-- | The character that separates directories. In the case where more than+-- one character is possible, 'pathSeparator' is the \'ideal\' one.+--+-- > Windows: pathSeparator == '\\'+-- > Posix: pathSeparator == '/'+-- > isPathSeparator pathSeparator+pathSeparator :: Char+pathSeparator = if isWindows then '\\' else '/'++-- | The list of all possible separators.+--+-- > Windows: pathSeparators == ['\\', '/']+-- > Posix: pathSeparators == ['/']+-- > pathSeparator `elem` pathSeparators+pathSeparators :: [Char]+pathSeparators = if isWindows then "\\/" else "/"++-- | Rather than using @(== 'pathSeparator')@, use this. Test if something+-- is a path separator.+--+-- > isPathSeparator a == (a `elem` pathSeparators)+isPathSeparator :: Char -> Bool+isPathSeparator '/' = True+isPathSeparator '\\' = isWindows+isPathSeparator _ = False+++-- | The character that is used to separate the entries in the $PATH environment variable.+--+-- > Windows: searchPathSeparator == ';'+-- > Posix: searchPathSeparator == ':'+searchPathSeparator :: Char+searchPathSeparator = if isWindows then ';' else ':'++-- | Is the character a file separator?+--+-- > isSearchPathSeparator a == (a == searchPathSeparator)+isSearchPathSeparator :: Char -> Bool+isSearchPathSeparator = (== searchPathSeparator)+++-- | File extension character+--+-- > extSeparator == '.'+extSeparator :: Char+extSeparator = '.'++-- | Is the character an extension character?+--+-- > isExtSeparator a == (a == extSeparator)+isExtSeparator :: Char -> Bool+isExtSeparator = (== extSeparator)+++---------------------------------------------------------------------+-- Path methods (environment $PATH)++-- | Take a string, split it on the 'searchPathSeparator' character.+-- Blank items are ignored on Windows, and converted to @.@ on Posix.+-- On Windows path elements are stripped of quotes.+--+-- Follows the recommendations in+-- <http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap08.html>+--+-- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"]+-- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"]+-- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"]+-- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"]+-- > Windows: splitSearchPath "File1;\"File2\";File3" == ["File1","File2","File3"]+splitSearchPath :: String -> [FilePath]+splitSearchPath = f+ where+ f xs = case break isSearchPathSeparator xs of+ (pre, [] ) -> g pre+ (pre, _:post) -> g pre ++ f post++ g "" = ["." | isPosix]+ g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]+ g x = [x]+++-- | Get a list of 'FilePath's in the $PATH variable.+getSearchPath :: IO [FilePath]+getSearchPath = fmap splitSearchPath (getEnv "PATH")+++---------------------------------------------------------------------+-- Extension methods++-- | Split on the extension. 'addExtension' is the inverse.+--+-- > splitExtension "/directory/path.ext" == ("/directory/path",".ext")+-- > uncurry (++) (splitExtension x) == x+-- > Valid x => uncurry addExtension (splitExtension x) == x+-- > splitExtension "file.txt" == ("file",".txt")+-- > splitExtension "file" == ("file","")+-- > splitExtension "file/file.txt" == ("file/file",".txt")+-- > splitExtension "file.txt/boris" == ("file.txt/boris","")+-- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext")+-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")+-- > splitExtension "file/path.txt/" == ("file/path.txt/","")+splitExtension :: FilePath -> (String, String)+splitExtension x = case nameDot of+ "" -> (x,"")+ _ -> (dir ++ init nameDot, extSeparator : ext)+ where+ (dir,file) = splitFileName_ x+ (nameDot,ext) = breakEnd isExtSeparator file++-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.+--+-- > takeExtension "/directory/path.ext" == ".ext"+-- > takeExtension x == snd (splitExtension x)+-- > Valid x => takeExtension (addExtension x "ext") == ".ext"+-- > Valid x => takeExtension (replaceExtension x "ext") == ".ext"+takeExtension :: FilePath -> String+takeExtension = snd . splitExtension++-- | Remove the current extension and add another, equivalent to 'replaceExtension'.+--+-- > "/directory/path.txt" -<.> "ext" == "/directory/path.ext"+-- > "/directory/path.txt" -<.> ".ext" == "/directory/path.ext"+-- > "foo.o" -<.> "c" == "foo.c"+(-<.>) :: FilePath -> String -> FilePath+(-<.>) = replaceExtension++-- | Set the extension of a file, overwriting one if already present, equivalent to '-<.>'.+--+-- > replaceExtension "/directory/path.txt" "ext" == "/directory/path.ext"+-- > replaceExtension "/directory/path.txt" ".ext" == "/directory/path.ext"+-- > replaceExtension "file.txt" ".bob" == "file.bob"+-- > replaceExtension "file.txt" "bob" == "file.bob"+-- > replaceExtension "file" ".bob" == "file.bob"+-- > replaceExtension "file.txt" "" == "file"+-- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt"+-- > replaceExtension x y == addExtension (dropExtension x) y+replaceExtension :: FilePath -> String -> FilePath+replaceExtension x y = dropExtension x <.> y++-- | Add an extension, even if there is already one there, equivalent to 'addExtension'.+--+-- > "/directory/path" <.> "ext" == "/directory/path.ext"+-- > "/directory/path" <.> ".ext" == "/directory/path.ext"+(<.>) :: FilePath -> String -> FilePath+(<.>) = addExtension++-- | Remove last extension, and the \".\" preceding it.+--+-- > dropExtension "/directory/path.ext" == "/directory/path"+-- > dropExtension x == fst (splitExtension x)+dropExtension :: FilePath -> FilePath+dropExtension = fst . splitExtension++-- | Add an extension, even if there is already one there, equivalent to '<.>'.+--+-- > addExtension "/directory/path" "ext" == "/directory/path.ext"+-- > addExtension "file.txt" "bib" == "file.txt.bib"+-- > addExtension "file." ".bib" == "file..bib"+-- > addExtension "file" ".bib" == "file.bib"+-- > addExtension "/" "x" == "/.x"+-- > addExtension x "" == x+-- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext"+-- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt"+addExtension :: FilePath -> String -> FilePath+addExtension file "" = file+addExtension file xs@(x:_) = joinDrive a res+ where+ res = if isExtSeparator x then b ++ xs+ else b ++ [extSeparator] ++ xs++ (a,b) = splitDrive file++-- | Does the given filename have an extension?+--+-- > hasExtension "/directory/path.ext" == True+-- > hasExtension "/directory/path" == False+-- > null (takeExtension x) == not (hasExtension x)+hasExtension :: FilePath -> Bool+hasExtension = any isExtSeparator . takeFileName+++-- | Does the given filename have the specified extension?+--+-- > "png" `isExtensionOf` "/directory/file.png" == True+-- > ".png" `isExtensionOf` "/directory/file.png" == True+-- > ".tar.gz" `isExtensionOf` "bar/foo.tar.gz" == True+-- > "ar.gz" `isExtensionOf` "bar/foo.tar.gz" == False+-- > "png" `isExtensionOf` "/directory/file.png.jpg" == False+-- > "csv/table.csv" `isExtensionOf` "/data/csv/table.csv" == False+isExtensionOf :: String -> FilePath -> Bool+isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions+isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions++-- | Drop the given extension from a FilePath, and the @\".\"@ preceding it.+-- Returns 'Nothing' if the FilePath does not have the given extension, or+-- 'Just' and the part before the extension if it does.+--+-- This function can be more predictable than 'dropExtensions', especially if the filename+-- might itself contain @.@ characters.+--+-- > stripExtension "hs.o" "foo.x.hs.o" == Just "foo.x"+-- > stripExtension "hi.o" "foo.x.hs.o" == Nothing+-- > dropExtension x == fromJust (stripExtension (takeExtension x) x)+-- > dropExtensions x == fromJust (stripExtension (takeExtensions x) x)+-- > stripExtension ".c.d" "a.b.c.d" == Just "a.b"+-- > stripExtension ".c.d" "a.b..c.d" == Just "a.b."+-- > stripExtension "baz" "foo.bar" == Nothing+-- > stripExtension "bar" "foobar" == Nothing+-- > stripExtension "" x == Just x+stripExtension :: String -> FilePath -> Maybe FilePath+stripExtension [] path = Just path+stripExtension ext@(x:_) path = stripSuffix dotExt path+ where dotExt = if isExtSeparator x then ext else '.':ext+++-- | Split on all extensions.+--+-- > splitExtensions "/directory/path.ext" == ("/directory/path",".ext")+-- > splitExtensions "file.tar.gz" == ("file",".tar.gz")+-- > uncurry (++) (splitExtensions x) == x+-- > Valid x => uncurry addExtension (splitExtensions x) == x+-- > splitExtensions "file.tar.gz" == ("file",".tar.gz")+splitExtensions :: FilePath -> (FilePath, String)+splitExtensions x = (a ++ c, d)+ where+ (a,b) = splitFileName_ x+ (c,d) = break isExtSeparator b++-- | Drop all extensions.+--+-- > dropExtensions "/directory/path.ext" == "/directory/path"+-- > dropExtensions "file.tar.gz" == "file"+-- > not $ hasExtension $ dropExtensions x+-- > not $ any isExtSeparator $ takeFileName $ dropExtensions x+dropExtensions :: FilePath -> FilePath+dropExtensions = fst . splitExtensions++-- | Get all extensions.+--+-- > takeExtensions "/directory/path.ext" == ".ext"+-- > takeExtensions "file.tar.gz" == ".tar.gz"+takeExtensions :: FilePath -> String+takeExtensions = snd . splitExtensions+++-- | Replace all extensions of a file with a new extension. Note+-- that 'replaceExtension' and 'addExtension' both work for adding+-- multiple extensions, so only required when you need to drop+-- all extensions first.+--+-- > replaceExtensions "file.fred.bob" "txt" == "file.txt"+-- > replaceExtensions "file.fred.bob" "tar.gz" == "file.tar.gz"+replaceExtensions :: FilePath -> String -> FilePath+replaceExtensions x y = dropExtensions x <.> y++++---------------------------------------------------------------------+-- Drive methods++-- | Is the given character a valid drive letter?+-- only a-z and A-Z are letters, not isAlpha which is more unicodey+isLetter :: Char -> Bool+isLetter x = isAsciiLower x || isAsciiUpper x+++-- | Split a path into a drive and a path.+-- On Posix, \/ is a Drive.+--+-- > uncurry (++) (splitDrive x) == x+-- > Windows: splitDrive "file" == ("","file")+-- > Windows: splitDrive "c:/file" == ("c:/","file")+-- > Windows: splitDrive "c:\\file" == ("c:\\","file")+-- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test")+-- > Windows: splitDrive "\\\\shared" == ("\\\\shared","")+-- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file")+-- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file")+-- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file")+-- > Windows: splitDrive "/d" == ("","/d")+-- > Posix: splitDrive "/test" == ("/","test")+-- > Posix: splitDrive "//test" == ("//","test")+-- > Posix: splitDrive "test/file" == ("","test/file")+-- > Posix: splitDrive "file" == ("","file")+splitDrive :: FilePath -> (FilePath, FilePath)+splitDrive x | isPosix = span (== '/') x+splitDrive x | Just y <- readDriveLetter x = y+splitDrive x | Just y <- readDriveUNC x = y+splitDrive x | Just y <- readDriveShare x = y+splitDrive x = ("",x)++addSlash :: FilePath -> FilePath -> (FilePath, FilePath)+addSlash a xs = (a++c,d)+ where (c,d) = span isPathSeparator xs++-- See [1].+-- "\\?\D:\<path>" or "\\?\UNC\<server>\<share>"+readDriveUNC :: FilePath -> Maybe (FilePath, FilePath)+readDriveUNC (s1:s2:'?':s3:xs) | all isPathSeparator [s1,s2,s3] =+ case map toUpper xs of+ ('U':'N':'C':s4:_) | isPathSeparator s4 ->+ let (a,b) = readDriveShareName (drop 4 xs)+ in Just (s1:s2:'?':s3:take 4 xs ++ a, b)+ _ -> case readDriveLetter xs of+ -- Extended-length path.+ Just (a,b) -> Just (s1:s2:'?':s3:a,b)+ Nothing -> Nothing+readDriveUNC _ = Nothing++{- c:\ -}+readDriveLetter :: String -> Maybe (FilePath, FilePath)+readDriveLetter (x:':':y:xs) | isLetter x && isPathSeparator y = Just $ addSlash [x,':'] (y:xs)+readDriveLetter (x:':':xs) | isLetter x = Just ([x,':'], xs)+readDriveLetter _ = Nothing++{- \\sharename\ -}+readDriveShare :: String -> Maybe (FilePath, FilePath)+readDriveShare (s1:s2:xs) | isPathSeparator s1 && isPathSeparator s2 =+ Just (s1:s2:a,b)+ where (a,b) = readDriveShareName xs+readDriveShare _ = Nothing++{- assume you have already seen \\ -}+{- share\bob -> "share\", "bob" -}+readDriveShareName :: String -> (FilePath, FilePath)+readDriveShareName name = addSlash a b+ where (a,b) = break isPathSeparator name++++-- | Join a drive and the rest of the path.+--+-- > Valid x => uncurry joinDrive (splitDrive x) == x+-- > Windows: joinDrive "C:" "foo" == "C:foo"+-- > Windows: joinDrive "C:\\" "bar" == "C:\\bar"+-- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo"+-- > Windows: joinDrive "/:" "foo" == "/:\\foo"+joinDrive :: FilePath -> FilePath -> FilePath+joinDrive = combineAlways++-- | Get the drive from a filepath.+--+-- > takeDrive x == fst (splitDrive x)+takeDrive :: FilePath -> FilePath+takeDrive = fst . splitDrive++-- | Delete the drive, if it exists.+--+-- > dropDrive x == snd (splitDrive x)+dropDrive :: FilePath -> FilePath+dropDrive = snd . splitDrive++-- | Does a path have a drive.+--+-- > not (hasDrive x) == null (takeDrive x)+-- > Posix: hasDrive "/foo" == True+-- > Windows: hasDrive "C:\\foo" == True+-- > Windows: hasDrive "C:foo" == True+-- > hasDrive "foo" == False+-- > hasDrive "" == False+hasDrive :: FilePath -> Bool+hasDrive = not . null . takeDrive+++-- | Is an element a drive+--+-- > Posix: isDrive "/" == True+-- > Posix: isDrive "/foo" == False+-- > Windows: isDrive "C:\\" == True+-- > Windows: isDrive "C:\\foo" == False+-- > isDrive "" == False+isDrive :: FilePath -> Bool+isDrive x = not (null x) && null (dropDrive x)+++---------------------------------------------------------------------+-- Operations on a filepath, as a list of directories++-- | Split a filename into directory and file. '</>' is the inverse.+-- The first component will often end with a trailing slash.+--+-- > splitFileName "/directory/file.ext" == ("/directory/","file.ext")+-- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"+-- > Valid x => isValid (fst (splitFileName x))+-- > splitFileName "file/bob.txt" == ("file/", "bob.txt")+-- > splitFileName "file/" == ("file/", "")+-- > splitFileName "bob" == ("./", "bob")+-- > Posix: splitFileName "/" == ("/","")+-- > Windows: splitFileName "c:" == ("c:","")+splitFileName :: FilePath -> (String, String)+splitFileName x = (if null dir then "./" else dir, name)+ where+ (dir, name) = splitFileName_ x++-- version of splitFileName where, if the FilePath has no directory+-- component, the returned directory is "" rather than "./". This+-- is used in cases where we are going to combine the returned+-- directory to make a valid FilePath, and having a "./" appear would+-- look strange and upset simple equality properties. See+-- e.g. replaceFileName.+splitFileName_ :: FilePath -> (String, String)+splitFileName_ x = (drv ++ dir, file)+ where+ (drv,pth) = splitDrive x+ (dir,file) = breakEnd isPathSeparator pth++-- | Set the filename.+--+-- > replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext"+-- > Valid x => replaceFileName x (takeFileName x) == x+replaceFileName :: FilePath -> String -> FilePath+replaceFileName x y = a </> y where (a,_) = splitFileName_ x++-- | Drop the filename. Unlike 'takeDirectory', this function will leave+-- a trailing path separator on the directory.+--+-- > dropFileName "/directory/file.ext" == "/directory/"+-- > dropFileName x == fst (splitFileName x)+dropFileName :: FilePath -> FilePath+dropFileName = fst . splitFileName+++-- | Get the file name.+--+-- > takeFileName "/directory/file.ext" == "file.ext"+-- > takeFileName "test/" == ""+-- > takeFileName x `isSuffixOf` x+-- > takeFileName x == snd (splitFileName x)+-- > Valid x => takeFileName (replaceFileName x "fred") == "fred"+-- > Valid x => takeFileName (x </> "fred") == "fred"+-- > Valid x => isRelative (takeFileName x)+takeFileName :: FilePath -> FilePath+takeFileName = snd . splitFileName++-- | Get the base name, without an extension or path.+--+-- > takeBaseName "/directory/file.ext" == "file"+-- > takeBaseName "file/test.txt" == "test"+-- > takeBaseName "dave.ext" == "dave"+-- > takeBaseName "" == ""+-- > takeBaseName "test" == "test"+-- > takeBaseName (addTrailingPathSeparator x) == ""+-- > takeBaseName "file/file.tar.gz" == "file.tar"+takeBaseName :: FilePath -> String+takeBaseName = dropExtension . takeFileName++-- | Set the base name.+--+-- > replaceBaseName "/directory/other.ext" "file" == "/directory/file.ext"+-- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt"+-- > replaceBaseName "fred" "bill" == "bill"+-- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar"+-- > Valid x => replaceBaseName x (takeBaseName x) == x+replaceBaseName :: FilePath -> String -> FilePath+replaceBaseName pth nam = combineAlways a (nam <.> ext)+ where+ (a,b) = splitFileName_ pth+ ext = takeExtension b++-- | Is an item either a directory or the last character a path separator?+--+-- > hasTrailingPathSeparator "test" == False+-- > hasTrailingPathSeparator "test/" == True+hasTrailingPathSeparator :: FilePath -> Bool+hasTrailingPathSeparator "" = False+hasTrailingPathSeparator x = isPathSeparator (last x)+++hasLeadingPathSeparator :: FilePath -> Bool+hasLeadingPathSeparator "" = False+hasLeadingPathSeparator (hd : _) = isPathSeparator hd+++-- | Add a trailing file path separator if one is not already present.+--+-- > hasTrailingPathSeparator (addTrailingPathSeparator x)+-- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x+-- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/"+addTrailingPathSeparator :: FilePath -> FilePath+addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator]+++-- | Remove any trailing path separators+--+-- > dropTrailingPathSeparator "file/test/" == "file/test"+-- > dropTrailingPathSeparator "/" == "/"+-- > Windows: dropTrailingPathSeparator "\\" == "\\"+-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x+dropTrailingPathSeparator :: FilePath -> FilePath+dropTrailingPathSeparator x =+ if hasTrailingPathSeparator x && not (isDrive x)+ then let x' = dropWhileEnd isPathSeparator x+ in if null x' then [last x] else x'+ else x+++-- | Get the directory name, move up one level.+--+-- > takeDirectory "/directory/other.ext" == "/directory"+-- > takeDirectory x `isPrefixOf` x || takeDirectory x == "."+-- > takeDirectory "foo" == "."+-- > takeDirectory "/" == "/"+-- > takeDirectory "/foo" == "/"+-- > takeDirectory "/foo/bar/baz" == "/foo/bar"+-- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz"+-- > takeDirectory "foo/bar/baz" == "foo/bar"+-- > Windows: takeDirectory "foo\\bar" == "foo"+-- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar"+-- > Windows: takeDirectory "C:\\" == "C:\\"+takeDirectory :: FilePath -> FilePath+takeDirectory = dropTrailingPathSeparator . dropFileName++-- | Set the directory, keeping the filename the same.+--+-- > replaceDirectory "root/file.ext" "/directory/" == "/directory/file.ext"+-- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x+replaceDirectory :: FilePath -> String -> FilePath+replaceDirectory x dir = combineAlways dir (takeFileName x)+++-- | An alias for '</>'.+combine :: FilePath -> FilePath -> FilePath+combine a b | hasLeadingPathSeparator b || hasDrive b = b+ | otherwise = combineAlways a b++-- | Combine two paths, assuming rhs is NOT absolute.+combineAlways :: FilePath -> FilePath -> FilePath+combineAlways a b | null a = b+ | null b = a+ | hasTrailingPathSeparator a = a ++ b+ | otherwise = case a of+ [a1,':'] | isWindows && isLetter a1 -> a ++ b+ _ -> a ++ [pathSeparator] ++ b+++-- | Combine two paths with a path separator.+-- If the second path starts with a path separator or a drive letter, then it returns the second.+-- The intention is that @readFile (dir '</>' file)@ will access the same file as+-- @setCurrentDirectory dir; readFile file@.+--+-- > Posix: "/directory" </> "file.ext" == "/directory/file.ext"+-- > Windows: "/directory" </> "file.ext" == "/directory\\file.ext"+-- > "directory" </> "/file.ext" == "/file.ext"+-- > Valid x => (takeDirectory x </> takeFileName x) `equalFilePath` x+--+-- Combined:+--+-- > Posix: "/" </> "test" == "/test"+-- > Posix: "home" </> "bob" == "home/bob"+-- > Posix: "x:" </> "foo" == "x:/foo"+-- > Windows: "C:\\foo" </> "bar" == "C:\\foo\\bar"+-- > Windows: "home" </> "bob" == "home\\bob"+--+-- Not combined:+--+-- > Posix: "home" </> "/bob" == "/bob"+-- > Windows: "home" </> "C:\\bob" == "C:\\bob"+--+-- Not combined (tricky):+--+-- On Windows, if a filepath starts with a single slash, it is relative to the+-- root of the current drive. In [1], this is (confusingly) referred to as an+-- absolute path.+-- The current behavior of '</>' is to never combine these forms.+--+-- > Windows: "home" </> "/bob" == "/bob"+-- > Windows: "home" </> "\\bob" == "\\bob"+-- > Windows: "C:\\home" </> "\\bob" == "\\bob"+--+-- On Windows, from [1]: "If a file name begins with only a disk designator+-- but not the backslash after the colon, it is interpreted as a relative path+-- to the current directory on the drive with the specified letter."+-- The current behavior of '</>' is to never combine these forms.+--+-- > Windows: "D:\\foo" </> "C:bar" == "C:bar"+-- > Windows: "C:\\foo" </> "C:bar" == "C:bar"+(</>) :: FilePath -> FilePath -> FilePath+(</>) = combine+++-- | Split a path by the directory separator.+--+-- > splitPath "/directory/file.ext" == ["/","directory/","file.ext"]+-- > concat (splitPath x) == x+-- > splitPath "test//item/" == ["test//","item/"]+-- > splitPath "test/item/file" == ["test/","item/","file"]+-- > splitPath "" == []+-- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"]+-- > Posix: splitPath "/file/test" == ["/","file/","test"]+splitPath :: FilePath -> [FilePath]+splitPath x = [drive | drive /= ""] ++ f path+ where+ (drive,path) = splitDrive x++ f "" = []+ f y = (a++c) : f d+ where+ (a,b) = break isPathSeparator y+ (c,d) = span isPathSeparator b++-- | Just as 'splitPath', but don't add the trailing slashes to each element.+--+-- > splitDirectories "/directory/file.ext" == ["/","directory","file.ext"]+-- > splitDirectories "test/file" == ["test","file"]+-- > splitDirectories "/test/file" == ["/","test","file"]+-- > Windows: splitDirectories "C:\\test\\file" == ["C:\\", "test", "file"]+-- > Valid x => joinPath (splitDirectories x) `equalFilePath` x+-- > splitDirectories "" == []+-- > Windows: splitDirectories "C:\\test\\\\\\file" == ["C:\\", "test", "file"]+-- > splitDirectories "/test///file" == ["/","test","file"]+splitDirectories :: FilePath -> [FilePath]+splitDirectories = map dropTrailingPathSeparator . splitPath+++-- | Join path elements back together.+--+-- > joinPath a == foldr (</>) "" a+-- > joinPath ["/","directory/","file.ext"] == "/directory/file.ext"+-- > Valid x => joinPath (splitPath x) == x+-- > joinPath [] == ""+-- > Posix: joinPath ["test","file","path"] == "test/file/path"+joinPath :: [FilePath] -> FilePath+-- Note that this definition on c:\\c:\\, join then split will give c:\\.+joinPath = foldr combine ""+++++++---------------------------------------------------------------------+-- File name manipulators++-- | Equality of two 'FilePath's.+-- If you call @System.Directory.canonicalizePath@+-- first this has a much better chance of working.+-- Note that this doesn't follow symlinks or DOSNAM~1s.+--+-- Similar to 'normalise', this does not expand @".."@, because of symlinks.+--+-- > x == y ==> equalFilePath x y+-- > normalise x == normalise y ==> equalFilePath x y+-- > equalFilePath "foo" "foo/"+-- > not (equalFilePath "/a/../c" "/c")+-- > not (equalFilePath "foo" "/foo")+-- > Posix: not (equalFilePath "foo" "FOO")+-- > Windows: equalFilePath "foo" "FOO"+-- > Windows: not (equalFilePath "C:" "C:/")+equalFilePath :: FilePath -> FilePath -> Bool+equalFilePath a b = f a == f b+ where+ f x | isWindows = dropTrailingPathSeparator $ map toLower $ normalise x+ | otherwise = dropTrailingPathSeparator $ normalise x+++-- | Contract a filename, based on a relative path. Note that the resulting path+-- will never introduce @..@ paths, as the presence of symlinks means @..\/b@+-- may not reach @a\/b@ if it starts from @a\/c@. For a worked example see+-- <http://neilmitchell.blogspot.co.uk/2015/10/filepaths-are-subtle-symlinks-are-hard.html this blog post>.+--+-- The corresponding @makeAbsolute@ function can be found in+-- @System.Directory@.+--+-- > makeRelative "/directory" "/directory/file.ext" == "file.ext"+-- > Valid x => makeRelative (takeDirectory x) x `equalFilePath` takeFileName x+-- > makeRelative x x == "."+-- > Valid x y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y </> makeRelative y x) x+-- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob"+-- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob"+-- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob"+-- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob"+-- > Windows: makeRelative "/Home" "/home/bob" == "bob"+-- > Windows: makeRelative "/" "//" == "//"+-- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob"+-- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar"+-- > Posix: makeRelative "/fred" "bob" == "bob"+-- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred"+-- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/"+-- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c"+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative root path+ | equalFilePath root path = "."+ | takeAbs root /= takeAbs path = path+ | otherwise = f (dropAbs root) (dropAbs path)+ where+ f "" y = dropWhile isPathSeparator y+ f x y = let (x1,x2) = g x+ (y1,y2) = g y+ in if equalFilePath x1 y1 then f x2 y2 else path++ g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b)+ where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x++ -- on windows, need to drop '/' which is kind of absolute, but not a drive+ dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x+ dropAbs x = dropDrive x++ takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator]+ takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x++-- | Normalise a file+--+-- * \/\/ outside of the drive can be made blank+--+-- * \/ -> 'pathSeparator'+--+-- * .\/ -> \"\"+--+-- Does not remove @".."@, because of symlinks.+--+-- > Posix: normalise "/file/\\test////" == "/file/\\test/"+-- > Posix: normalise "/file/./test" == "/file/test"+-- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/"+-- > Posix: normalise "../bob/fred/" == "../bob/fred/"+-- > Posix: normalise "/a/../c" == "/a/../c"+-- > Posix: normalise "./bob/fred/" == "bob/fred/"+-- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\"+-- > Windows: normalise "c:\\" == "C:\\"+-- > Windows: normalise "C:.\\" == "C:"+-- > Windows: normalise "\\\\server\\test" == "\\\\server\\test"+-- > Windows: normalise "//server/test" == "\\\\server\\test"+-- > Windows: normalise "c:/file" == "C:\\file"+-- > Windows: normalise "/file" == "\\file"+-- > Windows: normalise "\\" == "\\"+-- > Windows: normalise "/./" == "\\"+-- > normalise "." == "."+-- > Posix: normalise "./" == "./"+-- > Posix: normalise "./." == "./"+-- > Posix: normalise "/./" == "/"+-- > Posix: normalise "/" == "/"+-- > Posix: normalise "bob/fred/." == "bob/fred/"+-- > Posix: normalise "//home" == "/home"+normalise :: FilePath -> FilePath+normalise path = result ++ [pathSeparator | addPathSeparator]+ where+ (drv,pth) = splitDrive path+ result = joinDrive' (normaliseDrive drv) (f pth)++ joinDrive' "" "" = "."+ joinDrive' d p = joinDrive d p++ addPathSeparator = isDirPath pth+ && not (hasTrailingPathSeparator result)+ && not (isRelativeDrive drv)++ isDirPath xs = hasTrailingPathSeparator xs+ || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)++ f = joinPath . dropDots . propSep . splitDirectories++ propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs+ | otherwise = x : xs+ propSep [] = []++ dropDots = filter ("." /=)++normaliseDrive :: FilePath -> FilePath+normaliseDrive "" = ""+normaliseDrive _ | isPosix = [pathSeparator]+normaliseDrive drive = if isJust $ readDriveLetter x2+ then map toUpper x2+ else x2+ where+ x2 = map repSlash drive++ repSlash x = if isPathSeparator x then pathSeparator else x++-- Information for validity functions on Windows. See [1].+isBadCharacter :: Char -> Bool+isBadCharacter x = x >= '\0' && x <= '\31' || x `elem` ":*?><|\""++badElements :: [FilePath]+badElements =+ ["CON","PRN","AUX","NUL","CLOCK$"+ ,"COM1","COM2","COM3","COM4","COM5","COM6","COM7","COM8","COM9"+ ,"LPT1","LPT2","LPT3","LPT4","LPT5","LPT6","LPT7","LPT8","LPT9"]+++-- | Is a FilePath valid, i.e. could you create a file like it? This function checks for invalid names,+-- and invalid characters, but does not check if length limits are exceeded, as these are typically+-- filesystem dependent.+--+-- > isValid "" == False+-- > isValid "\0" == False+-- > Posix: isValid "/random_ path:*" == True+-- > Posix: isValid x == not (null x)+-- > Windows: isValid "c:\\test" == True+-- > Windows: isValid "c:\\test:of_test" == False+-- > Windows: isValid "test*" == False+-- > Windows: isValid "c:\\test\\nul" == False+-- > Windows: isValid "c:\\test\\prn.txt" == False+-- > Windows: isValid "c:\\nul\\file" == False+-- > Windows: isValid "\\\\" == False+-- > Windows: isValid "\\\\\\foo" == False+-- > Windows: isValid "\\\\?\\D:file" == False+-- > Windows: isValid "foo\tbar" == False+-- > Windows: isValid "nul .txt" == False+-- > Windows: isValid " nul.txt" == True+isValid :: FilePath -> Bool+isValid "" = False+isValid x | '\0' `elem` x = False+isValid _ | isPosix = True+isValid path =+ not (any isBadCharacter x2) &&+ not (any f $ splitDirectories x2) &&+ not (isJust (readDriveShare x1) && all isPathSeparator x1) &&+ not (isJust (readDriveUNC x1) && not (hasTrailingPathSeparator x1))+ where+ (x1,x2) = splitDrive path+ f x = map toUpper (dropWhileEnd (== ' ') $ dropExtensions x) `elem` badElements+++-- | Take a FilePath and make it valid; does not change already valid FilePaths.+--+-- > isValid (makeValid x)+-- > isValid x ==> makeValid x == x+-- > makeValid "" == "_"+-- > makeValid "file\0name" == "file_name"+-- > Windows: makeValid "c:\\already\\/valid" == "c:\\already\\/valid"+-- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test"+-- > Windows: makeValid "test*" == "test_"+-- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_"+-- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt"+-- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt"+-- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file"+-- > Windows: makeValid "\\\\\\foo" == "\\\\drive"+-- > Windows: makeValid "\\\\?\\D:file" == "\\\\?\\D:\\file"+-- > Windows: makeValid "nul .txt" == "nul _.txt"+makeValid :: FilePath -> FilePath+makeValid "" = "_"+makeValid path+ | isPosix = map (\x -> if x == '\0' then '_' else x) path+ | isJust (readDriveShare drv) && all isPathSeparator drv = take 2 drv ++ "drive"+ | isJust (readDriveUNC drv) && not (hasTrailingPathSeparator drv) =+ makeValid (drv ++ [pathSeparator] ++ pth)+ | otherwise = joinDrive drv $ validElements $ validChars pth+ where+ (drv,pth) = splitDrive path++ validChars = map f+ f x = if isBadCharacter x then '_' else x++ validElements x = joinPath $ map g $ splitPath x+ g x = h a ++ b+ where (a,b) = break isPathSeparator x+ h x = if map toUpper (dropWhileEnd (== ' ') a) `elem` badElements then a ++ "_" <.> b else x+ where (a,b) = splitExtensions x+++-- | Is a path relative, or is it fixed to the root?+--+-- > Windows: isRelative "path\\test" == True+-- > Windows: isRelative "c:\\test" == False+-- > Windows: isRelative "c:test" == True+-- > Windows: isRelative "c:\\" == False+-- > Windows: isRelative "c:/" == False+-- > Windows: isRelative "c:" == True+-- > Windows: isRelative "\\\\foo" == False+-- > Windows: isRelative "\\\\?\\foo" == False+-- > Windows: isRelative "\\\\?\\UNC\\foo" == False+-- > Windows: isRelative "/foo" == True+-- > Windows: isRelative "\\foo" == True+-- > Posix: isRelative "test/path" == True+-- > Posix: isRelative "/test" == False+-- > Posix: isRelative "/" == False+--+-- According to [1]:+--+-- * "A UNC name of any format [is never relative]."+--+-- * "You cannot use the "\\?\" prefix with a relative path."+isRelative :: FilePath -> Bool+isRelative x = null drive || isRelativeDrive drive+ where drive = takeDrive x+++{- c:foo -}+-- From [1]: "If a file name begins with only a disk designator but not the+-- backslash after the colon, it is interpreted as a relative path to the+-- current directory on the drive with the specified letter."+isRelativeDrive :: String -> Bool+isRelativeDrive x =+ maybe False (not . hasTrailingPathSeparator . fst) (readDriveLetter x)+++-- | @not . 'isRelative'@+--+-- > isAbsolute x == not (isRelative x)+isAbsolute :: FilePath -> Bool+isAbsolute = not . isRelative+++-----------------------------------------------------------------------------+-- dropWhileEnd (>2) [1,2,3,4,1,2,3,4] == [1,2,3,4,1,2])+-- Note that Data.List.dropWhileEnd is only available in base >= 4.5.+dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = reverse . dropWhile p . reverse++-- takeWhileEnd (>2) [1,2,3,4,1,2,3,4] == [3,4])+takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++-- spanEnd (>2) [1,2,3,4,1,2,3,4] = ([1,2,3,4,1,2], [3,4])+spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)++-- breakEnd (< 2) [1,2,3,4,1,2,3,4] == ([1,2,3,4,1],[2,3,4])+breakEnd :: (a -> Bool) -> [a] -> ([a], [a])+breakEnd p = spanEnd (not . p)++-- | The stripSuffix function drops the given suffix from a list. It returns+-- Nothing if the list did not end with the suffix given, or Just the list+-- before the suffix, if it does.+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)
+ vendored-filepath/System/FilePath/Windows.hs view
@@ -0,0 +1,1047 @@+-- Vendored from filepath v1.4.2.2++{-# LANGUAGE PatternGuards #-}++-- This template expects CPP definitions for:+-- MODULE_NAME = Posix | Windows+-- IS_WINDOWS = False | True++-- |+-- Module : System.FilePath.MODULE_NAME+-- Copyright : (c) Neil Mitchell 2005-2014+-- License : BSD3+--+-- Maintainer : ndmitchell@gmail.com+-- Stability : stable+-- Portability : portable+--+-- A library for 'FilePath' manipulations, using MODULE_NAME style paths on+-- all platforms. Importing "System.FilePath" is usually better.+--+-- Given the example 'FilePath': @\/directory\/file.ext@+--+-- We can use the following functions to extract pieces.+--+-- * 'takeFileName' gives @\"file.ext\"@+--+-- * 'takeDirectory' gives @\"\/directory\"@+--+-- * 'takeExtension' gives @\".ext\"@+--+-- * 'dropExtension' gives @\"\/directory\/file\"@+--+-- * 'takeBaseName' gives @\"file\"@+--+-- And we could have built an equivalent path with the following expressions:+--+-- * @\"\/directory\" '</>' \"file.ext\"@.+--+-- * @\"\/directory\/file" '<.>' \"ext\"@.+--+-- * @\"\/directory\/file.txt" '-<.>' \"ext\"@.+--+-- Each function in this module is documented with several examples,+-- which are also used as tests.+--+-- Here are a few examples of using the @filepath@ functions together:+--+-- /Example 1:/ Find the possible locations of a Haskell module @Test@ imported from module @Main@:+--+-- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@+--+-- /Example 2:/ Download a file from @url@ and save it to disk:+--+-- @do let file = 'makeValid' url+-- System.Directory.createDirectoryIfMissing True ('takeDirectory' file)@+--+-- /Example 3:/ Compile a Haskell file, putting the @.hi@ file under @interface@:+--+-- @'takeDirectory' file '</>' \"interface\" '</>' ('takeFileName' file '-<.>' \"hi\")@+--+-- References:+-- [1] <http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx Naming Files, Paths and Namespaces> (Microsoft MSDN)+module System.FilePath.Windows+ (+ -- * Separator predicates+ FilePath,+ pathSeparator, pathSeparators, isPathSeparator,+ searchPathSeparator, isSearchPathSeparator,+ extSeparator, isExtSeparator,++ -- * @$PATH@ methods+ splitSearchPath, getSearchPath,++ -- * Extension functions+ splitExtension,+ takeExtension, replaceExtension, (-<.>), dropExtension, addExtension, hasExtension, (<.>),+ splitExtensions, dropExtensions, takeExtensions, replaceExtensions, isExtensionOf,+ stripExtension,++ -- * Filename\/directory functions+ splitFileName,+ takeFileName, replaceFileName, dropFileName,+ takeBaseName, replaceBaseName,+ takeDirectory, replaceDirectory,+ combine, (</>),+ splitPath, joinPath, splitDirectories,++ -- * Drive functions+ splitDrive, joinDrive,+ takeDrive, hasDrive, dropDrive, isDrive,++ -- * Trailing slash functions+ hasTrailingPathSeparator,+ addTrailingPathSeparator,+ dropTrailingPathSeparator,++ -- * File name manipulations+ normalise, equalFilePath,+ makeRelative,+ isRelative, isAbsolute,+ isValid, makeValid+ )+ where++import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)+import Data.Maybe(isJust)+import Data.List(stripPrefix, isSuffixOf)++import System.Environment(getEnv)+++infixr 7 <.>, -<.>+infixr 5 </>++++++---------------------------------------------------------------------+-- Platform Abstraction Methods (private)++-- | Is the operating system Unix or Linux like+isPosix :: Bool+isPosix = not isWindows++-- | Is the operating system Windows like+isWindows :: Bool+isWindows = True+++---------------------------------------------------------------------+-- The basic functions++-- | The character that separates directories. In the case where more than+-- one character is possible, 'pathSeparator' is the \'ideal\' one.+--+-- > Windows: pathSeparator == '\\'+-- > Posix: pathSeparator == '/'+-- > isPathSeparator pathSeparator+pathSeparator :: Char+pathSeparator = if isWindows then '\\' else '/'++-- | The list of all possible separators.+--+-- > Windows: pathSeparators == ['\\', '/']+-- > Posix: pathSeparators == ['/']+-- > pathSeparator `elem` pathSeparators+pathSeparators :: [Char]+pathSeparators = if isWindows then "\\/" else "/"++-- | Rather than using @(== 'pathSeparator')@, use this. Test if something+-- is a path separator.+--+-- > isPathSeparator a == (a `elem` pathSeparators)+isPathSeparator :: Char -> Bool+isPathSeparator '/' = True+isPathSeparator '\\' = isWindows+isPathSeparator _ = False+++-- | The character that is used to separate the entries in the $PATH environment variable.+--+-- > Windows: searchPathSeparator == ';'+-- > Posix: searchPathSeparator == ':'+searchPathSeparator :: Char+searchPathSeparator = if isWindows then ';' else ':'++-- | Is the character a file separator?+--+-- > isSearchPathSeparator a == (a == searchPathSeparator)+isSearchPathSeparator :: Char -> Bool+isSearchPathSeparator = (== searchPathSeparator)+++-- | File extension character+--+-- > extSeparator == '.'+extSeparator :: Char+extSeparator = '.'++-- | Is the character an extension character?+--+-- > isExtSeparator a == (a == extSeparator)+isExtSeparator :: Char -> Bool+isExtSeparator = (== extSeparator)+++---------------------------------------------------------------------+-- Path methods (environment $PATH)++-- | Take a string, split it on the 'searchPathSeparator' character.+-- Blank items are ignored on Windows, and converted to @.@ on Posix.+-- On Windows path elements are stripped of quotes.+--+-- Follows the recommendations in+-- <http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap08.html>+--+-- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"]+-- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"]+-- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"]+-- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"]+-- > Windows: splitSearchPath "File1;\"File2\";File3" == ["File1","File2","File3"]+splitSearchPath :: String -> [FilePath]+splitSearchPath = f+ where+ f xs = case break isSearchPathSeparator xs of+ (pre, [] ) -> g pre+ (pre, _:post) -> g pre ++ f post++ g "" = ["." | isPosix]+ g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]+ g x = [x]+++-- | Get a list of 'FilePath's in the $PATH variable.+getSearchPath :: IO [FilePath]+getSearchPath = fmap splitSearchPath (getEnv "PATH")+++---------------------------------------------------------------------+-- Extension methods++-- | Split on the extension. 'addExtension' is the inverse.+--+-- > splitExtension "/directory/path.ext" == ("/directory/path",".ext")+-- > uncurry (++) (splitExtension x) == x+-- > Valid x => uncurry addExtension (splitExtension x) == x+-- > splitExtension "file.txt" == ("file",".txt")+-- > splitExtension "file" == ("file","")+-- > splitExtension "file/file.txt" == ("file/file",".txt")+-- > splitExtension "file.txt/boris" == ("file.txt/boris","")+-- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext")+-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")+-- > splitExtension "file/path.txt/" == ("file/path.txt/","")+splitExtension :: FilePath -> (String, String)+splitExtension x = case nameDot of+ "" -> (x,"")+ _ -> (dir ++ init nameDot, extSeparator : ext)+ where+ (dir,file) = splitFileName_ x+ (nameDot,ext) = breakEnd isExtSeparator file++-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.+--+-- > takeExtension "/directory/path.ext" == ".ext"+-- > takeExtension x == snd (splitExtension x)+-- > Valid x => takeExtension (addExtension x "ext") == ".ext"+-- > Valid x => takeExtension (replaceExtension x "ext") == ".ext"+takeExtension :: FilePath -> String+takeExtension = snd . splitExtension++-- | Remove the current extension and add another, equivalent to 'replaceExtension'.+--+-- > "/directory/path.txt" -<.> "ext" == "/directory/path.ext"+-- > "/directory/path.txt" -<.> ".ext" == "/directory/path.ext"+-- > "foo.o" -<.> "c" == "foo.c"+(-<.>) :: FilePath -> String -> FilePath+(-<.>) = replaceExtension++-- | Set the extension of a file, overwriting one if already present, equivalent to '-<.>'.+--+-- > replaceExtension "/directory/path.txt" "ext" == "/directory/path.ext"+-- > replaceExtension "/directory/path.txt" ".ext" == "/directory/path.ext"+-- > replaceExtension "file.txt" ".bob" == "file.bob"+-- > replaceExtension "file.txt" "bob" == "file.bob"+-- > replaceExtension "file" ".bob" == "file.bob"+-- > replaceExtension "file.txt" "" == "file"+-- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt"+-- > replaceExtension x y == addExtension (dropExtension x) y+replaceExtension :: FilePath -> String -> FilePath+replaceExtension x y = dropExtension x <.> y++-- | Add an extension, even if there is already one there, equivalent to 'addExtension'.+--+-- > "/directory/path" <.> "ext" == "/directory/path.ext"+-- > "/directory/path" <.> ".ext" == "/directory/path.ext"+(<.>) :: FilePath -> String -> FilePath+(<.>) = addExtension++-- | Remove last extension, and the \".\" preceding it.+--+-- > dropExtension "/directory/path.ext" == "/directory/path"+-- > dropExtension x == fst (splitExtension x)+dropExtension :: FilePath -> FilePath+dropExtension = fst . splitExtension++-- | Add an extension, even if there is already one there, equivalent to '<.>'.+--+-- > addExtension "/directory/path" "ext" == "/directory/path.ext"+-- > addExtension "file.txt" "bib" == "file.txt.bib"+-- > addExtension "file." ".bib" == "file..bib"+-- > addExtension "file" ".bib" == "file.bib"+-- > addExtension "/" "x" == "/.x"+-- > addExtension x "" == x+-- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext"+-- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt"+addExtension :: FilePath -> String -> FilePath+addExtension file "" = file+addExtension file xs@(x:_) = joinDrive a res+ where+ res = if isExtSeparator x then b ++ xs+ else b ++ [extSeparator] ++ xs++ (a,b) = splitDrive file++-- | Does the given filename have an extension?+--+-- > hasExtension "/directory/path.ext" == True+-- > hasExtension "/directory/path" == False+-- > null (takeExtension x) == not (hasExtension x)+hasExtension :: FilePath -> Bool+hasExtension = any isExtSeparator . takeFileName+++-- | Does the given filename have the specified extension?+--+-- > "png" `isExtensionOf` "/directory/file.png" == True+-- > ".png" `isExtensionOf` "/directory/file.png" == True+-- > ".tar.gz" `isExtensionOf` "bar/foo.tar.gz" == True+-- > "ar.gz" `isExtensionOf` "bar/foo.tar.gz" == False+-- > "png" `isExtensionOf` "/directory/file.png.jpg" == False+-- > "csv/table.csv" `isExtensionOf` "/data/csv/table.csv" == False+isExtensionOf :: String -> FilePath -> Bool+isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions+isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions++-- | Drop the given extension from a FilePath, and the @\".\"@ preceding it.+-- Returns 'Nothing' if the FilePath does not have the given extension, or+-- 'Just' and the part before the extension if it does.+--+-- This function can be more predictable than 'dropExtensions', especially if the filename+-- might itself contain @.@ characters.+--+-- > stripExtension "hs.o" "foo.x.hs.o" == Just "foo.x"+-- > stripExtension "hi.o" "foo.x.hs.o" == Nothing+-- > dropExtension x == fromJust (stripExtension (takeExtension x) x)+-- > dropExtensions x == fromJust (stripExtension (takeExtensions x) x)+-- > stripExtension ".c.d" "a.b.c.d" == Just "a.b"+-- > stripExtension ".c.d" "a.b..c.d" == Just "a.b."+-- > stripExtension "baz" "foo.bar" == Nothing+-- > stripExtension "bar" "foobar" == Nothing+-- > stripExtension "" x == Just x+stripExtension :: String -> FilePath -> Maybe FilePath+stripExtension [] path = Just path+stripExtension ext@(x:_) path = stripSuffix dotExt path+ where dotExt = if isExtSeparator x then ext else '.':ext+++-- | Split on all extensions.+--+-- > splitExtensions "/directory/path.ext" == ("/directory/path",".ext")+-- > splitExtensions "file.tar.gz" == ("file",".tar.gz")+-- > uncurry (++) (splitExtensions x) == x+-- > Valid x => uncurry addExtension (splitExtensions x) == x+-- > splitExtensions "file.tar.gz" == ("file",".tar.gz")+splitExtensions :: FilePath -> (FilePath, String)+splitExtensions x = (a ++ c, d)+ where+ (a,b) = splitFileName_ x+ (c,d) = break isExtSeparator b++-- | Drop all extensions.+--+-- > dropExtensions "/directory/path.ext" == "/directory/path"+-- > dropExtensions "file.tar.gz" == "file"+-- > not $ hasExtension $ dropExtensions x+-- > not $ any isExtSeparator $ takeFileName $ dropExtensions x+dropExtensions :: FilePath -> FilePath+dropExtensions = fst . splitExtensions++-- | Get all extensions.+--+-- > takeExtensions "/directory/path.ext" == ".ext"+-- > takeExtensions "file.tar.gz" == ".tar.gz"+takeExtensions :: FilePath -> String+takeExtensions = snd . splitExtensions+++-- | Replace all extensions of a file with a new extension. Note+-- that 'replaceExtension' and 'addExtension' both work for adding+-- multiple extensions, so only required when you need to drop+-- all extensions first.+--+-- > replaceExtensions "file.fred.bob" "txt" == "file.txt"+-- > replaceExtensions "file.fred.bob" "tar.gz" == "file.tar.gz"+replaceExtensions :: FilePath -> String -> FilePath+replaceExtensions x y = dropExtensions x <.> y++++---------------------------------------------------------------------+-- Drive methods++-- | Is the given character a valid drive letter?+-- only a-z and A-Z are letters, not isAlpha which is more unicodey+isLetter :: Char -> Bool+isLetter x = isAsciiLower x || isAsciiUpper x+++-- | Split a path into a drive and a path.+-- On Posix, \/ is a Drive.+--+-- > uncurry (++) (splitDrive x) == x+-- > Windows: splitDrive "file" == ("","file")+-- > Windows: splitDrive "c:/file" == ("c:/","file")+-- > Windows: splitDrive "c:\\file" == ("c:\\","file")+-- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test")+-- > Windows: splitDrive "\\\\shared" == ("\\\\shared","")+-- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file")+-- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file")+-- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file")+-- > Windows: splitDrive "/d" == ("","/d")+-- > Posix: splitDrive "/test" == ("/","test")+-- > Posix: splitDrive "//test" == ("//","test")+-- > Posix: splitDrive "test/file" == ("","test/file")+-- > Posix: splitDrive "file" == ("","file")+splitDrive :: FilePath -> (FilePath, FilePath)+splitDrive x | isPosix = span (== '/') x+splitDrive x | Just y <- readDriveLetter x = y+splitDrive x | Just y <- readDriveUNC x = y+splitDrive x | Just y <- readDriveShare x = y+splitDrive x = ("",x)++addSlash :: FilePath -> FilePath -> (FilePath, FilePath)+addSlash a xs = (a++c,d)+ where (c,d) = span isPathSeparator xs++-- See [1].+-- "\\?\D:\<path>" or "\\?\UNC\<server>\<share>"+readDriveUNC :: FilePath -> Maybe (FilePath, FilePath)+readDriveUNC (s1:s2:'?':s3:xs) | all isPathSeparator [s1,s2,s3] =+ case map toUpper xs of+ ('U':'N':'C':s4:_) | isPathSeparator s4 ->+ let (a,b) = readDriveShareName (drop 4 xs)+ in Just (s1:s2:'?':s3:take 4 xs ++ a, b)+ _ -> case readDriveLetter xs of+ -- Extended-length path.+ Just (a,b) -> Just (s1:s2:'?':s3:a,b)+ Nothing -> Nothing+readDriveUNC _ = Nothing++{- c:\ -}+readDriveLetter :: String -> Maybe (FilePath, FilePath)+readDriveLetter (x:':':y:xs) | isLetter x && isPathSeparator y = Just $ addSlash [x,':'] (y:xs)+readDriveLetter (x:':':xs) | isLetter x = Just ([x,':'], xs)+readDriveLetter _ = Nothing++{- \\sharename\ -}+readDriveShare :: String -> Maybe (FilePath, FilePath)+readDriveShare (s1:s2:xs) | isPathSeparator s1 && isPathSeparator s2 =+ Just (s1:s2:a,b)+ where (a,b) = readDriveShareName xs+readDriveShare _ = Nothing++{- assume you have already seen \\ -}+{- share\bob -> "share\", "bob" -}+readDriveShareName :: String -> (FilePath, FilePath)+readDriveShareName name = addSlash a b+ where (a,b) = break isPathSeparator name++++-- | Join a drive and the rest of the path.+--+-- > Valid x => uncurry joinDrive (splitDrive x) == x+-- > Windows: joinDrive "C:" "foo" == "C:foo"+-- > Windows: joinDrive "C:\\" "bar" == "C:\\bar"+-- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo"+-- > Windows: joinDrive "/:" "foo" == "/:\\foo"+joinDrive :: FilePath -> FilePath -> FilePath+joinDrive = combineAlways++-- | Get the drive from a filepath.+--+-- > takeDrive x == fst (splitDrive x)+takeDrive :: FilePath -> FilePath+takeDrive = fst . splitDrive++-- | Delete the drive, if it exists.+--+-- > dropDrive x == snd (splitDrive x)+dropDrive :: FilePath -> FilePath+dropDrive = snd . splitDrive++-- | Does a path have a drive.+--+-- > not (hasDrive x) == null (takeDrive x)+-- > Posix: hasDrive "/foo" == True+-- > Windows: hasDrive "C:\\foo" == True+-- > Windows: hasDrive "C:foo" == True+-- > hasDrive "foo" == False+-- > hasDrive "" == False+hasDrive :: FilePath -> Bool+hasDrive = not . null . takeDrive+++-- | Is an element a drive+--+-- > Posix: isDrive "/" == True+-- > Posix: isDrive "/foo" == False+-- > Windows: isDrive "C:\\" == True+-- > Windows: isDrive "C:\\foo" == False+-- > isDrive "" == False+isDrive :: FilePath -> Bool+isDrive x = not (null x) && null (dropDrive x)+++---------------------------------------------------------------------+-- Operations on a filepath, as a list of directories++-- | Split a filename into directory and file. '</>' is the inverse.+-- The first component will often end with a trailing slash.+--+-- > splitFileName "/directory/file.ext" == ("/directory/","file.ext")+-- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"+-- > Valid x => isValid (fst (splitFileName x))+-- > splitFileName "file/bob.txt" == ("file/", "bob.txt")+-- > splitFileName "file/" == ("file/", "")+-- > splitFileName "bob" == ("./", "bob")+-- > Posix: splitFileName "/" == ("/","")+-- > Windows: splitFileName "c:" == ("c:","")+splitFileName :: FilePath -> (String, String)+splitFileName x = (if null dir then "./" else dir, name)+ where+ (dir, name) = splitFileName_ x++-- version of splitFileName where, if the FilePath has no directory+-- component, the returned directory is "" rather than "./". This+-- is used in cases where we are going to combine the returned+-- directory to make a valid FilePath, and having a "./" appear would+-- look strange and upset simple equality properties. See+-- e.g. replaceFileName.+splitFileName_ :: FilePath -> (String, String)+splitFileName_ x = (drv ++ dir, file)+ where+ (drv,pth) = splitDrive x+ (dir,file) = breakEnd isPathSeparator pth++-- | Set the filename.+--+-- > replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext"+-- > Valid x => replaceFileName x (takeFileName x) == x+replaceFileName :: FilePath -> String -> FilePath+replaceFileName x y = a </> y where (a,_) = splitFileName_ x++-- | Drop the filename. Unlike 'takeDirectory', this function will leave+-- a trailing path separator on the directory.+--+-- > dropFileName "/directory/file.ext" == "/directory/"+-- > dropFileName x == fst (splitFileName x)+dropFileName :: FilePath -> FilePath+dropFileName = fst . splitFileName+++-- | Get the file name.+--+-- > takeFileName "/directory/file.ext" == "file.ext"+-- > takeFileName "test/" == ""+-- > takeFileName x `isSuffixOf` x+-- > takeFileName x == snd (splitFileName x)+-- > Valid x => takeFileName (replaceFileName x "fred") == "fred"+-- > Valid x => takeFileName (x </> "fred") == "fred"+-- > Valid x => isRelative (takeFileName x)+takeFileName :: FilePath -> FilePath+takeFileName = snd . splitFileName++-- | Get the base name, without an extension or path.+--+-- > takeBaseName "/directory/file.ext" == "file"+-- > takeBaseName "file/test.txt" == "test"+-- > takeBaseName "dave.ext" == "dave"+-- > takeBaseName "" == ""+-- > takeBaseName "test" == "test"+-- > takeBaseName (addTrailingPathSeparator x) == ""+-- > takeBaseName "file/file.tar.gz" == "file.tar"+takeBaseName :: FilePath -> String+takeBaseName = dropExtension . takeFileName++-- | Set the base name.+--+-- > replaceBaseName "/directory/other.ext" "file" == "/directory/file.ext"+-- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt"+-- > replaceBaseName "fred" "bill" == "bill"+-- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar"+-- > Valid x => replaceBaseName x (takeBaseName x) == x+replaceBaseName :: FilePath -> String -> FilePath+replaceBaseName pth nam = combineAlways a (nam <.> ext)+ where+ (a,b) = splitFileName_ pth+ ext = takeExtension b++-- | Is an item either a directory or the last character a path separator?+--+-- > hasTrailingPathSeparator "test" == False+-- > hasTrailingPathSeparator "test/" == True+hasTrailingPathSeparator :: FilePath -> Bool+hasTrailingPathSeparator "" = False+hasTrailingPathSeparator x = isPathSeparator (last x)+++hasLeadingPathSeparator :: FilePath -> Bool+hasLeadingPathSeparator "" = False+hasLeadingPathSeparator (hd : _) = isPathSeparator hd+++-- | Add a trailing file path separator if one is not already present.+--+-- > hasTrailingPathSeparator (addTrailingPathSeparator x)+-- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x+-- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/"+addTrailingPathSeparator :: FilePath -> FilePath+addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator]+++-- | Remove any trailing path separators+--+-- > dropTrailingPathSeparator "file/test/" == "file/test"+-- > dropTrailingPathSeparator "/" == "/"+-- > Windows: dropTrailingPathSeparator "\\" == "\\"+-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x+dropTrailingPathSeparator :: FilePath -> FilePath+dropTrailingPathSeparator x =+ if hasTrailingPathSeparator x && not (isDrive x)+ then let x' = dropWhileEnd isPathSeparator x+ in if null x' then [last x] else x'+ else x+++-- | Get the directory name, move up one level.+--+-- > takeDirectory "/directory/other.ext" == "/directory"+-- > takeDirectory x `isPrefixOf` x || takeDirectory x == "."+-- > takeDirectory "foo" == "."+-- > takeDirectory "/" == "/"+-- > takeDirectory "/foo" == "/"+-- > takeDirectory "/foo/bar/baz" == "/foo/bar"+-- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz"+-- > takeDirectory "foo/bar/baz" == "foo/bar"+-- > Windows: takeDirectory "foo\\bar" == "foo"+-- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar"+-- > Windows: takeDirectory "C:\\" == "C:\\"+takeDirectory :: FilePath -> FilePath+takeDirectory = dropTrailingPathSeparator . dropFileName++-- | Set the directory, keeping the filename the same.+--+-- > replaceDirectory "root/file.ext" "/directory/" == "/directory/file.ext"+-- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x+replaceDirectory :: FilePath -> String -> FilePath+replaceDirectory x dir = combineAlways dir (takeFileName x)+++-- | An alias for '</>'.+combine :: FilePath -> FilePath -> FilePath+combine a b | hasLeadingPathSeparator b || hasDrive b = b+ | otherwise = combineAlways a b++-- | Combine two paths, assuming rhs is NOT absolute.+combineAlways :: FilePath -> FilePath -> FilePath+combineAlways a b | null a = b+ | null b = a+ | hasTrailingPathSeparator a = a ++ b+ | otherwise = case a of+ [a1,':'] | isWindows && isLetter a1 -> a ++ b+ _ -> a ++ [pathSeparator] ++ b+++-- | Combine two paths with a path separator.+-- If the second path starts with a path separator or a drive letter, then it returns the second.+-- The intention is that @readFile (dir '</>' file)@ will access the same file as+-- @setCurrentDirectory dir; readFile file@.+--+-- > Posix: "/directory" </> "file.ext" == "/directory/file.ext"+-- > Windows: "/directory" </> "file.ext" == "/directory\\file.ext"+-- > "directory" </> "/file.ext" == "/file.ext"+-- > Valid x => (takeDirectory x </> takeFileName x) `equalFilePath` x+--+-- Combined:+--+-- > Posix: "/" </> "test" == "/test"+-- > Posix: "home" </> "bob" == "home/bob"+-- > Posix: "x:" </> "foo" == "x:/foo"+-- > Windows: "C:\\foo" </> "bar" == "C:\\foo\\bar"+-- > Windows: "home" </> "bob" == "home\\bob"+--+-- Not combined:+--+-- > Posix: "home" </> "/bob" == "/bob"+-- > Windows: "home" </> "C:\\bob" == "C:\\bob"+--+-- Not combined (tricky):+--+-- On Windows, if a filepath starts with a single slash, it is relative to the+-- root of the current drive. In [1], this is (confusingly) referred to as an+-- absolute path.+-- The current behavior of '</>' is to never combine these forms.+--+-- > Windows: "home" </> "/bob" == "/bob"+-- > Windows: "home" </> "\\bob" == "\\bob"+-- > Windows: "C:\\home" </> "\\bob" == "\\bob"+--+-- On Windows, from [1]: "If a file name begins with only a disk designator+-- but not the backslash after the colon, it is interpreted as a relative path+-- to the current directory on the drive with the specified letter."+-- The current behavior of '</>' is to never combine these forms.+--+-- > Windows: "D:\\foo" </> "C:bar" == "C:bar"+-- > Windows: "C:\\foo" </> "C:bar" == "C:bar"+(</>) :: FilePath -> FilePath -> FilePath+(</>) = combine+++-- | Split a path by the directory separator.+--+-- > splitPath "/directory/file.ext" == ["/","directory/","file.ext"]+-- > concat (splitPath x) == x+-- > splitPath "test//item/" == ["test//","item/"]+-- > splitPath "test/item/file" == ["test/","item/","file"]+-- > splitPath "" == []+-- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"]+-- > Posix: splitPath "/file/test" == ["/","file/","test"]+splitPath :: FilePath -> [FilePath]+splitPath x = [drive | drive /= ""] ++ f path+ where+ (drive,path) = splitDrive x++ f "" = []+ f y = (a++c) : f d+ where+ (a,b) = break isPathSeparator y+ (c,d) = span isPathSeparator b++-- | Just as 'splitPath', but don't add the trailing slashes to each element.+--+-- > splitDirectories "/directory/file.ext" == ["/","directory","file.ext"]+-- > splitDirectories "test/file" == ["test","file"]+-- > splitDirectories "/test/file" == ["/","test","file"]+-- > Windows: splitDirectories "C:\\test\\file" == ["C:\\", "test", "file"]+-- > Valid x => joinPath (splitDirectories x) `equalFilePath` x+-- > splitDirectories "" == []+-- > Windows: splitDirectories "C:\\test\\\\\\file" == ["C:\\", "test", "file"]+-- > splitDirectories "/test///file" == ["/","test","file"]+splitDirectories :: FilePath -> [FilePath]+splitDirectories = map dropTrailingPathSeparator . splitPath+++-- | Join path elements back together.+--+-- > joinPath a == foldr (</>) "" a+-- > joinPath ["/","directory/","file.ext"] == "/directory/file.ext"+-- > Valid x => joinPath (splitPath x) == x+-- > joinPath [] == ""+-- > Posix: joinPath ["test","file","path"] == "test/file/path"+joinPath :: [FilePath] -> FilePath+-- Note that this definition on c:\\c:\\, join then split will give c:\\.+joinPath = foldr combine ""+++++++---------------------------------------------------------------------+-- File name manipulators++-- | Equality of two 'FilePath's.+-- If you call @System.Directory.canonicalizePath@+-- first this has a much better chance of working.+-- Note that this doesn't follow symlinks or DOSNAM~1s.+--+-- Similar to 'normalise', this does not expand @".."@, because of symlinks.+--+-- > x == y ==> equalFilePath x y+-- > normalise x == normalise y ==> equalFilePath x y+-- > equalFilePath "foo" "foo/"+-- > not (equalFilePath "/a/../c" "/c")+-- > not (equalFilePath "foo" "/foo")+-- > Posix: not (equalFilePath "foo" "FOO")+-- > Windows: equalFilePath "foo" "FOO"+-- > Windows: not (equalFilePath "C:" "C:/")+equalFilePath :: FilePath -> FilePath -> Bool+equalFilePath a b = f a == f b+ where+ f x | isWindows = dropTrailingPathSeparator $ map toLower $ normalise x+ | otherwise = dropTrailingPathSeparator $ normalise x+++-- | Contract a filename, based on a relative path. Note that the resulting path+-- will never introduce @..@ paths, as the presence of symlinks means @..\/b@+-- may not reach @a\/b@ if it starts from @a\/c@. For a worked example see+-- <http://neilmitchell.blogspot.co.uk/2015/10/filepaths-are-subtle-symlinks-are-hard.html this blog post>.+--+-- The corresponding @makeAbsolute@ function can be found in+-- @System.Directory@.+--+-- > makeRelative "/directory" "/directory/file.ext" == "file.ext"+-- > Valid x => makeRelative (takeDirectory x) x `equalFilePath` takeFileName x+-- > makeRelative x x == "."+-- > Valid x y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y </> makeRelative y x) x+-- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob"+-- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob"+-- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob"+-- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob"+-- > Windows: makeRelative "/Home" "/home/bob" == "bob"+-- > Windows: makeRelative "/" "//" == "//"+-- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob"+-- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar"+-- > Posix: makeRelative "/fred" "bob" == "bob"+-- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred"+-- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/"+-- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c"+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative root path+ | equalFilePath root path = "."+ | takeAbs root /= takeAbs path = path+ | otherwise = f (dropAbs root) (dropAbs path)+ where+ f "" y = dropWhile isPathSeparator y+ f x y = let (x1,x2) = g x+ (y1,y2) = g y+ in if equalFilePath x1 y1 then f x2 y2 else path++ g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b)+ where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x++ -- on windows, need to drop '/' which is kind of absolute, but not a drive+ dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x+ dropAbs x = dropDrive x++ takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator]+ takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x++-- | Normalise a file+--+-- * \/\/ outside of the drive can be made blank+--+-- * \/ -> 'pathSeparator'+--+-- * .\/ -> \"\"+--+-- Does not remove @".."@, because of symlinks.+--+-- > Posix: normalise "/file/\\test////" == "/file/\\test/"+-- > Posix: normalise "/file/./test" == "/file/test"+-- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/"+-- > Posix: normalise "../bob/fred/" == "../bob/fred/"+-- > Posix: normalise "/a/../c" == "/a/../c"+-- > Posix: normalise "./bob/fred/" == "bob/fred/"+-- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\"+-- > Windows: normalise "c:\\" == "C:\\"+-- > Windows: normalise "C:.\\" == "C:"+-- > Windows: normalise "\\\\server\\test" == "\\\\server\\test"+-- > Windows: normalise "//server/test" == "\\\\server\\test"+-- > Windows: normalise "c:/file" == "C:\\file"+-- > Windows: normalise "/file" == "\\file"+-- > Windows: normalise "\\" == "\\"+-- > Windows: normalise "/./" == "\\"+-- > normalise "." == "."+-- > Posix: normalise "./" == "./"+-- > Posix: normalise "./." == "./"+-- > Posix: normalise "/./" == "/"+-- > Posix: normalise "/" == "/"+-- > Posix: normalise "bob/fred/." == "bob/fred/"+-- > Posix: normalise "//home" == "/home"+normalise :: FilePath -> FilePath+normalise path = result ++ [pathSeparator | addPathSeparator]+ where+ (drv,pth) = splitDrive path+ result = joinDrive' (normaliseDrive drv) (f pth)++ joinDrive' "" "" = "."+ joinDrive' d p = joinDrive d p++ addPathSeparator = isDirPath pth+ && not (hasTrailingPathSeparator result)+ && not (isRelativeDrive drv)++ isDirPath xs = hasTrailingPathSeparator xs+ || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)++ f = joinPath . dropDots . propSep . splitDirectories++ propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs+ | otherwise = x : xs+ propSep [] = []++ dropDots = filter ("." /=)++normaliseDrive :: FilePath -> FilePath+normaliseDrive "" = ""+normaliseDrive _ | isPosix = [pathSeparator]+normaliseDrive drive = if isJust $ readDriveLetter x2+ then map toUpper x2+ else x2+ where+ x2 = map repSlash drive++ repSlash x = if isPathSeparator x then pathSeparator else x++-- Information for validity functions on Windows. See [1].+isBadCharacter :: Char -> Bool+isBadCharacter x = x >= '\0' && x <= '\31' || x `elem` ":*?><|\""++badElements :: [FilePath]+badElements =+ ["CON","PRN","AUX","NUL","CLOCK$"+ ,"COM1","COM2","COM3","COM4","COM5","COM6","COM7","COM8","COM9"+ ,"LPT1","LPT2","LPT3","LPT4","LPT5","LPT6","LPT7","LPT8","LPT9"]+++-- | Is a FilePath valid, i.e. could you create a file like it? This function checks for invalid names,+-- and invalid characters, but does not check if length limits are exceeded, as these are typically+-- filesystem dependent.+--+-- > isValid "" == False+-- > isValid "\0" == False+-- > Posix: isValid "/random_ path:*" == True+-- > Posix: isValid x == not (null x)+-- > Windows: isValid "c:\\test" == True+-- > Windows: isValid "c:\\test:of_test" == False+-- > Windows: isValid "test*" == False+-- > Windows: isValid "c:\\test\\nul" == False+-- > Windows: isValid "c:\\test\\prn.txt" == False+-- > Windows: isValid "c:\\nul\\file" == False+-- > Windows: isValid "\\\\" == False+-- > Windows: isValid "\\\\\\foo" == False+-- > Windows: isValid "\\\\?\\D:file" == False+-- > Windows: isValid "foo\tbar" == False+-- > Windows: isValid "nul .txt" == False+-- > Windows: isValid " nul.txt" == True+isValid :: FilePath -> Bool+isValid "" = False+isValid x | '\0' `elem` x = False+isValid _ | isPosix = True+isValid path =+ not (any isBadCharacter x2) &&+ not (any f $ splitDirectories x2) &&+ not (isJust (readDriveShare x1) && all isPathSeparator x1) &&+ not (isJust (readDriveUNC x1) && not (hasTrailingPathSeparator x1))+ where+ (x1,x2) = splitDrive path+ f x = map toUpper (dropWhileEnd (== ' ') $ dropExtensions x) `elem` badElements+++-- | Take a FilePath and make it valid; does not change already valid FilePaths.+--+-- > isValid (makeValid x)+-- > isValid x ==> makeValid x == x+-- > makeValid "" == "_"+-- > makeValid "file\0name" == "file_name"+-- > Windows: makeValid "c:\\already\\/valid" == "c:\\already\\/valid"+-- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test"+-- > Windows: makeValid "test*" == "test_"+-- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_"+-- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt"+-- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt"+-- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file"+-- > Windows: makeValid "\\\\\\foo" == "\\\\drive"+-- > Windows: makeValid "\\\\?\\D:file" == "\\\\?\\D:\\file"+-- > Windows: makeValid "nul .txt" == "nul _.txt"+makeValid :: FilePath -> FilePath+makeValid "" = "_"+makeValid path+ | isPosix = map (\x -> if x == '\0' then '_' else x) path+ | isJust (readDriveShare drv) && all isPathSeparator drv = take 2 drv ++ "drive"+ | isJust (readDriveUNC drv) && not (hasTrailingPathSeparator drv) =+ makeValid (drv ++ [pathSeparator] ++ pth)+ | otherwise = joinDrive drv $ validElements $ validChars pth+ where+ (drv,pth) = splitDrive path++ validChars = map f+ f x = if isBadCharacter x then '_' else x++ validElements x = joinPath $ map g $ splitPath x+ g x = h a ++ b+ where (a,b) = break isPathSeparator x+ h x = if map toUpper (dropWhileEnd (== ' ') a) `elem` badElements then a ++ "_" <.> b else x+ where (a,b) = splitExtensions x+++-- | Is a path relative, or is it fixed to the root?+--+-- > Windows: isRelative "path\\test" == True+-- > Windows: isRelative "c:\\test" == False+-- > Windows: isRelative "c:test" == True+-- > Windows: isRelative "c:\\" == False+-- > Windows: isRelative "c:/" == False+-- > Windows: isRelative "c:" == True+-- > Windows: isRelative "\\\\foo" == False+-- > Windows: isRelative "\\\\?\\foo" == False+-- > Windows: isRelative "\\\\?\\UNC\\foo" == False+-- > Windows: isRelative "/foo" == True+-- > Windows: isRelative "\\foo" == True+-- > Posix: isRelative "test/path" == True+-- > Posix: isRelative "/test" == False+-- > Posix: isRelative "/" == False+--+-- According to [1]:+--+-- * "A UNC name of any format [is never relative]."+--+-- * "You cannot use the "\\?\" prefix with a relative path."+isRelative :: FilePath -> Bool+isRelative x = null drive || isRelativeDrive drive+ where drive = takeDrive x+++{- c:foo -}+-- From [1]: "If a file name begins with only a disk designator but not the+-- backslash after the colon, it is interpreted as a relative path to the+-- current directory on the drive with the specified letter."+isRelativeDrive :: String -> Bool+isRelativeDrive x =+ maybe False (not . hasTrailingPathSeparator . fst) (readDriveLetter x)+++-- | @not . 'isRelative'@+--+-- > isAbsolute x == not (isRelative x)+isAbsolute :: FilePath -> Bool+isAbsolute = not . isRelative+++-----------------------------------------------------------------------------+-- dropWhileEnd (>2) [1,2,3,4,1,2,3,4] == [1,2,3,4,1,2])+-- Note that Data.List.dropWhileEnd is only available in base >= 4.5.+dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = reverse . dropWhile p . reverse++-- takeWhileEnd (>2) [1,2,3,4,1,2,3,4] == [3,4])+takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++-- spanEnd (>2) [1,2,3,4,1,2,3,4] = ([1,2,3,4,1,2], [3,4])+spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)++-- breakEnd (< 2) [1,2,3,4,1,2,3,4] == ([1,2,3,4,1],[2,3,4])+breakEnd :: (a -> Bool) -> [a] -> ([a], [a])+breakEnd p = spanEnd (not . p)++-- | The stripSuffix function drops the given suffix from a list. It returns+-- Nothing if the list did not end with the suffix given, or Just the list+-- before the suffix, if it does.+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)