template-haskell 2.4.0.1 → 2.24.0.0
raw patch · 14 files changed
Files
- Language/Haskell/TH.hs +100/−52
- Language/Haskell/TH/CodeDo.hs +22/−0
- Language/Haskell/TH/LanguageExtensions.hs +23/−0
- Language/Haskell/TH/Lib.hs +346/−438
- Language/Haskell/TH/Ppr.hs +89/−436
- Language/Haskell/TH/PprLib.hs +53/−213
- Language/Haskell/TH/Quote.hs +37/−58
- Language/Haskell/TH/Syntax.hs +399/−825
- Language/Haskell/TH/Syntax/Internals.hs +0/−29
- changelog.md +333/−0
- template-haskell.cabal +61/−24
- 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,61 +1,109 @@--- The public face of Template Haskell+{- | The public face of Template Haskell +For other documentation, refer to:+<https://wiki.haskell.org/Template_Haskell>++-}+{-# LANGUAGE Safe #-} module Language.Haskell.TH(- -- The monad and its operations- Q, runQ, - report, -- :: Bool -> String -> Q ()- recover, -- :: Q a -> Q a -> Q a- reify, -- :: Name -> Q Info- location, -- :: Q Location- runIO, -- :: IO a -> Q a+ -- * The monad and its operations+ Q,+ runQ,+ Quote(..),+ -- ** Administration: errors, locations and IO+ reportError, -- :: String -> Q ()+ reportWarning, -- :: String -> Q ()+ report, -- :: Bool -> String -> Q ()+ recover, -- :: Q a -> Q a -> Q a+ location, -- :: Q Loc+ Loc(..),+ runIO, -- :: IO a -> Q a+ -- ** Querying the compiler+ -- *** Reify+ reify, -- :: Name -> Q Info+ reifyModule,+ newDeclarationGroup,+ Info(..), ModuleInfo(..),+ InstanceDec,+ ParentName,+ SumAlt, SumArity,+ Arity,+ Unlifted,+ -- *** Language extension lookup+ Extension(..),+ extsEnabled, isExtEnabled,+ -- *** Name lookup+ lookupTypeName, -- :: String -> Q (Maybe Name)+ lookupValueName, -- :: String -> Q (Maybe Name)+ -- *** Fixity lookup+ reifyFixity,+ -- *** Type lookup+ reifyType,+ -- *** Instance lookup+ reifyInstances,+ isInstance,+ -- *** Roles lookup+ reifyRoles,+ -- *** Annotation lookup+ reifyAnnotations, AnnLookup(..),+ -- *** Constructor strictness lookup+ reifyConStrictness, - -- Names- Name, - mkName, -- :: String -> Name- newName, -- :: String -> Q Name- nameBase, -- :: Name -> String- nameModule, -- :: Name -> Maybe String- tupleTypeName, tupleDataName, -- Int -> Name- - -- The algebraic data types- Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..), Cxt,- Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),- Range(..), Lit(..), Pat(..), FieldExp, FieldPat, - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),- InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..),- Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,+ -- * Typed expressions+ TExp, unType,+ Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode,+ bindCode_, joinCode, liftCode, - -- Library functions- InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, PredQ, MatchQ, ClauseQ, BodyQ,- GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,- InlineSpecQ,- intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,- charL, stringL,- litP, varP, tupP, conP, infixP, tildeP, bangP, asP, wildP, recP,- listP, sigP, - fieldPat,- bindS, letS, noBindS, parS, - fromR, fromThenR, fromToR, fromThenToR, - normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, - dyn, global, varE, conE, litE, appE, infixE, infixApp, sectionL, sectionR, - lamE, lam1E, tupE, condE, letE, caseE, doE, compE, arithSeqE, appsE,- fromE, fromThenE, fromToE, fromThenToE,- listE, sigE, recConE, recUpdE, stringE, fieldExp,- valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,- pragInlD, pragSpecD, familyNoKindD, familyKindD, dataInstD,- newtypeInstD, tySynInstD, - cxt, classP, equalP, normalC, recC, infixC,- forallT, varT, conT, appT, arrowT, listT, tupleT, sigT,- isStrict, notStrict, strictType, varStrictType,- cCall, stdCall, unsafe, safe, threadsafe, - inlineSpecNoPhase, inlineSpecPhase, typeFam, dataFam,+ -- * Names+ Name, NameSpace, -- Abstract+ -- ** Constructing names+ mkName, -- :: String -> Name+ -- ** Deconstructing names+ nameBase, -- :: Name -> String+ nameModule, -- :: Name -> Maybe String+ namePackage, -- :: Name -> Maybe String+ nameSpace, -- :: Name -> Maybe NameSpace+ -- ** Built-in names+ tupleTypeName, tupleDataName, -- Int -> Name+ unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name+ unboxedSumTypeName, -- :: SumArity -> Name+ unboxedSumDataName, -- :: SumAlt -> SumArity -> Name - -- Pretty-printer- Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType- + -- * The algebraic data types+ -- | The lowercase versions (/syntax operators/) of these constructors are+ -- preferred to these constructors, since they compose better with+ -- quotations (@[| |]@) and splices (@$( ... )@)++ -- ** Declarations+ Dec(..), Con(..), Clause(..),+ SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..),+ Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..),+ Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),+ FunDep(..), TySynEqn(..), TypeFamilyHead(..),+ Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity,+ maxPrecedence,+ PatSynDir(..), PatSynArgs(..),+ -- ** Expressions+ Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),+ -- ** Patterns+ Pat(..), FieldExp, FieldPat,+ -- ** Types+ Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),+ Syntax.Specificity(..),+ Syntax.BndrVis(..),+ FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType,++ -- ** Documentation+ putDoc, getDoc, DocLoc(..),++ -- * Library functions+ module Language.Haskell.TH.Lib,++ -- * Pretty-printer+ Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType+ ) where -import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax as Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr-
+ 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
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.TH.LanguageExtensions+-- Copyright : (c) The University of Glasgow 2015+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Language extensions known to GHC+--+-----------------------------------------------------------------------------++module Language.Haskell.TH.LanguageExtensions+ ( Extension(..)+ ) where++-- This module exists primarily to avoid inserting a massive list of language+-- extensions into the already quite large Haddocks for Language.Haskell.TH++import GHC.LanguageExtensions.Type (Extension(..))
Language/Haskell/TH/Lib.hs view
@@ -1,550 +1,458 @@--- TH.Lib contains lots of useful helper functions for+{-# LANGUAGE Safe #-}++-- |+-- Language.Haskell.TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms -module Language.Haskell.TH.Lib where+-- Note: this module mostly re-exports functions from+-- Language.Haskell.TH.Lib.Internal, but if a change occurs to Template+-- Haskell which requires breaking the API offered in this module, we opt to+-- copy the old definition here, and make the changes in+-- Language.Haskell.TH.Lib.Internal. This way, we can retain backwards+-- compatibility while still allowing GHC to make changes as it needs.++module Language.Haskell.TH.Lib ( -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. -import Language.Haskell.TH.Syntax-import Control.Monad( liftM, liftM2 )--------------------------------------------------------------- Type synonyms-------------------------------------------------------------type InfoQ = Q Info-type PatQ = Q Pat-type FieldPatQ = Q FieldPat-type ExpQ = Q Exp-type DecQ = Q Dec-type ConQ = Q Con-type TypeQ = Q Type-type CxtQ = Q Cxt-type PredQ = Q Pred-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 StrictTypeQ = Q StrictType-type VarStrictTypeQ = Q VarStrictType-type FieldExpQ = Q FieldExp-type InlineSpecQ = Q InlineSpec--------------------------------------------------------------- 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-stringL :: String -> Lit-stringL = StringL-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)}-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')-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')--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 _ = fail "No parallel comprehensions yet"------------------------------------------------------------------------------------ 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+ -- * Library functions+ -- ** Abbreviations+ 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, -match :: PatQ -> BodyQ -> [DecQ] -> MatchQ-match p rhs ds = do { p' <- p;- r' <- rhs;- ds' <- sequence ds;- return (Match p' r' ds') }+ -- ** Constructors lifted to 'Q'+ -- *** Literals+ intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,+ charL, stringL, stringPrimL, charPrimL, bytesPrimL, mkBytes,+ -- *** Patterns+ litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP,+ infixP, tildeP, bangP, asP, wildP, recP,+ listP, sigP, viewP, typeP, invisP,+ fieldPat, -clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ-clause ps r ds = do { ps' <- sequence ps;- r' <- r;- ds' <- sequence ds;- return (Clause ps' r' ds') }+ -- *** Pattern Guards+ normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, + -- *** Expressions+ dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE,+ appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,+ 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, ------------------------------------------------------------------------------- Exp+ -- **** Ranges+ fromE, fromThenE, fromToE, fromThenToE, -dyn :: String -> Q Exp -dyn s = return (VarE (mkName s))+ -- ***** Ranges with more indirection+ arithSeqE,+ fromR, fromThenR, fromToR, fromThenToR,+ -- **** Statements+ doE, mdoE, compE,+ bindS, letS, noBindS, parS, recS, -global :: Name -> ExpQ-global s = return (VarE s)+ -- *** Types+ 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, charTyLit,+ -- **** Strictness+ noSourceUnpackedness, sourceNoUnpack, sourceUnpack,+ noSourceStrictness, sourceLazy, sourceStrict,+ isStrict, notStrict, unpacked,+ bang, bangType, varBangType, strictType, varStrictType,+ -- **** Class Contexts+ cxt, classP, equalP,+ -- **** Constructors+ normalC, recC, infixC, forallC, gadtC, recGadtC, -varE :: Name -> ExpQ-varE s = return (VarE s)+ -- *** Kinds+ varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, -conE :: Name -> ExpQ-conE s = return (ConE s)+ -- *** Type variable binders+ DefaultBndrFlag(defaultBndrFlag),+ plainTV, kindedTV,+ plainInvisTV, kindedInvisTV,+ plainBndrTV, kindedBndrTV,+ specifiedSpec, inferredSpec,+ bndrReq, bndrInvis, -litE :: Lit -> ExpQ-litE c = return (LitE c)+ -- *** Roles+ nominalR, representationalR, phantomR, inferR, -appE :: ExpQ -> ExpQ -> ExpQ-appE x y = do { a <- x; b <- y; return (AppE a b)}+ -- *** Top Level Declarations+ -- **** Data+ valD, funD, tySynD, dataD, newtypeD, typeDataD,+ derivClause, DerivClause(..),+ stockStrategy, anyclassStrategy, newtypeStrategy,+ viaStrategy, DerivStrategy(..),+ -- **** Class+ classD, instanceD, instanceWithOverlapD, Overlap(..),+ sigD, kiSigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, -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) }+ -- **** Role annotations+ roleAnnotD,+ -- **** Type Family / Data Family+ dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD,+ newtypeInstD, tySynInstD,+ tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, -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)+ -- **** Fixity+ infixLD, infixRD, infixND, -lamE :: [PatQ] -> ExpQ -> ExpQ-lamE ps e = do ps' <- sequence ps- e' <- e- return (LamE ps' e')+ -- **** Default declaration+ defaultD, -lam1E :: PatQ -> ExpQ -> ExpQ -- Single-arg lambda-lam1E p e = lamE [p] e+ -- **** Foreign Function Interface (FFI)+ cCall, stdCall, cApi, prim, javaScript,+ unsafe, safe, interruptible, forImpD, -tupE :: [ExpQ] -> ExpQ-tupE es = do { es1 <- sequence es; return (TupE es1)}+ -- **** Functional dependencies+ funDep, -condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ-condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}+ -- **** Pragmas+ ruleVar, typedRuleVar,+ valueAnnotation, typeAnnotation, moduleAnnotation,+ pragInlD, pragSpecD, pragSpecInlD,+ pragSpecED, pragSpecInlED,+ pragSpecInstD, pragRuleD, pragAnnD,+ pragLineD, pragCompleteD, -letE :: [DecQ] -> ExpQ -> ExpQ-letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }+ -- **** Pattern Synonyms+ patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,+ infixPatSyn, recordPatSyn, -caseE :: ExpQ -> [MatchQ] -> ExpQ-caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } + -- **** Implicit Parameters+ implicitParamBindD, -doE :: [StmtQ] -> ExpQ-doE ss = do { ss1 <- sequence ss; return (DoE ss1) } + -- ** Reify+ thisModule, -compE :: [StmtQ] -> ExpQ-compE ss = do { ss1 <- sequence ss; return (CompE ss1) } + -- ** Documentation+ withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc,+ typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc -arithSeqE :: RangeQ -> ExpQ-arithSeqE r = do { r' <- r; return (ArithSeqE r') } + ) where --- arithSeqE Shortcuts-fromE :: ExpQ -> ExpQ-fromE x = do { a <- x; return (ArithSeqE (FromR a)) } +import GHC.Boot.TH.Lib hiding+ ( tySynD+ , dataD+ , newtypeD+ , typeDataD+ , classD+ , pragRuleD+ , dataInstD+ , newtypeInstD+ , dataFamilyD+ , openTypeFamilyD+ , closedTypeFamilyD+ , tySynEqn+ , forallC -fromThenE :: ExpQ -> ExpQ -> ExpQ-fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) } + , forallT+ , sigT -fromToE :: ExpQ -> ExpQ -> ExpQ-fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) } + , plainTV+ , kindedTV+ , starK+ , constraintK -fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ-fromThenToE x y z = do { a <- x; b <- y; c <- z;- return (ArithSeqE (FromThenToR a b c)) } --- End arithSeqE shortcuts+ , noSig+ , kindSig+ , tyVarSig -listE :: [ExpQ] -> ExpQ-listE es = do { es1 <- sequence es; return (ListE es1) }+ , derivClause+ , standaloneDerivWithStrategyD -sigE :: ExpQ -> TypeQ -> ExpQ-sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }+ , doE+ , mdoE+ , tupE+ , unboxedTupE -recConE :: Name -> [Q (Name,Exp)] -> ExpQ-recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }+ , conP -recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ-recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }+ , Role+ , InjectivityAnn+ )+import qualified GHC.Boot.TH.Lib as Internal+import Language.Haskell.TH.Syntax -stringE :: String -> ExpQ-stringE = litE . stringL+import Control.Applicative (Applicative(..))+import Foreign.ForeignPtr+import Data.Word+import Prelude hiding (Applicative(..)) -fieldExp :: Name -> ExpQ -> Q (Name, Exp)-fieldExp s e = do { e' <- e; return (s,e') }+-- All definitions below represent the "old" API, since their definitions are+-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before+-- deciding to change the APIs of the functions below, as they represent the+-- public API (as opposed to the Internal module, which has no API promises.) ---------------------------------------------------------------------------------- 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)- }+-- * 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] -> [ConQ] -> [Name] -> DecQ-dataD ctxt tc tvs cons derivs =+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- return (DataD ctxt1 tc tvs cons1 derivs)+ cons1 <- sequenceA cons+ derivs1 <- sequenceA derivs+ return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ-newtypeD ctxt tc tvs con derivs =+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- return (NewtypeD ctxt1 tc tvs con1 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+ do+ decs1 <- sequenceA decs ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 -instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ-instanceD ctxt ty decs =- do - ctxt1 <- ctxt- decs1 <- sequence decs- ty1 <- ty- return $ InstanceD 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')--pragInlD :: Name -> InlineSpecQ -> DecQ-pragInlD n ispec - = do- ispec1 <- ispec - return $ PragmaD (InlineP n ispec1)--pragSpecD :: Name -> TypeQ -> DecQ-pragSpecD n ty- = do- ty1 <- ty- return $ PragmaD (SpecialiseP n ty1 Nothing)--pragSpecInlD :: Name -> TypeQ -> InlineSpecQ -> DecQ-pragSpecInlD n ty ispec +pragRuleD :: Quote m => String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec+pragRuleD n bndrs lhs rhs phases = do- ty1 <- ty- ispec1 <- ispec- return $ PragmaD (SpecialiseP n ty1 (Just ispec1))--familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ-familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing--familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ-familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k)+ bndrs1 <- sequenceA bndrs+ lhs1 <- lhs+ rhs1 <- rhs+ return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases -dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ-dataInstD ctxt tc tys cons derivs =+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- tys1 <- sequence tys- cons1 <- sequence cons- return (DataInstD ctxt1 tc tys1 cons1 derivs)+ ty1 <- foldl appT (conT tc) tys+ cons1 <- sequenceA cons+ derivs1 <- sequenceA derivs+ return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ-newtypeInstD ctxt tc tys con derivs =+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- tys1 <- sequence tys+ ty1 <- foldl appT (conT tc) tys con1 <- con- return (NewtypeInstD ctxt1 tc tys1 con1 derivs)--tySynInstD :: Name -> [TypeQ] -> TypeQ -> DecQ-tySynInstD tc tys rhs = - do - tys1 <- sequence tys- rhs1 <- rhs- return (TySynInstD tc tys1 rhs1)--cxt :: [PredQ] -> CxtQ-cxt = sequence--classP :: Name -> [TypeQ] -> PredQ-classP cla tys- = do- tys1 <- sequence tys- return (ClassP cla tys1)--equalP :: TypeQ -> TypeQ -> PredQ-equalP tleft tright- = do- tleft1 <- tleft- tright1 <- tright- return (EqualP tleft1 tright1)+ derivs1 <- sequenceA derivs+ return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -normalC :: Name -> [StrictTypeQ] -> ConQ-normalC con strtys = liftM (NormalC con) $ sequence strtys+dataFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Dec+dataFamilyD tc tvs kind+ = pure $ DataFamilyD tc tvs kind -recC :: Name -> [VarStrictTypeQ] -> ConQ-recC con varstrtys = liftM (RecC con) $ sequence varstrtys+openTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig+ -> Maybe InjectivityAnn -> m Dec+openTypeFamilyD tc tvs res inj+ = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ-infixC st1 con st2 = do st1' <- st1- st2' <- st2- return $ InfixC st1' con st2'+closedTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig+ -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec+closedTypeFamilyD tc tvs result injectivity eqns =+ do eqns1 <- sequenceA eqns+ return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) -forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ-forallC ns ctxt con = liftM2 (ForallC ns) ctxt con+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 :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Con -> m Con+forallC ns ctxt con = liftA2 (ForallC ns) ctxt con ---------------------------------------------------------------------------------- Type+-- * 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 -varT :: Name -> TypeQ-varT = return . VarT+sigT :: Quote m => m Type -> Kind -> m Type+sigT t k+ = do+ t' <- t+ return $ SigT t' k -conT :: Name -> TypeQ-conT = return . ConT+-------------------------------------------------------------------------------+-- * Type variable binders -appT :: TypeQ -> TypeQ -> TypeQ-appT t1 t2 = do- t1' <- t1- t2' <- t2- return $ AppT t1' t2'+class DefaultBndrFlag flag where+ defaultBndrFlag :: flag -arrowT :: TypeQ-arrowT = return ArrowT+instance DefaultBndrFlag () where+ defaultBndrFlag = () -listT :: TypeQ-listT = return ListT+instance DefaultBndrFlag Specificity where+ defaultBndrFlag = SpecifiedSpec -tupleT :: Int -> TypeQ-tupleT i = return (TupleT i)+instance DefaultBndrFlag BndrVis where+ defaultBndrFlag = BndrReq -sigT :: TypeQ -> Kind -> TypeQ-sigT t k- = do- t' <- t- return $ SigT t' k+plainTV :: DefaultBndrFlag flag => Name -> TyVarBndr flag+plainTV n = PlainTV n defaultBndrFlag -isStrict, notStrict :: Q Strict-isStrict = return $ IsStrict-notStrict = return $ NotStrict+kindedTV :: DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag+kindedTV n k = KindedTV n defaultBndrFlag k -strictType :: Q Strict -> TypeQ -> StrictTypeQ-strictType = liftM2 (,)+-------------------------------------------------------------------------------+-- * Kind -varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ-varStrictType v st = do (s, t) <- st- return (v, s, t)+starK :: Kind+starK = StarT ----------------------------------------------------------------------------------- Kind+constraintK :: Kind+constraintK = ConstraintT -plainTV :: Name -> TyVarBndr-plainTV = PlainTV+-------------------------------------------------------------------------------+-- * Type family result -kindedTV :: Name -> Kind -> TyVarBndr-kindedTV = KindedTV+noSig :: FamilyResultSig+noSig = NoSig -starK :: Kind-starK = StarK+kindSig :: Kind -> FamilyResultSig+kindSig = KindSig -arrowK :: Kind -> Kind -> Kind-arrowK = ArrowK+tyVarSig :: TyVarBndr () -> FamilyResultSig+tyVarSig = TyVarSig ---------------------------------------------------------------------------------- Callconv+-- * Top Level Declarations -cCall, stdCall :: Callconv-cCall = CCall-stdCall = StdCall+derivClause :: Quote m => Maybe DerivStrategy -> [m Pred] -> m DerivClause+derivClause mds p = do+ p' <- cxt p+ return $ DerivClause mds p' +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'+ ---------------------------------------------------------------------------------- Safety+-- * Bytes literals -unsafe, safe, threadsafe :: Safety-unsafe = Unsafe-safe = Safe-threadsafe = Threadsafe+-- | 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 ---------------------------------------------------------------------------------- InlineSpec+-- * Tuple expressions -inlineSpecNoPhase :: Bool -> Bool -> InlineSpecQ-inlineSpecNoPhase inline conlike- = return $ InlineSpec inline conlike Nothing+tupE :: Quote m => [m Exp] -> m Exp+tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)} -inlineSpecPhase :: Bool -> Bool -> Bool -> Int -> InlineSpecQ-inlineSpecPhase inline conlike beforeFrom phase- = return $ InlineSpec inline conlike (Just (beforeFrom, phase))+unboxedTupE :: Quote m => [m Exp] -> m Exp+unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)} ---------------------------------------------------------------------------------- FunDep+-- * Do expressions -funDep :: [Name] -> [Name] -> FunDep-funDep = FunDep+doE :: Quote m => [m Stmt] -> m Exp+doE = Internal.doE Nothing +mdoE :: Quote m => [m Stmt] -> m Exp+mdoE = Internal.mdoE Nothing+ ---------------------------------------------------------------------------------- FamFlavour+-- * Patterns -typeFam, dataFam :: FamFlavour-typeFam = TypeFam-dataFam = DataFam+conP :: Quote m => Name -> [m Pat] -> m Pat+conP n xs = Internal.conP n [] xs ------------------------------------------------------------------ Useful helper functions -combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])-combine pairs = foldr f ([],[]) pairs- where f (env,p) (es,ps) = (env++es,p:ps)+--------------------------------------------------------------------------------+-- * Constraint predicates (deprecated) -rename :: Pat -> Q ([(Name, Name)], Pat)-rename (LitP c) = return([],LitP c)-rename (VarP s) = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }-rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }- where g (es,ps) = return (es,TupP ps)-rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }- where g (es,ps) = return (es,ConP nm ps)-rename (InfixP p1 n p2) = do { r1 <- rename p1;- r2 <- rename p2;- let {(env, [p1', p2']) = combine [r1, r2]};- return (env, InfixP p1' n p2') }-rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) } -rename (BangP p) = do { (env,p2) <- rename p; return(env,BangP p2) } -rename (AsP s p) = - do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }-rename WildP = return([],WildP)-rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }- where g (env,ps') = return (env,RecP nm (zip ss ps'))- (ss,ps) = unzip fs-rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }- where g (es,ps) = return (es,ListP ps)-rename (SigP {}) = fail "rename: Don't know how to do SigP yet"+{-# 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) -genpat :: Pat -> Q ((Name -> ExpQ), Pat)-genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }+{-# 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]) -alpha :: [(Name, Name)] -> Name -> ExpQ-alpha env s = case lookup s env of- Just x -> varE x- Nothing -> varE s+--------------------------------------------------------------------------------+-- * 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 -appsE :: [ExpQ] -> ExpQ-appsE [] = error "appsExp []"-appsE [x] = x-appsE (x:y:zs) = appsE ( (appE x y) : zs )+{-# 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 -simpleMatch :: Pat -> Exp -> Match-simpleMatch p e = Match p (NormalB e) []+{-# 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/Ppr.hs view
@@ -1,438 +1,91 @@--- TH.Ppr 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.HughesPJ (render)-import Language.Haskell.TH.PprLib-import Language.Haskell.TH.Syntax-import Data.Char ( toLower )--nestDepth :: Int-nestDepth = 4--type Precedence = Int-appPrec, opPrec, noPrec :: Precedence-appPrec = 2 -- Argument of a function application-opPrec = 1 -- Argument of an infix operator-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 (ClassI d) = ppr d- ppr (TyConI d) = ppr d- ppr (PrimTyConI name arity is_unlifted) - = text "Primitive"- <+> (if is_unlifted then text "unlifted" else empty)- <+> text "type construtor" <+> quotes (ppr name)- <+> parens (text "arity" <+> int arity)- ppr (ClassOpI v ty cls fix) - = text "Class op from" <+> ppr cls <> colon <+>- vcat [ppr_sig v ty, pprFixity v fix]- ppr (DataConI v ty tc fix) - = text "Constructor from" <+> ppr tc <> colon <+>- vcat [ppr_sig v ty, pprFixity v fix]- ppr (TyVarI v ty)- = text "Type variable" <+> ppr v <+> equals <+> ppr ty- ppr (VarI v ty mb_d fix) - = vcat [ppr_sig v ty, pprFixity v fix, - case mb_d of { Nothing -> empty; Just d -> ppr d }]--ppr_sig :: Name -> Type -> Doc-ppr_sig v ty = ppr v <+> text "::" <+> 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"----------------------------------instance Ppr Exp where- ppr = pprExp noPrec--pprInfixExp :: Exp -> Doc-pprInfixExp (VarE v) = pprName' Infix v-pprInfixExp (ConE v) = pprName' Infix v-pprInfixExp _ = error "Attempt to pretty-print non-variable or 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 (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 ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)- <+> text "->" <+> ppr e-pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es--- Nesting in Cond is to avoid potential problems in do statments-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 (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds- $$ text " in" <+> ppr e-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" <+> ppr ss-pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"--- This will probably break with fixity declarations - would need a ';'-pprExp _ (CompE ss) = text "[" <> ppr s- <+> text "|"- <+> (sep $ punctuate comma $ map ppr ss')- <> text "]"- where s = last ss- ss' = init ss-pprExp _ (ArithSeqE d) = ppr d-pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es-pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)--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" <+> ppr ds- ppr (NoBindS e) = ppr e- ppr (ParS sss) = sep $ punctuate (text "|")- $ map (sep . punctuate comma . map ppr) sss---------------------------------instance Ppr Match where- ppr (Match p rhs ds) = ppr p <+> pprBody False rhs- $$ where_clause ds---------------------------------pprBody :: Bool -> Body -> Doc-pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs- where eqd = if eq then text "=" else text "->"- do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e- do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)- $$ nest nestDepth (eqd <+> ppr e)-pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e---------------------------------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 _ (StringL s) = text (show s)-pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat---------------------------------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 $ sep $ punctuate comma $ map ppr ps-pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s- <+> sep (map (pprPat appPrec) ps)-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 $ sep $ punctuate comma $ map ppr ps-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t---------------------------------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 -> ppr 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 t (hsep (map ppr xs)) rhs-ppr_dec _ (DataD ctxt t xs cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs-ppr_dec _ (NewtypeD ctxt t xs c decs)- = ppr_newtype empty ctxt t (sep (map ppr xs)) 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 ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i- $$ where_clause ds-ppr_dec _ (SigD f t) = ppr f <+> text "::" <+> ppr t-ppr_dec _ (ForeignD f) = ppr f-ppr_dec _ (PragmaD p) = ppr p-ppr_dec isTop (FamilyD flav tc tvs k) - = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind- where- maybeFamily | isTop = text "family"- | otherwise = empty-- maybeKind | (Just k') <- k = text "::" <+> ppr k'- | otherwise = empty-ppr_dec isTop (DataInstD ctxt tc tys cs decs) - = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) - = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs- where- maybeInst | isTop = text "instance"- | otherwise = empty-ppr_dec isTop (TySynInstD tc tys rhs) - = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs- where- maybeInst | isTop = text "instance"- | otherwise = empty--ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc-ppr_data maybeInst ctxt t argsDoc cs decs- = text "data" <+> maybeInst- <+> pprCxt ctxt- <+> ppr t <+> argsDoc- <+> sep (pref $ map ppr cs)- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)- where - pref :: [Doc] -> [Doc]- pref [] = [] -- No constructors; can't happen in H98- pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds--ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc-ppr_newtype maybeInst ctxt t argsDoc c decs- = text "newtype" <+> maybeInst- <+> pprCxt ctxt- <+> ppr t <+> argsDoc- <+> char '=' <+> ppr c- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)--ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc-ppr_tySyn maybeInst t argsDoc rhs- = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs---------------------------------instance Ppr FunDep where- ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)- ppr_list [] = empty- ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))---------------------------------instance Ppr FamFlavour where- ppr DataFam = text "data"- ppr TypeFam = text "type"---------------------------------instance Ppr Foreign where- ppr (ImportF callconv safety impent as typ)- = text "foreign import"- <+> showtextl callconv- <+> showtextl safety- <+> text (show impent)- <+> ppr as- <+> text "::" <+> ppr typ- ppr (ExportF callconv expent as typ)- = text "foreign export"- <+> showtextl callconv- <+> text (show expent)- <+> ppr as- <+> text "::" <+> ppr typ---------------------------------instance Ppr Pragma where- ppr (InlineP n (InlineSpec inline conlike activation))- = text "{-#"- <+> (if inline then text "INLINE" else text "NOINLINE")- <+> (if conlike then text "CONLIKE" else empty)- <+> ppr_activation activation - <+> ppr n- <+> text "#-}"- ppr (SpecialiseP n ty Nothing)- = sep [ text "{-# SPECIALISE" - , ppr n <+> text "::"- , ppr ty- , text "#-}"- ]- ppr (SpecialiseP n ty (Just (InlineSpec inline _conlike activation)))- = sep [ text "{-# SPECIALISE" <+> - (if inline then text "INLINE" else text "NOINLINE") <+>- ppr_activation activation- , ppr n <+> text "::"- , ppr ty- , text "#-}"- ]- where--ppr_activation :: Maybe (Bool, Int) -> Doc-ppr_activation (Just (beforeFrom, i))- = brackets $ (if beforeFrom then empty else char '~') <+> int i-ppr_activation Nothing = empty---------------------------------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 pprStrictType sts)- ppr (RecC c vsts)- = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))- ppr (InfixC st1 c st2) = pprStrictType st1- <+> pprName' Infix c- <+> pprStrictType st2- ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)- <+> char '.' <+> pprCxt ctxt <+> ppr con---------------------------------pprVarStrictType :: (Name, Strict, Type) -> Doc--- Slight infelicity: with print non-atomic type with parens-pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)---------------------------------pprStrictType :: (Strict, Type) -> Doc--- Prints with parens if not already atomic-pprStrictType (IsStrict, t) = char '!' <> pprParendType t-pprStrictType (NotStrict, t) = pprParendType t---------------------------------pprParendType :: Type -> Doc-pprParendType (VarT v) = ppr v-pprParendType (ConT c) = ppr c-pprParendType (TupleT 0) = text "()"-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))-pprParendType ArrowT = parens (text "->")-pprParendType ListT = text "[]"-pprParendType other = parens (ppr other)--instance Ppr Type where- ppr (ForallT tvars ctxt ty)- = text "forall" <+> hsep (map ppr tvars) <+> text "."- <+> pprCxt ctxt <+> ppr ty- ppr (SigT ty k) = ppr ty <+> text "::" <+> ppr k- ppr ty = pprTyApp (split ty)--pprTyApp :: (Type, [Type]) -> Doc-pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]-pprTyApp (ListT, [arg]) = brackets (ppr arg)-pprTyApp (TupleT n, args)- | length args == n = parens (sep (punctuate comma (map ppr args)))-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType 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--split :: Type -> (Type, [Type]) -- Split into function and args-split t = go t []- where go (AppT t1 t2) args = go t1 (t2:args)- go ty args = (ty, args)---------------------------------instance Ppr TyVarBndr where- ppr (PlainTV nm) = ppr nm- ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k)--instance Ppr Kind where- ppr StarK = char '*'- ppr (ArrowK k1 k2) = pprArrowArgKind k1 <+> text "->" <+> ppr k2--pprArrowArgKind :: Kind -> Doc-pprArrowArgKind k@(ArrowK _ _) = parens (ppr k)-pprArrowArgKind k = ppr k---------------------------------pprCxt :: Cxt -> Doc-pprCxt [] = empty-pprCxt [t] = ppr t <+> text "=>"-pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"---------------------------------instance Ppr Pred where- ppr (ClassP cla tys) = ppr cla <+> sep (map pprParendType tys)- ppr (EqualP ty1 ty2) = pprFunArgType ty1 <+> char '~' <+> pprFunArgType ty2---------------------------------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)+{-# LANGUAGE Safe #-} -showtextl :: Show a => a -> Doc-showtextl = text . map toLower . show+{- | 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 +import GHC.Boot.TH.Ppr
Language/Haskell/TH/PprLib.hs view
@@ -1,216 +1,56 @@---- Monadic front-end to Text.PrettyPrint.HughesPJ+{-# 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, space, equals,- 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---import Language.Haskell.TH.Syntax- (Name(..), showName', NameFlavour(..), NameIs(..))-import qualified Text.PrettyPrint.HughesPJ as HPJ-import Control.Monad (liftM, liftM2)-import Data.Map ( Map )-import qualified Data.Map as Map ( lookup, insert, empty )-import GHC.Base (Int(..))--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-space :: Doc; -- ^ A space character-equals :: Doc; -- ^ A '=' character-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@(I# 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 Monad PprM where- return x = PprM $ \s -> (x, s)- 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-space = return HPJ.space-equals = return HPJ.equals-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.HughesPJ-punctuate _ [] = []-punctuate p (d:ds) = go d ds- where- go d' [] = [d']- go d' (e:es) = (d' <> p) : go e es+ ($$),+ ($+$),+ (<+>),+ (<>),+ 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 Prelude hiding ((<>))+import GHC.Boot.TH.PprLib
Language/Haskell/TH/Quote.hs view
@@ -1,62 +1,41 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}-module Language.Haskell.TH.Quote(- QuasiQuoter(..),- dataToQa, dataToExpQ, dataToPatQ- ) where+{-# LANGUAGE Safe #-}+{- |+Module : Language.Haskell.TH.Quote+Description : Quasi-quoting support for Template Haskell -import Data.Data-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Syntax+Template Haskell supports quasiquoting, which permits users to construct+program fragments by directly writing concrete syntax. A quasiquoter is+essentially a function with takes a string to a Template Haskell AST.+This module defines the 'QuasiQuoter' datatype, which specifies a+quasiquoter @q@ which can be invoked using the syntax+@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language+extension is enabled, and some utility functions for manipulating+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 -data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp,- quotePat :: String -> Q Pat }+import GHC.Boot.TH.Syntax+import GHC.Boot.TH.Quote+import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) -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 con conArgs- IntConstr n ->- mkLit $ integerL n- FloatConstr n ->- mkLit $ rationalL (toRational n)- CharConstr c ->- mkLit $ charL c- where- constr :: Constr- constr = toConstr t- constrName :: Constr -> String- constrName k =- case showConstr k of- "(:)" -> ":"- name -> name- con :: k- con = mkCon (mkName (constrName constr))- conArgs :: [Q q]- conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t - Just y -> y---- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same--- value. It takes a function to handle type-specific cases.-dataToExpQ :: Data a- => (forall b . Data b => b -> Maybe (Q Exp))- -> a- -> Q Exp-dataToExpQ = dataToQa conE litE (foldl appE)---- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same--- value. It takes a function to handle type-specific cases.-dataToPatQ :: Data a- => (forall b . Data b => b -> Maybe (Q Pat))- -> a- -> Q Pat-dataToPatQ = dataToQa id litP conP+-- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read+-- the data out of a file. For example, suppose @asmq@ is an+-- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]+-- as an expression. Then if you define @asmq_f = quoteFile asmq@, then+-- 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 })+ = 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)+ ; addDependentFile file_name+ ; old_quoter file_cts }
Language/Haskell/TH/Syntax.hs view
@@ -1,825 +1,399 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}--- The -fno-warn-warnings-deprecations flag is a temporary kludge.--- While working on this module you are encouraged to remove it and fix--- any warnings in the module. See--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings--- for details---------------------------------------------------------------------------------- |--- 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(- Quasi(..), Lift(..), liftString,-- Q, runQ, - report, recover, reify,- location, runIO,-- -- Names- Name(..), mkName, newName, nameBase, nameModule,- showName, showName', NameIs(..),-- -- The algebraic data types- Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,- Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),- Range(..), Lit(..), Pat(..), FieldExp, FieldPat, - Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),- InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..),- Info(..), Loc(..), CharPos,- Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,-- -- Internal functions- returnQ, bindQ, sequenceQ,- NameFlavour(..), NameSpace (..), - mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU,- tupleTypeName, tupleDataName,- OccName, mkOccName, occString,- ModName, mkModName, modString,- PkgName, mkPkgName, pkgString- ) where--import GHC.Base ( Int(..), Int#, (<#), (==#) )--import Language.Haskell.TH.Syntax.Internals-import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)-import qualified Data.Data as Data-import Data.IORef-import System.IO.Unsafe ( unsafePerformIO )-import Control.Monad (liftM)-import System.IO ( hPutStrLn, stderr )-import Data.Char ( isAlpha )------------------------------------------------------------- The Quasi class-----------------------------------------------------------class (Monad m, Functor m) => Quasi m where- -- Fresh names- qNewName :: String -> m Name-- -- 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 -> m a -> m a -- Recover from the monadic 'fail'- -- The first arg is the error handler- - -- Inspect the type-checker's environment- qReify :: Name -> m Info- qLocation :: m Loc-- -- Input/output (dangerous)- qRunIO :: IO a -> m a----------------------------------------------------------- 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 <- readIORef counter- ; writeIORef counter (n+1)- ; return (mkNameU s n) }-- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)-- qReify _ = badIO "reify"- qLocation = badIO "currentLocation"- qRecover _ _ = badIO "recover" -- Maybe we could fix this?-- qRunIO m = m- -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 }--runQ :: Quasi m => Q a -> m a-runQ (Q m) = m--instance Monad Q where- return x = Q (return x)- Q m >>= k = Q (m >>= \x -> unQ (k x))- Q m >> Q n = Q (m >> n)- fail s = report True s >> Q (fail "Q monad failure")--instance Functor Q where- fmap f (Q x) = Q (fmap f x)--------------------------------------------------------- Packaged versions for the programmer, hiding the Quasi-ness-newName :: String -> Q Name-newName s = Q (qNewName s)--report :: Bool -> String -> Q ()-report b s = Q (qReport b s)--recover :: Q a -> Q a -> Q a-recover (Q r) (Q m) = Q (qRecover r m)---- | 'reify' looks up information about the 'Name'-reify :: Name -> Q Info-reify v = Q (qReify v)---- | 'location' gives you 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 --- necesarily flushed when the compiler finishes running, so you should--- flush them yourself.-runIO :: IO a -> Q a-runIO m = Q (qRunIO m)--instance Quasi Q where- qNewName = newName- qReport = report- qRecover = recover - qReify = reify- qLocation = location- qRunIO = runIO---------------------------------------------------------- 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-----------------------------------------------------------class Lift t where- lift :: t -> Q Exp- -instance Lift Integer where- lift x = return (LitE (IntegerL x))--instance Lift Int where- lift x= return (LitE (IntegerL (fromIntegral 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))--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.Bool" "True"-falseName = mkNameG DataName "ghc-prim" "GHC.Bool" "False"--nothingName, justName :: Name-nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing"-justName = mkNameG DataName "base" "Data.Maybe" "Just"--leftName, rightName :: Name-leftName = mkNameG DataName "base" "Data.Either" "Left"-rightName = mkNameG DataName "base" "Data.Either" "Right"----------------------------------------------------------- Names and uniques --------------------------------------------------------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--data Name = Name OccName NameFlavour deriving (Typeable, Data)--data NameFlavour- = NameS -- An unqualified name; dynamically bound- | NameQ ModName -- A qualified name; dynamically bound-- | NameU Int# -- A unique local name-- -- The next two are for lexically-scoped names that- -- are bound *outside* the TH syntax tree, - -- either globally (NameG) or locally (NameL)- -- e.g. 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-- | NameL Int# -- - | NameG NameSpace PkgName ModName -- An original name (occurrences only, not binders)- -- Need the namespace too to be sure which - -- thing we are naming- deriving ( Typeable )---- Although the NameFlavour type is abstract, the Data instance is not. The reason for this--- is that currently we use Data to serialize values in annotations, and in order for that to--- work for Template Haskell names introduced via the 'x syntax we need gunfold on NameFlavour--- to work. Bleh!------ The long term solution to this is to use the binary package for annotation serialization and--- then remove this instance. However, to do _that_ we need to wait on binary to become stable, since--- boot libraries cannot be upgraded seperately from GHC itself.------ This instance cannot be derived automatically due to bug #2701-instance Data NameFlavour where- gfoldl _ z NameS = z NameS- gfoldl k z (NameQ mn) = z NameQ `k` mn- gfoldl k z (NameU i) = z (\(I# i') -> NameU i') `k` (I# i)- gfoldl k z (NameL i) = z (\(I# i') -> NameL i') `k` (I# i)- gfoldl k z (NameG ns p m) = z NameG `k` ns `k` p `k` m- gunfold k z c = case constrIndex c of- 1 -> z NameS- 2 -> k $ z NameQ- 3 -> k $ z (\(I# i) -> NameU i)- 4 -> k $ z (\(I# i) -> NameL i)- 5 -> k $ k $ k $ z NameG- _ -> error "gunfold: NameFlavour"- toConstr NameS = con_NameS- toConstr (NameQ _) = con_NameQ- toConstr (NameU _) = con_NameU- toConstr (NameL _) = con_NameL- toConstr (NameG _ _ _) = con_NameG- dataTypeOf _ = ty_NameFlavour--con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Data.Constr-con_NameS = mkConstr ty_NameFlavour "NameS" [] Data.Prefix-con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Data.Prefix-con_NameU = mkConstr ty_NameFlavour "NameU" [] Data.Prefix-con_NameL = mkConstr ty_NameFlavour "NameL" [] Data.Prefix-con_NameG = mkConstr ty_NameFlavour "NameG" [] Data.Prefix--ty_NameFlavour :: Data.DataType-ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"- [con_NameS, con_NameQ, con_NameU,- con_NameL, con_NameG]--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, Data, Typeable )--type Uniq = Int--nameBase :: Name -> String-nameBase (Name occ _) = occString occ--nameModule :: Name -> Maybe String-nameModule (Name _ (NameQ m)) = Just (modString m)-nameModule (Name _ (NameG _ _ m)) = Just (modString m)-nameModule _ = Nothing--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), - not (null rev), head rev /= '.'- = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))- -- The 'not (null occ)' guard ensures that- -- mkName "&." = Name "&." NameS- -- The 'rev' guards ensure that- -- mkName ".&" = Name ".&" NameS- -- 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--mkNameU :: String -> Uniq -> Name -- Only used internally-mkNameU s (I# u) = Name (mkOccName s) (NameU u)--mkNameL :: String -> Uniq -> Name -- Only used internally-mkNameL s (I# u) = Name (mkOccName s) (NameL u)--mkNameG :: NameSpace -> String -> String -> String -> Name -- Used for 'x etc, but not available-mkNameG ns pkg modu occ -- to the programmer- = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))--mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name-mkNameG_v = mkNameG VarName-mkNameG_tc = mkNameG TcClsName-mkNameG_d = mkNameG DataName--instance Eq Name where- v1 == v2 = cmpEq (v1 `compare` v2)--instance Ord Name where- (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`- (o1 `compare` o2)--instance Eq NameFlavour where- f1 == f2 = cmpEq (f1 `compare` f2)--instance Ord NameFlavour where- -- NameS < NameQ < NameU < NameL < NameG- NameS `compare` NameS = EQ- NameS `compare` _ = LT-- (NameQ _) `compare` NameS = GT- (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2- (NameQ _) `compare` _ = LT-- (NameU _) `compare` NameS = GT- (NameU _) `compare` (NameQ _) = GT- (NameU u1) `compare` (NameU u2) | u1 <# u2 = LT- | u1 ==# u2 = EQ- | otherwise = GT- (NameU _) `compare` _ = LT-- (NameL _) `compare` NameS = GT- (NameL _) `compare` (NameQ _) = GT- (NameL _) `compare` (NameU _) = GT- (NameL u1) `compare` (NameL u2) | u1 <# u2 = LT- | u1 ==# u2 = EQ- | otherwise = GT- (NameL _) `compare` _ = LT-- (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp`- (p1 `compare` p2) `thenCmp`- (m1 `compare` m2) - (NameG _ _ _) `compare` _ = GT--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 (I# u)- Name occ (NameL u) -> occString occ ++ "_" ++ show (I# 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-tupleDataName :: Int -> Name -- Data constructor-tupleTypeName :: Int -> Name -- Type constructor--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 ',' ++ ")")- -- XXX Should it be GHC.Unit for 0 commas?- tup_mod = mkModName "GHC.Tuple"------------------------------------------------------------ Locations--------------------------------------------------------data Loc- = Loc { loc_filename :: String- , loc_package :: String- , loc_module :: String- , loc_start :: CharPos- , loc_end :: CharPos }--type CharPos = (Int, Int) -- Line and character position-------------------------------------------------------------- The Info returned by reification-----------------------------------------------------------data Info - = ClassI Dec- | ClassOpI- Name -- The class op itself- Type -- Type of the class-op (fully polymoprhic)- Name -- Name of the parent class- Fixity-- | TyConI Dec-- | PrimTyConI -- Ones that can't be expressed with a data type - -- decl, such as (->), Int#- Name - Int -- Arity- Bool -- False => lifted type; True => unlifted-- | DataConI - Name -- The data con itself- Type -- Type of the constructor (fully polymorphic)- Name -- Name of the parent TyCon- Fixity-- | VarI - Name -- The variable itself- Type - (Maybe Dec) -- Nothing for lambda-bound variables, and - -- for anything else TH can't figure out- -- E.g. [| let x = 1 in $(do { d <- reify 'x; .. }) |]- Fixity-- | TyVarI -- Scoped type variable- Name- Type -- What it is bound to- deriving( Show, Data, Typeable )--data Fixity = Fixity Int FixityDirection- deriving( Eq, Show, Data, Typeable )-data FixityDirection = InfixL | InfixR | InfixN- deriving( Eq, Show, Data, Typeable )--maxPrecedence :: Int-maxPrecedence = (9::Int)--defaultFixity :: Fixity-defaultFixity = Fixity maxPrecedence InfixL-------------------------------------------------------------- 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- deriving( Show, Eq, Data, Typeable )-- -- We could add Int, Float, Double etc, as we do in HsLit, - -- but that could complicate the- -- suppposedly-simple TH.Syntax literal type--data Pat - = LitP Lit -- { 5 or 'c' }- | VarP Name -- { x }- | TupP [Pat] -- { (p1,p2) }- | ConP Name [Pat] -- data T1 = C1 t1 t2; {C1 p1 p1} = e - | InfixP Pat Name Pat -- foo ({x :+ y}) = e - | 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 }- deriving( Show, Eq, Data, Typeable )--type FieldPat = (Name,Pat)--data Match = Match Pat Body [Dec]- -- case e of { pat -> body where decs } - deriving( Show, Eq, Data, Typeable )-data Clause = Clause [Pat] Body [Dec]- -- f { p1 p2 = body where decs }- deriving( Show, Eq, Data, Typeable )- --- | The 'CompE' constructor represents a list comprehension, and --- takes a ['Stmt']. The result expression of the comprehension is--- the *last* of these, and should be a 'NoBindS'.--- E.g. [ f x | x <- xs ] is represented by--- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]-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 }-- | 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?-- | LamE [Pat] Exp -- { \ p1 p2 -> e }- | TupE [Exp] -- { (e1,e2) } - | CondE Exp Exp Exp -- { if e1 then e2 else e3 }- | LetE [Dec] Exp -- { let x=e1; y=e2 in e3 }- | CaseE Exp [Match] -- { case e of m1; m2 }- | DoE [Stmt] -- { do { p <- e1; e2 } }- | CompE [Stmt] -- { [ (x,y) | x <- xs, y <- ys ] }- | 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 } }- deriving( Show, Eq, Data, Typeable )--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, Data, Typeable )--data Guard- = NormalG Exp- | PatG [Stmt]- deriving( Show, Eq, Data, Typeable )--data Stmt- = BindS Pat Exp- | LetS [ Dec ]- | NoBindS Exp- | ParS [[Stmt]]- deriving( Show, Eq, Data, Typeable )--data Range = FromR Exp | FromThenR Exp Exp- | FromToR Exp Exp | FromThenToR Exp Exp Exp- deriving( Show, Eq, Data, Typeable )- -data Dec - = FunD Name [Clause] -- { f p1 p2 = b where decs }- | ValD Pat Body [Dec] -- { p = b where decs }- | DataD Cxt Name [TyVarBndr] - [Con] [Name] -- { data Cxt x => T x = A x | B (T x)- -- deriving (Z,W)}- | NewtypeD Cxt Name [TyVarBndr] - Con [Name] -- { newtype Cxt x => T x = A (B x)- -- deriving (Z,W)}- | TySynD Name [TyVarBndr] Type -- { type T x = (x,x) }- | ClassD Cxt Name [TyVarBndr] - [FunDep] [Dec] -- { class Eq a => Ord a where ds }- | InstanceD Cxt Type [Dec] -- { instance Show w => Show [w]- -- where ds }- | SigD Name Type -- { length :: [a] -> Int }- | ForeignD Foreign- -- pragmas- | PragmaD Pragma -- { {-# INLINE [1] foo #-} }- -- type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')- | FamilyD FamFlavour Name - [TyVarBndr] (Maybe Kind) -- { type family T a b c :: * }- - | DataInstD Cxt Name [Type]- [Con] [Name] -- { data instance Cxt x => T [x] = A x - -- | B (T x)- -- deriving (Z,W)}- | NewtypeInstD Cxt Name [Type]- Con [Name] -- { newtype instance Cxt x => T [x] = A (B x)- -- deriving (Z,W)}- | TySynInstD Name [Type] Type -- { type instance T (Maybe x) = (x,x) }- deriving( Show, Eq, Data, Typeable )--data FunDep = FunDep [Name] [Name]- deriving( Show, Eq, Data, Typeable )--data FamFlavour = TypeFam | DataFam- deriving( Show, Eq, Data, Typeable )--data Foreign = ImportF Callconv Safety String Name Type- | ExportF Callconv String Name Type- deriving( Show, Eq, Data, Typeable )--data Callconv = CCall | StdCall- deriving( Show, Eq, Data, Typeable )--data Safety = Unsafe | Safe | Threadsafe- deriving( Show, Eq, Data, Typeable )--data Pragma = InlineP Name InlineSpec- | SpecialiseP Name Type (Maybe InlineSpec)- deriving( Show, Eq, Data, Typeable )--data InlineSpec - = InlineSpec Bool -- False: no inline; True: inline - Bool -- False: fun-like; True: constructor-like- (Maybe (Bool, Int)) -- False: before phase; True: from phase- deriving( Show, Eq, Data, Typeable )--type Cxt = [Pred] -- (Eq a, Ord b)--data Pred = ClassP Name [Type] -- Eq (Int, a)- | EqualP Type Type -- F a ~ Bool- deriving( Show, Eq, Data, Typeable )--data Strict = IsStrict | NotStrict- deriving( Show, Eq, Data, Typeable )--data Con = NormalC Name [StrictType] -- C Int a- | RecC Name [VarStrictType] -- C { v :: Int, w :: a }- | InfixC StrictType Name StrictType -- Int :+ a- | ForallC [TyVarBndr] Cxt Con -- forall a. Eq a => C [a]- deriving( Show, Eq, Data, Typeable )--type StrictType = (Strict, Type)-type VarStrictType = (Name, Strict, Type)--data Type = ForallT [TyVarBndr] Cxt Type -- forall <vars>. <ctxt> -> <type>- | VarT Name -- a- | ConT Name -- T- | TupleT Int -- (,), (,,), etc.- | ArrowT -- ->- | ListT -- []- | AppT Type Type -- T a b- | SigT Type Kind -- t :: k- deriving( Show, Eq, Data, Typeable )--data TyVarBndr = PlainTV Name -- a- | KindedTV Name Kind -- (a :: k)- deriving( Show, Eq, Data, Typeable )--data Kind = StarK -- '*'- | ArrowK Kind Kind -- k1 -> k2- deriving( Show, Eq, Data, Typeable )---------------------------------------------------------- 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
− Language/Haskell/TH/Syntax/Internals.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving,DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : Language.Haskell.Syntax.Internals--- Copyright : (c) The University of Glasgow 2009--- 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.Internals (- ModName(..), PkgName(..), OccName(..)- ) where--import Data.Data--newtype ModName = ModName String -- Module name- deriving (Eq,Ord,Typeable,Data)--newtype PkgName = PkgName String -- package name- deriving (Eq,Ord,Typeable,Data)--newtype OccName = OccName String- deriving (Eq,Ord,Typeable,Data)
+ changelog.md view
@@ -0,0 +1,333 @@+# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)++## 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+ `Nothing` otherwise. `DataInstD`, `NewTypeInstD`, `TySynEqn` also now use+ a single `Type` argument to represent the left-hand-side to avoid+ malformed type family equations and allow visible kind application.++ Correspondingly, in `Language.Haskell.TH.Lib.Internal`, `pragRuleD`,+ `dataInstD`, `newtypeInstD`, and `tySynEqn` now all have a+ `Maybe [TyVarBndrQ]` argument. Non-API-breaking versions of these+ functions can be found in `Language.Haskell.TH.Lib`. The type signature+ of `tySynEqn` has also changed from `[TypeQ] -> TypeQ -> TySynEqnQ` to+ `(Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ`, for the same reason+ as in `Language.Haskell.TH.Syntax` above. Consequently, `tySynInstD` also+ changes from `Name -> TySynEqnQ -> DecQ` to `TySynEqnQ -> DecQ`.++ * Add `Lift` instances for `NonEmpty` and `Void`++ * `addForeignFilePath` now support assembler sources (#16180).++## 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+ takes the contents of the file as an argument, `addForeignFilePath` takes+ as an argument a path pointing to a foreign file. A new `addForeignSource`+ function has also been added which takes a file's contents as an argument.++ The old `addForeignFile` function is now deprecated in favor of+ `addForeignSource`, and the `qAddForeignFile` method of `Quasi` has been+ removed entirely.++ * Introduce an `addTempFile` function, as well as a corresponding+ `qAddTempFile` method to `Quasi`, which requests a temporary file of+ a given suffix.++ * Add a `ViaStrategy` constructor to `DerivStrategy`.++ * Add support for `-XImplicitParams` via `ImplicitParamT`,+ `ImplicitParamVarE`, and `ImplicitParamBindD`.++ * Add support for `-XRecursiveDo` via `MDoE` and `RecS`.++## 2.13.0.0 *March 2018*++ * Bundled with GHC 8.4.1++ * `Language.Haskell.TH.FamFlavour`, which was deprecated in 2.11,+ has been removed.++ * Add support for overloaded labels. Introduces `labelE :: String -> ExpQ`.++ * Add `KindQ`, `TyVarBndrQ`, and `FamilyResultSigQ` aliases to+ `Language.Haskell.TH.Lib`.++ * Add `Language.Haskell.TH.Lib.Internal` module, which 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.++ * `MonadIO` is now a superclass of `Quasi`, `qRunIO` has a default+ implementation `qRunIO = liftIO`++ * Add `MonadIO Q` instance++## 2.12.0.0 *July 2017*++ * Bundled with GHC 8.2.1++ * Add support for pattern synonyms. This introduces one new constructor to+ `Info` (`PatSynI`), two new constructors to `Dec` (`PatSynD` and+ `PatSynSigD`), and two new data types (`PatSynDir` and `PatSynArgs`),+ among other changes. (#8761)++ * Add support for unboxed sums. (#12478)++ * Add support for visible type applications. (#12530)++ * Add support for attaching deriving strategies to `deriving` statements+ (#10598)++ * Add support for `COMPLETE` pragmas. (#13098)++ * `unboxedTupleTypeName` and `unboxedTupleDataName` now work for unboxed+ 0-tuples and 1-tuples (#12977)++ * `Language.Haskell.TH` now reexports all of `Language.Haskell.TH.Lib`.+ (#12992). This causes `Language.Haskell.TH` to export more types and+ functions that it did before:+ - `TExp`, `BangQ`, and `FieldExpQ`+ - `unboxedTupP`, `unboxedTupE` and `unboundVarE`+ - `infixLD`, `infixRD`, and `infixND`+ - `unboxedTupleT` and `wildCardT`+ - `plainTV` and `kindedTV`+ - `interruptible` and `funDep`+ - `valueAnnotation`, `typeAnnotation`, and `moduleAnnotation`++ * Add support for overloaded labels.++## 2.11.0.0 *May 2016*++ * Bundled with GHC 8.0.1++ * The compiler can now resolve infix operator fixities in types on its own.+ The `UInfixT` constructor of `Type` is analoguous to `UInfixE` for expressions+ and can contain a tree of infix type applications which will be reassociated+ according to the fixities of the operators. The `ParensT` constructor can be+ used to explicitly group expressions.++ * Add `namePackage` and `nameSpace`++ * Make `dataToQa` and `dataToExpQ` able to handle `Data` instances whose+ `toConstr` implementation relies on a function instead of a data+ constructor (#10796)++ * Add `Show` instances for `NameFlavour` and `NameSpace`++ * Remove `FamilyD` and `FamFlavour`. Add `DataFamilyD` and `OpenTypeFamilyD`+ as the representation of data families and open type families+ respectively. (#6018)++ * Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and+ `ClosedTypeFamilyD` (#10902)++ * The `Strict` datatype was split among different datatypes: three for+ writing the strictness information of data constructors' fields as denoted+ in Haskell source code (`SourceUnpackedness` and `SourceStrictness`, as+ well as `Bang`), and one for strictness information after a constructor is+ compiled (`DecidedStrictness`). `Strict`, `StrictType` and `VarStrictType`+ have been deprecated in favor of `Bang`, `BangType` and `VarBangType`.+ (#10697)++ * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness`+ values for its fields (#10697)++ * The `ClassOpI`, `DataConI`, and `VarI` constructors no longer have a+ `Fixity` field. Instead, all `Fixity` information for a given `Name` is+ now determined through the `reifyFixity` function, which returns `Just` the+ fixity if there is an explicit fixity declaration for that `Name`, and+ `Nothing` otherwise (#10704 and #11345)++ * Add `MonadFail Q` instance for GHC 8.0 and later (#11661)++ * Add support for OVERLAP(S/PED/PING) pragmas on instances+++## 2.10.0.0 *Mar 2015*++ * Bundled with GHC 7.10.1+ * Remove build-dependency on `containers` package+ * Make `Pred` a type synonym of `Type`, and deprecate `classP`/`equalP` (#7021)+ * Add support for `LINE` pragma via `prageLineD` and `LineP`+ * Replace `Int#` with `!Int` in `NameFlavour` constructors+ * Derive `Generic` for TH types (#9527)+ * Add `standaloneDerivD` (#8100)+ * Add support for generic default signatures via `defaultSigD` (#9064)+ * Add `Lift` instances for `()` and `Rational`+ * Derive new `Show` and `Data` instances for `Loc`+ * Derive `Eq` instances for `Loc`, `Info`, and `ModuleInfo`+ * Make calling conventions available in template haskell consistent+ with those from GHC (#9703)+ * Add support for `-XStaticValues` via `staticE`+ * Add `Ord` instances to TH types+ * Merge some instances from `th-orphans` (`Ppr` instances for `Lit`+ and `Loc` as well as `Lift` instances for numeric types+ * Put parens around `(ty :: kind)` when pretty-printing TH syntax
template-haskell.cabal view
@@ -1,32 +1,69 @@-name: template-haskell-version: 2.4.0.1-license: BSD3-license-file: LICENSE-maintainer: libraries@haskell.org-bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=Template%20Haskell+-- 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.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/new+synopsis: Support library for Template Haskell+build-type: Simple+Cabal-Version: >= 1.10 description:- Facilities for manipulating Haskell source code using Template Haskell.-build-type: Simple-Cabal-Version: >= 1.6+ This package provides modules containing facilities for manipulating+ Haskell source code using Template Haskell.+ .+ See <http://www.haskell.org/haskellwiki/Template_Haskell> for more+ information. +extra-source-files: changelog.md++source-repository head+ type: git+ location: https://gitlab.haskell.org/ghc/ghc.git+ subdir: libraries/template-haskell+ Library- build-depends: base >= 4.2 && < 5,- pretty, containers+ default-language: Haskell2010+ other-extensions:+ BangPatterns+ CPP+ DefaultSignatures+ DeriveDataTypeable+ DeriveGeneric+ FlexibleInstances+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ exposed-modules:- Language.Haskell.TH.Syntax.Internals- Language.Haskell.TH.Syntax- Language.Haskell.TH.PprLib- Language.Haskell.TH.Ppr+ Language.Haskell.TH Language.Haskell.TH.Lib+ Language.Haskell.TH.Ppr+ Language.Haskell.TH.PprLib Language.Haskell.TH.Quote- Language.Haskell.TH- extensions: MagicHash, PatternGuards, PolymorphicComponents,- DeriveDataTypeable, TypeSynonymInstances- -- We need to set the package name to template-haskell (without a- -- version number) as it's magic.- ghc-options: -package-name template-haskell+ Language.Haskell.TH.Syntax+ Language.Haskell.TH.LanguageExtensions+ Language.Haskell.TH.CodeDo -source-repository head- type: darcs- location: http://darcs.haskell.org/packages/template-haskell/+ 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:+ System.FilePath+ System.FilePath.Posix+ System.FilePath.Windows+ hs-source-dirs: ./vendored-filepath .+ default-extensions:+ ImplicitPrelude++ ghc-options: -Wall
+ 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)