ghc-lib-parser-ex-8.10.0.16/cbits/0000755000000000000000000000000013713641612014534 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/0000755000000000000000000000000013713641612014217 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/0000755000000000000000000000000013713641612015742 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/0000755000000000000000000000000013713641612017325 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/0000755000000000000000000000000013713641612022167 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/0000755000000000000000000000000013713641612022570 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Driver/0000755000000000000000000000000013713641612024023 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/0000755000000000000000000000000013713641612023142 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Settings/0000755000000000000000000000000013713641612024370 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Types/0000755000000000000000000000000013713641612023674 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/0000755000000000000000000000000013713641612024554 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Utils/0000755000000000000000000000000013713641612023670 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/test/0000755000000000000000000000000013713641612014407 5ustar0000000000000000ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/Dump.hs0000644000000000000000000002010213713641612023423 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {- HLINT ignore -} -- Not our code. {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.Dump( showAstData , BlankSrcSpan(..), ) where #if !defined(MIN_VERSION_ghc_lib_parser) -- Using native ghc. # if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs.Dump # else import HsDumpAst # endif #else -- Using ghc-lib-parser. Recent versions will include -- GHC.Hs.Dump (it got moved in from ghc-lib on 2020-02-05). # if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs.Dump # else -- For simplicity, just assume it's missing from 8.8 ghc-lib-parser -- builds and reproduce the implementation. import Prelude as X hiding ((<>)) import Data.Data hiding (Fixity) import Bag import BasicTypes import FastString import NameSet import Name import DataCon import SrcLoc #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif import OccName hiding (occName) import Var import Module import Outputable import qualified Data.ByteString as B data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan deriving (Eq,Show) -- | Show a GHC syntax tree. This parameterised because it is also used for -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked -- out, to avoid comparing locations, only structure showAstData :: Data a => BlankSrcSpan -> a -> SDoc showAstData b a0 = blankLine $$ showAstData' a0 where showAstData' :: Data a => a -> SDoc showAstData' = generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` lit `extQ` litr `extQ` litt `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located where generic :: Data a => a -> SDoc generic t = parens $ text (showConstr (toConstr t)) $$ vcat (gmapQ showAstData' t) string :: String -> SDoc string = text . normalize_newlines . show fastString :: FastString -> SDoc fastString s = braces $ text "FastString: " <> text (normalize_newlines . show $ s) bytestring :: B.ByteString -> SDoc bytestring = text . normalize_newlines . show list [] = brackets empty list [x] = brackets (showAstData' x) list (x1 : x2 : xs) = (text "[" <> showAstData' x1) $$ go x2 xs where go y [] = text "," <> showAstData' y <> text "]" go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys -- Eliminate word-size dependence lit :: HsLit GhcPs -> SDoc lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s lit l = generic l litr :: HsLit GhcRn -> SDoc litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s litr l = generic l litt :: HsLit GhcTc -> SDoc litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s litt l = generic l numericLit :: String -> Integer -> SourceText -> SDoc numericLit tag x s = braces $ hsep [ text tag , generic x , generic s ] name :: Name -> SDoc name nm = braces $ text "Name: " <> ppr nm occName n = braces $ text "OccName: " <> text (OccName.occNameString n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName: " <> ppr m srcSpan :: SrcSpan -> SDoc srcSpan ss = case b of BlankSrcSpan -> text "{ ss }" NoBlankSrcSpan -> braces $ char ' ' <> (hang (ppr ss) 1 -- TODO: show annotations here (text "")) var :: Var -> SDoc var v = braces $ text "Var: " <> ppr v dataCon :: DataCon -> SDoc dataCon c = braces $ text "DataCon: " <> ppr c bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc bagRdrName bg = braces $ text "Bag(Located (HsBind GhcPs)):" $$ (list . bagToList $ bg) bagName :: Bag (Located (HsBind GhcRn)) -> SDoc bagName bg = braces $ text "Bag(Located (HsBind Name)):" $$ (list . bagToList $ bg) bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc bagVar bg = braces $ text "Bag(Located (HsBind Var)):" $$ (list . bagToList $ bg) nameSet ns = braces $ text "NameSet:" $$ (list . nameSetElemsStable $ ns) fixity :: Fixity -> SDoc fixity fx = braces $ text "Fixity: " <> ppr fx located :: (Data b,Data loc) => GenLocated loc b -> SDoc located (L ss a) = parens $ case cast ss of Just (s :: SrcSpan) -> srcSpan s Nothing -> text "nnnnnnnn" $$ showAstData' a normalize_newlines :: String -> String normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs normalize_newlines (x:xs) = x:normalize_newlines xs normalize_newlines [] = [] {- ************************************************************************ * * * Copied from syb * * ************************************************************************ -} -- | The type constructor for queries newtype Q q x = Q { unQ :: x -> q } -- | Extend a generic query by a type-specific case extQ :: ( Typeable a , Typeable b ) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) -- | Type extension of queries for type constructors ext1Q :: (Data d, Typeable t) => (d -> q) -> (forall e. Data e => t e -> q) -> d -> q ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) -- | Type extension of queries for type constructors ext2Q :: (Data d, Typeable t) => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) -- | Flexible type extension ext1 :: (Data a, Typeable t) => c a -> (forall d. Data d => c (t d)) -> c a ext1 def ext = maybe def id (dataCast1 ext) -- | Flexible type extension ext2 :: (Data a, Typeable t) => c a -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) -> c a ext2 def ext = maybe def id (dataCast2 ext) # endif #endif ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/Fixity.hs0000644000000000000000000001735213713641612024007 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. -- -- Adapted from (1) https://github.com/mpickering/apply-refact.git and -- (2) https://gitlab.haskell.org/ghc/ghc ('compiler/renamer/RnTypes.hs'). {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.Fixity( applyFixities , fixitiesFromModule , preludeFixities, baseFixities , infixr_, infixl_, infix_, fixity ) where #if defined (GHCLIB_API_811) import GHC.Hs import GHC.Types.Basic import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.SrcLoc #elif defined (GHCLIB_API_810) import GHC.Hs import BasicTypes import RdrName import OccName import SrcLoc #else import HsSyn import BasicTypes import RdrName import OccName import SrcLoc #endif import Data.Maybe import Data.Data hiding (Fixity) import Data.Generics.Uniplate.Data #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noExt :: NoExtField noExt = noExtField #endif -- | Rearrange a parse tree to account for fixities. applyFixities :: Data a => [(String, Fixity)] -> a -> a applyFixities fixities m = let m' = transformBi (expFix fixities) m m'' = transformBi (patFix fixities) m' in m'' expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs expFix fixities (L loc (OpApp _ l op r)) = mkOpApp (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r expFix _ e = e -- LPat and Pat have gone through a lot of churn. See -- https://gitlab.haskell.org/ghc/ghc/merge_requests/1925 for details. patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs #if defined (GHCLIB_API_811) patFix fixities (L loc (ConPat _ op (InfixCon pat1 pat2))) = L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #elif defined (GHCLIB_API_810) patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) = L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #else patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) = mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2 #endif patFix _ p = p mkConOpPat :: [(String, Fixity)] -> Located RdrName -> Fixity -> LPat GhcPs -> LPat GhcPs -> Pat GhcPs #if defined (GHCLIB_API_811) mkConOpPat fs op2 fix2 p1@(L loc (ConPat _ op1 (InfixCon p11 p12))) p2 #elif defined (GHCLIB_API_810) mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #else mkConOpPat fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #endif #if defined (GHCLIB_API_811) | nofix_error = ConPat noExtField op2 (InfixCon p1 p2) #else | nofix_error = ConPatIn op2 (InfixCon p1 p2) #endif #if defined (GHCLIB_API_811) | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #elif defined (GHCLIB_API_810) | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #else | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2))) #endif #if defined (GHCLIB_API_811) | otherwise = ConPat noExtField op2 (InfixCon p1 p2) #else | otherwise = ConPatIn op2 (InfixCon p1 p2) #endif where fix1 = findFixity' fs op1 (nofix_error, associate_right) = compareFixity fix1 fix2 #if defined (GHCLIB_API_811) mkConOpPat _ op _ p1 p2 = ConPat noExtField op (InfixCon p1 p2) #else mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2) #endif mkOpApp :: [(String, Fixity)] -> SrcSpan -> LHsExpr GhcPs -- Left operand; already rearrange. -> LHsExpr GhcPs -> Fixity -- Operator and fixity. -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp). -> LHsExpr GhcPs -- (e11 `op1` e12) `op2` e2 mkOpApp fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2 | nofix_error = L loc (OpApp noExt e1 op2 e2) | associate_right = L loc (OpApp x1 e11 op1 (mkOpApp fs loc' e12 op2 fix2 e2 )) where loc'= combineLocs e12 e2 fix1 = findFixity fs op1 (nofix_error, associate_right) = compareFixity fix1 fix2 -- (- neg_arg) `op` e2 mkOpApp fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = L loc (OpApp noExt e1 op2 e2) | associate_right = L loc (NegApp noExt (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 -- e1 `op` - neg_arg mkOpApp _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right. | not associate_right = L loc (OpApp noExt e1 op1 e2)-- We *want* right association. where (_, associate_right) = compareFixity fix1 negateFixity -- Default case, no rearrangment. mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExt e1 op e2) getIdent :: LHsExpr GhcPs -> String getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n getIdent _ = error "Must be HsVar" -- If there are no fixities, give 'baseFixities'. getFixities :: [(String, Fixity)] -> [(String, Fixity)] getFixities fixities = if null fixities then baseFixities else fixities findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity findFixity fs r = askFix fs (getIdent r) -- Expressions. findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r) -- Patterns. askFix :: [(String, Fixity)] -> String -> Fixity askFix xs = \k -> lookupWithDefault defaultFixity k xs where lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1 -- All fixities defined in the Prelude. preludeFixities :: [(String, Fixity)] preludeFixities = concat [ infixr_ 9 ["."] , infixl_ 9 ["!!"] , infixr_ 8 ["^","^^","**"] , infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"] , infixl_ 6 ["+","-"] , infixr_ 5 [":","++"] , infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"] , infixr_ 3 ["&&"] , infixr_ 2 ["||"] , infixl_ 1 [">>",">>="] , infixr_ 1 ["=<<"] , infixr_ 0 ["$","$!","seq"] ] -- All fixities defined in the base package. Note that the @+++@ -- operator appears in both Control.Arrows and -- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in -- this list is that of Control.Arrows. baseFixities :: [(String, Fixity)] baseFixities = preludeFixities ++ concat [ infixr_ 9 ["Compose"] , infixl_ 9 ["!","//","!:"] , infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"] , infixl_ 7 [".&."] , infixl_ 6 ["xor"] , infix_ 6 [":+"] , infixr_ 6 ["<>"] , infixl_ 5 [".|."] , infixr_ 5 ["+:+","<++","<+>","<|"] -- Fixity conflict for +++ between ReadP and Arrow. , infix_ 5 ["\\\\"] , infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"] , infix_ 4 ["elemP","notElemP",":~:", ":~~:"] , infixl_ 3 ["<|>"] , infixr_ 3 ["&&&","***"] , infixr_ 2 ["+++","|||"] , infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] , infixl_ 0 ["on"] , infixr_ 0 ["par","pseq"] ] infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)] infixr_ = fixity InfixR infixl_ = fixity InfixL infix_ = fixity InfixN fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)] fixity a p = map (,Fixity (SourceText "") p a) #if defined (GHCLIB_API_811) fixitiesFromModule :: Located HsModule -> [(String, Fixity)] #else fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)] #endif #if defined(GHCLIB_API_811) fixitiesFromModule (L _ (HsModule _ _ _ _ decls _ _)) = concatMap f decls #else fixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls #endif where f :: LHsDecl GhcPs -> [(String, Fixity)] f (L _ (SigD _ (FixSig _ (FixitySig _ ops (Fixity _ p dir))))) = fixity dir p (map (occNameString. rdrNameOcc . unLoc) ops) f _ = [] ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Settings/Config.hs0000644000000000000000000000537013713641612026136 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# OPTIONS_GHC -Wno-missing-fields #-} {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Settings.Config( fakeSettings , fakeLlvmConfig ) where #if defined (GHCLIB_API_811) import GHC.Settings.Config import GHC.Driver.Session import GHC.Utils.Fingerprint import GHC.Platform import GHC.Settings #elif defined (GHCLIB_API_810) import Config import DynFlags import Fingerprint import GHC.Platform import ToolSettings #else import Config import DynFlags import Fingerprint import Platform #endif fakeSettings :: Settings fakeSettings = Settings #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) { sGhcNameVersion=ghcNameVersion , sFileSettings=fileSettings , sTargetPlatform=platform , sPlatformMisc=platformMisc , sPlatformConstants=platformConstants , sToolSettings=toolSettings } #else { sTargetPlatform=platform , sPlatformConstants=platformConstants , sProjectVersion=cProjectVersion , sProgramName="ghc" , sOpt_P_fingerprint=fingerprint0 } #endif where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) toolSettings = ToolSettings { toolSettings_opt_P_fingerprint=fingerprint0 } fileSettings = FileSettings {} platformMisc = PlatformMisc {} ghcNameVersion = GhcNameVersion{ghcNameVersion_programName="ghc" ,ghcNameVersion_projectVersion=cProjectVersion } #endif platform = Platform{ #if defined(GHCLIB_API_811) -- It doesn't matter what values we write here as these fields are -- not referenced for our purposes. However the fields are strict -- so we must say something. platformByteOrder=LittleEndian , platformHasGnuNonexecStack=True , platformHasIdentDirective=False , platformHasSubsectionsViaSymbols=False , platformIsCrossCompiling=False , platformLeadingUnderscore=False , platformTablesNextToCode=False , platformConstants=platformConstants , #endif #if defined (GHCLIB_API_811) platformWordSize=PW8 , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown} #elif defined (GHCLIB_API_810) platformWordSize=PW8 , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} #else platformWordSize=8 , platformOS=OSUnknown #endif , platformUnregisterised=True } platformConstants = PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) fakeLlvmConfig :: LlvmConfig fakeLlvmConfig = LlvmConfig [] [] #else fakeLlvmConfig :: (LlvmTargets, LlvmPasses) fakeLlvmConfig = ([], []) #endif ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs0000644000000000000000000000065113713641612025415 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Driver.Flags () where #if !defined(GHCLIB_API_811) import DynFlags #endif -- This instance landed in -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2905. #if defined(GHCLIB_API_808) || defined(GHCLIB_API_810) instance Bounded Language where minBound = Haskell98 maxBound = Haskell2010 #endif ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs0000644000000000000000000001615413713641612026011 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Driver.Session( readExtension , extensionImplications -- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. #if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags #endif , parsePragmasIntoDynFlags ) where #if defined(GHCLIB_API_808) || defined(GHCLIB_API_810) import qualified GHC.LanguageExtensions as LangExt #endif #if defined (GHCLIB_API_811) import GHC.Utils.Panic import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Driver.Session import GHC.Driver.Types #else import Panic import HeaderInfo import StringBuffer import DynFlags import HscTypes #endif import GHC.LanguageExtensions.Type import Data.List import Data.Maybe import qualified Data.Map as Map -- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707. #if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) import Data.Function -- For `compareOn`. instance Ord Extension where compare = compare `on` fromEnum #endif -- | Parse a GHC extension. readExtension :: String -> Maybe Extension readExtension s = flagSpecFlag <$> find (\(FlagSpec n _ _ _) -> n == s) xFlags -- | Implicitly enabled/disabled extensions. extensionImplications :: [(Extension, ([Extension], [Extension]))] extensionImplications = map f $ Map.toList implicationsMap where f (e, ps) = (fromJust (readExtension e), ps) implicationsMap :: Map.Map String ([Extension], [Extension]) implicationsMap = Map.fromListWith (<>) [(show a, ([c | b], [c | not b])) | (a, flag, c) <- impliedXFlags, let b = flag == turnOn] -- Landed in -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. Copied from -- 'ghc/compiler/main/DynFlags.hs'. #if defined(GHCLIB_API_808) || defined(GHCLIB_API_810) type TurnOnFlag = Bool -- True <=> we are turning the flag on -- False <=> we are turning the flag off turnOn :: TurnOnFlag; turnOn = True turnOff :: TurnOnFlag; turnOff = False -- General flags that are switched on/off when other general flags are switched -- on impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) ,(Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits)] -- General flags that are switched on/off when other general flags are switched -- off impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] impliedXFlags -- See Note [Updating flag description in the User's Guide] = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds -- TypeInType is now just a synonym for a couple of other extensions. , (LangExt.TypeInType, turnOn, LangExt.DataKinds) , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) #if defined(GHCLIB_API_810) -- Standalone kind signatures are a replacement for CUSKs. , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) #endif -- AutoDeriveTypeable is not very useful without DeriveDataTypeable , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) -- We turn this on so that we can export associated type -- type synonyms in subordinates (e.g. MyClass(type AssocType)) , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) -- Record wild-cards implies field disambiguation -- Otherwise if you write (C {..}) you may well get -- stuff like " 'a' not in scope ", which is a bit silly -- if the compiler has just filled in field 'a' of constructor 'C' , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) -- Duplicate record fields require field disambiguation , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) , (LangExt.Strict, turnOn, LangExt.StrictData) ] #endif parsePragmasIntoDynFlags :: DynFlags -> ([Extension], [Extension]) -> FilePath -> String -> IO (Either String DynFlags) parsePragmasIntoDynFlags flags (enable, disable) file str = catchErrors $ do let opts = getOptions flags (stringToStringBuffer str) file -- Important : apply enables, disables *before* parsing dynamic -- file pragmas. let flags' = foldl' xopt_set flags enable let flags'' = foldl' xopt_unset flags' disable (flags, _, _) <- parseDynamicFilePragma flags'' opts return $ Right (flags `gopt_set` Opt_KeepRawTokenStream) where catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags) catchErrors act = handleGhcException reportErr (handleSourceError reportErr act) reportErr e = return $ Left (show e) ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs.hs0000644000000000000000000000125013713641612023474 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs( modName ) where #if defined(GHCLIB_API_811) import GHC.Hs import GHC.Unit.Module import GHC.Types.SrcLoc #elif defined(GHCLIB_API_810) import GHC.Hs import Module import SrcLoc #else import HsSyn import Module import SrcLoc #endif #if defined(GHCLIB_API_811) modName :: Located HsModule -> String #else modName :: Located (HsModule GhcPs) -> String #endif modName (L _ HsModule {hsmodName=Nothing}) = "Main" modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs0000644000000000000000000001425413713641612024422 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# OPTIONS_GHC -Wno-missing-fields #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Expr( isTag, isDol, isDot, isReturn, isSection, isRecConstr, isRecUpdate, isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isLambda, isQuasiQuote, isDotApp, isTypeApp, isWHNF, isLCase, isFieldPun, isFieldPunUpdate, isRecStmt, isParComp, isMDo, isTupleSection, isString, isPrimLiteral, isSpliceDecl, isFieldWildcard, isUnboxed, isWholeFrac, isStrictMatch, isMultiIf, isProc, isTransStmt, hasFieldsDotDot, varToStr, strToVar, fromChar ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined(GHCLIB_API_811) import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic import GHC.Builtin.Types #else import SrcLoc import RdrName import OccName import Name import BasicTypes import TysWiredIn #endif import Data.Ratio -- 'True' if the provided expression is a variable with name 'tag'. isTag :: String -> LHsExpr GhcPs -> Bool isTag tag = \case (L _ (HsVar _ (L _ s))) -> occNameString (rdrNameOcc s) == tag; _ -> False isDot, isDol, isReturn, isSection, isRecConstr, isRecUpdate, isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isQuasiQuote, isLambda, isDotApp, isTypeApp, isWHNF, isLCase :: LHsExpr GhcPs -> Bool isDol = isTag "$" isDot = isTag "." isReturn x = isTag "return" x || isTag "pure" x -- Allow both 'pure' and 'return' as they have the same semantics. isSection = \case (L _ SectionL{}) -> True ; (L _ SectionR{}) -> True; _ -> False isRecConstr = \case (L _ RecordCon{}) -> True; _ -> False isRecUpdate = \case (L _ RecordUpd{}) -> True; _ -> False isVar = \case (L _ HsVar{}) -> True; _ -> False isPar = \case (L _ HsPar{}) -> True; _ -> False isApp = \case (L _ HsApp{}) -> True; _ -> False isOpApp = \case (L _ OpApp{}) -> True; _ -> False isAnyApp x = isApp x || isOpApp x isLexeme = \case (L _ HsVar{}) -> True; (L _ HsOverLit{}) -> True; (L _ HsLit{}) -> True; _ -> False isLambda = \case (L _ HsLam{}) -> True; _ -> False isQuasiQuote = \case (L _ (HsSpliceE _ HsQuasiQuote{})) -> True; _ -> False isDotApp = \case (L _ (OpApp _ _ op _)) -> isDot op; _ -> False isTypeApp = \case (L _ HsAppType{}) -> True; _ -> False isWHNF = \case (L _ (HsVar _ (L _ x))) -> isRdrDataCon x (L _ (HsLit _ x)) -> case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True (L _ HsLam{}) -> True (L _ ExplicitTuple{}) -> True (L _ ExplicitList{}) -> True (L _ (HsPar _ x)) -> isWHNF x (L _ (ExprWithTySig _ x _)) -> isWHNF x -- Other (unknown) constructors may have bang patterns in them, so -- approximate. (L _ (HsApp _ (L _ (HsVar _ (L _ x))) _)) | occNameString (rdrNameOcc x) `elem` ["Just", "Left", "Right"] -> True _ -> False isLCase = \case (L _ HsLamCase{}) -> True; _ -> False isStrictMatch :: HsMatchContext RdrName -> Bool isStrictMatch FunRhs{mc_strictness=SrcStrict} = True isStrictMatch _ = False -- Field is punned e.g. '{foo}'. isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool isFieldPun = \case (L _ HsRecField {hsRecPun=True}) -> True; _ -> False -- Field puns in updates have a different type to field puns in -- constructions. isFieldPunUpdate :: HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool isFieldPunUpdate = \case HsRecField {hsRecPun=True} -> True; _ -> False -- Contains a '..' as in 'Foo{..}' hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool hasFieldsDotDot = \case HsRecFields {rec_dotdot=Just _} -> True; _ -> False isRecStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool isRecStmt = \case RecStmt{} -> True; _ -> False isParComp :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool isParComp = \case ParStmt{} -> True; _ -> False isMDo :: HsStmtContext Name -> Bool #if defined(GHCLIB_API_811) isMDo = \case MDoExpr _ -> True; _ -> False #else isMDo = \case MDoExpr -> True; _ -> False #endif isTupleSection :: HsTupArg GhcPs -> Bool isTupleSection = \case Missing{} -> True; _ -> False isString :: HsLit GhcPs -> Bool isString = \case HsString{} -> True; _ -> False isPrimLiteral :: HsLit GhcPs -> Bool isPrimLiteral = \case HsCharPrim{} -> True HsStringPrim{} -> True HsIntPrim{} -> True HsWordPrim{} -> True HsInt64Prim{} -> True HsWord64Prim{} -> True HsFloatPrim{} -> True HsDoublePrim{} -> True _ -> False isSpliceDecl :: HsExpr GhcPs -> Bool isSpliceDecl = \case HsSpliceE{} -> True; _ -> False isMultiIf :: HsExpr GhcPs -> Bool isMultiIf = \case HsMultiIf{} -> True; _ -> False isProc :: HsExpr GhcPs -> Bool isProc = \case HsProc{} -> True; _ -> False isTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool isTransStmt = \case TransStmt{} -> True; _ -> False -- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool isFieldWildcard = \case #if defined (GHCLIB_API_811) (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" #elif defined (GHCLIB_API_810) (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ _))}) -> True #else (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True #endif (L _ HsRecField {hsRecPun=True}) -> True (L _ HsRecField {}) -> False isUnboxed :: Boxity -> Bool isUnboxed = \case Unboxed -> True; _ -> False isWholeFrac :: HsExpr GhcPs -> Bool isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1 isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1 isWholeFrac _ = False varToStr :: LHsExpr GhcPs -> String varToStr (L _ (HsVar _ (L _ n))) | n == consDataCon_RDR = ":" | n == nameRdrName nilDataConName = "[]" | n == nameRdrName (getName (tupleDataCon Boxed 0)) = "()" | otherwise = occNameString (rdrNameOcc n) varToStr _ = "" strToVar :: String -> LHsExpr GhcPs #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) strToVar x = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc x)) #else strToVar x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x)) #endif fromChar :: LHsExpr GhcPs -> Maybe Char fromChar = \case (L _ (HsLit _ (HsChar _ x))) -> Just x; _ -> Nothing ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs0000644000000000000000000001113613713641612024224 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Pat( patToStr, strToPat , fromPChar , hasPFieldsDotDot , isPFieldWildcard, isPWildcard, isPFieldPun, isPatTypeSig, isPBangPat, isPViewPat ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined (GHCLIB_API_811) import GHC.Types.SrcLoc import GHC.Builtin.Types import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Data.FastString #else import SrcLoc import TysWiredIn import RdrName import OccName import FastString #endif patToStr :: LPat GhcPs -> String #if defined (GHCLIB_API_811) patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" patToStr _ = "" #elif defined (GHCLIB_API_810) patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" patToStr _ = "" #else patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" patToStr _ = "" #endif strToPat :: String -> LPat GhcPs strToPat z | z == "True" = #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noLoc $ #endif #if defined (GHCLIB_API_811) ConPat noExtField (noLoc true_RDR) (PrefixCon []) #else ConPatIn (noLoc true_RDR) (PrefixCon []) #endif | z == "False" = #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noLoc $ #endif #if defined (GHCLIB_API_811) ConPat noExtField (noLoc false_RDR) (PrefixCon []) #else ConPatIn (noLoc false_RDR) (PrefixCon []) #endif | z == "[]" = #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noLoc $ #endif #if defined (GHCLIB_API_811) ConPat noExtField (noLoc $ nameRdrName nilDataConName) (PrefixCon []) #else ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon []) #endif | otherwise = #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit z)) #else VarPat noExt (noLoc $ mkVarUnqual (fsLit z)) #endif fromPChar :: LPat GhcPs -> Maybe Char #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) fromPChar (L _ (LitPat _ (HsChar _ x))) = Just x #else fromPChar (dL -> L _ (LitPat _ (HsChar _ x))) = Just x #endif fromPChar _ = Nothing -- Contains a '..' as in 'Foo{..}' hasPFieldsDotDot :: HsRecFields GhcPs (LPat GhcPs) -> Bool hasPFieldsDotDot HsRecFields {rec_dotdot=Just _} = True hasPFieldsDotDot _ = False -- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. isPFieldWildcard :: LHsRecField GhcPs (LPat GhcPs) -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) isPFieldWildcard (L _ HsRecField {hsRecFieldArg=L _ WildPat {}}) = True isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (L _ HsRecField {}) = False #else isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=LL _ WildPat {}}) = True isPFieldWildcard (dL -> L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (dL -> L _ HsRecField {}) = False #endif isPWildcard :: LPat GhcPs -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) isPWildcard (L _ (WildPat _)) = True #else isPWildcard (dL -> L _ (WildPat _)) = True #endif isPWildcard _ = False isPFieldPun :: LHsRecField GhcPs (LPat GhcPs) -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) isPFieldPun (L _ HsRecField {hsRecPun=True}) = True #else isPFieldPun (dL -> L _ HsRecField {hsRecPun=True}) = True #endif isPFieldPun _ = False isPatTypeSig, isPBangPat, isPViewPat :: LPat GhcPs -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) isPatTypeSig (L _ SigPat{}) = True; isPatTypeSig _ = False isPBangPat (L _ BangPat{}) = True; isPBangPat _ = False isPViewPat (L _ ViewPat{}) = True; isPViewPat _ = False #else isPatTypeSig (dL -> L _ SigPat{}) = True; isPatTypeSig _ = False isPBangPat (dL -> L _ BangPat{}) = True; isPBangPat _ = False isPViewPat (dL -> L _ ViewPat{}) = True; isPViewPat _ = False #endif ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs0000644000000000000000000000137713713641612024612 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Types( fromTyParen , isTyQuasiQuote, isUnboxedTuple ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined (GHCLIB_API_811) import GHC.Types.SrcLoc #else import SrcLoc #endif fromTyParen :: LHsType GhcPs -> LHsType GhcPs fromTyParen (L _ (HsParTy _ x)) = x fromTyParen x = x isTyQuasiQuote :: LHsType GhcPs -> Bool isTyQuasiQuote (L _ (HsSpliceTy _ HsQuasiQuote{})) = True isTyQuasiQuote _ = False isUnboxedTuple :: HsTupleSort -> Bool isUnboxedTuple HsUnboxedTuple = True isUnboxedTuple _ = False ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs0000644000000000000000000000136613713641612024536 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Decls( isNewType, isForD, isDerivD, isClsDefSig ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined (GHCLIB_API_811) import GHC.Types.SrcLoc #else import SrcLoc #endif isNewType :: NewOrData -> Bool isNewType NewType = True isNewType DataType = False isForD, isDerivD :: LHsDecl GhcPs -> Bool isForD (L _ ForD{}) = True; isForD _ = False isDerivD (L _ DerivD{}) = True; isDerivD _ = False isClsDefSig :: Sig GhcPs -> Bool isClsDefSig (ClassOpSig _ True _ _) = True; isClsDefSig _ = False ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/Binds.hs0000644000000000000000000000072513713641612024541 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Binds( isPatSynBind ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs.Binds import GHC.Hs.Extension #else import HsBinds import HsExtension #endif isPatSynBind :: HsBind GhcPs -> Bool isPatSynBind PatSynBind{} = True isPatSynBind _ = False ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/ImpExp.hs0000644000000000000000000000223713713641612024704 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp( isPatSynIE #if defined (MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) , isImportQualifiedPost # endif #elif __GLASGOW_HASKELL__ >= 810 , isImportQualifiedPost #endif ) where #if defined (GHCLIB_API_811) import GHC.Hs.ImpExp import GHC.Types.Name.Reader #elif defined (GHCLIB_API_810) import GHC.Hs.ImpExp import RdrName #else import HsImpExp import RdrName #endif isPatSynIE :: IEWrappedName RdrName -> Bool isPatSynIE IEPattern{} = True isPatSynIE _ = False #if defined(MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) isImportQualifiedPost :: ImportDeclQualifiedStyle -> Bool isImportQualifiedPost QualifiedPost = True isImportQualifiedPost _ = False # endif #elif __GLASGOW_HASKELL__ >= 810 isImportQualifiedPost :: ImportDeclQualifiedStyle -> Bool isImportQualifiedPost QualifiedPost = True isImportQualifiedPost _ = False #endif ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs0000644000000000000000000000353513713641612026603 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances ( HsExtendInstances(..), extendInstances, astEq, astListEq) where -- At times, there are terms in Haskell syntax we work with that are -- not in `Eq`, `Show` or `Ord` and we need them to be. -- This work-around resorts to implementing Eq and Ord via -- lexicographic string comparisons. As long as two different terms -- never map to the same string, basing `Eq` and `Ord` on their string -- representations rather than the terms themselves, leads to -- identical results. #if defined (GHCLIB_API_811) import GHC.Utils.Outputable #else import Outputable #endif import Data.Data import Data.Function import Language.Haskell.GhclibParserEx.Dump newtype HsExtendInstances a = HsExtendInstances { unextendInstances :: a } deriving Outputable extendInstances :: a -> HsExtendInstances a extendInstances = HsExtendInstances -- Use 'showAstData'. This is preferable to 'ppr' in that trees that -- only differ in arrangement due to fixities will produce differing -- string representations. toStr :: Data a => HsExtendInstances a -> String toStr (HsExtendInstances e) = showSDocUnsafe $ showAstData BlankSrcSpan e instance Data a => Eq (HsExtendInstances a) where (==) a b = toStr a == toStr b instance Data a => Ord (HsExtendInstances a) where compare = compare `on` toStr astEq :: Data a => a -> a -> Bool astEq a b = extendInstances a == extendInstances b astListEq :: Data a => [a] -> [a] -> Bool astListEq as bs = length as == length bs && all (uncurry astEq) (zip as bs) -- Use 'ppr' for 'Show'. instance Outputable a => Show (HsExtendInstances a) where show (HsExtendInstances e) = showSDocUnsafe $ ppr e ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Parser.hs0000644000000000000000000000752713713641612024373 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Parser( parseFile , parseModule , parseSignature , parseImport , parseStatement , parseBackpack , parseDeclaration , parseExpression , parsePattern , parseTypeSignature , parseStmt , parseIdentifier , parseType , parseHeader , parse ) where #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined (GHCLIB_API_811) import GHC.Parser.PostProcess import GHC.Driver.Session import GHC.Data.StringBuffer import GHC.Parser.Lexer import qualified GHC.Parser.Lexer as Lexer import qualified GHC.Parser as Parser import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Driver.Backpack.Syntax import GHC.Unit.Info import GHC.Types.Name.Reader #else import DynFlags import StringBuffer import Lexer import qualified Parser import FastString import SrcLoc import BkpSyn import PackageConfig import RdrName #endif #if defined (GHCLIB_API_810) import RdrHsSyn #endif parse :: P a -> String -> DynFlags -> ParseResult a parse p str flags = Lexer.unP p parseState where location = mkRealSrcLoc (mkFastString "") 1 1 buffer = stringToStringBuffer str parseState = mkPState flags buffer location #if defined (GHCLIB_API_811) parseModule :: String -> DynFlags -> ParseResult (Located HsModule) #else parseModule :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif parseModule = parse Parser.parseModule #if defined (GHCLIB_API_811) parseSignature :: String -> DynFlags -> ParseResult (Located HsModule) #else parseSignature :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif parseSignature = parse Parser.parseSignature parseImport :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) parseImport = parse Parser.parseImport parseStatement :: String -> DynFlags -> ParseResult (LStmt GhcPs (LHsExpr GhcPs)) parseStatement = parse Parser.parseStatement parseBackpack :: String -> DynFlags -> ParseResult [LHsUnit PackageName] parseBackpack = parse Parser.parseBackpack parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) parseDeclaration = parse Parser.parseDeclaration parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) parseExpression s flags = case parse Parser.parseExpression s flags of POk s e -> unP (runECP_P e) s PFailed ps -> PFailed ps #else parseExpression = parse Parser.parseExpression #endif parsePattern :: String -> DynFlags -> ParseResult (LPat GhcPs) parsePattern = parse Parser.parsePattern parseTypeSignature :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) parseTypeSignature = parse Parser.parseTypeSignature parseStmt :: String -> DynFlags -> ParseResult (Maybe (LStmt GhcPs (LHsExpr GhcPs))) parseStmt = parse Parser.parseStmt parseIdentifier :: String -> DynFlags -> ParseResult (Located RdrName) parseIdentifier = parse Parser.parseIdentifier parseType :: String -> DynFlags -> ParseResult (LHsType GhcPs) parseType = parse Parser.parseType #if defined(GHCLIB_API_811) parseHeader :: String -> DynFlags -> ParseResult (Located HsModule) #else parseHeader :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif parseHeader = parse Parser.parseHeader #if defined (GHCLIB_API_811) parseFile :: String -> DynFlags -> String -> ParseResult (Located HsModule) #else parseFile :: String -> DynFlags -> String -> ParseResult (Located (HsModule GhcPs)) #endif parseFile filename flags str = unP Parser.parseModule parseState where location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str parseState = mkPState flags buffer location ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/Reader.hs0000644000000000000000000000267313713641612026322 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader( occNameStr, rdrNameStr, isSpecial, unqual, fromQual, isSymbolRdrName ) where #if defined(GHCLIB_API_811) import GHC.Types.SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader #else import SrcLoc import RdrName import OccName import Name #endif -- These names may not seem natural here but they work out in -- practice. The use of thse two functions is thoroughly ubiquitous. occNameStr :: RdrName -> String; occNameStr = occNameString . rdrNameOcc rdrNameStr :: Located RdrName -> String; rdrNameStr = occNameStr . unLoc -- Builtin type or data constructors. isSpecial :: Located RdrName -> Bool isSpecial (L _ (Exact n)) = isDataConName n || isTyConName n isSpecial _ = False -- Coerce qualified names to unqualified (by discarding the -- qualifier). unqual :: Located RdrName -> Located RdrName unqual (L loc (Qual _ n)) = L loc $ mkRdrUnqual n unqual x = x -- Extract the occ name from a qualified/unqualified reader name. fromQual :: Located RdrName -> Maybe OccName fromQual (L _ (Qual _ x)) = Just x fromQual (L _ (Unqual x)) = Just x fromQual _ = Nothing -- Test if the reader name is that of an operator (be it a data -- constructor, variable or whatever). isSymbolRdrName :: RdrName -> Bool isSymbolRdrName = isSymOcc . rdrNameOcc ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/GHC/Utils/Outputable.hs0000644000000000000000000000064513713641612026355 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Utils.Outputable ( unsafePrettyPrint ) where #if defined (GHCLIB_API_811) import GHC.Utils.Outputable #else import Outputable #endif unsafePrettyPrint :: Outputable a => a -> String unsafePrettyPrint = showSDocUnsafe . ppr ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/Config.hs0000644000000000000000000000056313713641612023734 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. module Language.Haskell.GhclibParserEx.Config {-# DEPRECATED "Use Language.Haskell.GhclibParserEx.GHC.Settings.Config instead" #-} ( module Language.Haskell.GhclibParserEx.GHC.Settings.Config ) where import Language.Haskell.GhclibParserEx.GHC.Settings.Config ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/Parse.hs0000644000000000000000000000052713713641612023601 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. module Language.Haskell.GhclibParserEx.Parse {-# DEPRECATED "Use Language.Haskell.GhclibParserEx.GHC.Parser instead" #-} ( module Language.Haskell.GhclibParserEx.GHC.Parser ) where import Language.Haskell.GhclibParserEx.GHC.Parser ghc-lib-parser-ex-8.10.0.16/src/Language/Haskell/GhclibParserEx/Outputable.hs0000644000000000000000000000057213713641612024653 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. module Language.Haskell.GhclibParserEx.Outputable {-# DEPRECATED "Use Language.Haskell.GhclibParserEx.GHC.Utils.Outputable instead" #-} ( module Language.Haskell.GhclibParserEx.GHC.Utils.Outputable ) where import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable ghc-lib-parser-ex-8.10.0.16/test/Test.hs0000644000000000000000000004022213713641612015662 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} #include "ghclib_api.h" import Test.Tasty import Test.Tasty.HUnit import System.FilePath import System.Directory as Directory import System.Environment import qualified System.FilePath as FilePath import System.IO.Extra import Control.Monad import Data.List.Extra import Data.Maybe import Language.Haskell.GhclibParserEx.Dump import Language.Haskell.GhclibParserEx.Fixity import Language.Haskell.GhclibParserEx.GHC.Settings.Config import Language.Haskell.GhclibParserEx.GHC.Parser import Language.Haskell.GhclibParserEx.GHC.Hs import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Hs.Pat -- We only test 'isImportQualifiedPost' at this time which requires >= -- 8.10; avoid unused import warning. #if defined (MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp # endif #elif __GLASGOW_HASKELL__ >= 810 import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp #endif import Language.Haskell.GhclibParserEx.GHC.Driver.Flags() import Language.Haskell.GhclibParserEx.GHC.Driver.Session import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif #if defined (GHCLIB_API_811) import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Parser.Lexer import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence #else import SrcLoc import DynFlags import Lexer import Outputable import ErrUtils import RdrName import OccName #endif import GHC.LanguageExtensions.Type #if defined (GHCLIB_API_808) import Bag #endif main :: IO () main = do setEnv "TASTY_NUM_THREADS" "1" setUnsafeGlobalDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) defaultMain tests tests :: TestTree tests = testGroup " All tests" [ parseTests , fixityTests , extendInstancesTests , expressionPredicateTests , patternPredicateTests , dynFlagsTests , nameTests ] makeFile :: FilePath -> String -> IO FilePath makeFile relPath contents = do Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath writeFile relPath contents return relPath chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO () chkParseResult report flags = \case POk s _ -> do let (wrns, errs) = getMessages s flags when (not (null errs) || not (null wrns)) $ assertFailure (report flags wrns ++ report flags errs) #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) PFailed s -> assertFailure (report flags $ snd (getMessages s flags)) #else PFailed _ loc err -> assertFailure (report flags $ unitBag $ mkPlainErrMsg flags loc err) #endif parseTests :: TestTree parseTests = testGroup "Parse tests" [ testCase "Module" $ chkParseResult report flags $ parseModule (unlines [ "module Foo (readMany) where" , "import Data.List" , "import Data.Maybe" , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" ]) flags , testCase "Signature" $ chkParseResult report flags $ parseSignature (unlines [ "signature Str where" , "data Str" , "empty :: Str" , "append :: Str -> Str -> Str" ]) flags , testCase "Import" $ chkParseResult report flags $ parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags , testCase "Statement" $ chkParseResult report flags $ parseStatement "Foo foo <- bar" flags , testCase "Backpack" $ chkParseResult report flags $ parseBackpack (unlines [ "unit main where" , " module Main where" , " main = putStrLn \"Hello world!\"" ]) flags , testCase "Expression" $ chkParseResult report flags $ parseExpression "unfoldr $ listToMaybe . concatMap reads . tails" flags , testCase "Declaration (1)" $ chkParseResult report flags $ parseDeclaration "fact n = if n <= 1 then 1 else n * fact (n - 1)" flags , testCase "Declaration (2)" $ -- Example from https://github.com/ndmitchell/hlint/issues/842. chkParseResult report flags $ parseDeclaration "infixr 4 <%@~" flags , testCase "File" $ withTempDir $ \tmpDir -> do foo <- makeFile (tmpDir "Foo.hs") $ unlines ["{-# LANGUAGE ScopedTypeVariables #-}" , "module Foo (readMany) where" , "import Data.List" , "import Data.Maybe" , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" ] s <- readFile' foo parsePragmasIntoDynFlags flags ([], []) foo s >>= \case Left msg -> assertFailure msg Right flags -> chkParseResult report flags $ parseFile foo flags s ] where flags = unsafeGlobalDynFlags report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ] #if defined(GHCLIB_API_811) moduleTest :: String -> DynFlags -> (Located HsModule -> IO ()) -> IO () #else moduleTest :: String -> DynFlags -> (Located (HsModule GhcPs) -> IO ()) -> IO () #endif moduleTest s flags test = case parseModule s flags of POk _ e -> test e _ -> assertFailure "parse error" exprTest :: String -> DynFlags -> (LHsExpr GhcPs -> IO ()) -> IO () exprTest s flags test = case parseExpression s flags of POk _ e -> test e _ -> assertFailure "parse error" patTest :: String -> DynFlags -> (LPat GhcPs -> IO ()) -> IO () patTest s flags test = case parsePattern s flags of POk _ e -> test e _ -> assertFailure "parse error" fixityTests :: TestTree fixityTests = testGroup "Fixity tests" [ testCase "Expression" $ exprTest "1 + 2 * 3" flags (\e -> assertBool "parse tree not affected" $ showSDocUnsafe (showAstData BlankSrcSpan e) /= showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e)) ) , testCase "Pattern" $ case parseDeclaration "f (1 : 2 :[]) = 1" flags of POk _ d -> assertBool "parse tree not affected" $ showSDocUnsafe (showAstData BlankSrcSpan d) /= showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] d)) PFailed{} -> assertFailure "parse error" , testCase "fixitiesFromModule" $ case parseModule "infixl 4 <*!" flags of POk _ m -> assertBool "one fixity expected" $ not (null (fixitiesFromModule m)) PFailed{} -> assertFailure "parse error" ] where flags = defaultDynFlags fakeSettings fakeLlvmConfig extendInstancesTests :: TestTree extendInstancesTests = testGroup "Extend instances tests" [ testCase "Eq, Ord" $ exprTest "1 + 2 * 3" flags (\e -> do e' <- return $ applyFixities [] e assertBool "astEq" $ astEq e e assertBool "astEq" $ not (astEq e e') e <- return $ extendInstances e e' <- return $ extendInstances e' assertBool "==" $ e == e assertBool "/=" $ e /= e' assertBool "< " $ e' < e assertBool ">=" $ e >= e' ) ] where flags = defaultDynFlags fakeSettings fakeLlvmConfig expressionPredicateTests :: TestTree expressionPredicateTests = testGroup "Expression predicate tests" [ testCase "isTag" $ test "foo" $ assert' . isTag "foo" , testCase "isTag" $ test "bar" $ assert' . not . isTag "foo" , testCase "isDol" $ test "f $ x" $ \case L _ (OpApp _ _ op _) -> assert' $ isDol op; _ -> assertFailure "unexpected" , testCase "isDot" $ test "f . g" $ \case L _ (OpApp _ _ op _) -> assert' $ isDot op; _ -> assertFailure "unexpected" , testCase "isReturn" $ test "return x" $ \case L _ (HsApp _ f _) -> assert' $ isReturn f; _ -> assertFailure "unexpected" , testCase "isReturn" $ test "pure x" $ \case L _ (HsApp _ f _) -> assert' $ isReturn f; _ -> assertFailure "unexpected" , testCase "isSection" $ test "(1 +)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" , testCase "isSection" $ test "(+ 1)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" , testCase "isRecConstr" $ test "Foo {bar=1}" $ assert' . isRecConstr , testCase "isRecUpdate" $ test "foo {bar=1}" $ assert' . isRecUpdate , testCase "isVar" $ test "foo" $ assert' . isVar , testCase "isVar" $ test "3" $ assert' . not. isVar , testCase "isPar" $ test "(foo)" $ assert' . isPar , testCase "isPar" $ test "foo" $ assert' . not. isPar , testCase "isApp" $ test "f x" $ assert' . isApp , testCase "isApp" $ test "x" $ assert' . not . isApp , testCase "isOpApp" $ test "l `op` r" $ assert' . isOpApp , testCase "isOpApp" $ test "op l r" $ assert' . not . isOpApp , testCase "isAnyApp" $ test "l `op` r" $ assert' . isAnyApp , testCase "isAnyApp" $ test "f x" $ assert' . isAnyApp , testCase "isAnyApp" $ test "f x y" $ assert' . isAnyApp , testCase "isAnyApp" $ test "(f x y)" $ assert' . not . isAnyApp , testCase "isLexeme" $ test "foo" $ assert' . isLexeme , testCase "isLexeme" $ test "3" $ assert' . isLexeme , testCase "isLexeme" $ test "f x" $ assert' . not . isLexeme , testCase "isLambda" $ test "\\x -> 12" $ assert' . isLambda , testCase "isLambda" $ test "foo" $ assert' . not . isLambda , testCase "isDotApp" $ test "f . g" $ assert' . isDotApp , testCase "isDotApp" $ test "f $ g" $ assert' . not . isDotApp , testCase "isTypeApp" $ test "f @Int" $ assert' . isTypeApp #if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) , testCase "isTypeApp" $ test "f @ Int" $ assert' . isTypeApp #else , testCase "isTypeApp" $ test "f @ Int" $ assert' . not . isTypeApp #endif , testCase "isTypeApp" $ test "f" $ assert' . not . isTypeApp , testCase "isWHNF" $ test "[]" $ assert' . isWHNF , testCase "isWHNF" $ test "[1, 2]" $ assert' . isWHNF , testCase "isWHNF" $ test "'f'" $ assert' . isWHNF , testCase "isWHNF" $ test "foo" $ assert' . not . isWHNF , testCase "isWHNF" $ test "42" $ assert' . not . isWHNF , testCase "isWHNF" $ test "\\foo -> []" $ assert' . isWHNF , testCase "isWHNF" $ test "(\\foo -> [])" $ assert' . isWHNF , testCase "isWHNF" $ test "(\\foo -> []) x" $ assert' . not . isWHNF , testCase "isWHNF" $ test "(42, \"foo\")" $ assert' . isWHNF , testCase "isWHNF" $ test "(42, \"foo\") :: (Int, String)" $ assert' . isWHNF , testCase "isWHNF" $ test "(\\x -> x * x) 3 :: Int" $ assert' . not . isWHNF , testCase "isWHNF" $ test "Just foo" $ assert' . isWHNF , testCase "isWHNF" $ test "Left foo" $ assert' . isWHNF , testCase "isWHNF" $ test "Right foo" $ assert' . isWHNF , testCase "isWHNF" $ test "POk s" $ assert' . not . isWHNF , testCase "isLCase" $ test "\\case _ -> False" $ assert' . isLCase , testCase "isLCase" $ test "case x of _ -> False" $ assert' . not . isLCase , testCase "isSpliceDecl" $ test "$x" $ assert' . isSpliceDecl . unLoc , testCase "isSpliceDecl" $ test "f$x" $ assert' . not . isSpliceDecl . unLoc , testCase "isSpliceDecl" $ test "$(a + b)" $ assert' . isSpliceDecl . unLoc , testCase "isQuasiQuote" $ test "[expr|1 + 2|]" $ assert' . isQuasiQuote , testCase "isQuasiQuote" $ test "[expr(1 + 2)]" $ assert' . not . isQuasiQuote , testCase "isWholeFrac" $ test "3.2e1" $ assert' . isWholeFrac . unLoc , testCase "isWholeFrac" $ test "3.22e1" $ assert' . not . isWholeFrac . unLoc , testCase "strToVar" $ assert' . isVar . strToVar $ "foo" , testCase "varToStr" $ test "[]" $ assert' . (== "[]") . varToStr , testCase "varToStr" $ test "foo" $ assert' . (== "foo") . varToStr , testCase "varToStr" $ test "3" $ assert' . null . varToStr ] where assert' = assertBool "" test s = exprTest s flags flags = foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) [ TemplateHaskell, TemplateHaskellQuotes, QuasiQuotes, TypeApplications, LambdaCase ] patternPredicateTests :: TestTree patternPredicateTests = testGroup "Pattern predicate tests" [ testCase "patToStr" $ test "True" $ assert' . (== "True") . patToStr , testCase "patToStr" $ test "False" $ assert' . (== "False") . patToStr , testCase "patToStr" $ test "[]" $ assert' . (== "[]") . patToStr , testCase "strToPat" $ assert' . (== "True") . patToStr . strToPat $ "True" , testCase "strToPat" $ assert' . (== "False") . patToStr . strToPat $ "False" , testCase "strToPat" $ assert' . (== "[]") . patToStr . strToPat $ "[]" , testCase "fromPChar" $ test "'a'" $ assert' . (== Just 'a') . fromPChar , testCase "fromPChar" $ test "\"a\"" $ assert' . isNothing . fromPChar ] where assert' = assertBool "" test s = patTest s flags flags = foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) [ TemplateHaskell, QuasiQuotes, TypeApplications, LambdaCase ] dynFlagsTests :: TestTree dynFlagsTests = testGroup "DynFlags tests" [ testCase "readExtension" $ assertBool "parse DeriveTraversable" (readExtension "DeriveTraversable" == Just DeriveTraversable) , testCase "readExtension" $ assertBool "parse DeriveTravresable" (isNothing $ readExtension "DeriveTravresable") , testCase "extensionImplications" $ do Just (_, (es, ds)) <- return $ find (\(e, _) -> e == DeriveTraversable) extensionImplications assertBool "no extensions disabled" (null ds) assertBool "two extensions enabled" $ DeriveFunctor `elem` es && DeriveFoldable `elem` es , testCase "check instance Bounded Language" $ assertBool "enumerate is null" (not (null (enumerate @Language))) , testCase "check instance Ord Extension" $ assertBool "minBound >= maxBound" (minBound @Extension < maxBound @Extension) , testCase "disable via pragma" $ withTempDir $ \tmpDir -> do foo <- makeFile (tmpDir "Foo.hs") $ unlines [ "{-# LANGUAGE NoStarIsType #-}" , "{-# LANGUAGE ExplicitNamespaces #-}" , "import GHC.TypeLits(KnownNat, type (+), type (*))" ] s <- readFile' foo -- If 'StarIsType' ends up enabled after -- 'parsePragmasIntoDynflags' has done its work, we'll get a -- parse error (see -- https://github.com/ndmitchell/hlint/issues/971). parsePragmasIntoDynFlags flags ([StarIsType], []) foo s >>= \case Left msg -> assertFailure msg Right flags -> chkParseResult report flags $ parseFile foo flags s #if defined (MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) , testCase "ImportQualifiedPost" $ do case parseImport "import Foo qualified" (flags `xopt_set` ImportQualifiedPost) of POk _ (L _ decl) -> assertBool "expected postpositive" (isImportQualifiedPost . ideclQualified $ decl) PFailed _ -> assertFailure "parse error" # endif #elif __GLASGOW_HASKELL__ >= 810 , testCase "ImportQualifiedPost" $ do case parseImport "import Foo qualified" (flags `xopt_set` ImportQualifiedPost) of POk _ (L _ decl) -> assertBool "expected postpositive" (isImportQualifiedPost . ideclQualified $ decl) PFailed _ -> assertFailure "parse error" #endif ] where flags = unsafeGlobalDynFlags report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ] nameTests :: TestTree nameTests = testGroup "Name tests" [ testCase "modName (1)" $ moduleTest "module Foo.Bar.Baz where" flags (\n -> assertBool "Unexpected name string" $ modName n == "Foo.Bar.Baz") , testCase "modName (2)" $ moduleTest "f x = x * 2" flags (\n -> assertBool "Unexpected name string" $ modName n == "Main") , testCase "isSymbolRdrName (1)" $ assertBool "Expected 'True'" $ isSymbolRdrName (mkRdrUnqual (mkVarOcc "+")) , testCase "isSymbolRdrName (2)" $ assertBool "Expected 'False'" $ not (isSymbolRdrName (mkRdrUnqual (mkVarOcc "_foo"))) , testCase "isSymbolRdrName (3)" $ assertBool "Expected 'False'" $ not (isSymbolRdrName (mkRdrUnqual (mkVarOcc "foo'"))) , testCase "isSymbolRdrName (4)" $ assertBool "Expected 'True'" $ isSymbolRdrName (mkRdrUnqual (mkVarOcc ":+:")) ] where flags = defaultDynFlags fakeSettings fakeLlvmConfig ghc-lib-parser-ex-8.10.0.16/LICENSE0000644000000000000000000000311613713641612014436 0ustar0000000000000000Copyright Shayne Fletcher 2020. * BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause) BSD 3-Clause License All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ghc-lib-parser-ex-8.10.0.16/cbits/ghclib_api.h0000644000000000000000000000163013713641612016766 0ustar0000000000000000/* Copyright (c) 2020, Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause. */ #if !defined(GHCLIB_API_H) # define GHCLIB_API_H # if !defined(GHCLIB_API_811) && !defined(GHCLIB_API_810) && !defined(GHCLIB_API_808) # if defined(MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) # define GHCLIB_API_811 # elif MIN_VERSION_ghc_lib_parser(8, 10, 0) # define GHCLIB_API_810 # elif MIN_VERSION_ghc_lib_parser(8, 8, 0) # define GHCLIB_API_808 # else # error Unsupported GHC API version # endif # else # if __GLASGOW_HASKELL__ == 811 # define GHCLIB_API_811 # elif __GLASGOW_HASKELL__ == 810 # define GHCLIB_API_810 # elif __GLASGOW_HASKELL__ == 808 # define GHCLIB_API_808 # else # error Unsupported GHC API version # endif # endif # endif #endif ghc-lib-parser-ex-8.10.0.16/Setup.hs0000644000000000000000000000005613713641612015065 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-lib-parser-ex-8.10.0.16/ghc-lib-parser-ex.cabal0000644000000000000000000000705313713641612017632 0ustar0000000000000000cabal-version: >= 1.18 name: ghc-lib-parser-ex version: 8.10.0.16 description: Please see the README on GitHub at homepage: https://github.com/shayne-fletcher/ghc-lib-parser-ex#readme bug-reports: https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues author: Shayne Fletcher maintainer: shayne@shaynefletcher.org copyright: Copyright © 2020, Shayne Fletcher. All rights reserved. license: BSD3 license-file: LICENSE category: Development synopsis: Algorithms on GHC parse trees build-type: Simple tested-with: GHC==8.8.2, GHC==8.6.5 extra-source-files: README.md ChangeLog.md cbits/ghclib_api.h source-repository head type: git location: https://github.com/shayne-fletcher/ghc-lib-parser-ex flag auto default: True manual: True description: Use default configuration flag no-ghc-lib default: False manual: True description: Force dependency on native ghc-libs library exposed-modules: Language.Haskell.GhclibParserEx.Dump Language.Haskell.GhclibParserEx.Fixity Language.Haskell.GhclibParserEx.GHC.Settings.Config Language.Haskell.GhclibParserEx.GHC.Driver.Flags Language.Haskell.GhclibParserEx.GHC.Driver.Session Language.Haskell.GhclibParserEx.GHC.Hs Language.Haskell.GhclibParserEx.GHC.Hs.Expr Language.Haskell.GhclibParserEx.GHC.Hs.Pat Language.Haskell.GhclibParserEx.GHC.Hs.Types Language.Haskell.GhclibParserEx.GHC.Hs.Decls Language.Haskell.GhclibParserEx.GHC.Hs.Binds Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances Language.Haskell.GhclibParserEx.GHC.Parser Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -- Deprecated and will be removed in a future release. Language.Haskell.GhclibParserEx.Config Language.Haskell.GhclibParserEx.Parse Language.Haskell.GhclibParserEx.Outputable other-modules: Paths_ghc_lib_parser_ex hs-source-dirs: src build-depends: base >=4.7 && <5, uniplate >= 1.5, bytestring >= 0.10.8.2, containers >= 0.5.8.1 if flag(auto) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0) build-depends: ghc == 8.10.*, ghc-boot-th, ghc-boot else if flag(auto) build-depends: ghc-lib-parser == 8.10.* else if flag(no-ghc-lib) build-depends: ghc, ghc-boot-th, ghc-boot else build-depends: ghc-lib-parser include-dirs: cbits install-includes: cbits/ghclib_api.h default-language: Haskell2010 test-suite ghc-lib-parser-ex-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: Paths_ghc_lib_parser_ex hs-source-dirs: test include-dirs: cbits ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , tasty >= 1.2 , tasty-hunit >= 0.10.0 , directory >= 1.3.3 , filepath >= 1.4.2 , extra >=1.6 , ghc-lib-parser-ex if flag(auto) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0) build-depends: ghc == 8.10.*, ghc-boot-th, ghc-boot else if flag(auto) build-depends: ghc-lib-parser == 8.10.* else if flag(no-ghc-lib) build-depends: ghc, ghc-boot-th, ghc-boot else build-depends: ghc-lib-parser default-language: Haskell2010 ghc-lib-parser-ex-8.10.0.16/README.md0000644000000000000000000000553013713641612014712 0ustar0000000000000000# ghc-lib-parser-ex [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage version](https://img.shields.io/hackage/v/ghc-lib-parser-ex.svg?label=Hackage)](https://hackage.haskell.org/package/ghc-lib-parser-ex) [![Stackage version](https://www.stackage.org/package/ghc-lib-parser-ex/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghc-lib-parser-ex) [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) Copyright © 2020, Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause The `ghc-lib-parser-ex` package contains GHC API parse tree utilities. It works with or without [`ghc-lib-parser`](https://github.com/digital-asset/ghc-lib). ## Using `ghc-lib-parser-ex` Package `ghc-lib-parser-ex` is on [Hackage](https://hackage.haskell.org/package/ghc-lib-parser-ex) e.g. `cabal install ghc-lib-parser-ex`. Like `ghc-lib-parser`, there are two release streams within the `ghc-lib-parser-ex` name. ### Versioning policy Package `ghc-lib-parser-ex` does **not** conform to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). Version numbers are of the form α.β.γ.δ where α.β corresponds to a GHC series and γ.δ are the major and minor parts of the `ghc-lib-ex-parser` package release. Examples: * Version 8.10.1.3 is compatible with any `ghc-lib-parser-8.10.*` (or `ghc-8.10.*`) package; * Version 0.20190204.2.0 is compatible with [`ghc-lib-parser-0.20190204`](http://hackage.haskell.org/package/ghc-lib-0.20190204). The major part γ of the release number indicates an interface breaking change from the previous release. The minor part δ indicates a non-interface breaking change from the previous release. ## Building `ghc-lib-parser-ex` You can build with `stack build` and test with `stack test`. Produce `ghc-lib-parser-ex` package distributions by executing the CI script: ```bash # Setup git clone git@github.com:shayne-fletcher/ghc-lib-parser-ex.git cd ghc-lib-parser-ex stack runhaskell --package extra --package optparse-applicative CI.hs ``` Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more options. To run [`hlint`](https://github.com/ndmitchell/hlint) on this repository, `hlint --cpp-include cbits --cpp-define GHCLIB_API_XXX .` (where `XXX` at this time is one of `808`, `810` or `811`). ## Releasing `ghc-lib-parser-ex` (notes for maintainers) Update the [changelog](./ChangeLog.md), `git tag && git push origin ` then build via the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). ghc-lib-parser-ex-8.10.0.16/ChangeLog.md0000644000000000000000000001201713713641612015602 0ustar0000000000000000# Changelog for ghc-lib-parser-ex ## 8.10.0.16 released 2020-08-08 - Update to ghc-8.10.2. ## 0.20200801 released 2020-08-01 - Update to `ghc-lib-0.20200801` ## 8.8.6.1 released 2020-07-16 ## 0.20200704 released 2020-07-04 - New function `isImportQualifiedPost` ## 8.10.0.15 released 2020-07-04 - New function `isImportQualifiedPost` ## 8.10.0.14 released 2020-06-10 - New function `isSymbolRdrName` - New module - `Language.Haskell.GhclibParserEx.GHC.Settings.Config` to replace `Language.Haskell.GhclibParserEx.Config` (which remains for now but deprecated and will be removed in a future release) ## 0.20200601 released 2020-06-01 ## 8.10.0.13 released 2020-05-31 - Sync `extra` with HLint ## 8.10.0.12 released 2020-05-31 - New module `Language.Haskell.GhclibParserEx.GHC.Hs` ## 8.10.0.11 released 2020-05-18 - Upgrade to `ghc-lib-parser-8.10.1.20200523` ## 8.10.0.10 released 2020-05-18 - Upgrade to `ghc-lib-parser-8.10.1.20200518` ## 8.10.0.9 released 2020-05-16 - New modules - `Language.Haskell.GhclibParserEx.GHC.Hs.Binds` - `Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp` ## 8.10.0.8 released 2020-05-14 - New module `Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader` ## 8.10.0.7 released 2020-05-13 - New function `fixitiesFromModule` ## 8.10.0.6 released 2020-05-05 - Bugfix in `parsePragmasIntoDynFlags` that meant that default enabled/disabled extensions subsequently disabled/enabled via pragma weren't getting disabled/enabled ## 8.10.0.5 released 2020-05-02 - New modules - `Language.Haskell.GhclibParserEx.GHC.Parser`, `Language.Haskell.GhcLibParserEx.GHC.Utils.Outputable` to replace `Language.Haskell.GhclibParserEx.Parse` and `Language.Haskell.GhclibParserEx.Outputable` (which remain for now but deprecated and will be removed in a future release) ## 0.20200501 released 2020-05-01 ## 8.10.0.4 released 2020-04-04 - Add expression predicates `isWholeFrac`, `isFieldPunUpdate`, `isStrictMatch`, `isMultiIf`, `isProc`, `isTransStmt`; - Add pattern predicate `isPFieldPun`. ## 8.10.0.3 released 2020-04-03 - `strToPat` now returns an `LPat GhcPs` - `parseExpression` now returns an `ParseResult (LHsExpr GhcPs)` (>= ghc-8.10) ## 0.20200401 released 2020-04-01 ## 8.10.0.2 released 2020-03-30 - Rework cabal flags; allow full configurability with a good default: - Have two flags `auto` and `no-ghc-lib`. Default behavior exactly as `hlint` linking `ghc-lib-parser-8.10.*` if not on `ghc-8.10.*` and `ghc-8.10.*` otherwise. ## 8.10.0.1 released 2020-03-28 - Unless the Cabal flag `ghc-lib` is `true` link native ghc-libs (without regard for the compiler version) - Change the signature of `hasPFieldsDotDot` - This has no impact on 8.8 parse trees but matters when it comes to >= 8.10 - Change the signature of `isPFieldWildcard` - This has no impact on 8.8 parse trees but matters when it comes to >= 8.10 ## 8.10.0.0 released 2020-03-24 - First release of the ghc-8.10 series ## 8.8.6.0 released 2020-03-22 - `Language.Haskell.GhclibParserEx.DynFlags` is now `Language.Haskell.GhclibParserEx.GHC.Driver.Session` ## 8.8.5.8 released 2020-03-17 - New module `Language.Haskell.GhclibParserEx.GHC.Driver.Flags` - Export `Bounded` instance for `Language` (https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues/30) ## 8.8.5.7 released 2020-03-16 - From `Language.Haskell.GhclibParserEx.Fixity`: - Supply missing fixities (https://github.com/ndmitchell/hlint/issues/913) - In `Language.Haskell.GhclibParserEx.DynFlags`: - Give `Extension` an `Ord` instance ## 8.8.5.6 released 2020-03-13 - From `Language.Haskell.GhclibParserEx.Fixity`: - Expose `infixr_`, `infixl_`, `infix_` and `fixity` ## 8.8.5.5 released 2020-03-12 - Remove from `Language.Haskell.GhclibParserEx.Fixity`: - `preludeFixities` - `baseFixities` ## 8.8.5.4 released 2020-03-11 - Expose from `Language.Haskell.GhclibParserEx.Fixity`: - `preludeFixities` - `baseFixities` - `lensFixities` - `otherFixities` ## 0.20200301 released 2020-03-01 ## 8.8.5.3 released 2020-02-25 - New modules: - `Language.Haskell.GhclibParserEx.Pat` - `Language.Haskell.GhclibParserEx.Types` - `Language.Haskell.GhclibParserEx.Decls` ## 8.8.5.2 released 2020-02-16 - New `DynFlags` functions `readExtension`, `extensionImplications`. ## 8.8.5.1 released 2020-02-09 - Expression predicate tests. ## 8.8.5.0 released 2020-02-07 - Expose `impliedGFlags` and friends from `DynFlags` (https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues/19). ## 8.8.4.0 released 2020-02-01 - New modules: - `Language.Haskell.GhclibparserEx.GHC.Hs.Expr` - Moved modules: - `Language.Haskell.GhclibparserEx.HsExtendInstances` -> `Language.Haskell.GhclibparserEx.GHC.Hs.ExtendInstances`; ## 0.20200201.1.0 released 2020-02-01 - New modules: - `Language.Haskell.GhclibparserEx.HsExtendInstances`. ## 8.8.3.0 released 2020-01-25 - Change in versioning scheme; - New modules: - `Language.Haskell.GhclibParserEx.Config` - `Language.Haskell.GhclibParserEx.DynFlags` - `parsePragmasIntoDynFlags` signature change. ## 8.8.1.20191204, 8.8.2, 0.20200102 released 2020-01-18 - First releases