diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -1,13 +1,15 @@ {- | The public face of Template Haskell For other documentation, refer to: - + -} +{-# LANGUAGE Safe #-} module Language.Haskell.TH( -- * The monad and its operations Q, runQ, + Quote(..), -- ** Administration: errors, locations and IO reportError, -- :: String -> Q () reportWarning, -- :: String -> Q () @@ -20,6 +22,7 @@ -- *** Reify reify, -- :: Name -> Q Info reifyModule, + newDeclarationGroup, Info(..), ModuleInfo(..), InstanceDec, ParentName, @@ -34,6 +37,8 @@ lookupValueName, -- :: String -> Q (Maybe Name) -- *** Fixity lookup reifyFixity, + -- *** Type lookup + reifyType, -- *** Instance lookup reifyInstances, isInstance, @@ -46,12 +51,13 @@ -- * Typed expressions TExp, unType, + Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode, + bindCode_, joinCode, liftCode, -- * Names Name, NameSpace, -- Abstract -- ** Constructing names mkName, -- :: String -> Name - newName, -- :: String -> Q Name -- ** Deconstructing names nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String @@ -73,8 +79,9 @@ SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..), Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), - FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..), - Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, + FunDep(..), TySynEqn(..), TypeFamilyHead(..), + Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity, + maxPrecedence, PatSynDir(..), PatSynArgs(..), -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), @@ -82,7 +89,12 @@ Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), - FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, + Syntax.Specificity(..), + Syntax.BndrVis(..), + FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, + + -- ** Documentation + putDoc, getDoc, DocLoc(..), -- * Library functions module Language.Haskell.TH.Lib, diff --git a/Language/Haskell/TH/CodeDo.hs b/Language/Haskell/TH/CodeDo.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/CodeDo.hs @@ -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_ diff --git a/Language/Haskell/TH/LanguageExtensions.hs b/Language/Haskell/TH/LanguageExtensions.hs --- a/Language/Haskell/TH/LanguageExtensions.hs +++ b/Language/Haskell/TH/LanguageExtensions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.LanguageExtensions diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -1,1002 +1,458 @@ --- | --- TH.Lib contains lots of useful helper functions for --- generating and manipulating Template Haskell terms - -{-# LANGUAGE CPP #-} - -module Language.Haskell.TH.Lib ( - -- All of the exports from this module should - -- be "public" functions. The main module TH - -- re-exports them all. - - -- * Library functions - -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, - DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, - SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, - StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, - TySynEqnQ, PatSynDirQ, PatSynArgsQ, - - -- ** Constructors lifted to 'Q' - -- *** Literals - intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, - charL, stringL, stringPrimL, charPrimL, - -- *** Patterns - litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP, - infixP, tildeP, bangP, asP, wildP, recP, - listP, sigP, viewP, - fieldPat, - - -- *** Pattern Guards - normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, - - -- *** Expressions - dyn, varE, unboundVarE, conE, litE, appE, appTypeE, uInfixE, parensE, - staticE, infixE, infixApp, sectionL, sectionR, - lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE, - letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, - -- **** Ranges - fromE, fromThenE, fromToE, fromThenToE, - - -- ***** Ranges with more indirection - arithSeqE, - fromR, fromThenR, fromToR, fromThenToR, - -- **** Statements - doE, compE, - bindS, letS, noBindS, parS, - - -- *** Types - forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, - listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, - promotedT, promotedTupleT, promotedNilT, promotedConsT, - -- **** Type literals - numTyLit, strTyLit, - -- **** 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, - - -- *** Kinds - varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, - - -- *** Type variable binders - plainTV, kindedTV, - - -- *** Roles - nominalR, representationalR, phantomR, inferR, - - -- *** Top Level Declarations - -- **** Data - valD, funD, tySynD, dataD, newtypeD, - derivClause, DerivClause(..), DerivStrategy(..), - -- **** Class - classD, instanceD, instanceWithOverlapD, Overlap(..), - sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, - - -- **** Role annotations - roleAnnotD, - -- **** Type Family / Data Family - dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, - familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, - newtypeInstD, tySynInstD, - typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, - - -- **** Fixity - infixLD, infixRD, infixND, - - -- **** Foreign Function Interface (FFI) - cCall, stdCall, cApi, prim, javaScript, - unsafe, safe, interruptible, forImpD, - - -- **** Functional dependencies - funDep, - - -- **** Pragmas - ruleVar, typedRuleVar, - valueAnnotation, typeAnnotation, moduleAnnotation, - pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD, - pragLineD, pragCompleteD, - - -- **** Pattern Synonyms - patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn, - infixPatSyn, recordPatSyn, - - -- ** Reify - thisModule - - ) where - -import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) -import qualified Language.Haskell.TH.Syntax as TH -import Control.Monad( liftM, liftM2 ) -import Data.Word( Word8 ) - ----------------------------------------------------------- --- * Type synonyms ----------------------------------------------------------- - -type InfoQ = Q Info -type PatQ = Q Pat -type FieldPatQ = Q FieldPat -type ExpQ = Q Exp -type TExpQ a = Q (TExp a) -type DecQ = Q Dec -type DecsQ = Q [Dec] -type ConQ = Q Con -type TypeQ = Q Type -type TyLitQ = Q TyLit -type CxtQ = Q Cxt -type PredQ = Q Pred -type DerivClauseQ = Q DerivClause -type MatchQ = Q Match -type ClauseQ = Q Clause -type BodyQ = Q Body -type GuardQ = Q Guard -type StmtQ = Q Stmt -type RangeQ = Q Range -type SourceStrictnessQ = Q SourceStrictness -type SourceUnpackednessQ = Q SourceUnpackedness -type BangQ = Q Bang -type BangTypeQ = Q BangType -type VarBangTypeQ = Q VarBangType -type StrictTypeQ = Q StrictType -type VarStrictTypeQ = Q VarStrictType -type FieldExpQ = Q FieldExp -type RuleBndrQ = Q RuleBndr -type TySynEqnQ = Q TySynEqn -type PatSynDirQ = Q PatSynDir -type PatSynArgsQ = Q PatSynArgs - --- must be defined here for DsMeta to find it -type Role = TH.Role -type InjectivityAnn = TH.InjectivityAnn - ----------------------------------------------------------- --- * Lowercase pattern syntax functions ----------------------------------------------------------- - -intPrimL :: Integer -> Lit -intPrimL = IntPrimL -wordPrimL :: Integer -> Lit -wordPrimL = WordPrimL -floatPrimL :: Rational -> Lit -floatPrimL = FloatPrimL -doublePrimL :: Rational -> Lit -doublePrimL = DoublePrimL -integerL :: Integer -> Lit -integerL = IntegerL -charL :: Char -> Lit -charL = CharL -charPrimL :: Char -> Lit -charPrimL = CharPrimL -stringL :: String -> Lit -stringL = StringL -stringPrimL :: [Word8] -> Lit -stringPrimL = StringPrimL -rationalL :: Rational -> Lit -rationalL = RationalL - -litP :: Lit -> PatQ -litP l = return (LitP l) - -varP :: Name -> PatQ -varP v = return (VarP v) - -tupP :: [PatQ] -> PatQ -tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} - -unboxedTupP :: [PatQ] -> PatQ -unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} - -unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ -unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } - -conP :: Name -> [PatQ] -> PatQ -conP n ps = do ps' <- sequence ps - return (ConP n ps') -infixP :: PatQ -> Name -> PatQ -> PatQ -infixP p1 n p2 = do p1' <- p1 - p2' <- p2 - return (InfixP p1' n p2') -uInfixP :: PatQ -> Name -> PatQ -> PatQ -uInfixP p1 n p2 = do p1' <- p1 - p2' <- p2 - return (UInfixP p1' n p2') -parensP :: PatQ -> PatQ -parensP p = do p' <- p - return (ParensP p') - -tildeP :: PatQ -> PatQ -tildeP p = do p' <- p - return (TildeP p') -bangP :: PatQ -> PatQ -bangP p = do p' <- p - return (BangP p') -asP :: Name -> PatQ -> PatQ -asP n p = do p' <- p - return (AsP n p') -wildP :: PatQ -wildP = return WildP -recP :: Name -> [FieldPatQ] -> PatQ -recP n fps = do fps' <- sequence fps - return (RecP n fps') -listP :: [PatQ] -> PatQ -listP ps = do ps' <- sequence ps - return (ListP ps') -sigP :: PatQ -> TypeQ -> PatQ -sigP p t = do p' <- p - t' <- t - return (SigP p' t') -viewP :: ExpQ -> PatQ -> PatQ -viewP e p = do e' <- e - p' <- p - return (ViewP e' p') - -fieldPat :: Name -> PatQ -> FieldPatQ -fieldPat n p = do p' <- p - return (n, p') - - -------------------------------------------------------------------------------- --- * Stmt - -bindS :: PatQ -> ExpQ -> StmtQ -bindS p e = liftM2 BindS p e - -letS :: [DecQ] -> StmtQ -letS ds = do { ds1 <- sequence ds; return (LetS ds1) } - -noBindS :: ExpQ -> StmtQ -noBindS e = do { e1 <- e; return (NoBindS e1) } - -parS :: [[StmtQ]] -> StmtQ -parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) } - -------------------------------------------------------------------------------- --- * Range - -fromR :: ExpQ -> RangeQ -fromR x = do { a <- x; return (FromR a) } - -fromThenR :: ExpQ -> ExpQ -> RangeQ -fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) } - -fromToR :: ExpQ -> ExpQ -> RangeQ -fromToR x y = do { a <- x; b <- y; return (FromToR a b) } - -fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ -fromThenToR x y z = do { a <- x; b <- y; c <- z; - return (FromThenToR a b c) } -------------------------------------------------------------------------------- --- * Body - -normalB :: ExpQ -> BodyQ -normalB e = do { e1 <- e; return (NormalB e1) } - -guardedB :: [Q (Guard,Exp)] -> BodyQ -guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') } - -------------------------------------------------------------------------------- --- * Guard - -normalG :: ExpQ -> GuardQ -normalG e = do { e1 <- e; return (NormalG e1) } - -normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp) -normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) } - -patG :: [StmtQ] -> GuardQ -patG ss = do { ss' <- sequence ss; return (PatG ss') } - -patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) -patGE ss e = do { ss' <- sequence ss; - e' <- e; - return (PatG ss', e') } - -------------------------------------------------------------------------------- --- * Match and Clause - --- | Use with 'caseE' -match :: PatQ -> BodyQ -> [DecQ] -> MatchQ -match p rhs ds = do { p' <- p; - r' <- rhs; - ds' <- sequence ds; - return (Match p' r' ds') } - --- | Use with 'funD' -clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ -clause ps r ds = do { ps' <- sequence ps; - r' <- r; - ds' <- sequence ds; - return (Clause ps' r' ds') } - - ---------------------------------------------------------------------------- --- * Exp - --- | Dynamically binding a variable (unhygenic) -dyn :: String -> ExpQ -dyn s = return (VarE (mkName s)) - -varE :: Name -> ExpQ -varE s = return (VarE s) - -conE :: Name -> ExpQ -conE s = return (ConE s) - -litE :: Lit -> ExpQ -litE c = return (LitE c) - -appE :: ExpQ -> ExpQ -> ExpQ -appE x y = do { a <- x; b <- y; return (AppE a b)} - -appTypeE :: ExpQ -> TypeQ -> ExpQ -appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } - -parensE :: ExpQ -> ExpQ -parensE x = do { x' <- x; return (ParensE x') } - -uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ -uInfixE x s y = do { x' <- x; s' <- s; y' <- y; - return (UInfixE x' s' y') } - -infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ -infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; - return (InfixE (Just a) s' (Just b))} -infixE Nothing s (Just y) = do { s' <- s; b <- y; - return (InfixE Nothing s' (Just b))} -infixE (Just x) s Nothing = do { a <- x; s' <- s; - return (InfixE (Just a) s' Nothing)} -infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) } - -infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ -infixApp x y z = infixE (Just x) y (Just z) -sectionL :: ExpQ -> ExpQ -> ExpQ -sectionL x y = infixE (Just x) y Nothing -sectionR :: ExpQ -> ExpQ -> ExpQ -sectionR x y = infixE Nothing x (Just y) - -lamE :: [PatQ] -> ExpQ -> ExpQ -lamE ps e = do ps' <- sequence ps - e' <- e - return (LamE ps' e') - --- | Single-arg lambda -lam1E :: PatQ -> ExpQ -> ExpQ -lam1E p e = lamE [p] e - -lamCaseE :: [MatchQ] -> ExpQ -lamCaseE ms = sequence ms >>= return . LamCaseE - -tupE :: [ExpQ] -> ExpQ -tupE es = do { es1 <- sequence es; return (TupE es1)} - -unboxedTupE :: [ExpQ] -> ExpQ -unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} - -unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ -unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } - -condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ -condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} - -multiIfE :: [Q (Guard, Exp)] -> ExpQ -multiIfE alts = sequence alts >>= return . MultiIfE - -letE :: [DecQ] -> ExpQ -> ExpQ -letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } - -caseE :: ExpQ -> [MatchQ] -> ExpQ -caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } - -doE :: [StmtQ] -> ExpQ -doE ss = do { ss1 <- sequence ss; return (DoE ss1) } - -compE :: [StmtQ] -> ExpQ -compE ss = do { ss1 <- sequence ss; return (CompE ss1) } - -arithSeqE :: RangeQ -> ExpQ -arithSeqE r = do { r' <- r; return (ArithSeqE r') } - -listE :: [ExpQ] -> ExpQ -listE es = do { es1 <- sequence es; return (ListE es1) } - -sigE :: ExpQ -> TypeQ -> ExpQ -sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) } - -recConE :: Name -> [Q (Name,Exp)] -> ExpQ -recConE c fs = do { flds <- sequence fs; return (RecConE c flds) } - -recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ -recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) } - -stringE :: String -> ExpQ -stringE = litE . stringL - -fieldExp :: Name -> ExpQ -> Q (Name, Exp) -fieldExp s e = do { e' <- e; return (s,e') } - --- | @staticE x = [| static x |]@ -staticE :: ExpQ -> ExpQ -staticE = fmap StaticE - -unboundVarE :: Name -> ExpQ -unboundVarE s = return (UnboundVarE s) - --- ** 'arithSeqE' Shortcuts -fromE :: ExpQ -> ExpQ -fromE x = do { a <- x; return (ArithSeqE (FromR a)) } - -fromThenE :: ExpQ -> ExpQ -> ExpQ -fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) } - -fromToE :: ExpQ -> ExpQ -> ExpQ -fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) } - -fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ -fromThenToE x y z = do { a <- x; b <- y; c <- z; - return (ArithSeqE (FromThenToR a b c)) } - - -------------------------------------------------------------------------------- --- * Dec - -valD :: PatQ -> BodyQ -> [DecQ] -> DecQ -valD p b ds = - do { p' <- p - ; ds' <- sequence ds - ; b' <- b - ; return (ValD p' b' ds') - } - -funD :: Name -> [ClauseQ] -> DecQ -funD nm cs = - do { cs1 <- sequence cs - ; return (FunD nm cs1) - } - -tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ -tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } - -dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] - -> DecQ -dataD ctxt tc tvs ksig cons derivs = - do - ctxt1 <- ctxt - cons1 <- sequence cons - derivs1 <- sequence derivs - return (DataD ctxt1 tc tvs ksig cons1 derivs1) - -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ] - -> DecQ -newtypeD ctxt tc tvs ksig con derivs = - do - ctxt1 <- ctxt - con1 <- con - derivs1 <- sequence derivs - return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) - -classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ -classD ctxt cls tvs fds decs = - do - decs1 <- sequence decs - ctxt1 <- ctxt - return $ ClassD ctxt1 cls tvs fds decs1 - -instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceD = instanceWithOverlapD Nothing - -instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceWithOverlapD o ctxt ty decs = - do - ctxt1 <- ctxt - decs1 <- sequence decs - ty1 <- ty - return $ InstanceD o ctxt1 ty1 decs1 - - - -sigD :: Name -> TypeQ -> DecQ -sigD fun ty = liftM (SigD fun) $ ty - -forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ -forImpD cc s str n ty - = do ty' <- ty - return $ ForeignD (ImportF cc s str n ty') - -infixLD :: Int -> Name -> DecQ -infixLD prec nm = return (InfixD (Fixity prec InfixL) nm) - -infixRD :: Int -> Name -> DecQ -infixRD prec nm = return (InfixD (Fixity prec InfixR) nm) - -infixND :: Int -> Name -> DecQ -infixND prec nm = return (InfixD (Fixity prec InfixN) nm) - -pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ -pragInlD name inline rm phases - = return $ PragmaD $ InlineP name inline rm phases - -pragSpecD :: Name -> TypeQ -> Phases -> DecQ -pragSpecD n ty phases - = do - ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 Nothing phases - -pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ -pragSpecInlD n ty inline phases - = do - ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases - -pragSpecInstD :: TypeQ -> DecQ -pragSpecInstD ty - = do - ty1 <- ty - return $ PragmaD $ SpecialiseInstP ty1 - -pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ -pragRuleD n bndrs lhs rhs phases - = do - bndrs1 <- sequence bndrs - lhs1 <- lhs - rhs1 <- rhs - return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases - -pragAnnD :: AnnTarget -> ExpQ -> DecQ -pragAnnD target expr - = do - exp1 <- expr - return $ PragmaD $ AnnP target exp1 - -pragLineD :: Int -> String -> DecQ -pragLineD line file = return $ PragmaD $ LineP line file - -pragCompleteD :: [Name] -> Maybe Name -> DecQ -pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty - -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] - -> DecQ -dataInstD ctxt tc tys ksig cons derivs = - do - ctxt1 <- ctxt - tys1 <- sequence tys - cons1 <- sequence cons - derivs1 <- sequence derivs - return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) - -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] - -> DecQ -newtypeInstD ctxt tc tys ksig con derivs = - do - ctxt1 <- ctxt - tys1 <- sequence tys - con1 <- con - derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) - -tySynInstD :: Name -> TySynEqnQ -> DecQ -tySynInstD tc eqn = - do - eqn1 <- eqn - return (TySynInstD tc eqn1) - -dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ -dataFamilyD tc tvs kind - = return $ DataFamilyD tc tvs kind - -openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig - -> Maybe InjectivityAnn -> DecQ -openTypeFamilyD tc tvs res inj - = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) - -closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig - -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ -closedTypeFamilyD tc tvs result injectivity eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) - --- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you --- remove this check please also: --- 1. remove deprecated functions --- 2. remove CPP language extension from top of this module --- 3. remove the FamFlavour data type from Syntax module --- 4. make sure that all references to FamFlavour are gone from DsMeta, --- Convert, TcSplice (follows from 3) -#if __GLASGOW_HASKELL__ >= 804 -#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD -#endif - -{-# DEPRECATED familyNoKindD, familyKindD - "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} -familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ -familyNoKindD flav tc tvs = - case flav of - TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) - DataFam -> return $ DataFamilyD tc tvs Nothing - -familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ -familyKindD flav tc tvs k = - case flav of - TypeFam -> - return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing) - DataFam -> return $ DataFamilyD tc tvs (Just k) - -{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD - "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} -closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ -closedTypeFamilyNoKindD tc tvs eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1) - -closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ -closedTypeFamilyKindD tc tvs kind eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing) - eqns1) - -roleAnnotD :: Name -> [Role] -> DecQ -roleAnnotD name roles = return $ RoleAnnotD name roles - -standaloneDerivD :: CxtQ -> TypeQ -> DecQ -standaloneDerivD = standaloneDerivWithStrategyD Nothing - -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = - do - ctxt <- ctxtq - ty <- tyq - return $ StandaloneDerivD ds ctxt ty - -defaultSigD :: Name -> TypeQ -> DecQ -defaultSigD n tyq = - do - ty <- tyq - return $ DefaultSigD n ty - --- | Pattern synonym declaration -patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ -patSynD name args dir pat = do - args' <- args - dir' <- dir - pat' <- pat - return (PatSynD name args' dir' pat') - --- | Pattern synonym type signature -patSynSigD :: Name -> TypeQ -> DecQ -patSynSigD nm ty = - do ty' <- ty - return $ PatSynSigD nm ty' - -tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ -tySynEqn lhs rhs = - do - lhs1 <- sequence lhs - rhs1 <- rhs - return (TySynEqn lhs1 rhs1) - -cxt :: [PredQ] -> CxtQ -cxt = sequence - -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' - -normalC :: Name -> [BangTypeQ] -> ConQ -normalC con strtys = liftM (NormalC con) $ sequence strtys - -recC :: Name -> [VarBangTypeQ] -> ConQ -recC con varstrtys = liftM (RecC con) $ sequence varstrtys - -infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ -infixC st1 con st2 = do st1' <- st1 - st2' <- st2 - return $ InfixC st1' con st2' - -forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ -forallC ns ctxt con = liftM2 (ForallC ns) ctxt con - -gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ -gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty - -recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ -recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty - -------------------------------------------------------------------------------- --- * Type - -forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ -forallT tvars ctxt ty = do - ctxt1 <- ctxt - ty1 <- ty - return $ ForallT tvars ctxt1 ty1 - -varT :: Name -> TypeQ -varT = return . VarT - -conT :: Name -> TypeQ -conT = return . ConT - -infixT :: TypeQ -> Name -> TypeQ -> TypeQ -infixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (InfixT t1' n t2') - -uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ -uInfixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (UInfixT t1' n t2') - -parensT :: TypeQ -> TypeQ -parensT t = do t' <- t - return (ParensT t') - -appT :: TypeQ -> TypeQ -> TypeQ -appT t1 t2 = do - t1' <- t1 - t2' <- t2 - return $ AppT t1' t2' - -arrowT :: TypeQ -arrowT = return ArrowT - -listT :: TypeQ -listT = return ListT - -litT :: TyLitQ -> TypeQ -litT l = fmap LitT l - -tupleT :: Int -> TypeQ -tupleT i = return (TupleT i) - -unboxedTupleT :: Int -> TypeQ -unboxedTupleT i = return (UnboxedTupleT i) - -unboxedSumT :: SumArity -> TypeQ -unboxedSumT arity = return (UnboxedSumT arity) - -sigT :: TypeQ -> Kind -> TypeQ -sigT t k - = do - t' <- t - return $ SigT t' k - -equalityT :: TypeQ -equalityT = return EqualityT - -wildCardT :: TypeQ -wildCardT = return WildCardT - -{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-} -classP :: Name -> [Q Type] -> Q Pred -classP cla tys - = do - tysl <- sequence tys - return (foldl AppT (ConT cla) tysl) - -{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-} -equalP :: TypeQ -> TypeQ -> PredQ -equalP tleft tright - = do - tleft1 <- tleft - tright1 <- tright - eqT <- equalityT - return (foldl AppT eqT [tleft1, tright1]) - -promotedT :: Name -> TypeQ -promotedT = return . PromotedT - -promotedTupleT :: Int -> TypeQ -promotedTupleT i = return (PromotedTupleT i) - -promotedNilT :: TypeQ -promotedNilT = return PromotedNilT - -promotedConsT :: TypeQ -promotedConsT = return PromotedConsT - -noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ -noSourceUnpackedness = return NoSourceUnpackedness -sourceNoUnpack = return SourceNoUnpack -sourceUnpack = return SourceUnpack - -noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ -noSourceStrictness = return NoSourceStrictness -sourceLazy = return SourceLazy -sourceStrict = return SourceStrict - -{-# DEPRECATED isStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} -{-# DEPRECATED notStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} -{-# DEPRECATED unpacked - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang sourceUnpack sourceStrict'"] #-} -isStrict, notStrict, unpacked :: Q Strict -isStrict = bang noSourceUnpackedness sourceStrict -notStrict = bang noSourceUnpackedness noSourceStrictness -unpacked = bang sourceUnpack sourceStrict - -bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ -bang u s = do u' <- u - s' <- s - return (Bang u' s') - -bangType :: BangQ -> TypeQ -> BangTypeQ -bangType = liftM2 (,) - -varBangType :: Name -> BangTypeQ -> VarBangTypeQ -varBangType v bt = do (b, t) <- bt - return (v, b, t) - -{-# DEPRECATED strictType - "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} -strictType :: Q Strict -> TypeQ -> StrictTypeQ -strictType = bangType - -{-# DEPRECATED varStrictType - "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} -varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ -varStrictType = varBangType - --- * Type Literals - -numTyLit :: Integer -> TyLitQ -numTyLit n = if n >= 0 then return (NumTyLit n) - else fail ("Negative type-level number: " ++ show n) - -strTyLit :: String -> TyLitQ -strTyLit s = return (StrTyLit s) - -------------------------------------------------------------------------------- --- * Kind - -plainTV :: Name -> TyVarBndr -plainTV = PlainTV - -kindedTV :: Name -> Kind -> TyVarBndr -kindedTV = KindedTV - -varK :: Name -> Kind -varK = VarT - -conK :: Name -> Kind -conK = ConT - -tupleK :: Int -> Kind -tupleK = TupleT - -arrowK :: Kind -arrowK = ArrowT - -listK :: Kind -listK = ListT - -appK :: Kind -> Kind -> Kind -appK = AppT - -starK :: Kind -starK = StarT - -constraintK :: Kind -constraintK = ConstraintT - -------------------------------------------------------------------------------- --- * Type family result - -noSig :: FamilyResultSig -noSig = NoSig - -kindSig :: Kind -> FamilyResultSig -kindSig = KindSig - -tyVarSig :: TyVarBndr -> FamilyResultSig -tyVarSig = TyVarSig - -------------------------------------------------------------------------------- --- * Injectivity annotation - -injectivityAnn :: Name -> [Name] -> InjectivityAnn -injectivityAnn = TH.InjectivityAnn - -------------------------------------------------------------------------------- --- * Role - -nominalR, representationalR, phantomR, inferR :: Role -nominalR = NominalR -representationalR = RepresentationalR -phantomR = PhantomR -inferR = InferR - -------------------------------------------------------------------------------- --- * Callconv - -cCall, stdCall, cApi, prim, javaScript :: Callconv -cCall = CCall -stdCall = StdCall -cApi = CApi -prim = Prim -javaScript = JavaScript - -------------------------------------------------------------------------------- --- * Safety - -unsafe, safe, interruptible :: Safety -unsafe = Unsafe -safe = Safe -interruptible = Interruptible - -------------------------------------------------------------------------------- --- * FunDep - -funDep :: [Name] -> [Name] -> FunDep -funDep = FunDep - -------------------------------------------------------------------------------- --- * FamFlavour - -typeFam, dataFam :: FamFlavour -typeFam = TypeFam -dataFam = DataFam - -------------------------------------------------------------------------------- --- * RuleBndr -ruleVar :: Name -> RuleBndrQ -ruleVar = return . RuleVar - -typedRuleVar :: Name -> TypeQ -> RuleBndrQ -typedRuleVar n ty = ty >>= return . TypedRuleVar n - -------------------------------------------------------------------------------- --- * AnnTarget -valueAnnotation :: Name -> AnnTarget -valueAnnotation = ValueAnnotation - -typeAnnotation :: Name -> AnnTarget -typeAnnotation = TypeAnnotation - -moduleAnnotation :: AnnTarget -moduleAnnotation = ModuleAnnotation - -------------------------------------------------------------------------------- --- * Pattern Synonyms (sub constructs) - -unidir, implBidir :: PatSynDirQ -unidir = return Unidir -implBidir = return ImplBidir - -explBidir :: [ClauseQ] -> PatSynDirQ -explBidir cls = do - cls' <- sequence cls - return (ExplBidir cls') - -prefixPatSyn :: [Name] -> PatSynArgsQ -prefixPatSyn args = return $ PrefixPatSyn args - -recordPatSyn :: [Name] -> PatSynArgsQ -recordPatSyn sels = return $ RecordPatSyn sels - -infixPatSyn :: Name -> Name -> PatSynArgsQ -infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 - --------------------------------------------------------------- --- * Useful helper function - -appsE :: [ExpQ] -> ExpQ -appsE [] = error "appsE []" -appsE [x] = x -appsE (x:y:zs) = appsE ( (appE x y) : zs ) - --- | Return the Module at the place of splicing. Can be used as an --- input for 'reifyModule'. -thisModule :: Q Module -thisModule = do - loc <- location - return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc) +{-# LANGUAGE Safe #-} + +-- | +-- Language.Haskell.TH.Lib contains lots of useful helper functions for +-- generating and manipulating Template Haskell terms + +-- 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. + + -- * 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, + + -- ** 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, + + -- *** 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, + + -- **** Ranges + fromE, fromThenE, fromToE, fromThenToE, + + -- ***** Ranges with more indirection + arithSeqE, + fromR, fromThenR, fromToR, fromThenToR, + -- **** Statements + doE, mdoE, compE, + bindS, letS, noBindS, parS, recS, + + -- *** 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, + + -- *** Kinds + varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, + + -- *** Type variable binders + DefaultBndrFlag(defaultBndrFlag), + plainTV, kindedTV, + plainInvisTV, kindedInvisTV, + plainBndrTV, kindedBndrTV, + specifiedSpec, inferredSpec, + bndrReq, bndrInvis, + + -- *** Roles + nominalR, representationalR, phantomR, inferR, + + -- *** Top Level Declarations + -- **** Data + valD, funD, tySynD, dataD, newtypeD, typeDataD, + derivClause, DerivClause(..), + stockStrategy, anyclassStrategy, newtypeStrategy, + viaStrategy, DerivStrategy(..), + -- **** Class + classD, instanceD, instanceWithOverlapD, Overlap(..), + sigD, kiSigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, + + -- **** Role annotations + roleAnnotD, + -- **** Type Family / Data Family + dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, + newtypeInstD, tySynInstD, + tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, + + -- **** Fixity + infixLD, infixRD, infixND, + + -- **** Default declaration + defaultD, + + -- **** Foreign Function Interface (FFI) + cCall, stdCall, cApi, prim, javaScript, + unsafe, safe, interruptible, forImpD, + + -- **** Functional dependencies + funDep, + + -- **** Pragmas + ruleVar, typedRuleVar, + valueAnnotation, typeAnnotation, moduleAnnotation, + pragInlD, pragSpecD, pragSpecInlD, + pragSpecED, pragSpecInlED, + pragSpecInstD, pragRuleD, pragAnnD, + pragLineD, pragCompleteD, + + -- **** Pattern Synonyms + patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn, + infixPatSyn, recordPatSyn, + + -- **** Implicit Parameters + implicitParamBindD, + + -- ** Reify + thisModule, + + -- ** Documentation + withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, + typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc + + ) where + +import GHC.Boot.TH.Lib hiding + ( tySynD + , dataD + , newtypeD + , typeDataD + , classD + , pragRuleD + , dataInstD + , newtypeInstD + , dataFamilyD + , openTypeFamilyD + , closedTypeFamilyD + , tySynEqn + , forallC + + , forallT + , sigT + + , plainTV + , kindedTV + , starK + , constraintK + + , noSig + , kindSig + , tyVarSig + + , derivClause + , standaloneDerivWithStrategyD + + , doE + , mdoE + , tupE + , unboxedTupE + + , conP + + , Role + , InjectivityAnn + ) +import qualified GHC.Boot.TH.Lib as Internal +import Language.Haskell.TH.Syntax + +import Control.Applicative (Applicative(..)) +import Foreign.ForeignPtr +import Data.Word +import Prelude hiding (Applicative(..)) + +-- All definitions below represent the "old" API, since their definitions are +-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before +-- 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 + +tySynD :: Quote m => Name -> [TyVarBndr BndrVis] -> m Type -> m Dec +tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } + +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 <- sequenceA cons + derivs1 <- sequenceA derivs + return (DataD ctxt1 tc tvs ksig cons1 derivs1) + +newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Con -> [m DerivClause] + -> m Dec +newtypeD ctxt tc tvs ksig con derivs = + do + ctxt1 <- ctxt + con1 <- con + derivs1 <- sequenceA derivs + return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) + +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 <- sequenceA decs + ctxt1 <- ctxt + return $ ClassD ctxt1 cls tvs fds decs1 + +pragRuleD :: Quote m => String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec +pragRuleD n bndrs lhs rhs phases + = do + bndrs1 <- sequenceA bndrs + lhs1 <- lhs + rhs1 <- rhs + return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases + +dataInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> [m Con] -> [m DerivClause] + -> m Dec +dataInstD ctxt tc tys ksig cons derivs = + do + ctxt1 <- ctxt + ty1 <- foldl appT (conT tc) tys + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs + return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) + +newtypeInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> m Con -> [m DerivClause] + -> m Dec +newtypeInstD ctxt tc tys ksig con derivs = + do + ctxt1 <- ctxt + ty1 <- foldl appT (conT tc) tys + con1 <- con + derivs1 <- sequenceA derivs + return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) + +dataFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Dec +dataFamilyD tc tvs kind + = pure $ DataFamilyD tc tvs kind + +openTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig + -> Maybe InjectivityAnn -> m Dec +openTypeFamilyD tc tvs res inj + = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) + +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) + +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 + +forallT :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type +forallT tvars ctxt ty = do + ctxt1 <- ctxt + ty1 <- ty + return $ ForallT tvars ctxt1 ty1 + +sigT :: Quote m => m Type -> Kind -> m Type +sigT t k + = do + t' <- t + return $ SigT t' k + +------------------------------------------------------------------------------- +-- * Type variable binders + +class DefaultBndrFlag flag where + defaultBndrFlag :: flag + +instance DefaultBndrFlag () where + defaultBndrFlag = () + +instance DefaultBndrFlag Specificity where + defaultBndrFlag = SpecifiedSpec + +instance DefaultBndrFlag BndrVis where + defaultBndrFlag = BndrReq + +plainTV :: DefaultBndrFlag flag => Name -> TyVarBndr flag +plainTV n = PlainTV n defaultBndrFlag + +kindedTV :: DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag +kindedTV n k = KindedTV n defaultBndrFlag k + +------------------------------------------------------------------------------- +-- * Kind + +starK :: Kind +starK = StarT + +constraintK :: Kind +constraintK = ConstraintT + +------------------------------------------------------------------------------- +-- * Type family result + +noSig :: FamilyResultSig +noSig = NoSig + +kindSig :: Kind -> FamilyResultSig +kindSig = KindSig + +tyVarSig :: TyVarBndr () -> FamilyResultSig +tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Top Level Declarations + +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' + +------------------------------------------------------------------------------- +-- * Bytes literals + +-- | Create a Bytes datatype representing raw bytes to be embedded into the +-- program/library binary. +-- +-- @since 2.16.0.0 +mkBytes + :: ForeignPtr Word8 -- ^ Pointer to the data + -> Word -- ^ Offset from the pointer + -> Word -- ^ Number of bytes + -> Bytes +mkBytes = Bytes + +------------------------------------------------------------------------------- +-- * Tuple expressions + +tupE :: Quote m => [m Exp] -> m Exp +tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)} + +unboxedTupE :: Quote m => [m Exp] -> m Exp +unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)} + +------------------------------------------------------------------------------- +-- * Do expressions + +doE :: Quote m => [m Stmt] -> m Exp +doE = Internal.doE Nothing + +mdoE :: Quote m => [m Stmt] -> m Exp +mdoE = Internal.mdoE Nothing + +------------------------------------------------------------------------------- +-- * Patterns + +conP :: Quote m => Name -> [m Pat] -> m Pat +conP n xs = Internal.conP n [] xs + + +-------------------------------------------------------------------------------- +-- * Constraint predicates (deprecated) + +{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-} +classP :: Quote m => Name -> [m Type] -> m Pred +classP cla tys + = do + tysl <- sequenceA tys + pure (foldl AppT (ConT cla) tysl) + +{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-} +equalP :: Quote m => m Type -> m Type -> m Pred +equalP tleft tright + = do + tleft1 <- tleft + tright1 <- tright + eqT <- equalityT + pure (foldl AppT eqT [tleft1, tright1]) + +-------------------------------------------------------------------------------- +-- * Strictness queries (deprecated) +{-# DEPRECATED isStrict + ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} +{-# DEPRECATED notStrict + ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} +{-# DEPRECATED unpacked + ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ", + "Example usage: 'bang sourceUnpack sourceStrict'"] #-} +isStrict, notStrict, unpacked :: Quote m => m Strict +isStrict = bang noSourceUnpackedness sourceStrict +notStrict = bang noSourceUnpackedness noSourceStrictness +unpacked = bang sourceUnpack sourceStrict + +{-# DEPRECATED strictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} +strictType :: Quote m => m Strict -> m Type -> m StrictType +strictType = bangType + +{-# DEPRECATED varStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} +varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType +varStrictType = varBangType + +-------------------------------------------------------------------------------- +-- * Specialisation pragmas (backwards compatibility) + +pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec +pragSpecD n ty phases + = do + ty1 <- ty + pure $ PragmaD $ SpecialiseP n ty1 Nothing phases + +pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec +pragSpecInlD n ty inline phases + = do + ty1 <- ty + pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases diff --git a/Language/Haskell/TH/Lib/Map.hs b/Language/Haskell/TH/Lib/Map.hs deleted file mode 100644 --- a/Language/Haskell/TH/Lib/Map.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- This is a non-exposed internal module --- --- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost --- verbatimely to avoid a dependency of 'template-haskell' on the containers package. --- --- [1] see https://hackage.haskell.org/package/containers-0.5.5.1 --- --- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al. - -module Language.Haskell.TH.Lib.Map - ( Map - , empty - , insert - , Language.Haskell.TH.Lib.Map.lookup - ) where - -data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) - | Tip - -type Size = Int - -empty :: Map k a -empty = Tip -{-# INLINE empty #-} - -singleton :: k -> a -> Map k a -singleton k x = Bin 1 k x Tip Tip -{-# INLINE singleton #-} - -size :: Map k a -> Int -size Tip = 0 -size (Bin sz _ _ _ _) = sz -{-# INLINE size #-} - -lookup :: Ord k => k -> Map k a -> Maybe a -lookup = go - where - go _ Tip = Nothing - go !k (Bin _ kx x l r) = case compare k kx of - LT -> go k l - GT -> go k r - EQ -> Just x -{-# INLINABLE lookup #-} - - -insert :: Ord k => k -> a -> Map k a -> Map k a -insert = go - where - go :: Ord k => k -> a -> Map k a -> Map k a - go !kx x Tip = singleton kx x - go !kx x (Bin sz ky y l r) = - case compare kx ky of - LT -> balanceL ky y (go kx x l) r - GT -> balanceR ky y l (go kx x r) - EQ -> Bin sz kx x l r -{-# INLINABLE insert #-} - -balanceL :: k -> a -> Map k a -> Map k a -> Map k a -balanceL k x l r = case r of - Tip -> case l of - Tip -> Bin 1 k x Tip Tip - (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip - (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) - (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) - (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr)) - | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) - | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) - - (Bin rs _ _ _ _) -> case l of - Tip -> Bin (1+rs) k x Tip r - - (Bin ls lk lx ll lr) - | ls > delta*rs -> case (ll, lr) of - (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) - | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) - | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) - (_, _) -> error "Failure in Data.Map.balanceL" - | otherwise -> Bin (1+ls+rs) k x l r -{-# NOINLINE balanceL #-} - -balanceR :: k -> a -> Map k a -> Map k a -> Map k a -balanceR k x l r = case l of - Tip -> case r of - Tip -> Bin 1 k x Tip Tip - (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r - (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr - (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) - (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) - | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr - | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - - (Bin ls _ _ _ _) -> case r of - Tip -> Bin (1+ls) k x l Tip - - (Bin rs rk rx rl rr) - | rs > delta*ls -> case (rl, rr) of - (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) - | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr - | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) - (_, _) -> error "Failure in Data.Map.balanceR" - | otherwise -> Bin (1+ls+rs) k x l r -{-# NOINLINE balanceR #-} - -delta,ratio :: Int -delta = 3 -ratio = 2 diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -1,837 +1,91 @@ --- | contains a prettyprinter for the --- Template Haskell datatypes - -module Language.Haskell.TH.Ppr where - -- All of the exports from this module should - -- be "public" functions. The main module TH - -- re-exports them all. - -import Text.PrettyPrint (render) -import Language.Haskell.TH.PprLib -import Language.Haskell.TH.Syntax -import Data.Word ( Word8 ) -import Data.Char ( toLower, chr) -import GHC.Show ( showMultiLineString ) -import GHC.Lexeme( startsVarSym ) -import Data.Ratio ( numerator, denominator ) - -nestDepth :: Int -nestDepth = 4 - -type Precedence = Int -appPrec, unopPrec, opPrec, noPrec :: Precedence -appPrec = 3 -- Argument of a function application -opPrec = 2 -- Argument of an infix operator -unopPrec = 1 -- Argument of an unresolved 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 (TyConI d) = ppr d - ppr (ClassI d is) = ppr d $$ vcat (map ppr is) - ppr (FamilyI d is) = ppr d $$ vcat (map ppr is) - ppr (PrimTyConI name arity is_unlifted) - = text "Primitive" - <+> (if is_unlifted then text "unlifted" else empty) - <+> text "type constructor" <+> quotes (ppr name) - <+> parens (text "arity" <+> int arity) - ppr (ClassOpI v ty cls) - = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty - ppr (DataConI v ty tc) - = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty - ppr (PatSynI nm ty) = pprPatSynSig nm ty - ppr (TyVarI v ty) - = text "Type variable" <+> ppr v <+> equals <+> ppr ty - ppr (VarI v ty mb_d) - = vcat [ppr_sig v ty, - case mb_d of { Nothing -> empty; Just d -> ppr d }] - -ppr_sig :: Name -> Type -> Doc -ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty - -pprFixity :: Name -> Fixity -> Doc -pprFixity _ f | f == defaultFixity = empty -pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v - where ppr_fix InfixR = text "infixr" - ppr_fix InfixL = text "infixl" - ppr_fix InfixN = text "infix" - --- | Pretty prints a pattern synonym type signature -pprPatSynSig :: Name -> PatSynType -> Doc -pprPatSynSig nm ty - = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty - --- | Pretty prints a pattern synonym's type; follows the usual --- conventions to print a pattern synonym type compactly, yet --- unambiguously. See the note on 'PatSynType' and the section on --- pattern synonyms in the GHC user's guide for more information. -pprPatSynType :: PatSynType -> Doc -pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty'')) - | null exTys, null provs = ppr (ForallT uniTys reqs ty'') - | null uniTys, null reqs = noreqs <+> ppr ty' - | null reqs = forall uniTys <+> noreqs <+> ppr ty' - | otherwise = ppr ty - where noreqs = text "() =>" - forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "." -pprPatSynType ty = ppr ty - ------------------------------- -instance Ppr Module where - ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m) - -instance Ppr ModuleInfo where - ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps) - ------------------------------- -instance Ppr Exp where - ppr = pprExp noPrec - -pprPrefixOcc :: Name -> Doc --- Print operators with parens around them -pprPrefixOcc n = parensIf (isSymOcc n) (ppr n) - -isSymOcc :: Name -> Bool -isSymOcc n - = case nameBase n of - [] -> True -- Empty name; weird - (c:_) -> startsVarSym c - -- c.f. OccName.startsVarSym in GHC itself - -pprInfixExp :: Exp -> Doc -pprInfixExp (VarE v) = pprName' Infix v -pprInfixExp (ConE v) = pprName' Infix v -pprInfixExp _ = text "<>" - -pprExp :: Precedence -> Exp -> Doc -pprExp _ (VarE v) = pprName' Applied v -pprExp _ (ConE c) = pprName' Applied c -pprExp i (LitE l) = pprLit i l -pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 - <+> pprExp appPrec e2 -pprExp i (AppTypeE e t) - = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t -pprExp _ (ParensE e) = parens (pprExp noPrec e) -pprExp i (UInfixE e1 op e2) - = parensIf (i > unopPrec) $ pprExp unopPrec e1 - <+> pprInfixExp op - <+> pprExp unopPrec e2 -pprExp i (InfixE (Just e1) op (Just e2)) - = parensIf (i >= opPrec) $ pprExp opPrec e1 - <+> pprInfixExp op - <+> pprExp opPrec e2 -pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1 - <+> pprInfixExp op - <+> pprMaybeExp noPrec me2 -pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) - <+> text "->" <+> ppr e -pprExp i (LamCaseE ms) = parensIf (i > noPrec) - $ text "\\case" $$ nest nestDepth (ppr ms) -pprExp _ (TupE es) = parens (commaSep es) -pprExp _ (UnboxedTupE es) = hashParens (commaSep es) -pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity --- Nesting in Cond is to avoid potential problems in do 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 (MultiIfE alts) - = parensIf (i > noPrec) $ vcat $ - case alts of - [] -> [text "if {}"] - (alt : alts') -> text "if" <+> pprGuarded arrow alt - : map (nest 3 . pprGuarded arrow) alts' -pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_ - $$ text " in" <+> ppr e - where - pprDecs [] = empty - pprDecs [d] = ppr d - pprDecs ds = braces (semiSep ds) - -pprExp i (CaseE e ms) - = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" - $$ nest nestDepth (ppr ms) -pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ - where - pprStms [] = empty - pprStms [s] = ppr s - pprStms ss = braces (semiSep ss) - -pprExp _ (CompE []) = text "<>" --- This will probably break with fixity declarations - would need a ';' -pprExp _ (CompE ss) = - if null ss' - -- If there are no statements in a list comprehension besides the last - -- one, we simply treat it like a normal list. - then text "[" <> ppr s <> text "]" - else text "[" <> ppr s - <+> bar - <+> commaSep ss' - <> text "]" - where s = last ss - ss' = init ss -pprExp _ (ArithSeqE d) = ppr d -pprExp _ (ListE es) = brackets (commaSep es) -pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t -pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) -pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) -pprExp i (StaticE e) = parensIf (i >= appPrec) $ - text "static"<+> pprExp appPrec e -pprExp _ (UnboundVarE v) = pprName' Applied v - -pprFields :: [(Name,Exp)] -> Doc -pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) - -pprMaybeExp :: Precedence -> Maybe Exp -> Doc -pprMaybeExp _ Nothing = empty -pprMaybeExp i (Just e) = pprExp i e - ------------------------------- -instance Ppr Stmt where - ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e - ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) - ppr (NoBindS e) = ppr e - ppr (ParS sss) = sep $ punctuate bar - $ map commaSep sss - ------------------------------- -instance Ppr Match where - ppr (Match p rhs ds) = ppr p <+> pprBody False rhs - $$ where_clause ds - ------------------------------- -pprGuarded :: Doc -> (Guard, Exp) -> Doc -pprGuarded eqDoc (guard, expr) = case guard of - NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr - PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$ - nest nestDepth (eqDoc <+> ppr expr) - ------------------------------- -pprBody :: Bool -> Body -> Doc -pprBody eq body = case body of - GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs - NormalB e -> eqDoc <+> ppr e - where eqDoc | eq = equals - | otherwise = arrow - ------------------------------- -instance Ppr Lit where - ppr = pprLit noPrec - -pprLit :: Precedence -> Lit -> Doc -pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0) - (integer x <> char '#') -pprLit _ (WordPrimL x) = integer x <> text "##" -pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0) - (float (fromRational x) <> char '#') -pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0) - (double (fromRational x) <> text "##") -pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) -pprLit _ (CharL c) = text (show c) -pprLit _ (CharPrimL c) = text (show c) <> char '#' -pprLit _ (StringL s) = pprString s -pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' -pprLit i (RationalL rat) = parensIf (i > noPrec) $ - integer (numerator rat) <+> char '/' - <+> integer (denominator rat) - -bytesToString :: [Word8] -> String -bytesToString = map (chr . fromIntegral) - -pprString :: String -> Doc --- Print newlines as newlines with Haskell string escape notation, --- not as '\n'. For other non-printables use regular escape notation. -pprString s = vcat (map text (showMultiLineString s)) - ------------------------------- -instance Ppr Pat where - ppr = pprPat noPrec - -pprPat :: Precedence -> Pat -> Doc -pprPat i (LitP l) = pprLit i l -pprPat _ (VarP v) = pprName' Applied v -pprPat _ (TupP ps) = parens (commaSep ps) -pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) -pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity -pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s - <+> sep (map (pprPat appPrec) ps) -pprPat _ (ParensP p) = parens $ pprPat noPrec p -pprPat i (UInfixP p1 n p2) - = parensIf (i > unopPrec) (pprPat unopPrec p1 <+> - pprName' Infix n <+> - pprPat unopPrec p2) -pprPat i (InfixP p1 n p2) - = parensIf (i >= opPrec) (pprPat opPrec p1 <+> - pprName' Infix n <+> - pprPat opPrec p2) -pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p -pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p -pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" - <> pprPat appPrec p -pprPat _ WildP = text "_" -pprPat _ (RecP nm fs) - = parens $ ppr nm - <+> braces (sep $ punctuate comma $ - map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) -pprPat _ (ListP ps) = brackets (commaSep ps) -pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t -pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p - ------------------------------- -instance Ppr Dec where - ppr = ppr_dec True - -ppr_dec :: Bool -- declaration on the toplevel? - -> Dec - -> Doc -ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs -ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r - $$ where_clause ds -ppr_dec _ (TySynD t xs rhs) - = ppr_tySyn empty t (hsep (map ppr xs)) rhs -ppr_dec _ (DataD ctxt t xs ksig cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs -ppr_dec _ (NewtypeD ctxt t xs ksig c decs) - = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs -ppr_dec _ (ClassD ctxt c xs fds ds) - = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds - $$ where_clause ds -ppr_dec _ (InstanceD o ctxt i ds) = - text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i - $$ where_clause ds -ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t -ppr_dec _ (ForeignD f) = ppr f -ppr_dec _ (InfixD fx n) = pprFixity n fx -ppr_dec _ (PragmaD p) = ppr p -ppr_dec isTop (DataFamilyD tc tvs kind) - = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind - where - maybeFamily | isTop = text "family" - | otherwise = empty - maybeKind | (Just k') <- kind = dcolon <+> ppr k' - | otherwise = empty -ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs) - = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs - where - maybeInst | isTop = text "instance" - | otherwise = empty -ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs) - = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs - where - maybeInst | isTop = text "instance" - | otherwise = empty -ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs)) - = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs - where - maybeInst | isTop = text "instance" - | otherwise = empty -ppr_dec isTop (OpenTypeFamilyD tfhead) - = text "type" <+> maybeFamily <+> ppr_tf_head tfhead - where - maybeFamily | isTop = text "family" - | otherwise = empty -ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns) - = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") - nestDepth (vcat (map ppr_eqn eqns)) - where - ppr_eqn (TySynEqn lhs rhs) - = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs -ppr_dec _ (RoleAnnotD name roles) - = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) -ppr_dec _ (StandaloneDerivD ds cxt ty) - = hsep [ text "deriving" - , maybe empty ppr_deriv_strategy ds - , text "instance" - , pprCxt cxt - , ppr ty ] -ppr_dec _ (DefaultSigD n ty) - = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] -ppr_dec _ (PatSynD name args dir pat) - = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS - where - pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2 - | otherwise = ppr name <+> ppr args - pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") - nestDepth (ppr name <+> ppr cls) - | otherwise = ppr pat -ppr_dec _ (PatSynSigD name ty) - = pprPatSynSig name ty - -ppr_deriv_strategy :: DerivStrategy -> Doc -ppr_deriv_strategy ds = text $ - case ds of - StockStrategy -> "stock" - AnyclassStrategy -> "anyclass" - NewtypeStrategy -> "newtype" - -ppr_overlap :: Overlap -> Doc -ppr_overlap o = text $ - case o of - Overlaps -> "{-# OVERLAPS #-}" - Overlappable -> "{-# OVERLAPPABLE #-}" - Overlapping -> "{-# OVERLAPPING #-}" - Incoherent -> "{-# INCOHERENT #-}" - -ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] - -> Doc -ppr_data maybeInst ctxt t argsDoc ksig cs decs - = sep [text "data" <+> maybeInst - <+> pprCxt ctxt - <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere, - nest nestDepth (sep (pref $ map ppr cs)), - if null decs - then empty - else nest nestDepth - $ vcat $ map ppr_deriv_clause decs] - where - pref :: [Doc] -> [Doc] - pref xs | isGadtDecl = xs - pref [] = [] -- No constructors; can't happen in H98 - pref (d:ds) = (char '=' <+> d):map (bar <+>) ds - - maybeWhere :: Doc - maybeWhere | isGadtDecl = text "where" - | otherwise = empty - - isGadtDecl :: Bool - isGadtDecl = not (null cs) && all isGadtCon cs - where isGadtCon (GadtC _ _ _ ) = True - isGadtCon (RecGadtC _ _ _) = True - isGadtCon (ForallC _ _ x ) = isGadtCon x - isGadtCon _ = False - - ksigDoc = case ksig of - Nothing -> empty - Just k -> dcolon <+> ppr k - -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause] - -> Doc -ppr_newtype maybeInst ctxt t argsDoc ksig c decs - = sep [text "newtype" <+> maybeInst - <+> pprCxt ctxt - <+> ppr t <+> argsDoc <+> ksigDoc, - nest 2 (char '=' <+> ppr c), - if null decs - then empty - else nest nestDepth - $ vcat $ map ppr_deriv_clause decs] - where - ksigDoc = case ksig of - Nothing -> empty - Just k -> dcolon <+> ppr k - -ppr_deriv_clause :: DerivClause -> Doc -ppr_deriv_clause (DerivClause ds ctxt) - = text "deriving" <+> maybe empty ppr_deriv_strategy ds - <+> ppr_cxt_preds ctxt - -ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc -ppr_tySyn maybeInst t argsDoc rhs - = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs - -ppr_tf_head :: TypeFamilyHead -> Doc -ppr_tf_head (TypeFamilyHead tc tvs res inj) - = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj - where - maybeInj | (Just inj') <- inj = ppr inj' - | otherwise = empty - ------------------------------- -instance Ppr FunDep where - ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) - ppr_list [] = empty - ppr_list xs = bar <+> commaSep xs - ------------------------------- -instance Ppr FamFlavour where - ppr DataFam = text "data" - ppr TypeFam = text "type" - ------------------------------- -instance Ppr FamilyResultSig where - ppr NoSig = empty - ppr (KindSig k) = dcolon <+> ppr k - ppr (TyVarSig bndr) = text "=" <+> ppr bndr - ------------------------------- -instance Ppr InjectivityAnn where - ppr (InjectivityAnn lhs rhs) = - bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) - ------------------------------- -instance Ppr Foreign where - ppr (ImportF callconv safety impent as typ) - = text "foreign import" - <+> showtextl callconv - <+> showtextl safety - <+> text (show impent) - <+> ppr as - <+> dcolon <+> ppr typ - ppr (ExportF callconv expent as typ) - = text "foreign export" - <+> showtextl callconv - <+> text (show expent) - <+> ppr as - <+> dcolon <+> ppr typ - ------------------------------- -instance Ppr Pragma where - ppr (InlineP n inline rm phases) - = text "{-#" - <+> ppr inline - <+> ppr rm - <+> ppr phases - <+> ppr n - <+> text "#-}" - ppr (SpecialiseP n ty inline phases) - = text "{-# SPECIALISE" - <+> maybe empty ppr inline - <+> ppr phases - <+> sep [ ppr n <+> dcolon - , nest 2 $ ppr ty ] - <+> text "#-}" - ppr (SpecialiseInstP inst) - = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}" - ppr (RuleP n bndrs lhs rhs phases) - = sep [ text "{-# RULES" <+> pprString n <+> ppr phases - , nest 4 $ ppr_forall <+> ppr lhs - , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ] - where ppr_forall | null bndrs = empty - | otherwise = text "forall" - <+> fsep (map ppr bndrs) - <+> char '.' - ppr (AnnP tgt expr) - = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}" - where target1 ModuleAnnotation = text "module" - target1 (TypeAnnotation t) = text "type" <+> ppr t - target1 (ValueAnnotation v) = ppr v - ppr (LineP line file) - = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" - ppr (CompleteP cls mty) - = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls) - <+> maybe empty (\ty -> dcolon <+> ppr ty) mty - ------------------------------- -instance Ppr Inline where - ppr NoInline = text "NOINLINE" - ppr Inline = text "INLINE" - ppr Inlinable = text "INLINABLE" - ------------------------------- -instance Ppr RuleMatch where - ppr ConLike = text "CONLIKE" - ppr FunLike = empty - ------------------------------- -instance Ppr Phases where - ppr AllPhases = empty - ppr (FromPhase i) = brackets $ int i - ppr (BeforePhase i) = brackets $ char '~' <> int i - ------------------------------- -instance Ppr RuleBndr where - ppr (RuleVar n) = ppr n - ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty - ------------------------------- -instance Ppr Clause where - ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs - $$ where_clause ds - ------------------------------- -instance Ppr Con where - ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) - - ppr (RecC c vsts) - = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) - - ppr (InfixC st1 c st2) = pprBangType st1 - <+> pprName' Infix c - <+> pprBangType st2 - - ppr (ForallC ns ctxt (GadtC c sts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt - <+> pprGadtRHS sts ty - - ppr (ForallC ns ctxt (RecGadtC c vsts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt - <+> pprRecFields vsts ty - - ppr (ForallC ns ctxt con) - = pprForall ns ctxt <+> ppr con - - ppr (GadtC c sts ty) - = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty - - ppr (RecGadtC c vsts ty) - = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty - -instance Ppr PatSynDir where - ppr Unidir = text "<-" - ppr ImplBidir = text "=" - ppr (ExplBidir _) = text "<-" - -- the ExplBidir's clauses are pretty printed together with the - -- entire pattern synonym; so only print the direction here. - -instance Ppr PatSynArgs where - ppr (PrefixPatSyn args) = sep $ map ppr args - ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2 - ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels)) - -commaSepApplied :: [Name] -> Doc -commaSepApplied = commaSepWith (pprName' Applied) - -pprForall :: [TyVarBndr] -> Cxt -> Doc -pprForall tvs cxt - -- even in the case without any tvs, there could be a non-empty - -- context cxt (e.g., in the case of pattern synonyms, where there - -- are multiple forall binders and contexts). - | [] <- tvs = pprCxt cxt - | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt - -pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc -pprRecFields vsts ty - = braces (sep (punctuate comma $ map pprVarBangType vsts)) - <+> arrow <+> ppr ty - -pprGadtRHS :: [(Strict, Type)] -> Type -> Doc -pprGadtRHS [] ty - = ppr ty -pprGadtRHS sts ty - = sep (punctuate (space <> arrow) (map pprBangType sts)) - <+> arrow <+> ppr ty - ------------------------------- -pprVarBangType :: VarBangType -> Doc --- Slight infelicity: with print non-atomic type with parens -pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t) - ------------------------------- -pprBangType :: BangType -> Doc --- Make sure we print --- --- Con {-# UNPACK #-} a --- --- rather than --- --- Con {-# UNPACK #-}a --- --- when there's no strictness annotation. If there is a strictness annotation, --- it's okay to not put a space between it and the type. -pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t -pprBangType (bt, t) = ppr bt <> pprParendType t - ------------------------------- -instance Ppr Bang where - ppr (Bang su ss) = ppr su <+> ppr ss - ------------------------------- -instance Ppr SourceUnpackedness where - ppr NoSourceUnpackedness = empty - ppr SourceNoUnpack = text "{-# NOUNPACK #-}" - ppr SourceUnpack = text "{-# UNPACK #-}" - ------------------------------- -instance Ppr SourceStrictness where - ppr NoSourceStrictness = empty - ppr SourceLazy = char '~' - ppr SourceStrict = char '!' - ------------------------------- -instance Ppr DecidedStrictness where - ppr DecidedLazy = empty - ppr DecidedStrict = char '!' - ppr DecidedUnpack = text "{-# UNPACK #-} !" - ------------------------------- -{-# DEPRECATED pprVarStrictType - "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-} -pprVarStrictType :: (Name, Strict, Type) -> Doc -pprVarStrictType = pprVarBangType - ------------------------------- -{-# DEPRECATED pprStrictType - "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-} -pprStrictType :: (Strict, Type) -> Doc -pprStrictType = pprBangType - ------------------------------- -pprParendType :: Type -> Doc -pprParendType (VarT v) = ppr v -pprParendType (ConT c) = ppr c -pprParendType (TupleT 0) = text "()" -pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) -pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma -pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar -pprParendType ArrowT = parens (text "->") -pprParendType ListT = text "[]" -pprParendType (LitT l) = pprTyLit l -pprParendType (PromotedT c) = text "'" <> ppr c -pprParendType (PromotedTupleT 0) = text "'()" -pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) -pprParendType PromotedNilT = text "'[]" -pprParendType PromotedConsT = text "(':)" -pprParendType StarT = char '*' -pprParendType ConstraintT = text "Constraint" -pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) -pprParendType WildCardT = char '_' -pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) -pprParendType t@(UInfixT {}) = parens (pprUInfixT t) -pprParendType (ParensT t) = ppr t -pprParendType tuple | (TupleT n, args) <- split tuple - , length args == n - = parens (commaSep args) -pprParendType other = parens (ppr other) - -pprUInfixT :: Type -> Doc -pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y -pprUInfixT t = ppr t - -instance Ppr Type where - ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] - ppr ty = pprTyApp (split ty) - -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) - -- See Note [Pretty-printing kind signatures] - -{- Note [Pretty-printing kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC's parser only recognises a kind signature in a type when there are -parens around it. E.g. the parens are required here: - f :: (Int :: *) - type instance F Int = (Bool :: *) -So we always print a SigT with parens (see Trac #10050). -} - -pprTyApp :: (Type, [Type]) -> Doc -pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (EqualityT, [arg1, arg2]) = - sep [pprFunArgType arg1 <+> text "~", ppr arg2] -pprTyApp (ListT, [arg]) = brackets (ppr arg) -pprTyApp (TupleT n, args) - | length args == n = parens (commaSep args) -pprTyApp (PromotedTupleT n, args) - | length args == n = quoteParens (commaSep args) -pprTyApp (fun, args) = pprParendType fun <+> sep (map 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) - -pprTyLit :: TyLit -> Doc -pprTyLit (NumTyLit n) = integer n -pprTyLit (StrTyLit s) = text (show s) - -instance Ppr TyLit where - ppr = pprTyLit - ------------------------------- -instance Ppr TyVarBndr where - ppr (PlainTV nm) = ppr nm - ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) - -instance Ppr Role where - ppr NominalR = text "nominal" - ppr RepresentationalR = text "representational" - ppr PhantomR = text "phantom" - ppr InferR = text "_" - ------------------------------- -pprCxt :: Cxt -> Doc -pprCxt [] = empty -pprCxt ts = ppr_cxt_preds ts <+> text "=>" - -ppr_cxt_preds :: Cxt -> Doc -ppr_cxt_preds [] = empty -ppr_cxt_preds [t] = ppr t -ppr_cxt_preds ts = parens (commaSep ts) - ------------------------------- -instance Ppr Range where - ppr = brackets . pprRange - where pprRange :: Range -> Doc - pprRange (FromR e) = ppr e <> text ".." - pprRange (FromThenR e1 e2) = ppr e1 <> text "," - <> ppr e2 <> text ".." - pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2 - pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text "," - <> ppr e2 <> text ".." - <> ppr e3 - ------------------------------- -where_clause :: [Dec] -> Doc -where_clause [] = empty -where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds) - -showtextl :: Show a => a -> Doc -showtextl = text . map toLower . show - -hashParens :: Doc -> Doc -hashParens d = text "(# " <> d <> text " #)" - -quoteParens :: Doc -> Doc -quoteParens d = text "'(" <> d <> text ")" - ------------------------------ -instance Ppr Loc where - ppr (Loc { loc_module = md - , loc_package = pkg - , loc_start = (start_ln, start_col) - , loc_end = (end_ln, end_col) }) - = hcat [ text pkg, colon, text md, colon - , parens $ int start_ln <> comma <> int start_col - , text "-" - , parens $ int end_ln <> comma <> int end_col ] - --- Takes a list of printable things and prints them separated by commas followed --- by space. -commaSep :: Ppr a => [a] -> Doc -commaSep = commaSepWith ppr - --- Takes a list of things and prints them with the given pretty-printing --- function, separated by commas followed by space. -commaSepWith :: (a -> Doc) -> [a] -> Doc -commaSepWith pprFun = sep . punctuate comma . map pprFun - --- Takes a list of printable things and prints them separated by semicolons --- followed by space. -semiSep :: Ppr a => [a] -> Doc -semiSep = sep . punctuate semi . map ppr +{-# LANGUAGE Safe #-} --- Prints out the series of vertical bars that wraps an expression or pattern --- used in an unboxed sum. -unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc -unboxedSumBars d alt arity = hashParens $ - bars (alt-1) <> d <> bars (arity - alt) - where - bars i = hsep (replicate i bar) +{- | contains a prettyprinter for the +Template Haskell datatypes +-} +module Language.Haskell.TH.Ppr ( + appPrec, + bar, + bytesToString, + commaSep, + commaSepApplied, + commaSepWith, + fromTANormal, + funPrec, + hashParens, + isStarT, + isSymOcc, + nestDepth, + noPrec, + opPrec, + parensIf, + pprBangType, + pprBndrVis, + pprBody, + pprClause, + pprCtxWith, + pprCxt, + pprExp, + pprFields, + pprFixity, + pprForall, + pprForall', + pprForallVis, + pprFunArgType, + pprGadtRHS, + pprGuarded, + pprInfixExp, + pprInfixT, + pprLit, + pprMatchPat, + pprMaybeExp, + pprNamespaceSpecifier, + pprParendType, + pprParendTypeArg, + pprPat, + pprPatSynSig, + pprPatSynType, + pprPrefixOcc, + pprRecFields, + pprStrictType, + pprString, + pprTyApp, + pprTyLit, + pprType, + pprVarBangType, + pprVarStrictType, + ppr_bndrs, + ppr_ctx_preds_with, + ppr_cxt_preds, + ppr_data, + ppr_dec, + ppr_deriv_clause, + ppr_deriv_strategy, + ppr_newtype, + ppr_overlap, + ppr_sig, + ppr_tf_head, + ppr_tySyn, + ppr_type_data, + ppr_typedef, + pprint, + qualPrec, + quoteParens, + semiSep, + semiSepWith, + sepWith, + showtextl, + sigPrec, + split, + unboxedSumBars, + unopPrec, + where_clause, + ForallVisFlag (..), + Ppr (..), + PprFlag (..), + Precedence, + TypeArg (..), +) +where --- Text containing the vertical bar character. -bar :: Doc -bar = char '|' +import GHC.Boot.TH.Ppr diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs --- a/Language/Haskell/TH/PprLib.hs +++ b/Language/Haskell/TH/PprLib.hs @@ -1,225 +1,56 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} -- | Monadic front-end to Text.PrettyPrint - module Language.Haskell.TH.PprLib ( - - -- * The document type - Doc, -- Abstract, instance of Show - PprM, - - -- * Primitive Documents - empty, - semi, comma, colon, dcolon, space, equals, arrow, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, - - -- * Converting values into documents - text, char, ptext, - int, integer, float, double, rational, - - -- * Wrapping documents in delimiters - parens, brackets, braces, quotes, doubleQuotes, - - -- * Combining documents - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, - hang, punctuate, - - -- * Predicates on documents - isEmpty, - - to_HPJ_Doc, pprName, pprName' - ) where - - -import Language.Haskell.TH.Syntax - (Name(..), showName', NameFlavour(..), NameIs(..)) -import qualified Text.PrettyPrint as HPJ -import Control.Monad (liftM, liftM2, ap) -import Language.Haskell.TH.Lib.Map ( Map ) -import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) - -infixl 6 <> -infixl 6 <+> -infixl 5 $$, $+$ - --- --------------------------------------------------------------------------- --- The interface - --- The primitive Doc values - -instance Show Doc where - show d = HPJ.render (to_HPJ_Doc d) - -isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty - -empty :: Doc; -- ^ An empty document -semi :: Doc; -- ^ A ';' character -comma :: Doc; -- ^ A ',' character -colon :: Doc; -- ^ A ':' character -dcolon :: Doc; -- ^ A "::" string -space :: Doc; -- ^ A space character -equals :: Doc; -- ^ A '=' character -arrow :: Doc; -- ^ A "->" string -lparen :: Doc; -- ^ A '(' character -rparen :: Doc; -- ^ A ')' character -lbrack :: Doc; -- ^ A '[' character -rbrack :: Doc; -- ^ A ']' character -lbrace :: Doc; -- ^ A '{' character -rbrace :: Doc; -- ^ A '}' character - -text :: String -> Doc -ptext :: String -> Doc -char :: Char -> Doc -int :: Int -> Doc -integer :: Integer -> Doc -float :: Float -> Doc -double :: Double -> Doc -rational :: Rational -> Doc - - -parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ -doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ - --- Combining @Doc@ values - -(<>) :: Doc -> Doc -> Doc; -- ^Beside -hcat :: [Doc] -> Doc; -- ^List version of '<>' -(<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space -hsep :: [Doc] -> Doc; -- ^List version of '<+>' - -($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no - -- overlap it \"dovetails\" the two -($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. -vcat :: [Doc] -> Doc; -- ^List version of '$$' - -cat :: [Doc] -> Doc; -- ^ Either hcat or vcat -sep :: [Doc] -> Doc; -- ^ Either hsep or vcat -fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat -fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep - -nest :: Int -> Doc -> Doc; -- ^ Nested - - --- GHC-specific ones. - -hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ -punctuate :: Doc -> [Doc] -> [Doc] - -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ - --- --------------------------------------------------------------------------- --- The "implementation" - -type State = (Map Name Name, Int) -data PprM a = PprM { runPprM :: State -> (a, State) } - -pprName :: Name -> Doc -pprName = pprName' Alone - -pprName' :: NameIs -> Name -> Doc -pprName' ni n@(Name o (NameU _)) - = PprM $ \s@(fm, i) - -> let (n', s') = case Map.lookup n fm of - Just d -> (d, s) - Nothing -> let n'' = Name o (NameU i) - in (n'', (Map.insert n n'' fm, i + 1)) - in (HPJ.text $ showName' ni n', s') -pprName' ni n = text $ showName' ni n - -{- -instance Show Name where - show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u) - show (Name occ NameS) = occString occ - show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ - -data Name = Name OccName NameFlavour - -data NameFlavour - | NameU Int# -- A unique local name --} - -to_HPJ_Doc :: Doc -> HPJ.Doc -to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0) - -instance Functor PprM where - fmap = liftM - -instance Applicative PprM where - pure x = PprM $ \s -> (x, s) - (<*>) = ap - -instance Monad PprM where - m >>= k = PprM $ \s -> let (x, s') = runPprM m s - in runPprM (k x) s' - -type Doc = PprM HPJ.Doc - --- The primitive Doc values - -isEmpty = liftM HPJ.isEmpty - -empty = return HPJ.empty -semi = return HPJ.semi -comma = return HPJ.comma -colon = return HPJ.colon -dcolon = return $ HPJ.text "::" -space = return HPJ.space -equals = return HPJ.equals -arrow = return $ HPJ.text "->" -lparen = return HPJ.lparen -rparen = return HPJ.rparen -lbrack = return HPJ.lbrack -rbrack = return HPJ.rbrack -lbrace = return HPJ.lbrace -rbrace = return HPJ.rbrace - -text = return . HPJ.text -ptext = return . HPJ.ptext -char = return . HPJ.char -int = return . HPJ.int -integer = return . HPJ.integer -float = return . HPJ.float -double = return . HPJ.double -rational = return . HPJ.rational - - -parens = liftM HPJ.parens -brackets = liftM HPJ.brackets -braces = liftM HPJ.braces -quotes = liftM HPJ.quotes -doubleQuotes = liftM HPJ.doubleQuotes - --- Combining @Doc@ values - -(<>) = liftM2 (HPJ.<>) -hcat = liftM HPJ.hcat . sequence -(<+>) = liftM2 (HPJ.<+>) -hsep = liftM HPJ.hsep . sequence - -($$) = liftM2 (HPJ.$$) -($+$) = liftM2 (HPJ.$+$) -vcat = liftM HPJ.vcat . sequence - -cat = liftM HPJ.cat . sequence -sep = liftM HPJ.sep . sequence -fcat = liftM HPJ.fcat . sequence -fsep = liftM HPJ.fsep . sequence - -nest n = liftM (HPJ.nest n) - -hang d1 n d2 = do d1' <- d1 - d2' <- d2 - return (HPJ.hang d1' n d2') + ($$), + ($+$), + (<+>), + (<>), + 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 --- punctuate uses the same definition as Text.PrettyPrint -punctuate _ [] = [] -punctuate p (d:ds) = go d ds - where - go d' [] = [d'] - go d' (e:es) = (d' <> p) : go e es +import Prelude hiding ((<>)) +import GHC.Boot.TH.PprLib diff --git a/Language/Haskell/TH/Quote.hs b/Language/Haskell/TH/Quote.hs --- a/Language/Haskell/TH/Quote.hs +++ b/Language/Haskell/TH/Quote.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} {- | Module : Language.Haskell.TH.Quote Description : Quasi-quoting support for Template Haskell @@ -13,44 +13,29 @@ quasiquoters. Nota bene: this package does not define any parsers, that is up to you. -} -module Language.Haskell.TH.Quote( - QuasiQuoter(..), - quoteFile, - -- * For backwards compatibility - dataToQa, dataToExpQ, dataToPatQ - ) where +module Language.Haskell.TH.Quote + ( QuasiQuoter(..) + , quoteFile + -- * For backwards compatibility + , dataToQa, dataToExpQ, dataToPatQ + ) where -import Language.Haskell.TH.Syntax +import GHC.Boot.TH.Syntax +import GHC.Boot.TH.Quote +import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) --- | The 'QuasiQuoter' type, a value @q@ of this type can be used --- in the syntax @[q| ... string to parse ...|]@. In fact, for --- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters --- to be used in different splice contexts; if you are only interested --- in defining a quasiquoter to be used for expressions, you would --- define a 'QuasiQuoter' with only 'quoteExp', and leave the other --- fields stubbed out with errors. -data QuasiQuoter = QuasiQuoter { - -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@ - quoteExp :: String -> Q Exp, - -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@ - quotePat :: String -> Q Pat, - -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@ - quoteType :: String -> Q Type, - -- | Quasi-quoter for declarations, invoked by top-level quotes - quoteDec :: String -> Q [Dec] - } -- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read --- the data out of a file. For example, suppose 'asmq' is an +-- 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 }) +quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd } where get :: (String -> Q a) -> String -> Q a - get old_quoter file_name = do { file_cts <- runIO (readFile file_name) + get old_quoter file_name = do { file_cts <- runIO (readFile file_name) ; addDependentFile file_name ; old_quoter file_cts } diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -1,2027 +1,399 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, - DeriveGeneric, FlexibleInstances, DefaultSignatures, - RankNTypes, RoleAnnotations, ScopedTypeVariables, - Trustworthy #-} - -{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} - -#if MIN_VERSION_base(4,9,0) -# define HAS_MONADFAIL 1 -#endif - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Syntax --- Copyright : (c) The University of Glasgow 2003 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Abstract syntax definitions for Template Haskell. --- ------------------------------------------------------------------------------ - -module Language.Haskell.TH.Syntax - ( module Language.Haskell.TH.Syntax - -- * Language extensions - , module Language.Haskell.TH.LanguageExtensions - , ForeignSrcLang(..) - ) where - -import Data.Data hiding (Fixity(..)) -import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) -import Control.Monad (liftM) -import System.IO ( hPutStrLn, stderr ) -import Data.Char ( isAlpha, isAlphaNum, isUpper ) -import Data.Int -import Data.Word -import Data.Ratio -import GHC.Generics ( Generic ) -import GHC.Lexeme ( startsVarSym, startsVarId ) -import GHC.ForeignSrcLang.Type -import Language.Haskell.TH.LanguageExtensions -import Numeric.Natural - -#if HAS_MONADFAIL -import qualified Control.Monad.Fail as Fail -#endif - ------------------------------------------------------ --- --- The Quasi class --- ------------------------------------------------------ - -#if HAS_MONADFAIL -class Fail.MonadFail m => Quasi m where -#else -class Monad m => Quasi m where -#endif - qNewName :: String -> m Name - -- ^ Fresh names - - -- Error reporting and recovery - qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False) - -- ...but carry on; use 'fail' to stop - qRecover :: m a -- ^ the error handler - -> m a -- ^ action which may fail - -> m a -- ^ Recover from the monadic 'fail' - - -- Inspect the type-checker's environment - qLookupName :: Bool -> String -> m (Maybe Name) - -- True <=> type namespace, False <=> value namespace - qReify :: Name -> m Info - qReifyFixity :: Name -> m (Maybe Fixity) - qReifyInstances :: Name -> [Type] -> m [Dec] - -- Is (n tys) an instance? - -- Returns list of matching instance Decs - -- (with empty sub-Decs) - -- Works for classes and type functions - qReifyRoles :: Name -> m [Role] - qReifyAnnotations :: Data a => AnnLookup -> m [a] - qReifyModule :: Module -> m ModuleInfo - qReifyConStrictness :: Name -> m [DecidedStrictness] - - qLocation :: m Loc - - qRunIO :: IO a -> m a - -- ^ Input/output (dangerous) - - qAddDependentFile :: FilePath -> m () - - qAddTopDecls :: [Dec] -> m () - - qAddForeignFile :: ForeignSrcLang -> String -> m () - - qAddModFinalizer :: Q () -> m () - - qGetQ :: Typeable a => m (Maybe a) - - qPutQ :: Typeable a => a -> m () - - qIsExtEnabled :: Extension -> m Bool - qExtsEnabled :: m [Extension] - ------------------------------------------------------ --- The IO instance of Quasi --- --- This instance is used only when running a Q --- computation in the IO monad, usually just to --- print the result. There is no interesting --- type environment, so reification isn't going to --- work. --- ------------------------------------------------------ - -instance Quasi IO where - qNewName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) - ; pure (mkNameU s n) } - - qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qReifyConStrictness _ = badIO "reifyConStrictness" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qAddDependentFile _ = badIO "addDependentFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFile _ _ = badIO "addForeignFile" - qAddModFinalizer _ = badIO "addModFinalizer" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" - - 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 } - --- \"Runs\" the 'Q' monad. Normal users of Template Haskell --- should not need this function, as the splice brackets @$( ... )@ --- are the usual way of running a 'Q' computation. --- --- This function is primarily used in GHC internals, and for debugging --- splices by running them in 'IO'. --- --- Note that many functions in 'Q', such as 'reify' and other compiler --- queries, are not supported when running 'Q' in 'IO'; these operations --- simply fail at runtime. Indeed, the only operations guaranteed to succeed --- are 'newName', 'runIO', 'reportError' and 'reportWarning'. -runQ :: Quasi m => Q a -> m a -runQ (Q m) = m - -instance Monad Q where - Q m >>= k = Q (m >>= \x -> unQ (k x)) - (>>) = (*>) -#if !HAS_MONADFAIL - fail s = report True s >> Q (fail "Q monad failure") -#else - fail = Fail.fail - -instance Fail.MonadFail Q where - fail s = report True s >> Q (Fail.fail "Q monad failure") -#endif - -instance Functor Q where - fmap f (Q x) = Q (fmap f x) - -instance Applicative Q where - pure x = Q (pure x) - Q f <*> Q x = Q (f <*> x) - Q m *> Q n = Q (m *> n) - ------------------------------------------------------ --- --- The TExp type --- ------------------------------------------------------ - -type role TExp nominal -- See Note [Role of TExp] -newtype TExp a = TExp { unType :: Exp } - -unTypeQ :: Q (TExp a) -> Q Exp -unTypeQ m = do { TExp e <- m - ; return e } - -unsafeTExpCoerce :: Q Exp -> Q (TExp a) -unsafeTExpCoerce m = do { e <- m - ; return (TExp e) } - -{- Note [Role of TExp] -~~~~~~~~~~~~~~~~~~~~~~ -TExp's argument must have a nominal role, not phantom as would -be inferred (Trac #8459). Consider - - e :: TExp Age - e = MkAge 3 - - foo = $(coerce e) + 4::Int - -The splice will evaluate to (MkAge 3) and you can't add that to -4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -} - ----------------------------------------------------- --- Packaged versions for the programmer, hiding the Quasi-ness - -{- | -Generate a fresh name, which cannot be captured. - -For example, this: - -@f = $(do - nm1 <- newName \"x\" - let nm2 = 'mkName' \"x\" - return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1))) - )@ - -will produce the splice - ->f = \x0 -> \x -> x0 - -In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@, -and is not captured by the binding @VarP nm2@. - -Although names generated by @newName@ cannot /be captured/, they can -/capture/ other names. For example, this: - ->g = $(do -> nm1 <- newName "x" -> let nm2 = mkName "x" -> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2))) -> ) - -will produce the splice - ->g = \x -> \x0 -> x0 - -since the occurrence @VarE nm2@ is captured by the innermost binding -of @x@, namely @VarP nm1@. --} -newName :: String -> Q Name -newName s = Q (qNewName s) - --- | Report an error (True) or warning (False), --- but carry on; use 'fail' to stop. -report :: Bool -> String -> Q () -report b s = Q (qReport b s) -{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 - --- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. -reportError :: String -> Q () -reportError = report True - --- | Report a warning to the user, and carry on. -reportWarning :: String -> Q () -reportWarning = report False - --- | Recover from errors raised by 'reportError' or 'fail'. -recover :: Q a -- ^ handler to invoke on failure - -> Q a -- ^ computation to run - -> Q a -recover (Q r) (Q m) = Q (qRecover r m) - --- We don't export lookupName; the Bool isn't a great API --- Instead we export lookupTypeName, lookupValueName -lookupName :: Bool -> String -> Q (Maybe Name) -lookupName ns s = Q (qLookupName ns s) - --- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. -lookupTypeName :: String -> Q (Maybe Name) -lookupTypeName s = Q (qLookupName True s) - --- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. -lookupValueName :: String -> Q (Maybe Name) -lookupValueName s = Q (qLookupName False s) - -{- -Note [Name lookup] -~~~~~~~~~~~~~~~~~~ --} -{- $namelookup #namelookup# -The functions 'lookupTypeName' and 'lookupValueName' provide -a way to query the current splice's context for what names -are in scope. The function 'lookupTypeName' queries the type -namespace, whereas 'lookupValueName' queries the value namespace, -but the functions are otherwise identical. - -A call @lookupValueName s@ will check if there is a value -with name @s@ in scope at the current splice's location. If -there is, the @Name@ of this value is returned; -if not, then @Nothing@ is returned. - -The returned name cannot be \"captured\". -For example: - -> f = "global" -> g = $( do -> Just nm <- lookupValueName "f" -> [| let f = "local" in $( varE nm ) |] - -In this case, @g = \"global\"@; the call to @lookupValueName@ -returned the global @f@, and this name was /not/ captured by -the local definition of @f@. - -The lookup is performed in the context of the /top-level/ splice -being run. For example: - -> f = "global" -> g = $( [| let f = "local" in -> $(do -> Just nm <- lookupValueName "f" -> varE nm -> ) |] ) - -Again in this example, @g = \"global\"@, because the call to -@lookupValueName@ queries the context of the outer-most @$(...)@. - -Operators should be queried without any surrounding parentheses, like so: - -> lookupValueName "+" - -Qualified names are also supported, like so: - -> lookupValueName "Prelude.+" -> lookupValueName "Prelude.map" - --} - - -{- | 'reify' looks up information about the 'Name'. - -It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName' -to ensure that we are reifying from the right namespace. For instance, in this context: - -> data D = D - -which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.) -To ensure we get information about @D@-the-value, use 'lookupValueName': - -> do -> Just nm <- lookupValueName "D" -> reify nm - -and to get information about @D@-the-type, use 'lookupTypeName'. --} -reify :: Name -> Q Info -reify v = Q (qReify v) - -{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For -example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then -@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function -@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns -'Nothing', so you may assume @bar@ has 'defaultFixity'. --} -reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity nm = Q (qReifyFixity nm) - -{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, -if @nm@ is the name of a type class, then all instances of this class at the types @tys@ -are returned. Alternatively, if @nm@ is the name of a data family or type family, -all instances of this family at the types @tys@ are returned. --} -reifyInstances :: Name -> [Type] -> Q [InstanceDec] -reifyInstances cls tys = Q (qReifyInstances cls tys) - -{- | @reifyRoles nm@ returns the list of roles associated with the parameters of -the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon. -The returned list should never contain 'InferR'. --} -reifyRoles :: Name -> Q [Role] -reifyRoles nm = Q (qReifyRoles nm) - --- | @reifyAnnotations target@ returns the list of annotations --- associated with @target@. Only the annotations that are --- appropriately typed is returned. So if you have @Int@ and @String@ --- annotations for the same target, you have to call this function twice. -reifyAnnotations :: Data a => AnnLookup -> Q [a] -reifyAnnotations an = Q (qReifyAnnotations an) - --- | @reifyModule mod@ looks up information about module @mod@. To --- look up the current module, call this function with the return --- value of @thisModule@. -reifyModule :: Module -> Q ModuleInfo -reifyModule m = Q (qReifyModule m) - --- | @reifyConStrictness nm@ looks up the strictness information for the fields --- of the constructor with the name @nm@. Note that the strictness information --- that 'reifyConStrictness' returns may not correspond to what is written in --- the source code. For example, in the following data declaration: --- --- @ --- data Pair a = Pair a a --- @ --- --- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most --- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the --- @-XStrictData@ language extension was enabled. -reifyConStrictness :: Name -> Q [DecidedStrictness] -reifyConStrictness n = Q (qReifyConStrictness n) - --- | Is the list of instances returned by 'reifyInstances' nonempty? -isInstance :: Name -> [Type] -> Q Bool -isInstance nm tys = do { decs <- reifyInstances nm tys - ; return (not (null decs)) } - --- | The location at which this computation is spliced. -location :: Q Loc -location = Q qLocation - --- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. --- Take care: you are guaranteed the ordering of calls to 'runIO' within --- a single 'Q' computation, but not about the order in which splices are run. --- --- Note: for various murky reasons, stdout and stderr handles are not --- necessarily flushed when the compiler finishes running, so you should --- flush them yourself. -runIO :: IO a -> Q a -runIO m = Q (qRunIO m) - --- | Record external files that runIO is using (dependent upon). --- The compiler can then recognize that it should re-compile the Haskell file --- when an external file changes. --- --- Expects an absolute file path. --- --- Notes: --- --- * ghc -M does not know about these dependencies - it does not execute TH. --- --- * The dependency is based on file content, not a modification time -addDependentFile :: FilePath -> Q () -addDependentFile fp = Q (qAddDependentFile fp) - --- | Add additional top-level declarations. The added declarations will be type --- checked along with the current declaration group. -addTopDecls :: [Dec] -> Q () -addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is reccomended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignFile LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignFile :: ForeignSrcLang -> String -> Q () -addForeignFile lang str = Q (qAddForeignFile lang str) - --- | Add a finalizer that will run in the Q monad after the current module has --- been type checked. This only makes sense when run within a top-level splice. --- --- The finalizer is given the local type environment at the splice point. Thus --- 'reify' is able to find the local definitions when executed inside the --- finalizer. -addModFinalizer :: Q () -> Q () -addModFinalizer act = Q (qAddModFinalizer (unQ act)) - --- | Get state from the 'Q' monad. Note that the state is local to the --- Haskell module in which the Template Haskell expression is executed. -getQ :: Typeable a => Q (Maybe a) -getQ = Q qGetQ - --- | Replace the state in the 'Q' monad. Note that the state is local to the --- Haskell module in which the Template Haskell expression is executed. -putQ :: Typeable a => a -> Q () -putQ x = Q (qPutQ x) - --- | Determine whether the given language extension is enabled in the 'Q' monad. -isExtEnabled :: Extension -> Q Bool -isExtEnabled ext = Q (qIsExtEnabled ext) - --- | List all enabled language extensions. -extsEnabled :: Q [Extension] -extsEnabled = Q qExtsEnabled - -instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qRunIO = runIO - qAddDependentFile = addDependentFile - qAddTopDecls = addTopDecls - qAddForeignFile = addForeignFile - qAddModFinalizer = addModFinalizer - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - - ----------------------------------------------------- --- The following operations are used solely in DsMeta when desugaring brackets --- They are not necessary for the user, who can use ordinary return and (>>=) etc - -returnQ :: a -> Q a -returnQ = return - -bindQ :: Q a -> (a -> Q b) -> Q b -bindQ = (>>=) - -sequenceQ :: [Q a] -> Q [a] -sequenceQ = sequence - - ------------------------------------------------------ --- --- The Lift class --- ------------------------------------------------------ - --- | A 'Lift' instance can have any of its values turned into a Template --- Haskell expression. This is needed when a value used within a Template --- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not --- at the top level. As an example: --- --- > add1 :: Int -> Q Exp --- > add1 x = [| x + 1 |] --- --- Template Haskell has no way of knowing what value @x@ will take on at --- splice-time, so it requires the type of @x@ to be an instance of 'Lift'. --- --- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@ --- GHC language extension: --- --- > {-# LANGUAGE DeriveLift #-} --- > module Foo where --- > --- > import Language.Haskell.TH.Syntax --- > --- > data Bar a = Bar1 a (Bar a) | Bar2 String --- > deriving Lift -class Lift t where - -- | Turn a value into a Template Haskell expression, suitable for use in - -- a splice. - lift :: t -> Q Exp - default lift :: Data t => t -> Q Exp - lift = liftData - --- If you add any instances here, consider updating test th/TH_Lift -instance Lift Integer where - lift x = return (LitE (IntegerL x)) - -instance Lift Int where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Int8 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Int16 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Int32 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Int64 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Word where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Word8 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Word16 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Word32 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Word64 where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Lift Natural where - lift x = return (LitE (IntegerL (fromIntegral x))) - -instance Integral a => Lift (Ratio a) where - lift x = return (LitE (RationalL (toRational x))) - -instance Lift Float where - lift x = return (LitE (RationalL (toRational x))) - -instance Lift Double where - lift x = return (LitE (RationalL (toRational x))) - -instance Lift Char where - lift x = return (LitE (CharL x)) - -instance Lift Bool where - lift True = return (ConE trueName) - lift False = return (ConE falseName) - -instance Lift a => Lift (Maybe a) where - lift Nothing = return (ConE nothingName) - lift (Just x) = liftM (ConE justName `AppE`) (lift x) - -instance (Lift a, Lift b) => Lift (Either a b) where - lift (Left x) = liftM (ConE leftName `AppE`) (lift x) - lift (Right y) = liftM (ConE rightName `AppE`) (lift y) - -instance Lift a => Lift [a] where - lift xs = do { xs' <- mapM lift xs; return (ListE xs') } - -liftString :: String -> Q Exp --- Used in TcExpr to short-circuit the lifting for strings -liftString s = return (LitE (StringL s)) - -instance Lift () where - lift () = return (ConE (tupleDataName 0)) - -instance (Lift a, Lift b) => Lift (a, b) where - lift (a, b) - = liftM TupE $ sequence [lift a, lift b] - -instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where - lift (a, b, c) - = liftM TupE $ sequence [lift a, lift b, lift c] - -instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where - lift (a, b, c, d) - = liftM TupE $ sequence [lift a, lift b, lift c, lift d] - -instance (Lift a, Lift b, Lift c, Lift d, Lift e) - => Lift (a, b, c, d, e) where - lift (a, b, c, d, e) - = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e] - -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) - => Lift (a, b, c, d, e, f) where - lift (a, b, c, d, e, f) - = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f] - -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) - => Lift (a, b, c, d, e, f, g) where - lift (a, b, c, d, e, f, g) - = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g] - --- TH has a special form for literal strings, --- which we should take advantage of. --- NB: the lhs of the rule has no args, so that --- the rule will apply to a 'lift' all on its own --- which happens to be the way the type checker --- creates it. -{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-} - - -trueName, falseName :: Name -trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" -falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" - -nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Base" "Nothing" -justName = mkNameG DataName "base" "GHC.Base" "Just" - -leftName, rightName :: Name -leftName = mkNameG DataName "base" "Data.Either" "Left" -rightName = mkNameG DataName "base" "Data.Either" "Right" - ------------------------------------------------------ --- --- Generic Lift implementations --- ------------------------------------------------------ - --- | 'dataToQa' is an internal utility function for constructing generic --- conversion functions from types with 'Data' instances to various --- quasi-quoting representations. See the source of 'dataToExpQ' and --- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@ --- and @appQ@ are overloadable to account for different syntax for --- expressions and patterns; @antiQ@ allows you to override type-specific --- cases, a common usage is just @const Nothing@, which results in --- no overloading. -dataToQa :: forall a k q. Data a - => (Name -> k) - -> (Lit -> Q q) - -> (k -> [Q q] -> Q q) - -> (forall b . Data b => b -> Maybe (Q q)) - -> a - -> Q q -dataToQa mkCon mkLit appCon antiQ t = - case antiQ t of - Nothing -> - case constrRep constr of - AlgConstr _ -> - appCon (mkCon funOrConName) conArgs - where - funOrConName :: Name - funOrConName = - case showConstr constr of - "(:)" -> Name (mkOccName ":") - (NameG DataName - (mkPkgName "ghc-prim") - (mkModName "GHC.Types")) - con@"[]" -> Name (mkOccName con) - (NameG DataName - (mkPkgName "ghc-prim") - (mkModName "GHC.Types")) - con@('(':_) -> Name (mkOccName con) - (NameG DataName - (mkPkgName "ghc-prim") - (mkModName "GHC.Tuple")) - - -- Tricky case: see Note [Data for non-algebraic types] - fun@(x:_) | startsVarSym x || startsVarId x - -> mkNameG_v tyconPkg tyconMod fun - con -> mkNameG_d tyconPkg tyconMod con - - where - tycon :: TyCon - tycon = (typeRepTyCon . typeOf) t - - tyconPkg, tyconMod :: String - tyconPkg = tyConPackage tycon - tyconMod = tyConModule tycon - - conArgs :: [Q q] - conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t - IntConstr n -> - mkLit $ IntegerL n - FloatConstr n -> - mkLit $ RationalL n - CharConstr c -> - mkLit $ CharL c - where - constr :: Constr - constr = toConstr t - - Just y -> y - - -{- Note [Data for non-algebraic types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Class Data was originally intended for algebraic data types. But -it is possible to use it for abstract types too. For example, in -package `text` we find - - instance Data Text where - ... - toConstr _ = packConstr - - packConstr :: Constr - packConstr = mkConstr textDataType "pack" [] Prefix - -Here `packConstr` isn't a real data constructor, it's an ordinary -function. Two complications - -* In such a case, we must take care to build the Name using - mkNameG_v (for values), not mkNameG_d (for data constructors). - See Trac #10796. - -* The pseudo-constructor is named only by its string, here "pack". - But 'dataToQa' needs the TyCon of its defining module, and has - to assume it's defined in the same module as the TyCon itself. - But nothing enforces that; Trac #12596 shows what goes wrong if - "pack" is defined in a different module than the data type "Text". - -} - --- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the --- same value, in the SYB style. It is generalized to take a function --- override type-specific cases; see 'liftData' for a more commonly --- used variant. -dataToExpQ :: Data a - => (forall b . Data b => b -> Maybe (Q Exp)) - -> a - -> Q Exp -dataToExpQ = dataToQa varOrConE litE (foldl appE) - where - -- Make sure that VarE is used if the Constr value relies on a - -- function underneath the surface (instead of a constructor). - -- See Trac #10796. - varOrConE s = - case nameSpace s of - Just VarName -> return (VarE s) - Just DataName -> return (ConE s) - _ -> fail $ "Can't construct an expression from name " - ++ showName s - appE x y = do { a <- x; b <- y; return (AppE a b)} - litE c = return (LitE c) - --- | 'liftData' is a variant of 'lift' in the 'Lift' type class which --- works for any type with a 'Data' instance. -liftData :: Data a => a -> Q Exp -liftData = dataToExpQ (const Nothing) - --- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same --- value, in the SYB style. It takes a function to handle type-specific cases, --- alternatively, pass @const Nothing@ to get default behavior. -dataToPatQ :: Data a - => (forall b . Data b => b -> Maybe (Q Pat)) - -> a - -> Q Pat -dataToPatQ = dataToQa id litP conP - where litP l = return (LitP l) - conP n ps = - case nameSpace n of - Just DataName -> do - ps' <- sequence ps - return (ConP n ps') - _ -> fail $ "Can't construct a pattern from name " - ++ showName n - ------------------------------------------------------ --- Names and uniques ------------------------------------------------------ - -newtype ModName = ModName String -- Module name - deriving (Show,Eq,Ord,Data,Generic) - -newtype PkgName = PkgName String -- package name - deriving (Show,Eq,Ord,Data,Generic) - --- | Obtained from 'reifyModule' and 'thisModule'. -data Module = Module PkgName ModName -- package qualified module name - deriving (Show,Eq,Ord,Data,Generic) - -newtype OccName = OccName String - deriving (Show,Eq,Ord,Data,Generic) - -mkModName :: String -> ModName -mkModName s = ModName s - -modString :: ModName -> String -modString (ModName m) = m - - -mkPkgName :: String -> PkgName -mkPkgName s = PkgName s - -pkgString :: PkgName -> String -pkgString (PkgName m) = m - - ------------------------------------------------------ --- OccName ------------------------------------------------------ - -mkOccName :: String -> OccName -mkOccName s = OccName s - -occString :: OccName -> String -occString (OccName occ) = occ - - ------------------------------------------------------ --- Names ------------------------------------------------------ --- --- For "global" names ('NameG') we need a totally unique name, --- so we must include the name-space of the thing --- --- For unique-numbered things ('NameU'), we've got a unique reference --- anyway, so no need for name space --- --- For dynamically bound thing ('NameS') we probably want them to --- in a context-dependent way, so again we don't want the name --- space. For example: --- --- > let v = mkName "T" in [| data $v = $v |] --- --- Here we use the same Name for both type constructor and data constructor --- --- --- NameL and NameG are bound *outside* the TH syntax tree --- either globally (NameG) or locally (NameL). Ex: --- --- > f x = $(h [| (map, x) |]) --- --- The 'map' will be a NameG, and 'x' wil be a NameL --- --- These Names should never appear in a binding position in a TH syntax tree - -{- $namecapture #namecapture# -Much of 'Name' API is concerned with the problem of /name capture/, which -can be seen in the following example. - -> f expr = [| let x = 0 in $expr |] -> ... -> g x = $( f [| x |] ) -> h y = $( f [| y |] ) - -A naive desugaring of this would yield: - -> g x = let x = 0 in x -> h y = let x = 0 in y - -All of a sudden, @g@ and @h@ have different meanings! In this case, -we say that the @x@ in the RHS of @g@ has been /captured/ -by the binding of @x@ in @f@. - -What we actually want is for the @x@ in @f@ to be distinct from the -@x@ in @g@, so we get the following desugaring: - -> g x = let x' = 0 in x -> h y = let x' = 0 in y - -which avoids name capture as desired. - -In the general case, we say that a @Name@ can be captured if -the thing it refers to can be changed by adding new declarations. --} - -{- | -An abstract type representing names in the syntax tree. - -'Name's can be constructed in several ways, which come with different -name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for -an explanation of name capture): - - * the built-in syntax @'f@ and @''T@ can be used to construct names, - The expression @'f@ gives a @Name@ which refers to the value @f@ - currently in scope, and @''T@ gives a @Name@ which refers to the - type @T@ currently in scope. These names can never be captured. - - * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and - @''T@ respectively, but the @Name@s are looked up at the point - where the current splice is being run. These names can never be - captured. - - * 'newName' monadically generates a new name, which can never - be captured. - - * 'mkName' generates a capturable name. - -Names constructed using @newName@ and @mkName@ may be used in bindings -(such as @let x = ...@ or @\x -> ...@), but names constructed using -@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. --} -data Name = Name OccName NameFlavour deriving (Data, Eq, Generic) - -instance Ord Name where - -- check if unique is different before looking at strings - (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp` - (o1 `compare` o2) - -data NameFlavour - = NameS -- ^ An unqualified name; dynamically bound - | NameQ ModName -- ^ A qualified name; dynamically bound - | NameU !Int -- ^ A unique local name - | NameL !Int -- ^ Local name bound outside of the TH AST - | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST: - -- An original name (occurrences only, not binders) - -- Need the namespace too to be sure which - -- thing we are naming - deriving ( Data, Eq, Ord, Show, Generic ) - -data NameSpace = VarName -- ^ Variables - | DataName -- ^ Data constructors - | TcClsName -- ^ Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord, Show, Data, Generic ) - -type Uniq = Int - --- | The name without its module prefix. --- --- ==== __Examples__ --- --- >>> nameBase ''Data.Either.Either --- "Either" --- >>> nameBase (mkName "foo") --- "foo" --- >>> nameBase (mkName "Module.foo") --- "foo" -nameBase :: Name -> String -nameBase (Name occ _) = occString occ - --- | Module prefix of a name, if it exists. --- --- ==== __Examples__ --- --- >>> nameModule ''Data.Either.Either --- Just "Data.Either" --- >>> nameModule (mkName "foo") --- Nothing --- >>> nameModule (mkName "Module.foo") --- Just "Module" -nameModule :: Name -> Maybe String -nameModule (Name _ (NameQ m)) = Just (modString m) -nameModule (Name _ (NameG _ _ m)) = Just (modString m) -nameModule _ = Nothing - --- | A name's package, if it exists. --- --- ==== __Examples__ --- --- >>> namePackage ''Data.Either.Either --- Just "base" --- >>> namePackage (mkName "foo") --- Nothing --- >>> namePackage (mkName "Module.foo") --- Nothing -namePackage :: Name -> Maybe String -namePackage (Name _ (NameG _ p _)) = Just (pkgString p) -namePackage _ = Nothing - --- | Returns whether a name represents an occurrence of a top-level variable --- ('VarName'), data constructor ('DataName'), type constructor, or type class --- ('TcClsName'). If we can't be sure, it returns 'Nothing'. --- --- ==== __Examples__ --- --- >>> nameSpace 'Prelude.id --- Just VarName --- >>> nameSpace (mkName "id") --- Nothing -- only works for top-level variable names --- >>> nameSpace 'Data.Maybe.Just --- Just DataName --- >>> nameSpace ''Data.Maybe.Maybe --- Just TcClsName --- >>> nameSpace ''Data.Ord.Ord --- Just TcClsName -nameSpace :: Name -> Maybe NameSpace -nameSpace (Name _ (NameG ns _ _)) = Just ns -nameSpace _ = Nothing - -{- | -Generate a capturable name. Occurrences of such names will be -resolved according to the Haskell scoping rules at the occurrence -site. - -For example: - -> f = [| pi + $(varE (mkName "pi")) |] -> ... -> g = let pi = 3 in $f - -In this case, @g@ is desugared to - -> g = Prelude.pi + 3 - -Note that @mkName@ may be used with qualified names: - -> mkName "Prelude.pi" - -See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could -be rewritten using 'dyn' as - -> f = [| pi + $(dyn "pi") |] --} -mkName :: String -> Name --- The string can have a '.', thus "Foo.baz", --- giving a dynamically-bound qualified name, --- in which case we want to generate a NameQ --- --- Parse the string to see if it has a "." in it --- so we know whether to generate a qualified or unqualified name --- It's a bit tricky because we need to parse --- --- > Foo.Baz.x as Qual Foo.Baz x --- --- So we parse it from back to front -mkName str - = split [] (reverse str) - where - split occ [] = Name (mkOccName occ) NameS - split occ ('.':rev) | not (null occ) - , is_rev_mod_name rev - = Name (mkOccName occ) (NameQ (mkModName (reverse rev))) - -- The 'not (null occ)' guard ensures that - -- mkName "&." = Name "&." NameS - -- The 'is_rev_mod' guards ensure that - -- mkName ".&" = Name ".&" NameS - -- mkName "^.." = Name "^.." NameS -- Trac #8633 - -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits") - -- This rather bizarre case actually happened; (.&.) is in Data.Bits - split occ (c:rev) = split (c:occ) rev - - -- Recognises a reversed module name xA.yB.C, - -- with at least one component, - -- and each component looks like a module name - -- (i.e. non-empty, starts with capital, all alpha) - is_rev_mod_name rev_mod_str - | (compt, rest) <- break (== '.') rev_mod_str - , not (null compt), isUpper (last compt), all is_mod_char compt - = case rest of - [] -> True - (_dot : rest') -> is_rev_mod_name rest' - | otherwise - = False - - is_mod_char c = isAlphaNum c || c == '_' || c == '\'' - --- | Only used internally -mkNameU :: String -> Uniq -> Name -mkNameU s u = Name (mkOccName s) (NameU u) - --- | Only used internally -mkNameL :: String -> Uniq -> Name -mkNameL s u = Name (mkOccName s) (NameL u) - --- | Used for 'x etc, but not available to the programmer -mkNameG :: NameSpace -> String -> String -> String -> Name -mkNameG ns pkg modu occ - = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu)) - -mkNameS :: String -> Name -mkNameS n = Name (mkOccName n) NameS - -mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name -mkNameG_v = mkNameG VarName -mkNameG_tc = mkNameG TcClsName -mkNameG_d = mkNameG DataName - -data NameIs = Alone | Applied | Infix - -showName :: Name -> String -showName = showName' Alone - -showName' :: NameIs -> Name -> String -showName' ni nm - = case ni of - Alone -> nms - Applied - | pnam -> nms - | otherwise -> "(" ++ nms ++ ")" - Infix - | pnam -> "`" ++ nms ++ "`" - | otherwise -> nms - where - -- For now, we make the NameQ and NameG print the same, even though - -- NameQ is a qualified name (so what it means depends on what the - -- current scope is), and NameG is an original name (so its meaning - -- should be independent of what's in scope. - -- We may well want to distinguish them in the end. - -- Ditto NameU and NameL - nms = case nm of - Name occ NameS -> occString occ - Name occ (NameQ m) -> modString m ++ "." ++ occString occ - Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ - Name occ (NameU u) -> occString occ ++ "_" ++ show u - Name occ (NameL u) -> occString occ ++ "_" ++ show u - - pnam = classify nms - - -- True if we are function style, e.g. f, [], (,) - -- False if we are operator style, e.g. +, :+ - classify "" = False -- shouldn't happen; . operator is handled below - classify (x:xs) | isAlpha x || (x `elem` "_[]()") = - case dropWhile (/='.') xs of - (_:xs') -> classify xs' - [] -> True - | otherwise = False - -instance Show Name where - show = showName - --- Tuple data and type constructors --- | Tuple data constructor -tupleDataName :: Int -> Name --- | Tuple type constructor -tupleTypeName :: Int -> Name - -tupleDataName 0 = mk_tup_name 0 DataName -tupleDataName 1 = error "tupleDataName 1" -tupleDataName n = mk_tup_name (n-1) DataName - -tupleTypeName 0 = mk_tup_name 0 TcClsName -tupleTypeName 1 = error "tupleTypeName 1" -tupleTypeName n = mk_tup_name (n-1) TcClsName - -mk_tup_name :: Int -> NameSpace -> Name -mk_tup_name n_commas space - = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod) - where - occ = mkOccName ('(' : replicate n_commas ',' ++ ")") - tup_mod = mkModName "GHC.Tuple" - --- Unboxed tuple data and type constructors --- | Unboxed tuple data constructor -unboxedTupleDataName :: Int -> Name --- | Unboxed tuple type constructor -unboxedTupleTypeName :: Int -> Name - -unboxedTupleDataName n = mk_unboxed_tup_name n DataName -unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName - -mk_unboxed_tup_name :: Int -> NameSpace -> Name -mk_unboxed_tup_name n space - = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod) - where - tup_occ | n == 1 = "Unit#" -- See Note [One-tuples] in TysWiredIn - | otherwise = "(#" ++ replicate n_commas ',' ++ "#)" - n_commas = n - 1 - tup_mod = mkModName "GHC.Tuple" - --- Unboxed sum data and type constructors --- | Unboxed sum data constructor -unboxedSumDataName :: SumAlt -> SumArity -> Name --- | Unboxed sum type constructor -unboxedSumTypeName :: SumArity -> Name - -unboxedSumDataName alt arity - | alt > arity - = error $ prefix ++ "Index out of bounds." ++ debug_info - - | alt <= 0 - = error $ prefix ++ "Alt must be > 0." ++ debug_info - - | arity < 2 - = error $ prefix ++ "Arity must be >= 2." ++ debug_info - - | otherwise - = Name (mkOccName sum_occ) - (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) - - where - prefix = "unboxedSumDataName: " - debug_info = " (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")" - - -- Synced with the definition of mkSumDataConOcc in TysWiredIn - sum_occ = '(' : '#' : bars nbars_before ++ '_' : bars nbars_after ++ "#)" - bars i = replicate i '|' - nbars_before = alt - 1 - nbars_after = arity - alt - -unboxedSumTypeName arity - | arity < 2 - = error $ "unboxedSumTypeName: Arity must be >= 2." - ++ " (arity: " ++ show arity ++ ")" - - | otherwise - = Name (mkOccName sum_occ) - (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) - - where - -- Synced with the definition of mkSumTyConOcc in TysWiredIn - sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)" - ------------------------------------------------------ --- Locations ------------------------------------------------------ - -data Loc - = Loc { loc_filename :: String - , loc_package :: String - , loc_module :: String - , loc_start :: CharPos - , loc_end :: CharPos } - deriving( Show, Eq, Ord, Data, Generic ) - -type CharPos = (Int, Int) -- ^ Line and character position - - ------------------------------------------------------ --- --- The Info returned by reification --- ------------------------------------------------------ - --- | Obtained from 'reify' in the 'Q' Monad. -data Info - = - -- | A class, with a list of its visible instances - ClassI - Dec - [InstanceDec] - - -- | A class method - | ClassOpI - Name - Type - ParentName - - -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate - | TyConI - Dec - - -- | A type or data family, with a list of its visible instances. A closed - -- type family is returned with 0 instances. - | FamilyI - Dec - [InstanceDec] - - -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. Examples: @(->)@, @Int#@. - | PrimTyConI - Name - Arity - Unlifted - - -- | A data constructor - | DataConI - Name - Type - ParentName - - -- | A pattern synonym. - | PatSynI - Name - PatSynType - - {- | - A \"value\" variable (as opposed to a type variable, see 'TyVarI'). - - The @Maybe Dec@ field contains @Just@ the declaration which - defined the variable -- including the RHS of the declaration -- - or else @Nothing@, in the case where the RHS is unavailable to - the compiler. At present, this value is _always_ @Nothing@: - returning the RHS has not yet been implemented because of - lack of interest. - -} - | VarI - Name - Type - (Maybe Dec) - - {- | - A type variable. - - The @Type@ field contains the type which underlies the variable. - At present, this is always @'VarT' theName@, but future changes - may permit refinement of this. - -} - | TyVarI -- Scoped type variable - Name - Type -- What it is bound to - deriving( Show, Eq, Ord, Data, Generic ) - --- | Obtained from 'reifyModule' in the 'Q' Monad. -data ModuleInfo = - -- | Contains the import list of the module. - ModuleInfo [Module] - deriving( Show, Eq, Ord, Data, Generic ) - -{- | -In 'ClassOpI' and 'DataConI', name of the parent class or type --} -type ParentName = Name - --- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a --- particular data constructor. 'SumAlt's are one-indexed and should never --- exceed the value of its corresponding 'SumArity'. For example: --- --- * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2) --- --- * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2) -type SumAlt = Int - --- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of --- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2. -type SumArity = Int - --- | In 'PrimTyConI', arity of the type constructor -type Arity = Int - --- | In 'PrimTyConI', is the type constructor unlifted? -type Unlifted = Bool - --- | 'InstanceDec' desribes a single instance of a class or type function. --- It is just a 'Dec', but guaranteed to be one of the following: --- --- * 'InstanceD' (with empty @['Dec']@) --- --- * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@) --- --- * 'TySynInstD' -type InstanceDec = Dec - -data Fixity = Fixity Int FixityDirection - deriving( Eq, Ord, Show, Data, Generic ) -data FixityDirection = InfixL | InfixR | InfixN - deriving( Eq, Ord, Show, Data, Generic ) - --- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) -maxPrecedence :: Int -maxPrecedence = (9::Int) - --- | Default fixity: @infixl 9@ -defaultFixity :: Fixity -defaultFixity = Fixity maxPrecedence InfixL - - -{- -Note [Unresolved infix] -~~~~~~~~~~~~~~~~~~~~~~~ --} -{- $infix #infix# -When implementing antiquotation for quasiquoters, one often wants -to parse strings into expressions: - -> parse :: String -> Maybe Exp - -But how should we parse @a + b * c@? If we don't know the fixities of -@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a -+ b) * c@. - -In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for -\"unresolved infix expression/pattern/type\", respectively. When the compiler -is given a splice containing a tree of @UInfixE@ applications such as - -> UInfixE -> (UInfixE e1 op1 e2) -> op2 -> (UInfixE e3 op3 e4) - -it will look up and the fixities of the relevant operators and -reassociate the tree as necessary. - - * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT', - which are of use for parsing expressions like - - > (a + b * c) + d * e - - * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated. - - * The 'UInfixE' constructor doesn't support sections. Sections - such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer - sections such as @(a + b * c -)@, use an 'InfixE' constructor for the - outer-most section, and use 'UInfixE' constructors for all - other operators: - - > InfixE - > Just (UInfixE ...a + b * c...) - > op - > Nothing - - Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered - into 'Exp's differently: - - > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b) - > -- will result in a fixity error if (+) is left-infix - > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b) - > -- no fixity errors - - * Quoted expressions such as - - > [| a * b + c |] :: Q Exp - > [p| a : b : c |] :: Q Pat - > [t| T + T |] :: Q Type - - will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE', - 'ParensP', or 'ParensT' constructors. - --} - ------------------------------------------------------ --- --- The main syntax data types --- ------------------------------------------------------ - -data Lit = CharL Char - | StringL String - | IntegerL Integer -- ^ Used for overloaded and non-overloaded - -- literals. We don't have a good way to - -- represent non-overloaded literals at - -- the moment. Maybe that doesn't matter? - | RationalL Rational -- Ditto - | IntPrimL Integer - | WordPrimL Integer - | FloatPrimL Rational - | DoublePrimL Rational - | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# - | CharPrimL Char - deriving( Show, Eq, Ord, Data, Generic ) - - -- We could add Int, Float, Double etc, as we do in HsLit, - -- but that could complicate the - -- supposedly-simple TH.Syntax literal type - --- | Pattern in Haskell given in @{}@ -data Pat - = LitP Lit -- ^ @{ 5 or \'c\' }@ - | VarP Name -- ^ @{ x }@ - | TupP [Pat] -- ^ @{ (p1,p2) }@ - | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@ - | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@ - | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ - | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ - | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | ParensP Pat -- ^ @{(p)}@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | TildeP Pat -- ^ @{ ~p }@ - | BangP Pat -- ^ @{ !p }@ - | AsP Name Pat -- ^ @{ x \@ p }@ - | WildP -- ^ @{ _ }@ - | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@ - | ListP [ Pat ] -- ^ @{ [1,2,3] }@ - | SigP Pat Type -- ^ @{ p :: t }@ - | ViewP Exp Pat -- ^ @{ e -> p }@ - deriving( Show, Eq, Ord, Data, Generic ) - -type FieldPat = (Name,Pat) - -data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@ - deriving( Show, Eq, Ord, Data, Generic ) -data Clause = Clause [Pat] Body [Dec] - -- ^ @f { p1 p2 = body where decs }@ - deriving( Show, Eq, Ord, Data, Generic ) - -data Exp - = VarE Name -- ^ @{ x }@ - | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @ - | LitE Lit -- ^ @{ 5 or \'c\'}@ - | AppE Exp Exp -- ^ @{ f x }@ - | AppTypeE Exp Type -- ^ @{ f \@Int } - - | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@ - - -- It's a bit gruesome to use an Exp as the - -- operator, but how else can we distinguish - -- constructors from non-constructors? - -- Maybe there should be a var-or-con type? - -- Or maybe we should leave it to the String itself? - - | UInfixE Exp Exp Exp -- ^ @{x + y}@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | ParensE Exp -- ^ @{ (e) }@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@ - | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@ - | TupE [Exp] -- ^ @{ (e1,e2) } @ - | UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @ - | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@ - | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ - | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ - | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@ - | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ - | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ - | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ - -- - -- The result expression of the comprehension is - -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'. - -- - -- E.g. translation: - -- - -- > [ f x | x <- xs ] - -- - -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] - - | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@ - | ListE [ Exp ] -- ^ @{ [1,2,3] }@ - | SigE Exp Type -- ^ @{ e :: t }@ - | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ - | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ - | StaticE Exp -- ^ @{ static e }@ - | UnboundVarE Name -- ^ @{ _x }@ (hole) - deriving( Show, Eq, Ord, Data, Generic ) - -type FieldExp = (Name,Exp) - --- Omitted: implicit parameters - -data Body - = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2 - -- | e3 = e4 } - -- where ds@ - | NormalB Exp -- ^ @f p { = e } where ds@ - deriving( Show, Eq, Ord, Data, Generic ) - -data Guard - = NormalG Exp -- ^ @f x { | odd x } = x@ - | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ - deriving( Show, Eq, Ord, Data, Generic ) - -data Stmt - = BindS Pat Exp - | LetS [ Dec ] - | NoBindS Exp - | ParS [[Stmt]] - deriving( Show, Eq, Ord, Data, Generic ) - -data Range = FromR Exp | FromThenR Exp Exp - | FromToR Exp Exp | FromThenToR Exp Exp Exp - deriving( Show, Eq, Ord, Data, Generic ) - -data Dec - = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ - | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ - | DataD Cxt Name [TyVarBndr] - (Maybe Kind) -- Kind signature (allowed only for GADTs) - [Con] [DerivClause] - -- ^ @{ data Cxt x => T x = A x | B (T x) - -- deriving (Z,W) - -- deriving stock Eq }@ - | NewtypeD Cxt Name [TyVarBndr] - (Maybe Kind) -- Kind signature - Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) - -- deriving (Z,W Q) - -- deriving stock Eq }@ - | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ - | ClassD Cxt Name [TyVarBndr] - [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ - | InstanceD (Maybe Overlap) Cxt Type [Dec] - -- ^ @{ instance {\-\# OVERLAPS \#-\} - -- Show w => Show [w] where ds }@ - | SigD Name Type -- ^ @{ length :: [a] -> Int }@ - | ForeignD Foreign -- ^ @{ foreign import ... } - --{ foreign export ... }@ - - | InfixD Fixity Name -- ^ @{ infix 3 foo }@ - - -- | pragmas - | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@ - - -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | DataFamilyD Name [TyVarBndr] - (Maybe Kind) - -- ^ @{ data family T a b c :: * }@ - - | DataInstD Cxt Name [Type] - (Maybe Kind) -- Kind signature - [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] - -- = A x | B (T x) - -- deriving (Z,W) - -- deriving stock Eq }@ - - | NewtypeInstD Cxt Name [Type] - (Maybe Kind) -- Kind signature - Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] - -- = A (B x) - -- deriving (Z,W) - -- deriving stock Eq }@ - | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ - - -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | OpenTypeFamilyD TypeFamilyHead - -- ^ @{ type family T a b c = (r :: *) | r -> a b }@ - - | ClosedTypeFamilyD TypeFamilyHead [TySynEqn] - -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@ - - | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ - | StandaloneDerivD (Maybe DerivStrategy) Cxt Type - -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@ - | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ - - -- | Pattern Synonyms - | PatSynD Name PatSynArgs PatSynDir Pat - -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or - -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or - -- @{ pattern P v1 v2 .. vn <- p - -- where P v1 v2 .. vn = e }@ explicit bidirectional - -- - -- also, besides prefix pattern synonyms, both infix and record - -- pattern synonyms are supported. See 'PatSynArgs' for details - - | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature. - deriving( Show, Eq, Ord, Data, Generic ) - --- | Varieties of allowed instance overlap. -data Overlap = Overlappable -- ^ May be overlapped by more specific instances - | Overlapping -- ^ May overlap a more general instance - | Overlaps -- ^ Both 'Overlapping' and 'Overlappable' - | Incoherent -- ^ Both 'Overlappable' and 'Overlappable', and - -- pick an arbitrary one if multiple choices are - -- available. - deriving( Show, Eq, Ord, Data, Generic ) - --- | A single @deriving@ clause at the end of a datatype. -data DerivClause = DerivClause (Maybe DerivStrategy) Cxt - -- ^ @{ deriving stock (Eq, Ord) }@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | What the user explicitly requests when deriving an instance. -data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | A Pattern synonym's type. Note that a pattern synonym's *fully* --- specified type has a peculiar shape coming with two forall --- quantifiers and two constraint contexts. For example, consider the --- pattern synonym --- --- pattern P x1 x2 ... xn = --- --- P's complete type is of the following form --- --- forall universals. required constraints --- => forall existentials. provided constraints --- => t1 -> t2 -> ... -> tn -> t --- --- consisting of four parts: --- --- 1) the (possibly empty lists of) universally quantified type --- variables and required constraints on them. --- 2) the (possibly empty lists of) existentially quantified --- type variables and the provided constraints on them. --- 3) the types t1, t2, .., tn of x1, x2, .., xn, respectively --- 4) the type t of , mentioning only universals. --- --- Pattern synonym types interact with TH when (a) reifying a pattern --- synonym, (b) pretty printing, or (c) specifying a pattern synonym's --- type signature explicitly: --- --- (a) Reification always returns a pattern synonym's *fully* specified --- type in abstract syntax. --- --- (b) Pretty printing via 'pprPatSynType' abbreviates a pattern --- synonym's type unambiguously in concrete syntax: The rule of --- thumb is to print initial empty universals and the required --- context as `() =>`, if existentials and a provided context --- follow. If only universals and their required context, but no --- existentials are specified, only the universals and their --- required context are printed. If both or none are specified, so --- both (or none) are printed. --- --- (c) When specifying a pattern synonym's type explicitly with --- 'PatSynSigD' either one of the universals, the existentials, or --- their contexts may be left empty. --- --- See the GHC user's guide for more information on pattern synonyms --- and their types: https://downloads.haskell.org/~ghc/latest/docs/html/ --- users_guide/syntax-extns.html#pattern-synonyms. -type PatSynType = Type - --- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By --- analogy with "head" for type classes and type class instances as --- defined in /Type classes: an exploration of the design space/, the --- @TypeFamilyHead@ is defined to be the elements of the declaration --- between @type family@ and @where@. -data TypeFamilyHead = - TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn) - deriving( Show, Eq, Ord, Data, Generic ) - --- | One equation of a type family instance or closed type family. The --- arguments are the left-hand-side type patterns and the right-hand-side --- result. -data TySynEqn = TySynEqn [Type] Type - deriving( Show, Eq, Ord, Data, Generic ) - -data FunDep = FunDep [Name] [Name] - deriving( Show, Eq, Ord, Data, Generic ) - -data FamFlavour = TypeFam | DataFam - deriving( Show, Eq, Ord, Data, Generic ) - -data Foreign = ImportF Callconv Safety String Name Type - | ExportF Callconv String Name Type - deriving( Show, Eq, Ord, Data, Generic ) - --- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs -data Callconv = CCall | StdCall | CApi | Prim | JavaScript - deriving( Show, Eq, Ord, Data, Generic ) - -data Safety = Unsafe | Safe | Interruptible - deriving( Show, Eq, Ord, Data, Generic ) - -data Pragma = InlineP Name Inline RuleMatch Phases - | SpecialiseP Name Type (Maybe Inline) Phases - | SpecialiseInstP Type - | RuleP String [RuleBndr] Exp Exp Phases - | AnnP AnnTarget Exp - | LineP Int String - | CompleteP [Name] (Maybe Name) - -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@ - deriving( Show, Eq, Ord, Data, Generic ) - -data Inline = NoInline - | Inline - | Inlinable - deriving (Show, Eq, Ord, Data, Generic) - -data RuleMatch = ConLike - | FunLike - deriving (Show, Eq, Ord, Data, Generic) - -data Phases = AllPhases - | FromPhase Int - | BeforePhase Int - deriving (Show, Eq, Ord, Data, Generic) - -data RuleBndr = RuleVar Name - | TypedRuleVar Name Type - deriving (Show, Eq, Ord, Data, Generic) - -data AnnTarget = ModuleAnnotation - | TypeAnnotation Name - | ValueAnnotation Name - deriving (Show, Eq, Ord, Data, Generic) - -type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ - --- | Since the advent of @ConstraintKinds@, constraints are really just types. --- Equality constraints use the 'EqualityT' constructor. Constraints may also --- be tuples of other constraints. -type Pred = Type - -data SourceUnpackedness - = NoSourceUnpackedness -- ^ @C a@ - | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ - | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ - deriving (Show, Eq, Ord, Data, Generic) - -data SourceStrictness = NoSourceStrictness -- ^ @C a@ - | SourceLazy -- ^ @C {~}a@ - | SourceStrict -- ^ @C {!}a@ - deriving (Show, Eq, Ord, Data, Generic) - --- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' --- refers to the strictness that the compiler chooses for a data constructor --- field, which may be different from what is written in source code. See --- 'reifyConStrictness' for more information. -data DecidedStrictness = DecidedLazy - | DecidedStrict - | DecidedUnpack - deriving (Show, Eq, Ord, Data, Generic) - -data Con = NormalC Name [BangType] -- ^ @C Int a@ - | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ - | InfixC BangType Name BangType -- ^ @Int :+ a@ - | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ - | GadtC [Name] [BangType] - Type -- See Note [GADT return type] - -- ^ @C :: a -> b -> T b Int@ - | RecGadtC [Name] [VarBangType] - Type -- See Note [GADT return type] - -- ^ @C :: { v :: Int } -> T b Int@ - deriving (Show, Eq, Ord, Data, Generic) - --- Note [GADT return type] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- The return type of a GADT constructor does not necessarily match the name of --- the data type: --- --- type S = T --- --- data T a where --- MkT :: S Int --- --- --- type S a = T --- --- data T a where --- MkT :: S Char Int --- --- --- type Id a = a --- type S a = T --- --- data T a where --- MkT :: Id (S Char Int) --- --- --- That is why we allow the return type stored by a constructor to be an --- arbitrary type. See also #11341 - -data Bang = Bang SourceUnpackedness SourceStrictness - -- ^ @C { {\-\# UNPACK \#-\} !}a@ - deriving (Show, Eq, Ord, Data, Generic) - -type BangType = (Bang, Type) -type VarBangType = (Name, Bang, Type) - --- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'. -type Strict = Bang - --- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by --- 'BangType'. -type StrictType = BangType - --- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by --- 'VarBangType'. -type VarStrictType = VarBangType - --- | A pattern synonym's directionality. -data PatSynDir - = Unidir -- ^ @pattern P x {<-} p@ - | ImplBidir -- ^ @pattern P x {=} p@ - | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | A pattern synonym's argument type. -data PatSynArgs - = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ - | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ - | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ - deriving( Show, Eq, Ord, Data, Generic ) - -data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ -> \@ - | AppT Type Type -- ^ @T a b@ - | SigT Type Kind -- ^ @t :: k@ - | VarT Name -- ^ @a@ - | ConT Name -- ^ @T@ - | PromotedT Name -- ^ @'T@ - | InfixT Type Name Type -- ^ @T + T@ - | UInfixT Type Name Type -- ^ @T + T@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | ParensT Type -- ^ @(T)@ - - -- See Note [Representing concrete syntax in types] - | TupleT Int -- ^ @(,), (,,), etc.@ - | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ - | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ - | ArrowT -- ^ @->@ - | EqualityT -- ^ @~@ - | ListT -- ^ @[]@ - | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ - | PromotedNilT -- ^ @'[]@ - | PromotedConsT -- ^ @(':)@ - | StarT -- ^ @*@ - | ConstraintT -- ^ @Constraint@ - | LitT TyLit -- ^ @0,1,2, etc.@ - | WildCardT -- ^ @_, - deriving( Show, Eq, Ord, Data, Generic ) - -data TyVarBndr = PlainTV Name -- ^ @a@ - | KindedTV Name Kind -- ^ @(a :: k)@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | Type family result signature -data FamilyResultSig = NoSig -- ^ no signature - | KindSig Kind -- ^ @k@ - | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | Injectivity annotation -data InjectivityAnn = InjectivityAnn Name [Name] - deriving ( Show, Eq, Ord, Data, Generic ) - -data TyLit = NumTyLit Integer -- ^ @2@ - | StrTyLit String -- ^ @"Hello"@ - deriving ( Show, Eq, Ord, Data, Generic ) - --- | Role annotations -data Role = NominalR -- ^ @nominal@ - | RepresentationalR -- ^ @representational@ - | PhantomR -- ^ @phantom@ - | InferR -- ^ @_@ - deriving( Show, Eq, Ord, Data, Generic ) - --- | Annotation target for reifyAnnotations -data AnnLookup = AnnLookupModule Module - | AnnLookupName Name - deriving( Show, Eq, Ord, Data, Generic ) - --- | To avoid duplication between kinds and types, they --- are defined to be the same. Naturally, you would never --- have a type be 'StarT' and you would never have a kind --- be 'SigT', but many of the other constructors are shared. --- Note that the kind @Bool@ is denoted with 'ConT', not --- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT', --- not 'PromotedTupleT'. - -type Kind = Type - -{- Note [Representing concrete syntax in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell has a rich concrete syntax for types, including - t1 -> t2, (t1,t2), [t], and so on -In TH we represent all of this using AppT, with a distinguished -type constructor at the head. So, - Type TH representation - ----------------------------------------------- - t1 -> t2 ArrowT `AppT` t2 `AppT` t2 - [t] ListT `AppT` t - (t1,t2) TupleT 2 `AppT` t1 `AppT` t2 - '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2 - -But if the original HsSyn used prefix application, we won't use -these special TH constructors. For example - [] t ConT "[]" `AppT` t - (->) t ConT "->" `AppT` t -In this way we can faithfully represent in TH whether the original -HsType used concrete syntax or not. - -The one case that doesn't fit this pattern is that of promoted lists - '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2 -but it's very smelly because there really is no type constructor -corresponding to PromotedListT. So we encode HsExplicitListTy with -PromotedConsT and PromotedNilT (which *do* have underlying type -constructors): - '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT` - (PromotedConsT `AppT` IO `AppT` PromotedNilT) --} - ------------------------------------------------------ --- Internal helper functions ------------------------------------------------------ - -cmpEq :: Ordering -> Bool -cmpEq EQ = True -cmpEq _ = False - -thenCmp :: Ordering -> Ordering -> Ordering -thenCmp EQ o2 = o2 -thenCmp o1 _ = o1 +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} + +module Language.Haskell.TH.Syntax ( + Quote (..), + Exp (..), + Match (..), + Clause (..), + Q (..), + Pat (..), + Stmt (..), + Con (..), + Type (..), + Dec (..), + BangType, + VarBangType, + FieldExp, + FieldPat, + Name (..), + FunDep (..), + Pred, + RuleBndr (..), + TySynEqn (..), + InjectivityAnn (..), + Kind, + Overlap (..), + DerivClause (..), + DerivStrategy (..), + Code (..), + ModName (..), + addCorePlugin, + addDependentFile, + addForeignFile, + addForeignFilePath, + addForeignSource, + addModFinalizer, + addTempFile, + addTopDecls, + badIO, + bindCode, + bindCode_, + cmpEq, + compareBytes, + counter, + defaultFixity, + eqBytes, + extsEnabled, + getDoc, + getPackageRoot, + getQ, + get_cons_names, + hoistCode, + isExtEnabled, + isInstance, + joinCode, + liftCode, + location, + lookupName, + lookupTypeName, + lookupValueName, + manyName, + maxPrecedence, + memcmp, + mkNameG, + mkNameU, + mkOccName, + mkPkgName, + mk_tup_name, + mkName, + mkNameG_v, + mkNameG_d, + mkNameG_tc, + mkNameL, + mkNameS, + unTypeCode, + mkModName, + unsafeCodeCoerce, + mkNameQ, + mkNameG_fld, + modString, + nameBase, + nameModule, + namePackage, + nameSpace, + newDeclarationGroup, + newNameIO, + occString, + oneName, + pkgString, + putDoc, + putQ, + recover, + reify, + reifyAnnotations, + reifyConStrictness, + reifyFixity, + reifyInstances, + reifyModule, + reifyRoles, + reifyType, + report, + reportError, + reportWarning, + runIO, + sequenceQ, + runQ, + showName, + showName', + thenCmp, + tupleDataName, + tupleTypeName, + unTypeQ, + unboxedSumDataName, + unboxedSumTypeName, + unboxedTupleDataName, + unboxedTupleTypeName, + unsafeTExpCoerce, + ForeignSrcLang (..), + Extension (..), + AnnLookup (..), + AnnTarget (..), + Arity, + Bang (..), + BndrVis (..), + Body (..), + Bytes (..), + Callconv (..), + CharPos, + Cxt, + DecidedStrictness (..), + DocLoc (..), + FamilyResultSig (..), + Fixity (..), + FixityDirection (..), + Foreign (..), + Guard (..), + Info (..), + Inline (..), + InstanceDec, + Lit (..), + Loc (..), + Module (..), + ModuleInfo (..), + NameFlavour (..), + NameIs (..), + NameSpace (..), + NamespaceSpecifier (..), + OccName (..), + ParentName, + PatSynArgs (..), + PatSynDir (..), + PatSynType, + Phases (..), + PkgName (..), + Pragma (SpecialiseP, ..), + Quasi (..), + Range (..), + Role (..), + RuleMatch (..), + Safety (..), + SourceStrictness (..), + SourceUnpackedness (..), + Specificity (..), + Strict, + StrictType, + SumAlt, + SumArity, + TExp (..), + TyLit (..), + TyVarBndr (..), + TypeFamilyHead (..), + Uniq, + Unlifted, + VarStrictType, + makeRelativeToProject, + liftString, + Lift (..), + dataToCodeQ, + dataToExpQ, + dataToPatQ, + dataToQa, + falseName, + justName, + leftName, + liftData, + liftDataTyped, + nonemptyName, + nothingName, + rightName, + trueName, +) +where + +import GHC.Boot.TH.Lift +import GHC.Boot.TH.Syntax +import System.FilePath +import Data.Data hiding (Fixity(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Lexeme ( startsVarSym, startsVarId ) + +-- This module completely re-exports 'GHC.Boot.TH.Syntax', +-- and exports additionally functions that depend on filepath. + +-- | +addForeignFile :: ForeignSrcLang -> String -> Q () +addForeignFile = addForeignSource +{-# DEPRECATED addForeignFile + "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" + #-} -- deprecated in 8.6 + +-- | The input is a filepath, which if relative is offset by the package root. +makeRelativeToProject :: FilePath -> Q FilePath +makeRelativeToProject fp | isRelative fp = do + root <- getPackageRoot + return (root fp) +makeRelativeToProject fp = return fp + +trueName, falseName :: Name +trueName = 'True +falseName = 'False + +nothingName, justName :: Name +nothingName = 'Nothing +justName = 'Just + +leftName, rightName :: Name +leftName = 'Left +rightName = 'Right + +nonemptyName :: Name +nonemptyName = '(:|) + +----------------------------------------------------- +-- +-- Generic Lift implementations +-- +----------------------------------------------------- + +-- | 'dataToQa' is an internal utility function for constructing generic +-- conversion functions from types with 'Data' instances to various +-- quasi-quoting representations. See the source of 'dataToExpQ' and +-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@ +-- and @appQ@ are overloadable to account for different syntax for +-- expressions and patterns; @antiQ@ allows you to override type-specific +-- cases, a common usage is just @const Nothing@, which results in +-- no overloading. +dataToQa :: forall m a k q. (Quote m, Data a) + => (Name -> k) + -> (Lit -> m q) + -> (k -> [m q] -> m q) + -> (forall b . Data b => b -> Maybe (m q)) + -> a + -> m q +dataToQa mkCon mkLit appCon antiQ t = + case antiQ t of + Nothing -> + case constrRep constr of + AlgConstr _ -> + appCon (mkCon funOrConName) conArgs + where + funOrConName :: Name + funOrConName = + case showConstr constr of + "(:)" -> Name (mkOccName ":") + (NameG DataName + (mkPkgName "ghc-internal") + (mkModName "GHC.Internal.Types")) + con@"[]" -> Name (mkOccName con) + (NameG DataName + (mkPkgName "ghc-internal") + (mkModName "GHC.Internal.Types")) + con@('(':_) -> Name (mkOccName con) + (NameG DataName + (mkPkgName "ghc-internal") + (mkModName "GHC.Internal.Tuple")) + + -- Tricky case: see Note [Data for non-algebraic types] + fun@(x:_) | startsVarSym x || startsVarId x + -> mkNameG_v tyconPkg tyconMod fun + con -> mkNameG_d tyconPkg tyconMod con + + where + tycon :: TyCon + tycon = (typeRepTyCon . typeOf) t + + tyconPkg, tyconMod :: String + tyconPkg = tyConPackage tycon + tyconMod = tyConModule tycon + + conArgs :: [m q] + conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t + IntConstr n -> + mkLit $ IntegerL n + FloatConstr n -> + mkLit $ RationalL n + CharConstr c -> + mkLit $ CharL c + where + constr :: Constr + constr = toConstr t + + Just y -> y + + +{- Note [Data for non-algebraic types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class Data was originally intended for algebraic data types. But +it is possible to use it for abstract types too. For example, in +package `text` we find + + instance Data Text where + ... + toConstr _ = packConstr + + packConstr :: Constr + packConstr = mkConstr textDataType "pack" [] Prefix + +Here `packConstr` isn't a real data constructor, it's an ordinary +function. Two complications + +* In such a case, we must take care to build the Name using + mkNameG_v (for values), not mkNameG_d (for data constructors). + See #10796. + +* The pseudo-constructor is named only by its string, here "pack". + But 'dataToQa' needs the TyCon of its defining module, and has + to assume it's defined in the same module as the TyCon itself. + But nothing enforces that; #12596 shows what goes wrong if + "pack" is defined in a different module than the data type "Text". + -} + +-- | A typed variant of 'dataToExpQ'. +dataToCodeQ :: (Quote m, Data a) + => (forall b . Data b => b -> Maybe (Code m b)) + -> a -> Code m a +dataToCodeQ f = unsafeCodeCoerce . dataToExpQ (fmap unTypeCode . f) + +-- | 'dataToExpQ' converts a value to a 'Exp' representation of the +-- same value, in the SYB style. It is generalized to take a function +-- override type-specific cases; see 'liftData' for a more commonly +-- used variant. +dataToExpQ :: (Quote m, Data a) + => (forall b . Data b => b -> Maybe (m Exp)) + -> a + -> m Exp +dataToExpQ = dataToQa varOrConE litE (foldl appE) + where + -- Make sure that VarE is used if the Constr value relies on a + -- function underneath the surface (instead of a constructor). + -- See #10796. + varOrConE s = + case nameSpace s of + Just VarName -> return (VarE s) + Just (FldName {}) -> return (VarE s) + Just DataName -> return (ConE s) + _ -> error $ "Can't construct an expression from name " + ++ showName s + appE x y = do { a <- x; b <- y; return (AppE a b)} + litE c = return (LitE c) + +-- | A typed variant of 'liftData'. +liftDataTyped :: (Quote m, Data a) => a -> Code m a +liftDataTyped = dataToCodeQ (const Nothing) + +-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which +-- works for any type with a 'Data' instance. +liftData :: (Quote m, Data a) => a -> m Exp +liftData = dataToExpQ (const Nothing) + +-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same +-- value, in the SYB style. It takes a function to handle type-specific cases, +-- alternatively, pass @const Nothing@ to get default behavior. +dataToPatQ :: (Quote m, Data a) + => (forall b . Data b => b -> Maybe (m Pat)) + -> a + -> m Pat +dataToPatQ = dataToQa id litP conP + where litP l = return (LitP l) + conP n ps = + case nameSpace n of + Just DataName -> do + ps' <- sequence ps + return (ConP n [] ps') + _ -> error $ "Can't construct a pattern from name " + ++ showName n + +-------------------------------------------------------------------------------- +-- Back-compat for Specialise pragmas + +-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@. +-- +-- Subsumed by the more general 'SpecialiseEP' constructor. +pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma +pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,238 @@ # 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. + * 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 @@ -31,6 +261,8 @@ - `plainTV` and `kindedTV` - `interruptible` and `funDep` - `valueAnnotation`, `typeAnnotation`, and `moduleAnnotation` + + * Add support for overloaded labels. ## 2.11.0.0 *May 2016* diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -1,11 +1,15 @@ +-- WARNING: template-haskell.cabal is automatically generated from template-haskell.cabal.in by +-- ../../configure. Make sure you are editing template-haskell.cabal.in, not +-- template-haskell.cabal. + name: template-haskell -version: 2.12.0.0 +version: 2.24.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE category: Template Haskell maintainer: libraries@haskell.org -bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=Template%20Haskell +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new synopsis: Support library for Template Haskell build-type: Simple Cabal-Version: >= 1.10 @@ -20,7 +24,7 @@ source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/template-haskell Library @@ -44,23 +48,22 @@ Language.Haskell.TH.Quote Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions - - other-modules: - Language.Haskell.TH.Lib.Map + Language.Haskell.TH.CodeDo build-depends: - base >= 4.8 && < 4.11, - ghc-boot-th == 8.2.*, - pretty == 1.1.* + 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 - -- We need to set the unit ID to template-haskell (without a - -- version number) as it's magic. - ghc-options: -Wall + other-modules: + System.FilePath + System.FilePath.Posix + System.FilePath.Windows + hs-source-dirs: ./vendored-filepath . + default-extensions: + ImplicitPrelude - if impl( ghc >= 7.11 ) - ghc-options: -this-unit-id template-haskell - else - if impl( ghc >= 7.9 ) - ghc-options: -this-package-key template-haskell - else - ghc-options: -package-name template-haskell + ghc-options: -Wall diff --git a/vendored-filepath/System/FilePath.hs b/vendored-filepath/System/FilePath.hs new file mode 100644 --- /dev/null +++ b/vendored-filepath/System/FilePath.hs @@ -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] (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 diff --git a/vendored-filepath/System/FilePath/Posix.hs b/vendored-filepath/System/FilePath/Posix.hs new file mode 100644 --- /dev/null +++ b/vendored-filepath/System/FilePath/Posix.hs @@ -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] (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 +-- +-- +-- > 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:\" or "\\?\UNC\\" +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 +-- . +-- +-- 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) diff --git a/vendored-filepath/System/FilePath/Windows.hs b/vendored-filepath/System/FilePath/Windows.hs new file mode 100644 --- /dev/null +++ b/vendored-filepath/System/FilePath/Windows.hs @@ -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] (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 +-- +-- +-- > 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:\" or "\\?\UNC\\" +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 +-- . +-- +-- 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)